From 7c02f2122a972ab94a0df63e9e7632e97938f9bb Mon Sep 17 00:00:00 2001 From: Ximin Luo Date: Mon, 17 Jul 2017 16:11:47 +0200 Subject: [PATCH] Import ocaml_4.05.0.orig.tar.xz [dgit import orig ocaml_4.05.0.orig.tar.xz] --- .depend | 2228 +++++ .gitattributes | 169 + .gitignore | 373 + .gitmodules | 3 + .mailmap | 84 + .merlin | 56 + .ocp-indent | 2 + .travis-ci.sh | 150 + .travis.yml | 28 + CONTRIBUTING.md | 359 + Changes | 6338 ++++++++++++++ HACKING.adoc | 260 + INSTALL.adoc | 369 + LICENSE | 203 + Makefile | 1305 +++ Makefile.nt | 16 + Makefile.tools | 109 + README.adoc | 117 + README.win32.adoc | 345 + VERSION | 4 + appveyor.yml | 81 + appveyor_build.sh | 95 + asmcomp/CSEgen.ml | 366 + asmcomp/CSEgen.mli | 38 + asmcomp/afl_instrument.ml | 94 + asmcomp/afl_instrument.mli | 4 + asmcomp/amd64/CSE.ml | 41 + asmcomp/amd64/NOTES.md | 21 + asmcomp/amd64/arch.ml | 133 + asmcomp/amd64/emit.mlp | 1128 +++ asmcomp/amd64/proc.ml | 343 + asmcomp/amd64/reload.ml | 128 + asmcomp/amd64/scheduling.ml | 21 + asmcomp/amd64/selection.ml | 271 + asmcomp/arm/CSE.ml | 40 + asmcomp/arm/NOTES.md | 20 + asmcomp/arm/arch.ml | 262 + asmcomp/arm/emit.mlp | 960 +++ asmcomp/arm/proc.ml | 314 + asmcomp/arm/reload.ml | 19 + asmcomp/arm/scheduling.ml | 80 + asmcomp/arm/selection.ml | 316 + asmcomp/arm64/CSE.ml | 40 + asmcomp/arm64/NOTES.md | 12 + asmcomp/arm64/arch.ml | 171 + asmcomp/arm64/emit.mlp | 993 +++ asmcomp/arm64/proc.ml | 237 + asmcomp/arm64/reload.ml | 19 + asmcomp/arm64/scheduling.ml | 21 + asmcomp/arm64/selection.ml | 254 + asmcomp/asmgen.ml | 270 + asmcomp/asmgen.mli | 44 + asmcomp/asmlibrarian.ml | 87 + asmcomp/asmlibrarian.mli | 28 + asmcomp/asmlink.ml | 421 + asmcomp/asmlink.mli | 44 + asmcomp/asmpackager.ml | 289 + asmcomp/asmpackager.mli | 37 + asmcomp/branch_relaxation.ml | 142 + asmcomp/branch_relaxation.mli | 29 + asmcomp/branch_relaxation_intf.ml | 75 + asmcomp/build_export_info.ml | 551 ++ asmcomp/build_export_info.mli | 25 + asmcomp/clambda.ml | 175 + asmcomp/clambda.mli | 114 + asmcomp/closure.ml | 1376 ++++ asmcomp/closure.mli | 19 + asmcomp/closure_offsets.ml | 138 + asmcomp/closure_offsets.mli | 44 + asmcomp/cmm.ml | 206 + asmcomp/cmm.mli | 180 + asmcomp/cmmgen.ml | 3501 ++++++++ asmcomp/cmmgen.mli | 39 + asmcomp/cmx_format.mli | 72 + asmcomp/coloring.ml | 226 + asmcomp/coloring.mli | 18 + asmcomp/comballoc.ml | 98 + asmcomp/comballoc.mli | 18 + asmcomp/compilenv.ml | 460 ++ asmcomp/compilenv.mli | 158 + asmcomp/deadcode.ml | 81 + asmcomp/deadcode.mli | 19 + asmcomp/emit.mli | 21 + asmcomp/emitaux.ml | 315 + asmcomp/emitaux.mli | 76 + asmcomp/export_info.ml | 360 + asmcomp/export_info.mli | 149 + asmcomp/export_info_for_pack.ml | 211 + asmcomp/export_info_for_pack.mli | 34 + asmcomp/flambda_to_clambda.ml | 694 ++ asmcomp/flambda_to_clambda.mli | 38 + asmcomp/i386/CSE.ml | 50 + asmcomp/i386/NOTES.md | 22 + asmcomp/i386/arch.ml | 167 + asmcomp/i386/emit.mlp | 1096 +++ asmcomp/i386/proc.ml | 231 + asmcomp/i386/reload.ml | 86 + asmcomp/i386/scheduling.ml | 23 + asmcomp/i386/selection.ml | 327 + asmcomp/import_approx.ml | 192 + asmcomp/import_approx.mli | 34 + asmcomp/interf.ml | 203 + asmcomp/interf.mli | 19 + asmcomp/linearize.ml | 317 + asmcomp/linearize.mli | 57 + asmcomp/liveness.ml | 179 + asmcomp/liveness.mli | 22 + asmcomp/mach.ml | 181 + asmcomp/mach.mli | 125 + asmcomp/power/CSE.ml | 40 + asmcomp/power/NOTES.md | 26 + asmcomp/power/arch.ml | 122 + asmcomp/power/emit.mlp | 1225 +++ asmcomp/power/proc.ml | 311 + asmcomp/power/reload.ml | 19 + asmcomp/power/scheduling.ml | 64 + asmcomp/power/selection.ml | 94 + asmcomp/printclambda.ml | 227 + asmcomp/printclambda.mli | 21 + asmcomp/printcmm.ml | 234 + asmcomp/printcmm.mli | 30 + asmcomp/printlinear.ml | 83 + asmcomp/printlinear.mli | 22 + asmcomp/printmach.ml | 254 + asmcomp/printmach.mli | 32 + asmcomp/proc.mli | 74 + asmcomp/reg.ml | 200 + asmcomp/reg.mli | 70 + asmcomp/reload.mli | 18 + asmcomp/reloadgen.ml | 135 + asmcomp/reloadgen.mli | 27 + asmcomp/s390x/CSE.ml | 42 + asmcomp/s390x/NOTES.md | 16 + asmcomp/s390x/arch.ml | 91 + asmcomp/s390x/emit.mlp | 759 ++ asmcomp/s390x/proc.ml | 214 + asmcomp/s390x/reload.ml | 50 + asmcomp/s390x/scheduling.ml | 63 + asmcomp/s390x/selection.ml | 120 + asmcomp/schedgen.ml | 400 + asmcomp/schedgen.mli | 49 + asmcomp/scheduling.mli | 18 + asmcomp/selectgen.ml | 1239 +++ asmcomp/selectgen.mli | 176 + asmcomp/selection.mli | 19 + asmcomp/spacetime_profiling.ml | 431 + asmcomp/spacetime_profiling.mli | 17 + asmcomp/sparc/CSE.ml | 33 + asmcomp/sparc/NOTES.md | 17 + asmcomp/sparc/arch.ml | 83 + asmcomp/sparc/emit.mlp | 771 ++ asmcomp/sparc/proc.ml | 251 + asmcomp/sparc/reload.ml | 19 + asmcomp/sparc/scheduling.ml | 63 + asmcomp/sparc/selection.ml | 80 + asmcomp/spill.ml | 476 ++ asmcomp/spill.mli | 20 + asmcomp/split.ml | 227 + asmcomp/split.mli | 20 + asmcomp/strmatch.ml | 395 + asmcomp/strmatch.mli | 32 + asmcomp/un_anf.ml | 750 ++ asmcomp/un_anf.mli | 22 + asmcomp/x86_ast.mli | 219 + asmcomp/x86_dsl.ml | 199 + asmcomp/x86_dsl.mli | 192 + asmcomp/x86_gas.ml | 311 + asmcomp/x86_gas.mli | 18 + asmcomp/x86_masm.ml | 261 + asmcomp/x86_masm.mli | 18 + asmcomp/x86_proc.ml | 275 + asmcomp/x86_proc.mli | 91 + asmrun/.depend | 1520 ++++ asmrun/Makefile | 197 + asmrun/Makefile.nt | 16 + asmrun/amd64.S | 742 ++ asmrun/amd64nt.asm | 467 ++ asmrun/arm.S | 527 ++ asmrun/arm64.S | 560 ++ asmrun/backtrace_prim.c | 249 + asmrun/clambda_checks.c | 89 + asmrun/fail.c | 198 + asmrun/i386.S | 488 ++ asmrun/i386nt.asm | 323 + asmrun/natdynlink.c | 185 + asmrun/power.S | 680 ++ asmrun/roots.c | 521 ++ asmrun/s390x.S | 340 + asmrun/signals_asm.c | 311 + asmrun/signals_osdep.h | 376 + asmrun/spacetime.c | 1123 +++ asmrun/spacetime_offline.c | 228 + asmrun/spacetime_snapshot.c | 600 ++ asmrun/sparc.S | 360 + asmrun/startup.c | 159 + boot/ocamlc | Bin 0 -> 2152368 bytes boot/ocamldep | Bin 0 -> 2077975 bytes boot/ocamllex | Bin 0 -> 280309 bytes bytecomp/bytegen.ml | 983 +++ bytecomp/bytegen.mli | 23 + bytecomp/bytelibrarian.ml | 134 + bytecomp/bytelibrarian.mli | 37 + bytecomp/bytelink.ml | 699 ++ bytecomp/bytelink.mli | 42 + bytecomp/bytepackager.ml | 329 + bytecomp/bytepackager.mli | 31 + bytecomp/bytesections.ml | 101 + bytecomp/bytesections.mli | 57 + bytecomp/cmo_format.mli | 71 + bytecomp/dll.ml | 184 + bytecomp/dll.mli | 66 + bytecomp/emitcode.ml | 435 + bytecomp/emitcode.mli | 48 + bytecomp/instruct.ml | 112 + bytecomp/instruct.mli | 128 + bytecomp/lambda.ml | 704 ++ bytecomp/lambda.mli | 364 + bytecomp/matching.ml | 3225 ++++++++ bytecomp/matching.mli | 46 + bytecomp/meta.ml | 33 + bytecomp/meta.mli | 35 + bytecomp/printinstr.ml | 116 + bytecomp/printinstr.mli | 23 + bytecomp/printlambda.ml | 625 ++ bytecomp/printlambda.mli | 25 + bytecomp/runtimedef.mli | 19 + bytecomp/semantics_of_primitives.ml | 177 + bytecomp/semantics_of_primitives.mli | 69 + bytecomp/simplif.ml | 695 ++ bytecomp/simplif.mli | 38 + bytecomp/switch.ml | 858 ++ bytecomp/switch.mli | 116 + bytecomp/symtable.ml | 390 + bytecomp/symtable.mli | 65 + bytecomp/translattribute.ml | 255 + bytecomp/translattribute.mli | 60 + bytecomp/translclass.ml | 901 ++ bytecomp/translclass.mli | 29 + bytecomp/translcore.ml | 1453 ++++ bytecomp/translcore.mli | 57 + bytecomp/translmod.ml | 1275 +++ bytecomp/translmod.mli | 52 + bytecomp/translobj.ml | 210 + bytecomp/translobj.mli | 33 + bytecomp/typeopt.ml | 174 + bytecomp/typeopt.mli | 35 + byterun/.depend | 856 ++ byterun/Makefile | 251 + byterun/Makefile.nt | 16 + byterun/afl.c | 162 + byterun/alloc.c | 241 + byterun/array.c | 436 + byterun/backtrace.c | 349 + byterun/backtrace_prim.c | 456 ++ byterun/callback.c | 262 + byterun/caml/address_class.h | 85 + byterun/caml/alloc.h | 77 + byterun/caml/backtrace.h | 136 + byterun/caml/backtrace_prim.h | 91 + byterun/caml/callback.h | 60 + byterun/caml/compact.h | 31 + byterun/caml/compare.h | 25 + byterun/caml/compatibility.h | 375 + byterun/caml/config.h | 203 + byterun/caml/custom.h | 73 + byterun/caml/debugger.h | 117 + byterun/caml/dynlink.h | 42 + byterun/caml/exec.h | 65 + byterun/caml/fail.h | 137 + byterun/caml/finalise.h | 36 + byterun/caml/fix_code.h | 45 + byterun/caml/freelist.h | 38 + byterun/caml/gc.h | 79 + byterun/caml/gc_ctrl.h | 58 + byterun/caml/globroots.h | 31 + byterun/caml/hash.h | 39 + byterun/caml/hooks.h | 42 + byterun/caml/instrtrace.h | 35 + byterun/caml/instruct.h | 67 + byterun/caml/int64_emul.h | 293 + byterun/caml/int64_format.h | 111 + byterun/caml/int64_native.h | 67 + byterun/caml/interp.h | 37 + byterun/caml/intext.h | 207 + byterun/caml/io.h | 125 + byterun/caml/major_gc.h | 86 + byterun/caml/md5.h | 47 + byterun/caml/memory.h | 484 ++ byterun/caml/minor_gc.h | 119 + byterun/caml/misc.h | 413 + byterun/caml/mlvalues.h | 336 + byterun/caml/osdeps.h | 96 + byterun/caml/prims.h | 40 + byterun/caml/printexc.h | 35 + byterun/caml/reverse.h | 92 + byterun/caml/roots.h | 44 + byterun/caml/signals.h | 59 + byterun/caml/signals_machdep.h | 74 + byterun/caml/spacetime.h | 201 + byterun/caml/stack.h | 129 + byterun/caml/stacks.h | 46 + byterun/caml/startup.h | 50 + byterun/caml/startup_aux.h | 38 + byterun/caml/sys.h | 45 + byterun/caml/ui.h | 32 + byterun/caml/weak.h | 93 + byterun/compact.c | 555 ++ byterun/compare.c | 352 + byterun/custom.c | 110 + byterun/debugger.c | 445 + byterun/dynlink.c | 283 + byterun/extern.c | 916 +++ byterun/fail.c | 204 + byterun/finalise.c | 443 + byterun/fix_code.c | 194 + byterun/floats.c | 686 ++ byterun/freelist.c | 615 ++ byterun/gc_ctrl.c | 673 ++ byterun/globroots.c | 291 + byterun/hash.c | 416 + byterun/instrtrace.c | 269 + byterun/intern.c | 1041 +++ byterun/interp.c | 1169 +++ byterun/ints.c | 830 ++ byterun/io.c | 818 ++ byterun/lexing.c | 233 + byterun/main.c | 40 + byterun/major_gc.c | 906 ++ byterun/md5.c | 325 + byterun/memory.c | 714 ++ byterun/meta.c | 233 + byterun/minor_gc.c | 550 ++ byterun/misc.c | 291 + byterun/obj.c | 389 + byterun/parsing.c | 304 + byterun/printexc.c | 154 + byterun/roots.c | 120 + byterun/signals.c | 398 + byterun/signals_byt.c | 101 + byterun/spacetime.c | 40 + byterun/stacks.c | 117 + byterun/startup.c | 486 ++ byterun/startup_aux.c | 106 + byterun/str.c | 443 + byterun/sys.c | 671 ++ byterun/terminfo.c | 134 + byterun/unix.c | 428 + byterun/weak.c | 430 + byterun/win32.c | 697 ++ compilerlibs/.gitignore | 7 + config/Makefile-templ | 223 + config/Makefile.mingw | 213 + config/Makefile.mingw64 | 213 + config/Makefile.msvc | 214 + config/Makefile.msvc64 | 217 + config/auto-aux/align.c | 103 + config/auto-aux/ansi.c | 27 + config/auto-aux/async_io.c | 60 + config/auto-aux/cckind.c | 30 + config/auto-aux/cfi.S | 6 + config/auto-aux/dblalign.c | 54 + config/auto-aux/elf.c | 26 + config/auto-aux/endian.c | 42 + config/auto-aux/getgroups.c | 32 + config/auto-aux/gethostbyaddr.c | 55 + config/auto-aux/gethostbyname.c | 45 + config/auto-aux/hasgot | 45 + config/auto-aux/hasgot2 | 44 + config/auto-aux/hashbang | 2 + config/auto-aux/hashbang2 | 2 + config/auto-aux/hashbang3 | 2 + config/auto-aux/ia32sse2.c | 24 + config/auto-aux/initgroups.c | 26 + config/auto-aux/int64align.c | 65 + config/auto-aux/mmap-huge.c | 51 + config/auto-aux/nanosecond_stat.c | 30 + config/auto-aux/runtest | 24 + config/auto-aux/searchpath | 34 + config/auto-aux/setgroups.c | 28 + config/auto-aux/signals.c | 68 + config/auto-aux/sizes.c | 27 + config/auto-aux/solaris-ld | 23 + config/auto-aux/tryassemble | 33 + config/auto-aux/trycompile | 23 + config/gnu/config.guess | 1558 ++++ config/gnu/config.sub | 1788 ++++ config/m-nt.h | 58 + config/m-templ.h | 83 + config/s-nt.h | 40 + config/s-templ.h | 223 + configure | 2248 +++++ debugger/.depend | 202 + debugger/Makefile | 130 + debugger/Makefile.nt | 16 + debugger/breakpoints.ml | 227 + debugger/breakpoints.mli | 61 + debugger/checkpoints.ml | 86 + debugger/checkpoints.mli | 59 + debugger/command_line.ml | 1235 +++ debugger/command_line.mli | 23 + debugger/debugcom.ml | 309 + debugger/debugcom.mli | 114 + debugger/debugger_config.ml | 87 + debugger/debugger_config.mli | 40 + debugger/eval.ml | 211 + debugger/eval.mli | 41 + debugger/events.ml | 49 + debugger/events.mli | 30 + debugger/exec.ml | 54 + debugger/exec.mli | 20 + debugger/frames.ml | 130 + debugger/frames.mli | 55 + debugger/history.ml | 44 + debugger/history.mli | 21 + debugger/input_handling.ml | 116 + debugger/input_handling.mli | 61 + debugger/int64ops.ml | 27 + debugger/int64ops.mli | 27 + debugger/lexer.mli | 22 + debugger/lexer.mll | 102 + debugger/loadprinter.ml | 187 + debugger/loadprinter.mli | 35 + debugger/main.ml | 235 + debugger/parameters.ml | 41 + debugger/parameters.mli | 30 + debugger/parser.mly | 256 + debugger/parser_aux.mli | 30 + debugger/pattern_matching.ml | 254 + debugger/pattern_matching.mli | 23 + debugger/pos.ml | 26 + debugger/pos.mli | 16 + debugger/primitives.ml | 122 + debugger/primitives.mli | 63 + debugger/printval.ml | 109 + debugger/printval.mli | 34 + debugger/program_loading.ml | 190 + debugger/program_loading.mli | 35 + debugger/program_management.ml | 161 + debugger/program_management.mli | 28 + debugger/question.ml | 50 + debugger/question.mli | 17 + debugger/show_information.ml | 108 + debugger/show_information.mli | 27 + debugger/show_source.ml | 94 + debugger/show_source.mli | 26 + debugger/source.ml | 191 + debugger/source.mli | 62 + debugger/symbols.ml | 212 + debugger/symbols.mli | 51 + debugger/time_travel.ml | 651 ++ debugger/time_travel.mli | 38 + debugger/trap_barrier.ml | 48 + debugger/trap_barrier.mli | 28 + debugger/unix_tools.ml | 144 + debugger/unix_tools.mli | 35 + driver/compdynlink.mlno | 57 + driver/compenv.ml | 638 ++ driver/compenv.mli | 78 + driver/compile.ml | 115 + driver/compile.mli | 21 + driver/compmisc.ml | 79 + driver/compmisc.mli | 19 + driver/compplugin.ml | 49 + driver/compplugin.mli | 16 + driver/errors.ml | 19 + driver/errors.mli | 19 + driver/main.ml | 202 + driver/main.mli | 18 + driver/main_args.ml | 1397 ++++ driver/main_args.mli | 240 + driver/ocamlcomp.sh.in | 20 + driver/optcompile.ml | 142 + driver/optcompile.mli | 27 + driver/opterrors.ml | 19 + driver/opterrors.mli | 18 + driver/optmain.ml | 311 + driver/optmain.mli | 18 + driver/pparse.ml | 242 + driver/pparse.mli | 62 + emacs/COPYING | 340 + emacs/Makefile | 84 + emacs/README | 209 + emacs/README.itz | 177 + emacs/caml-compat.el | 41 + emacs/caml-emacs.el | 45 + emacs/caml-font-old.el | 141 + emacs/caml-font.el | 440 + emacs/caml-help.el | 857 ++ emacs/caml-hilit.el | 67 + emacs/caml-types.el | 762 ++ emacs/caml-xemacs.el | 57 + emacs/caml.el | 1974 +++++ emacs/camldebug.el | 795 ++ emacs/inf-caml.el | 364 + emacs/ocamltags.in | 141 + lex/.depend | 34 + lex/Makefile | 87 + lex/Makefile.nt | 16 + lex/common.ml | 174 + lex/common.mli | 31 + lex/compact.ml | 232 + lex/compact.mli | 34 + lex/cset.ml | 97 + lex/cset.mli | 34 + lex/lexer.mli | 23 + lex/lexer.mll | 305 + lex/lexgen.ml | 1190 +++ lex/lexgen.mli | 60 + lex/main.ml | 125 + lex/output.ml | 153 + lex/output.mli | 27 + lex/outputbis.ml | 241 + lex/outputbis.mli | 23 + lex/parser.mly | 202 + lex/syntax.ml | 49 + lex/syntax.mli | 46 + lex/table.ml | 59 + lex/table.mli | 34 + man/Makefile | 27 + man/ocaml.m | 297 + man/ocamlc.m | 1036 +++ man/ocamlcp.m | 142 + man/ocamldebug.m | 124 + man/ocamldep.m | 206 + man/ocamldoc.m | 462 ++ man/ocamllex.m | 101 + man/ocamlmktop.m | 97 + man/ocamlopt.m | 767 ++ man/ocamlprof.m | 87 + man/ocamlrun.m | 238 + man/ocamlyacc.m | 112 + middle_end/alias_analysis.ml | 167 + middle_end/alias_analysis.mli | 63 + middle_end/allocated_const.ml | 85 + middle_end/allocated_const.mli | 36 + middle_end/augment_specialised_args.ml | 754 ++ middle_end/augment_specialised_args.mli | 65 + middle_end/backend_intf.mli | 47 + middle_end/base_types/closure_element.ml | 25 + middle_end/base_types/closure_element.mli | 32 + middle_end/base_types/closure_id.ml | 19 + middle_end/base_types/closure_id.mli | 27 + middle_end/base_types/compilation_unit.ml | 73 + middle_end/base_types/compilation_unit.mli | 33 + middle_end/base_types/export_id.ml | 28 + middle_end/base_types/export_id.mli | 28 + middle_end/base_types/id_types.ml | 92 + middle_end/base_types/id_types.mli | 56 + middle_end/base_types/linkage_name.ml | 29 + middle_end/base_types/linkage_name.mli | 22 + middle_end/base_types/mutable_variable.ml | 91 + middle_end/base_types/mutable_variable.mli | 37 + middle_end/base_types/set_of_closures_id.ml | 28 + middle_end/base_types/set_of_closures_id.mli | 26 + .../base_types/set_of_closures_origin.ml | 22 + .../base_types/set_of_closures_origin.mli | 22 + middle_end/base_types/static_exception.ml | 22 + middle_end/base_types/static_exception.mli | 26 + middle_end/base_types/symbol.ml | 79 + middle_end/base_types/symbol.mli | 43 + middle_end/base_types/tag.ml | 32 + middle_end/base_types/tag.mli | 27 + middle_end/base_types/var_within_closure.ml | 19 + middle_end/base_types/var_within_closure.mli | 24 + middle_end/base_types/variable.ml | 124 + middle_end/base_types/variable.mli | 62 + middle_end/closure_conversion.ml | 699 ++ middle_end/closure_conversion.mli | 53 + middle_end/closure_conversion_aux.ml | 185 + middle_end/closure_conversion_aux.mli | 94 + middle_end/debuginfo.ml | 121 + middle_end/debuginfo.mli | 43 + middle_end/effect_analysis.ml | 59 + middle_end/effect_analysis.mli | 27 + middle_end/extract_projections.ml | 189 + middle_end/extract_projections.mli | 33 + middle_end/find_recursive_functions.ml | 31 + middle_end/find_recursive_functions.mli | 37 + middle_end/flambda.ml | 1197 +++ middle_end/flambda.mli | 662 ++ middle_end/flambda_invariants.ml | 830 ++ middle_end/flambda_invariants.mli | 29 + middle_end/flambda_iterators.ml | 834 ++ middle_end/flambda_iterators.mli | 227 + middle_end/flambda_utils.ml | 865 ++ middle_end/flambda_utils.mli | 231 + middle_end/freshening.ml | 444 + middle_end/freshening.mli | 165 + middle_end/inconstant_idents.ml | 503 ++ middle_end/inconstant_idents.mli | 36 + middle_end/initialize_symbol_to_let_symbol.ml | 56 + .../initialize_symbol_to_let_symbol.mli | 21 + middle_end/inline_and_simplify.ml | 1669 ++++ middle_end/inline_and_simplify.mli | 38 + middle_end/inline_and_simplify_aux.ml | 694 ++ middle_end/inline_and_simplify_aux.mli | 363 + middle_end/inlining_cost.ml | 686 ++ middle_end/inlining_cost.mli | 141 + middle_end/inlining_decision.ml | 663 ++ middle_end/inlining_decision.mli | 43 + middle_end/inlining_decision_intf.mli | 49 + middle_end/inlining_stats.ml | 251 + middle_end/inlining_stats.mli | 46 + middle_end/inlining_stats_types.ml | 282 + middle_end/inlining_stats_types.mli | 88 + middle_end/inlining_transforms.ml | 532 ++ middle_end/inlining_transforms.mli | 103 + middle_end/invariant_params.ml | 414 + middle_end/invariant_params.mli | 57 + middle_end/lift_code.ml | 162 + middle_end/lift_code.mli | 43 + middle_end/lift_constants.ml | 1038 +++ middle_end/lift_constants.mli | 65 + middle_end/lift_let_to_initialize_symbol.ml | 294 + middle_end/lift_let_to_initialize_symbol.mli | 38 + middle_end/middle_end.ml | 183 + middle_end/middle_end.mli | 30 + middle_end/pass_wrapper.ml | 34 + middle_end/pass_wrapper.mli | 25 + middle_end/projection.ml | 169 + middle_end/projection.mli | 80 + middle_end/ref_to_variables.ml | 202 + middle_end/ref_to_variables.mli | 23 + middle_end/remove_free_vars_equal_to_args.ml | 104 + middle_end/remove_free_vars_equal_to_args.mli | 20 + middle_end/remove_unused_arguments.ml | 230 + middle_end/remove_unused_arguments.mli | 39 + middle_end/remove_unused_closure_vars.ml | 124 + middle_end/remove_unused_closure_vars.mli | 26 + .../remove_unused_program_constructs.ml | 108 + .../remove_unused_program_constructs.mli | 24 + middle_end/share_constants.ml | 129 + middle_end/share_constants.mli | 22 + middle_end/simple_value_approx.ml | 860 ++ middle_end/simple_value_approx.mli | 428 + middle_end/simplify_boxed_integer_ops.ml | 110 + middle_end/simplify_boxed_integer_ops.mli | 28 + .../simplify_boxed_integer_ops_intf.mli | 45 + middle_end/simplify_common.ml | 66 + middle_end/simplify_common.mli | 73 + middle_end/simplify_primitives.ml | 248 + middle_end/simplify_primitives.mli | 28 + middle_end/unbox_closures.ml | 87 + middle_end/unbox_closures.mli | 32 + middle_end/unbox_free_vars_of_closures.ml | 175 + middle_end/unbox_free_vars_of_closures.mli | 26 + middle_end/unbox_specialised_args.ml | 103 + middle_end/unbox_specialised_args.mli | 49 + ocamldoc/.depend | 274 + ocamldoc/Changes.txt | 209 + ocamldoc/Makefile | 429 + ocamldoc/Makefile.nt | 16 + ocamldoc/generators/odoc_literate.ml | 215 + ocamldoc/generators/odoc_todo.ml | 235 + ocamldoc/ocamldoc.hva | 34 + ocamldoc/ocamldoc.sty | 58 + ocamldoc/odoc.ml | 133 + ocamldoc/odoc_analyse.ml | 485 ++ ocamldoc/odoc_analyse.mli | 33 + ocamldoc/odoc_args.ml | 423 + ocamldoc/odoc_args.mli | 53 + ocamldoc/odoc_ast.ml | 1893 +++++ ocamldoc/odoc_ast.mli | 101 + ocamldoc/odoc_class.ml | 252 + ocamldoc/odoc_comments.ml | 262 + ocamldoc/odoc_comments.mli | 76 + ocamldoc/odoc_comments_global.ml | 51 + ocamldoc/odoc_comments_global.mli | 52 + ocamldoc/odoc_config.ml | 20 + ocamldoc/odoc_config.mli | 22 + ocamldoc/odoc_control.ml | 14 + ocamldoc/odoc_cross.ml | 1133 +++ ocamldoc/odoc_cross.mli | 22 + ocamldoc/odoc_dag2html.ml | 1613 ++++ ocamldoc/odoc_dag2html.mli | 31 + ocamldoc/odoc_dep.ml | 220 + ocamldoc/odoc_dot.ml | 147 + ocamldoc/odoc_env.ml | 247 + ocamldoc/odoc_env.mli | 78 + ocamldoc/odoc_exception.ml | 33 + ocamldoc/odoc_extension.ml | 48 + ocamldoc/odoc_gen.ml | 64 + ocamldoc/odoc_gen.mli | 46 + ocamldoc/odoc_global.ml | 79 + ocamldoc/odoc_global.mli | 104 + ocamldoc/odoc_html.ml | 2841 +++++++ ocamldoc/odoc_info.ml | 338 + ocamldoc/odoc_info.mli | 1093 +++ ocamldoc/odoc_inherit.ml | 14 + ocamldoc/odoc_latex.ml | 1339 +++ ocamldoc/odoc_latex_style.ml | 93 + ocamldoc/odoc_lexer.mll | 422 + ocamldoc/odoc_man.ml | 1315 +++ ocamldoc/odoc_merge.ml | 1086 +++ ocamldoc/odoc_merge.mli | 37 + ocamldoc/odoc_messages.ml | 405 + ocamldoc/odoc_misc.ml | 504 ++ ocamldoc/odoc_misc.mli | 122 + ocamldoc/odoc_module.ml | 572 ++ ocamldoc/odoc_name.ml | 226 + ocamldoc/odoc_name.mli | 74 + ocamldoc/odoc_ocamlhtml.mll | 552 ++ ocamldoc/odoc_parameter.ml | 125 + ocamldoc/odoc_parser.mly | 177 + ocamldoc/odoc_print.ml | 103 + ocamldoc/odoc_print.mli | 34 + ocamldoc/odoc_scan.ml | 190 + ocamldoc/odoc_search.ml | 747 ++ ocamldoc/odoc_search.mli | 242 + ocamldoc/odoc_see_lexer.mll | 103 + ocamldoc/odoc_sig.ml | 1651 ++++ ocamldoc/odoc_sig.mli | 192 + ocamldoc/odoc_str.ml | 394 + ocamldoc/odoc_str.mli | 62 + ocamldoc/odoc_test.ml | 126 + ocamldoc/odoc_texi.ml | 1315 +++ ocamldoc/odoc_text.ml | 169 + ocamldoc/odoc_text.mli | 26 + ocamldoc/odoc_text_lexer.mll | 857 ++ ocamldoc/odoc_text_parser.mly | 214 + ocamldoc/odoc_to_text.ml | 608 ++ ocamldoc/odoc_type.ml | 73 + ocamldoc/odoc_types.ml | 143 + ocamldoc/odoc_types.mli | 142 + ocamldoc/odoc_value.ml | 140 + ocamldoc/remove_DEBUG | 24 + otherlibs/Makefile | 116 + otherlibs/bigarray/.depend | 25 + otherlibs/bigarray/Makefile | 37 + otherlibs/bigarray/Makefile.nt | 16 + otherlibs/bigarray/bigarray.h | 125 + otherlibs/bigarray/bigarray.ml | 349 + otherlibs/bigarray/bigarray.mli | 953 +++ otherlibs/bigarray/bigarray_stubs.c | 1333 +++ otherlibs/bigarray/mmap_unix.c | 206 + otherlibs/bigarray/mmap_win32.c | 155 + otherlibs/dynlink/Makefile | 123 + otherlibs/dynlink/Makefile.nt | 18 + otherlibs/dynlink/dynlink.ml | 338 + otherlibs/dynlink/dynlink.mli | 148 + otherlibs/dynlink/extract_crc.ml | 53 + otherlibs/dynlink/natdynlink.ml | 256 + otherlibs/graph/.depend | 100 + otherlibs/graph/Makefile | 34 + otherlibs/graph/color.c | 233 + otherlibs/graph/draw.c | 127 + otherlibs/graph/dump_img.c | 58 + otherlibs/graph/events.c | 279 + otherlibs/graph/fill.c | 90 + otherlibs/graph/graphics.ml | 266 + otherlibs/graph/graphics.mli | 388 + otherlibs/graph/graphicsX11.ml | 42 + otherlibs/graph/graphicsX11.mli | 30 + otherlibs/graph/image.c | 108 + otherlibs/graph/image.h | 29 + otherlibs/graph/libgraph.h | 89 + otherlibs/graph/make_img.c | 99 + otherlibs/graph/open.c | 400 + otherlibs/graph/point_col.c | 31 + otherlibs/graph/sound.c | 34 + otherlibs/graph/subwindow.c | 45 + otherlibs/graph/text.c | 86 + otherlibs/num/.depend | 41 + otherlibs/num/.depend.nt | 66 + otherlibs/num/Makefile | 48 + otherlibs/num/Makefile.nt | 16 + otherlibs/num/README | 55 + otherlibs/num/arith_flags.ml | 24 + otherlibs/num/arith_flags.mli | 20 + otherlibs/num/arith_status.ml | 100 + otherlibs/num/arith_status.mli | 64 + otherlibs/num/big_int.ml | 898 ++ otherlibs/num/big_int.mli | 276 + otherlibs/num/bng.c | 433 + otherlibs/num/bng.h | 156 + otherlibs/num/bng_amd64.c | 195 + otherlibs/num/bng_arm64.c | 22 + otherlibs/num/bng_digit.c | 178 + otherlibs/num/bng_ia32.c | 411 + otherlibs/num/bng_ppc.c | 94 + otherlibs/num/bng_sparc.c | 77 + otherlibs/num/int_misc.ml | 36 + otherlibs/num/int_misc.mli | 25 + otherlibs/num/nat.h | 18 + otherlibs/num/nat.ml | 594 ++ otherlibs/num/nat.mli | 89 + otherlibs/num/nat_stubs.c | 421 + otherlibs/num/num.ml | 450 + otherlibs/num/num.mli | 191 + otherlibs/num/ratio.ml | 619 ++ otherlibs/num/ratio.mli | 93 + otherlibs/raw_spacetime_lib/.depend | 54 + otherlibs/raw_spacetime_lib/Makefile | 83 + otherlibs/raw_spacetime_lib/Makefile.nt | 16 + .../raw_spacetime_lib/raw_spacetime_lib.ml | 644 ++ .../raw_spacetime_lib/raw_spacetime_lib.mli | 349 + otherlibs/str/.depend | 9 + otherlibs/str/Makefile | 40 + otherlibs/str/Makefile.nt | 16 + otherlibs/str/str.ml | 754 ++ otherlibs/str/str.mli | 291 + otherlibs/str/strstubs.c | 546 ++ otherlibs/systhreads/.depend | 28 + otherlibs/systhreads/Makefile | 159 + otherlibs/systhreads/Makefile.nt | 16 + otherlibs/systhreads/condition.ml | 20 + otherlibs/systhreads/condition.mli | 53 + otherlibs/systhreads/event.ml | 276 + otherlibs/systhreads/event.mli | 81 + otherlibs/systhreads/mutex.ml | 20 + otherlibs/systhreads/mutex.mli | 49 + otherlibs/systhreads/st_posix.h | 428 + otherlibs/systhreads/st_stubs.c | 951 +++ otherlibs/systhreads/st_win32.h | 424 + otherlibs/systhreads/thread.ml | 90 + otherlibs/systhreads/thread.mli | 133 + otherlibs/systhreads/threadUnix.ml | 65 + otherlibs/systhreads/threadUnix.mli | 96 + otherlibs/systhreads/threads.h | 68 + otherlibs/threads/.depend | 33 + otherlibs/threads/Makefile | 136 + otherlibs/threads/condition.ml | 35 + otherlibs/threads/condition.mli | 53 + otherlibs/threads/event.ml | 274 + otherlibs/threads/event.mli | 81 + otherlibs/threads/marshal.ml | 61 + otherlibs/threads/mutex.ml | 38 + otherlibs/threads/mutex.mli | 49 + otherlibs/threads/pervasives.ml | 636 ++ otherlibs/threads/scheduler.c | 878 ++ otherlibs/threads/thread.ml | 147 + otherlibs/threads/thread.mli | 140 + otherlibs/threads/threadUnix.ml | 68 + otherlibs/threads/threadUnix.mli | 104 + otherlibs/threads/unix.ml | 1205 +++ otherlibs/unix/.depend | 527 ++ otherlibs/unix/Makefile | 52 + otherlibs/unix/accept.c | 64 + otherlibs/unix/access.c | 65 + otherlibs/unix/addrofstr.c | 97 + otherlibs/unix/alarm.c | 22 + otherlibs/unix/bind.c | 41 + otherlibs/unix/chdir.c | 34 + otherlibs/unix/chmod.c | 36 + otherlibs/unix/chown.c | 34 + otherlibs/unix/chroot.c | 34 + otherlibs/unix/close.c | 28 + otherlibs/unix/closedir.c | 38 + otherlibs/unix/connect.c | 44 + otherlibs/unix/cst2constr.c | 26 + otherlibs/unix/cst2constr.h | 16 + otherlibs/unix/cstringv.c | 34 + otherlibs/unix/dup.c | 36 + otherlibs/unix/dup2.c | 44 + otherlibs/unix/envir.c | 30 + otherlibs/unix/errmsg.c | 28 + otherlibs/unix/execv.c | 30 + otherlibs/unix/execve.c | 33 + otherlibs/unix/execvp.c | 54 + otherlibs/unix/exit.c | 24 + otherlibs/unix/fchmod.c | 40 + otherlibs/unix/fchown.c | 38 + otherlibs/unix/fcntl.c | 58 + otherlibs/unix/fork.c | 32 + otherlibs/unix/ftruncate.c | 59 + otherlibs/unix/getaddrinfo.c | 135 + otherlibs/unix/getcwd.c | 58 + otherlibs/unix/getegid.c | 22 + otherlibs/unix/geteuid.c | 22 + otherlibs/unix/getgid.c | 22 + otherlibs/unix/getgr.c | 58 + otherlibs/unix/getgroups.c | 49 + otherlibs/unix/gethost.c | 184 + otherlibs/unix/gethostname.c | 56 + otherlibs/unix/getlogin.c | 29 + otherlibs/unix/getnameinfo.c | 67 + otherlibs/unix/getpeername.c | 41 + otherlibs/unix/getpid.c | 22 + otherlibs/unix/getppid.c | 22 + otherlibs/unix/getproto.c | 69 + otherlibs/unix/getpw.c | 66 + otherlibs/unix/getserv.c | 77 + otherlibs/unix/getsockname.c | 41 + otherlibs/unix/gettimeofday.c | 38 + otherlibs/unix/getuid.c | 22 + otherlibs/unix/gmtime.c | 95 + otherlibs/unix/initgroups.c | 46 + otherlibs/unix/isatty.c | 22 + otherlibs/unix/itimer.c | 75 + otherlibs/unix/kill.c | 31 + otherlibs/unix/link.c | 38 + otherlibs/unix/listen.c | 35 + otherlibs/unix/lockf.c | 116 + otherlibs/unix/lseek.c | 66 + otherlibs/unix/mkdir.c | 36 + otherlibs/unix/mkfifo.c | 73 + otherlibs/unix/nanosecond_stat.h | 27 + otherlibs/unix/nice.c | 34 + otherlibs/unix/open.c | 87 + otherlibs/unix/opendir.c | 45 + otherlibs/unix/pipe.c | 40 + otherlibs/unix/putenv.c | 53 + otherlibs/unix/read.c | 38 + otherlibs/unix/readdir.c | 42 + otherlibs/unix/readlink.c | 57 + otherlibs/unix/rename.c | 40 + otherlibs/unix/rewinddir.c | 42 + otherlibs/unix/rmdir.c | 34 + otherlibs/unix/select.c | 114 + otherlibs/unix/sendrecv.c | 148 + otherlibs/unix/setgid.c | 23 + otherlibs/unix/setgroups.c | 53 + otherlibs/unix/setsid.c | 31 + otherlibs/unix/setuid.c | 23 + otherlibs/unix/shutdown.c | 40 + otherlibs/unix/signals.c | 108 + otherlibs/unix/sleep.c | 71 + otherlibs/unix/socket.c | 65 + otherlibs/unix/socketaddr.c | 156 + otherlibs/unix/socketaddr.h | 62 + otherlibs/unix/socketpair.c | 56 + otherlibs/unix/sockopt.c | 301 + otherlibs/unix/stat.c | 179 + otherlibs/unix/strofaddr.c | 74 + otherlibs/unix/symlink.c | 61 + otherlibs/unix/termios.c | 387 + otherlibs/unix/time.c | 24 + otherlibs/unix/times.c | 67 + otherlibs/unix/truncate.c | 72 + otherlibs/unix/umask.c | 24 + otherlibs/unix/unix.ml | 1100 +++ otherlibs/unix/unix.mli | 1611 ++++ otherlibs/unix/unixLabels.ml | 18 + otherlibs/unix/unixLabels.mli | 1401 ++++ otherlibs/unix/unixsupport.c | 347 + otherlibs/unix/unixsupport.h | 57 + otherlibs/unix/unlink.c | 34 + otherlibs/unix/utimes.c | 95 + otherlibs/unix/wait.c | 104 + otherlibs/unix/write.c | 86 + otherlibs/win32graph/Makefile | 38 + otherlibs/win32graph/Makefile.nt | 16 + otherlibs/win32graph/draw.c | 648 ++ otherlibs/win32graph/events.c | 210 + otherlibs/win32graph/libgraph.h | 78 + otherlibs/win32graph/open.c | 372 + otherlibs/win32unix/.depend | 5 + otherlibs/win32unix/Makefile | 67 + otherlibs/win32unix/Makefile.nt | 16 + otherlibs/win32unix/accept.c | 53 + otherlibs/win32unix/bind.c | 34 + otherlibs/win32unix/channels.c | 100 + otherlibs/win32unix/close.c | 42 + otherlibs/win32unix/close_on.c | 43 + otherlibs/win32unix/connect.c | 39 + otherlibs/win32unix/createprocess.c | 124 + otherlibs/win32unix/dup.c | 35 + otherlibs/win32unix/dup2.c | 42 + otherlibs/win32unix/errmsg.c | 43 + otherlibs/win32unix/getpeername.c | 35 + otherlibs/win32unix/getpid.c | 24 + otherlibs/win32unix/getsockname.c | 32 + otherlibs/win32unix/gettimeofday.c | 40 + otherlibs/win32unix/link.c | 44 + otherlibs/win32unix/listen.c | 27 + otherlibs/win32unix/lockf.c | 160 + otherlibs/win32unix/lseek.c | 70 + otherlibs/win32unix/mkdir.c | 25 + otherlibs/win32unix/nonblock.c | 44 + otherlibs/win32unix/open.c | 84 + otherlibs/win32unix/pipe.c | 46 + otherlibs/win32unix/read.c | 61 + otherlibs/win32unix/readlink.c | 112 + otherlibs/win32unix/rename.c | 45 + otherlibs/win32unix/select.c | 1330 +++ otherlibs/win32unix/sendrecv.c | 143 + otherlibs/win32unix/shutdown.c | 32 + otherlibs/win32unix/sleep.c | 28 + otherlibs/win32unix/socket.c | 56 + otherlibs/win32unix/socketaddr.h | 58 + otherlibs/win32unix/sockopt.c | 229 + otherlibs/win32unix/startup.c | 51 + otherlibs/win32unix/stat.c | 409 + otherlibs/win32unix/symlink.c | 115 + otherlibs/win32unix/system.c | 45 + otherlibs/win32unix/times.c | 58 + otherlibs/win32unix/unix.ml | 1058 +++ otherlibs/win32unix/unixsupport.c | 327 + otherlibs/win32unix/unixsupport.h | 130 + otherlibs/win32unix/windbug.c | 32 + otherlibs/win32unix/windbug.h | 70 + otherlibs/win32unix/windir.c | 77 + otherlibs/win32unix/winlist.c | 80 + otherlibs/win32unix/winlist.h | 55 + otherlibs/win32unix/winwait.c | 70 + otherlibs/win32unix/winworker.c | 322 + otherlibs/win32unix/winworker.h | 73 + otherlibs/win32unix/write.c | 101 + parsing/HACKING.adoc | 9 + parsing/ast_helper.ml | 554 ++ parsing/ast_helper.mli | 439 + parsing/ast_invariants.ml | 166 + parsing/ast_invariants.mli | 18 + parsing/ast_iterator.ml | 597 ++ parsing/ast_iterator.mli | 72 + parsing/ast_mapper.ml | 928 +++ parsing/ast_mapper.mli | 200 + parsing/asttypes.mli | 58 + parsing/attr_helper.ml | 54 + parsing/attr_helper.mli | 36 + parsing/builtin_attributes.ml | 213 + parsing/builtin_attributes.mli | 55 + parsing/depend.ml | 517 ++ parsing/depend.mli | 38 + parsing/docstrings.ml | 343 + parsing/docstrings.mli | 157 + parsing/lexer.mli | 63 + parsing/lexer.mll | 793 ++ parsing/location.ml | 469 ++ parsing/location.mli | 141 + parsing/longident.ml | 44 + parsing/longident.mli | 25 + parsing/parse.ml | 67 + parsing/parse.mli | 24 + parsing/parser.mly | 2582 ++++++ parsing/parsetree.mli | 866 ++ parsing/pprintast.ml | 1474 ++++ parsing/pprintast.mli | 26 + parsing/printast.ml | 912 +++ parsing/printast.mli | 25 + parsing/syntaxerr.ml | 87 + parsing/syntaxerr.mli | 37 + stdlib/.depend | 320 + stdlib/Compflags | 30 + stdlib/Makefile | 250 + stdlib/Makefile.nt | 16 + stdlib/StdlibModules | 72 + stdlib/arg.ml | 394 + stdlib/arg.mli | 207 + stdlib/array.ml | 294 + stdlib/array.mli | 265 + stdlib/arrayLabels.ml | 18 + stdlib/arrayLabels.mli | 266 + stdlib/buffer.ml | 196 + stdlib/buffer.mli | 139 + stdlib/bytes.ml | 329 + stdlib/bytes.mli | 460 ++ stdlib/bytesLabels.ml | 18 + stdlib/bytesLabels.mli | 307 + stdlib/callback.ml | 27 + stdlib/callback.mli | 34 + stdlib/camlinternalFormat.ml | 2958 +++++++ stdlib/camlinternalFormat.mli | 122 + stdlib/camlinternalFormatBasics.ml | 683 ++ stdlib/camlinternalFormatBasics.mli | 325 + stdlib/camlinternalLazy.ml | 65 + stdlib/camlinternalLazy.mli | 27 + stdlib/camlinternalMod.ml | 74 + stdlib/camlinternalMod.mli | 28 + stdlib/camlinternalOO.ml | 613 ++ stdlib/camlinternalOO.mli | 153 + stdlib/char.ml | 76 + stdlib/char.mli | 72 + stdlib/complex.ml | 87 + stdlib/complex.mli | 86 + stdlib/digest.ml | 76 + stdlib/digest.mli | 84 + stdlib/ephemeron.ml | 641 ++ stdlib/ephemeron.mli | 373 + stdlib/filename.ml | 262 + stdlib/filename.mli | 167 + stdlib/format.ml | 1326 +++ stdlib/format.mli | 823 ++ stdlib/gc.ml | 116 + stdlib/gc.mli | 346 + stdlib/genlex.ml | 201 + stdlib/genlex.mli | 73 + stdlib/hashbang | 1 + stdlib/hashtbl.ml | 544 ++ stdlib/hashtbl.mli | 411 + stdlib/header.c | 193 + stdlib/headernt.c | 182 + stdlib/int32.ml | 68 + stdlib/int32.mli | 181 + stdlib/int64.ml | 75 + stdlib/int64.mli | 202 + stdlib/lazy.ml | 81 + stdlib/lazy.mli | 95 + stdlib/lexing.ml | 231 + stdlib/lexing.mli | 176 + stdlib/list.ml | 468 ++ stdlib/list.mli | 340 + stdlib/listLabels.ml | 18 + stdlib/listLabels.mli | 346 + stdlib/map.ml | 459 ++ stdlib/map.mli | 302 + stdlib/marshal.ml | 68 + stdlib/marshal.mli | 185 + stdlib/moreLabels.ml | 22 + stdlib/moreLabels.mli | 197 + stdlib/nativeint.ml | 65 + stdlib/nativeint.mli | 198 + stdlib/obj.ml | 113 + stdlib/obj.mli | 152 + stdlib/oo.ml | 19 + stdlib/oo.mli | 38 + stdlib/parsing.ml | 211 + stdlib/parsing.mli | 105 + stdlib/pervasives.ml | 544 ++ stdlib/pervasives.mli | 1168 +++ stdlib/printexc.ml | 324 + stdlib/printexc.mli | 342 + stdlib/printf.ml | 41 + stdlib/printf.mli | 172 + stdlib/queue.ml | 132 + stdlib/queue.mli | 82 + stdlib/random.ml | 277 + stdlib/random.mli | 107 + stdlib/scanf.ml | 1574 ++++ stdlib/scanf.mli | 559 ++ stdlib/set.ml | 524 ++ stdlib/set.mli | 266 + stdlib/sort.ml | 99 + stdlib/sort.mli | 44 + stdlib/spacetime.ml | 91 + stdlib/spacetime.mli | 99 + stdlib/stack.ml | 44 + stdlib/stack.mli | 63 + stdlib/stdLabels.ml | 24 + stdlib/stdLabels.mli | 29 + stdlib/std_exit.ml | 18 + stdlib/stream.ml | 233 + stdlib/stream.mli | 110 + stdlib/string.ml | 226 + stdlib/string.mli | 348 + stdlib/stringLabels.ml | 18 + stdlib/stringLabels.mli | 303 + stdlib/sys.mli | 329 + stdlib/sys.mlp | 131 + stdlib/uchar.ml | 55 + stdlib/uchar.mli | 84 + stdlib/weak.ml | 336 + stdlib/weak.mli | 185 + testsuite/HACKING.adoc | 11 + testsuite/Makefile | 203 + testsuite/interactive/lib-gc/Makefile | 27 + testsuite/interactive/lib-gc/alloc.ml | 51 + testsuite/interactive/lib-graph-2/Makefile | 23 + .../interactive/lib-graph-2/graph_test.ml | 290 + .../lib-graph-2/graph_test.reference | 0 testsuite/interactive/lib-graph-3/Makefile | 23 + testsuite/interactive/lib-graph-3/sorts.ml | 243 + .../interactive/lib-graph-3/sorts.reference | 0 testsuite/interactive/lib-graph/Makefile | 23 + .../interactive/lib-graph/graph_example.ml | 146 + .../lib-graph/graph_example.reference | 0 testsuite/interactive/lib-signals/Makefile | 27 + testsuite/interactive/lib-signals/signals.ml | 47 + testsuite/lib/Makefile | 31 + testsuite/lib/testing.ml | 96 + testsuite/lib/testing.mli | 35 + testsuite/makefiles/Makefile.common | 82 + testsuite/makefiles/Makefile.dlambda | 35 + testsuite/makefiles/Makefile.dparsetree | 30 + testsuite/makefiles/Makefile.expect | 32 + testsuite/makefiles/Makefile.okbad | 54 + testsuite/makefiles/Makefile.one | 104 + testsuite/makefiles/Makefile.several | 142 + testsuite/makefiles/Makefile.toplevel | 34 + testsuite/makefiles/summarize.awk | 212 + testsuite/tests/array-functions/Makefile | 18 + testsuite/tests/array-functions/test.ml | 182 + .../tests/array-functions/test.reference | 1 + testsuite/tests/asmcomp/Makefile | 156 + testsuite/tests/asmcomp/alpha.S | 63 + testsuite/tests/asmcomp/amd64.S | 78 + testsuite/tests/asmcomp/arith.cmm | 221 + testsuite/tests/asmcomp/arm.S | 40 + testsuite/tests/asmcomp/arm64.S | 55 + testsuite/tests/asmcomp/bind_tuples.ml | 28 + testsuite/tests/asmcomp/catch-rec.cmm | 5 + testsuite/tests/asmcomp/catch-try.cmm | 7 + testsuite/tests/asmcomp/checkbound.cmm | 20 + testsuite/tests/asmcomp/even-odd-spill.cmm | 19 + testsuite/tests/asmcomp/even-odd.cmm | 8 + testsuite/tests/asmcomp/fib.cmm | 20 + testsuite/tests/asmcomp/hppa.S | 161 + testsuite/tests/asmcomp/i386.S | 58 + testsuite/tests/asmcomp/i386nt.asm | 65 + testsuite/tests/asmcomp/ia64.S | 119 + testsuite/tests/asmcomp/integr.cmm | 31 + testsuite/tests/asmcomp/is_in_static_data.c | 5 + testsuite/tests/asmcomp/is_static.ml | 34 + testsuite/tests/asmcomp/is_static_flambda.ml | 115 + .../tests/asmcomp/is_static_flambda_dep.ml | 1 + testsuite/tests/asmcomp/lexcmm.mli | 10 + testsuite/tests/asmcomp/lexcmm.mll | 241 + testsuite/tests/asmcomp/m68k.S | 57 + testsuite/tests/asmcomp/main.c | 125 + testsuite/tests/asmcomp/main.ml | 66 + testsuite/tests/asmcomp/mainarith.c | 343 + testsuite/tests/asmcomp/mips.s | 72 + testsuite/tests/asmcomp/optargs.ml | 21 + testsuite/tests/asmcomp/parsecmm.mly | 359 + testsuite/tests/asmcomp/parsecmmaux.ml | 43 + testsuite/tests/asmcomp/parsecmmaux.mli | 16 + testsuite/tests/asmcomp/pgcd.cmm | 9 + testsuite/tests/asmcomp/power.S | 197 + testsuite/tests/asmcomp/quicksort.cmm | 44 + testsuite/tests/asmcomp/quicksort2.cmm | 50 + testsuite/tests/asmcomp/register_typing.ml | 20 + .../tests/asmcomp/register_typing_switch.ml | 21 + testsuite/tests/asmcomp/s390x.S | 64 + testsuite/tests/asmcomp/simple_float_const.ml | 1 + .../asmcomp/simple_float_const_opaque.ml | 1 + testsuite/tests/asmcomp/soli.cmm | 110 + testsuite/tests/asmcomp/sparc.S | 42 + .../asmcomp/static_float_array_flambda.ml | 18 + .../static_float_array_flambda_opaque.ml | 21 + testsuite/tests/asmcomp/staticalloc.ml | 19 + testsuite/tests/asmcomp/tagged-fib.cmm | 19 + testsuite/tests/asmcomp/tagged-integr.cmm | 45 + testsuite/tests/asmcomp/tagged-quicksort.cmm | 47 + testsuite/tests/asmcomp/tagged-tak.cmm | 24 + testsuite/tests/asmcomp/tak.cmm | 24 + testsuite/tests/asmcomp/unrolling_flambda.ml | 7 + testsuite/tests/asmcomp/unrolling_flambda2.ml | 20 + testsuite/tests/ast-invariants/Makefile | 27 + testsuite/tests/ast-invariants/test.ml | 71 + testsuite/tests/ast-invariants/test.reference | 0 testsuite/tests/backtrace/Makefile | 155 + .../tests/backtrace/backtrace..byte.reference | 2 + .../backtrace/backtrace..native.reference | 2 + .../backtrace/backtrace.a.byte.reference | 1 + .../backtrace/backtrace.a.native.reference | 1 + .../backtrace/backtrace.b.byte.reference | 11 + .../backtrace/backtrace.b.native.reference | 11 + .../backtrace/backtrace.c.byte.reference | 3 + .../backtrace/backtrace.c.native.reference | 3 + .../backtrace/backtrace.d.byte.reference | 9 + .../backtrace/backtrace.d.native.reference | 9 + testsuite/tests/backtrace/backtrace.ml | 18 + .../tests/backtrace/backtrace2.byte.reference | 58 + testsuite/tests/backtrace/backtrace2.ml | 75 + .../backtrace/backtrace2.native.reference | 58 + .../tests/backtrace/backtrace3.byte.reference | 27 + testsuite/tests/backtrace/backtrace3.ml | 39 + .../backtrace/backtrace3.native.reference | 27 + .../backtrace_deprecated.byte.reference | 27 + .../tests/backtrace/backtrace_deprecated.ml | 39 + .../backtrace_deprecated.native.reference | 27 + .../backtrace/backtrace_slots.byte.reference | 27 + testsuite/tests/backtrace/backtrace_slots.ml | 61 + .../backtrace_slots.native.reference | 27 + .../backtrace/backtraces_and_finalizers.ml | 26 + ...backtraces_and_finalizers.native.reference | 1 + .../backtrace/inline_test.byte.reference | 15 + testsuite/tests/backtrace/inline_test.ml | 18 + .../backtrace/inline_test.native.reference | 15 + .../inline_traversal_test.byte.reference | 5 + .../tests/backtrace/inline_traversal_test.ml | 46 + .../inline_traversal_test.native.reference | 5 + .../backtrace/pr6920_why_at.byte.reference | 4 + testsuite/tests/backtrace/pr6920_why_at.ml | 9 + .../backtrace/pr6920_why_at.native.reference | 4 + .../pr6920_why_swallow.byte.reference | 4 + .../tests/backtrace/pr6920_why_swallow.ml | 11 + .../pr6920_why_swallow.native.reference | 4 + .../backtrace/raw_backtrace.byte.reference | 49 + testsuite/tests/backtrace/raw_backtrace.ml | 59 + .../backtrace/raw_backtrace.native.reference | 49 + testsuite/tests/basic-float/Makefile | 18 + testsuite/tests/basic-float/tfloat_hex.ml | 15 + .../tests/basic-float/tfloat_hex.reference | 6 + testsuite/tests/basic-float/tfloat_record.ml | 46 + .../tests/basic-float/tfloat_record.reference | 46 + .../basic-float/zero_sized_float_arrays.ml | 15 + .../zero_sized_float_arrays.reference | 0 testsuite/tests/basic-io-2/Makefile | 22 + testsuite/tests/basic-io-2/io.ml | 103 + testsuite/tests/basic-io-2/io.reference | 24 + .../tests/basic-io-2/test-file-short-lines | 10 + testsuite/tests/basic-io/Makefile | 22 + testsuite/tests/basic-io/wc.ml | 55 + testsuite/tests/basic-io/wc.reference | 1 + testsuite/tests/basic-manyargs/Makefile | 22 + testsuite/tests/basic-manyargs/manyargs.ml | 45 + .../tests/basic-manyargs/manyargs.reference | 65 + testsuite/tests/basic-manyargs/manyargsprim.c | 40 + testsuite/tests/basic-modules/Makefile | 22 + testsuite/tests/basic-modules/main.ml | 22 + testsuite/tests/basic-modules/main.mli | 0 testsuite/tests/basic-modules/main.reference | 1 + testsuite/tests/basic-modules/offset.ml | 10 + testsuite/tests/basic-modules/pr6726.ml | 18 + testsuite/tests/basic-modules/pr7427.ml | 7 + testsuite/tests/basic-more/Makefile | 21 + testsuite/tests/basic-more/bounds.ml | 26 + testsuite/tests/basic-more/bounds.reference | 9 + testsuite/tests/basic-more/div_by_zero.ml | 67 + .../tests/basic-more/div_by_zero.reference | 3 + testsuite/tests/basic-more/function_in_ref.ml | 9 + .../basic-more/function_in_ref.reference | 2 + testsuite/tests/basic-more/if_in_if.ml | 44 + testsuite/tests/basic-more/if_in_if.reference | 2 + testsuite/tests/basic-more/morematch.ml | 1189 +++ .../tests/basic-more/morematch.reference | 2 + testsuite/tests/basic-more/opaque_prim.ml | 6 + .../tests/basic-more/opaque_prim.reference | 2 + testsuite/tests/basic-more/pr2719.ml | 17 + testsuite/tests/basic-more/pr2719.reference | 4 + testsuite/tests/basic-more/pr6216.ml | 12 + testsuite/tests/basic-more/pr6216.reference | 2 + .../basic-more/record_evaluation_order.ml | 89 + .../record_evaluation_order.reference | 38 + .../tests/basic-more/sequential_and_or.ml | 122 + .../basic-more/sequential_and_or.reference | 74 + .../tests/basic-more/structural_constants.ml | 217 + .../basic-more/structural_constants.reference | 2 + testsuite/tests/basic-more/tbuffer.ml | 26 + testsuite/tests/basic-more/tbuffer.reference | 2 + testsuite/tests/basic-more/testrandom.ml | 12 + .../tests/basic-more/testrandom.reference | 4 + testsuite/tests/basic-more/tformat.ml | 21 + testsuite/tests/basic-more/tformat.reference | 2 + .../tests/basic-more/top_level_patterns.ml | 8 + .../basic-more/top_level_patterns.reference | 2 + testsuite/tests/basic-more/tprintf.ml | 75 + testsuite/tests/basic-more/tprintf.reference | 2 + testsuite/tests/basic-multdef/Makefile | 21 + testsuite/tests/basic-multdef/multdef.ml | 2 + testsuite/tests/basic-multdef/multdef.mli | 3 + testsuite/tests/basic-multdef/usemultdef.ml | 1 + .../tests/basic-multdef/usemultdef.reference | 1 + testsuite/tests/basic-private/Makefile | 22 + testsuite/tests/basic-private/length.ml | 16 + testsuite/tests/basic-private/length.mli | 13 + testsuite/tests/basic-private/tlength.ml | 23 + .../tests/basic-private/tlength.reference | 0 testsuite/tests/basic/Makefile | 33 + testsuite/tests/basic/arrays.ml | 137 + testsuite/tests/basic/arrays.reference | 0 testsuite/tests/basic/bigints.ml | 25 + testsuite/tests/basic/bigints.reference | 10 + testsuite/tests/basic/boxedints.ml | 581 ++ testsuite/tests/basic/boxedints.reference | 118 + testsuite/tests/basic/constprop.ml | 104 + testsuite/tests/basic/constprop.mlp | 117 + testsuite/tests/basic/constprop.reference | 10 + testsuite/tests/basic/divint.ml | 145 + testsuite/tests/basic/divint.reference | 37 + testsuite/tests/basic/equality.ml | 104 + testsuite/tests/basic/equality.reference | 49 + testsuite/tests/basic/eval_order_1.ml | 4 + testsuite/tests/basic/eval_order_1.reference | 1 + testsuite/tests/basic/eval_order_2.ml | 24 + testsuite/tests/basic/eval_order_2.reference | 0 testsuite/tests/basic/eval_order_3.ml | 22 + testsuite/tests/basic/eval_order_3.reference | 1 + testsuite/tests/basic/eval_order_4.ml | 17 + testsuite/tests/basic/eval_order_4.reference | 4 + testsuite/tests/basic/float.ml | 1 + testsuite/tests/basic/float.reference | 1 + .../tests/basic/float_physical_equality.ml | 10 + .../basic/float_physical_equality.reference | 0 testsuite/tests/basic/includestruct.ml | 107 + testsuite/tests/basic/includestruct.reference | 17 + testsuite/tests/basic/localexn.ml | 9 + testsuite/tests/basic/localexn.reference | 2 + testsuite/tests/basic/maps.ml | 31 + testsuite/tests/basic/maps.reference | 10 + testsuite/tests/basic/min_int.ml | 10 + testsuite/tests/basic/min_int.reference | 1 + testsuite/tests/basic/opt_variants.ml | 114 + testsuite/tests/basic/opt_variants.reference | 0 testsuite/tests/basic/patmatch.ml | 1635 ++++ testsuite/tests/basic/patmatch.reference | 76 + testsuite/tests/basic/pr6322.ml.in | 11 + testsuite/tests/basic/pr6322.reference | 1 + testsuite/tests/basic/pr7533.ml | 19 + testsuite/tests/basic/pr7533.reference | 0 testsuite/tests/basic/recvalues.ml | 38 + testsuite/tests/basic/recvalues.reference | 5 + testsuite/tests/basic/sets.ml | 25 + testsuite/tests/basic/sets.reference | 25 + testsuite/tests/basic/stringmatch.ml | 738 ++ testsuite/tests/basic/stringmatch.reference | 0 testsuite/tests/basic/switch_opts.ml | 63 + testsuite/tests/basic/switch_opts.reference | 1 + testsuite/tests/basic/tailcalls.ml | 41 + testsuite/tests/basic/tailcalls.reference | 6 + testsuite/tests/basic/zero_divided_by_n.ml | 17 + .../tests/basic/zero_divided_by_n.reference | 0 testsuite/tests/callback/Makefile | 69 + testsuite/tests/callback/callbackprim.c | 69 + testsuite/tests/callback/reference | 8 + testsuite/tests/callback/tcallback.ml | 71 + testsuite/tests/docstrings/Makefile | 4 + testsuite/tests/docstrings/empty.ml | 8 + testsuite/tests/docstrings/empty.ml.reference | 52 + testsuite/tests/embedded/Makefile | 44 + testsuite/tests/embedded/cmcaml.ml | 16 + testsuite/tests/embedded/cmmain.c | 35 + testsuite/tests/embedded/cmstub.c | 30 + testsuite/tests/embedded/program.reference | 4 + testsuite/tests/exotic-syntax/Makefile | 20 + testsuite/tests/exotic-syntax/exotic.ml | 159 + .../tests/exotic-syntax/exotic.reference | 0 .../tests/extension-constructor/Makefile | 18 + testsuite/tests/extension-constructor/test.ml | 21 + .../extension-constructor/test.reference | 1 + testsuite/tests/flambda/Makefile | 21 + testsuite/tests/flambda/gpr998.ml | 39 + testsuite/tests/flambda/gpr998.reference | 0 testsuite/tests/float-unboxing/Makefile | 32 + .../tests/float-unboxing/float_flambda.ml | 9 + .../float_subst_boxed_number.ml | 174 + .../float_subst_boxed_number.reference | 0 testsuite/tests/formats-transition/Makefile | 3 + .../deprecated_unsigned_printers.ml | 22 + .../deprecated_unsigned_printers.ml.reference | 7 + .../ignored_scan_counters.ml | 33 + .../ignored_scan_counters.ml.reference | 15 + .../legacy_incompatible_flags.ml | 20 + .../legacy_incompatible_flags.ml.reference | 8 + .../legacy_unfinished_modifiers.ml | 18 + .../legacy_unfinished_modifiers.ml.reference | 6 + testsuite/tests/formatting/Makefile | 5 + testsuite/tests/formatting/margins.ml | 7 + .../tests/formatting/margins.ml.reference | 14 + testsuite/tests/gc-roots/Makefile | 23 + testsuite/tests/gc-roots/globroots.ml | 83 + testsuite/tests/gc-roots/globroots.reference | 4 + testsuite/tests/gc-roots/globrootsprim.c | 83 + testsuite/tests/int64-unboxing/Makefile | 24 + testsuite/tests/int64-unboxing/stubs.c | 25 + testsuite/tests/int64-unboxing/test.ml | 25 + testsuite/tests/int64-unboxing/test.reference | 0 testsuite/tests/lazy/Makefile | 18 + testsuite/tests/lazy/lazy1.ml | 14 + testsuite/tests/lazy/lazy1.reference | 1 + testsuite/tests/letrec/Makefile | 19 + testsuite/tests/letrec/backreferences.ml | 18 + .../tests/letrec/backreferences.reference | 0 testsuite/tests/letrec/class_1.ml | 5 + testsuite/tests/letrec/class_1.reference | 0 testsuite/tests/letrec/class_2.ml | 8 + testsuite/tests/letrec/class_2.reference | 2 + testsuite/tests/letrec/evaluation_order_1.ml | 20 + .../tests/letrec/evaluation_order_1.reference | 3 + testsuite/tests/letrec/evaluation_order_2.ml | 19 + .../tests/letrec/evaluation_order_2.reference | 3 + testsuite/tests/letrec/evaluation_order_3.ml | 11 + .../tests/letrec/evaluation_order_3.reference | 6 + testsuite/tests/letrec/float_block_1.ml | 10 + .../tests/letrec/float_block_1.reference | 2 + testsuite/tests/letrec/float_block_2.ml | 7 + .../tests/letrec/float_block_2.reference | 0 testsuite/tests/letrec/lists.ml | 8 + testsuite/tests/letrec/lists.reference | 0 .../tests/letrec/mixing_value_closures_1.ml | 8 + .../letrec/mixing_value_closures_1.reference | 0 .../tests/letrec/mixing_value_closures_2.ml | 8 + .../letrec/mixing_value_closures_2.reference | 0 testsuite/tests/letrec/mutual_functions.ml | 11 + .../tests/letrec/mutual_functions.reference | 0 testsuite/tests/letrec/record_with.ml | 24 + testsuite/tests/letrec/record_with.reference | 1 + testsuite/tests/lib-arg/Makefile | 19 + testsuite/tests/lib-arg/testarg.ml | 189 + testsuite/tests/lib-arg/testarg.reference | 0 testsuite/tests/lib-arg/testerror.ml | 41 + testsuite/tests/lib-arg/testerror.reference | 45 + testsuite/tests/lib-bigarray-2/Makefile | 24 + testsuite/tests/lib-bigarray-2/bigarrf.f | 26 + testsuite/tests/lib-bigarray-2/bigarrfml.ml | 66 + .../tests/lib-bigarray-2/bigarrfml.reference | 27 + testsuite/tests/lib-bigarray-2/bigarrfstub.c | 74 + testsuite/tests/lib-bigarray-file/Makefile | 23 + testsuite/tests/lib-bigarray-file/mapfile.ml | 109 + .../tests/lib-bigarray-file/mapfile.reference | 3 + testsuite/tests/lib-bigarray/Makefile | 23 + testsuite/tests/lib-bigarray/bigarrays.ml | 1045 +++ .../tests/lib-bigarray/bigarrays.reference | 79 + testsuite/tests/lib-bigarray/fftba.ml | 182 + testsuite/tests/lib-bigarray/fftba.reference | 13 + testsuite/tests/lib-bigarray/pr5115.ml | 12 + testsuite/tests/lib-bigarray/pr5115.reference | 2 + testsuite/tests/lib-bigarray/weak_bigarray.ml | 28 + .../lib-bigarray/weak_bigarray.reference | 3 + testsuite/tests/lib-buffer/Makefile | 18 + testsuite/tests/lib-buffer/test.ml | 86 + testsuite/tests/lib-buffer/test.reference | 6 + testsuite/tests/lib-bytes/Makefile | 19 + testsuite/tests/lib-bytes/test_bytes.ml | 122 + .../tests/lib-bytes/test_bytes.reference | 2 + testsuite/tests/lib-digest/Makefile | 22 + testsuite/tests/lib-digest/md5.ml | 230 + testsuite/tests/lib-digest/md5.reference | 1 + testsuite/tests/lib-dynlink-bytecode/Makefile | 73 + .../lib-dynlink-bytecode/custom.reference | 5 + testsuite/tests/lib-dynlink-bytecode/main.ml | 37 + .../tests/lib-dynlink-bytecode/main.reference | 13 + testsuite/tests/lib-dynlink-bytecode/plug1.ml | 7 + testsuite/tests/lib-dynlink-bytecode/plug2.ml | 7 + .../tests/lib-dynlink-bytecode/registry.ml | 7 + .../lib-dynlink-bytecode/static.reference | 5 + testsuite/tests/lib-dynlink-bytecode/stub1.c | 27 + testsuite/tests/lib-dynlink-bytecode/stub2.c | 28 + testsuite/tests/lib-dynlink-csharp/Makefile | 122 + .../lib-dynlink-csharp/bytecode.reference | 6 + testsuite/tests/lib-dynlink-csharp/entry.c | 44 + testsuite/tests/lib-dynlink-csharp/main.cs | 11 + testsuite/tests/lib-dynlink-csharp/main.ml | 23 + .../tests/lib-dynlink-csharp/native.reference | 6 + testsuite/tests/lib-dynlink-csharp/plugin.ml | 4 + testsuite/tests/lib-dynlink-native/Makefile | 128 + testsuite/tests/lib-dynlink-native/a.ml | 5 + testsuite/tests/lib-dynlink-native/api.ml | 20 + testsuite/tests/lib-dynlink-native/b.ml | 4 + testsuite/tests/lib-dynlink-native/bug.ml | 2 + testsuite/tests/lib-dynlink-native/c.ml | 4 + .../tests/lib-dynlink-native/factorial.c | 33 + testsuite/tests/lib-dynlink-native/main.ml | 32 + .../tests/lib-dynlink-native/pack_client.ml | 2 + testsuite/tests/lib-dynlink-native/packed1.ml | 5 + .../lib-dynlink-native/packed1_client.ml | 3 + testsuite/tests/lib-dynlink-native/plugin.ml | 11 + testsuite/tests/lib-dynlink-native/plugin.mli | 1 + testsuite/tests/lib-dynlink-native/plugin2.ml | 8 + testsuite/tests/lib-dynlink-native/plugin4.ml | 3 + .../tests/lib-dynlink-native/plugin_ext.ml | 5 + .../lib-dynlink-native/plugin_high_arity.ml | 6 + .../tests/lib-dynlink-native/plugin_ref.ml | 10 + .../tests/lib-dynlink-native/plugin_simple.ml | 3 + .../tests/lib-dynlink-native/plugin_thread.ml | 15 + testsuite/tests/lib-dynlink-native/reference | 30 + testsuite/tests/lib-dynlink-native/sub/api.ml | 3 + .../tests/lib-dynlink-native/sub/api.mli | 1 + .../tests/lib-dynlink-native/sub/plugin.ml | 6 + .../tests/lib-dynlink-native/sub/plugin3.ml | 2 + testsuite/tests/lib-filename/Makefile | 18 + testsuite/tests/lib-filename/extension.ml | 14 + .../tests/lib-filename/extension.reference | 0 testsuite/tests/lib-format/Makefile | 20 + testsuite/tests/lib-format/pr6824.ml | 7 + testsuite/tests/lib-format/pr6824.reference | 6 + testsuite/tests/lib-format/tformat.ml | 529 ++ testsuite/tests/lib-format/tformat.reference | 95 + testsuite/tests/lib-hashtbl/Makefile | 18 + testsuite/tests/lib-hashtbl/hfun.ml | 42 + testsuite/tests/lib-hashtbl/hfun.reference | 27 + testsuite/tests/lib-hashtbl/htbl.ml | 251 + testsuite/tests/lib-hashtbl/htbl.reference | 56 + testsuite/tests/lib-marshal/Makefile | 22 + testsuite/tests/lib-marshal/intext.ml | 614 ++ testsuite/tests/lib-marshal/intext.reference | 174 + testsuite/tests/lib-marshal/intextaux.c | 30 + testsuite/tests/lib-num-2/Makefile | 23 + testsuite/tests/lib-num-2/pi_big_int.ml | 78 + .../tests/lib-num-2/pi_big_int.reference | 100 + testsuite/tests/lib-num-2/pi_num.ml | 72 + testsuite/tests/lib-num-2/pi_num.reference | 100 + testsuite/tests/lib-num/Makefile | 24 + testsuite/tests/lib-num/end_test.ml | 1 + testsuite/tests/lib-num/end_test.reference | 170 + testsuite/tests/lib-num/test.ml | 103 + testsuite/tests/lib-num/test_big_ints.ml | 1030 +++ testsuite/tests/lib-num/test_io.ml | 64 + testsuite/tests/lib-num/test_nats.ml | 148 + testsuite/tests/lib-num/test_nums.ml | 234 + testsuite/tests/lib-num/test_ratios.ml | 1195 +++ testsuite/tests/lib-obj/Makefile | 21 + testsuite/tests/lib-obj/reachable_words.ml | 37 + .../tests/lib-obj/reachable_words.reference | 1 + testsuite/tests/lib-printf/Makefile | 20 + testsuite/tests/lib-printf/pr6534.ml | 19 + testsuite/tests/lib-printf/pr6534.reference | 14 + testsuite/tests/lib-printf/pr6938.ml | 42 + testsuite/tests/lib-printf/pr6938.reference | 31 + testsuite/tests/lib-printf/tprintf.ml | 609 ++ testsuite/tests/lib-printf/tprintf.reference | 95 + testsuite/tests/lib-queue/Makefile | 18 + testsuite/tests/lib-queue/test.ml | 138 + testsuite/tests/lib-queue/test.reference | 1 + testsuite/tests/lib-random/Makefile | 18 + testsuite/tests/lib-random/rand.ml | 12 + testsuite/tests/lib-random/rand.reference | 1 + testsuite/tests/lib-scanf-2/Makefile | 63 + testsuite/tests/lib-scanf-2/reference | 2 + testsuite/tests/lib-scanf-2/tscanf2_io.ml | 19 + testsuite/tests/lib-scanf-2/tscanf2_master.ml | 51 + testsuite/tests/lib-scanf-2/tscanf2_slave.ml | 28 + testsuite/tests/lib-scanf/Makefile | 24 + testsuite/tests/lib-scanf/tscanf.ml | 1537 ++++ testsuite/tests/lib-scanf/tscanf.reference | 2 + testsuite/tests/lib-set/Makefile | 18 + testsuite/tests/lib-set/testmap.ml | 224 + testsuite/tests/lib-set/testmap.reference | 0 testsuite/tests/lib-set/testset.ml | 243 + testsuite/tests/lib-set/testset.reference | 0 testsuite/tests/lib-stack/Makefile | 18 + testsuite/tests/lib-stack/test.ml | 118 + testsuite/tests/lib-stack/test.reference | 1 + testsuite/tests/lib-stdlabels/Makefile | 19 + .../tests/lib-stdlabels/test_stdlabels.ml | 40 + .../lib-stdlabels/test_stdlabels.reference | 0 testsuite/tests/lib-str/Makefile | 22 + testsuite/tests/lib-str/t01.ml | 1078 +++ testsuite/tests/lib-str/t01.reference | 106 + testsuite/tests/lib-stream/Makefile | 19 + .../tests/lib-stream/count_concat_bug.ml | 57 + .../lib-stream/count_concat_bug.reference | 2 + testsuite/tests/lib-string/Makefile | 22 + testsuite/tests/lib-string/test_string.ml | 52 + .../tests/lib-string/test_string.reference | 0 testsuite/tests/lib-systhreads/Makefile | 23 + testsuite/tests/lib-systhreads/testfork.ml | 31 + .../tests/lib-systhreads/testfork.precheck | 23 + .../tests/lib-systhreads/testfork.reference | 6 + testsuite/tests/lib-threads/Makefile | 33 + .../tests/lib-threads/backtrace_threads.ml | 18 + .../lib-threads/backtrace_threads.reference | 0 testsuite/tests/lib-threads/bank.ml | 27 + testsuite/tests/lib-threads/bank.reference | 2 + testsuite/tests/lib-threads/beat.ml | 19 + testsuite/tests/lib-threads/beat.reference | 1 + testsuite/tests/lib-threads/bufchan.ml | 51 + testsuite/tests/lib-threads/bufchan.reference | 3 + testsuite/tests/lib-threads/close.ml | 18 + testsuite/tests/lib-threads/close.reference | 3 + testsuite/tests/lib-threads/fileio.ml | 117 + testsuite/tests/lib-threads/fileio.reference | 22 + testsuite/tests/lib-threads/pr4466.ml | 71 + testsuite/tests/lib-threads/pr4466.reference | 6 + testsuite/tests/lib-threads/pr5325.ml | 58 + testsuite/tests/lib-threads/pr5325.reference | 1 + testsuite/tests/lib-threads/prodcons.ml | 62 + .../tests/lib-threads/prodcons.reference | 1 + testsuite/tests/lib-threads/prodcons2.ml | 33 + .../tests/lib-threads/prodcons2.reference | 1 + testsuite/tests/lib-threads/sieve.ml | 28 + testsuite/tests/lib-threads/sieve.reference | 50 + testsuite/tests/lib-threads/sigint.c | 37 + testsuite/tests/lib-threads/signal.checker | 16 + testsuite/tests/lib-threads/signal.ml | 13 + testsuite/tests/lib-threads/signal.precheck | 1 + testsuite/tests/lib-threads/signal.runner | 19 + testsuite/tests/lib-threads/signal2.checker | 16 + testsuite/tests/lib-threads/signal2.ml | 11 + testsuite/tests/lib-threads/signal2.precheck | 16 + testsuite/tests/lib-threads/signal2.runner | 21 + testsuite/tests/lib-threads/sockets.ml | 38 + testsuite/tests/lib-threads/sockets.reference | 2 + testsuite/tests/lib-threads/socketsbuf.ml | 40 + .../tests/lib-threads/socketsbuf.reference | 2 + testsuite/tests/lib-threads/swapchan.checker | 16 + testsuite/tests/lib-threads/swapchan.ml | 26 + .../tests/lib-threads/swapchan.reference | 2 + testsuite/tests/lib-threads/tls.checker | 16 + testsuite/tests/lib-threads/tls.ml | 26 + testsuite/tests/lib-threads/tls.reference | 5 + testsuite/tests/lib-threads/token1.reference | 0 testsuite/tests/lib-threads/token2.reference | 0 testsuite/tests/lib-threads/torture.ml | 44 + testsuite/tests/lib-threads/torture.reference | 1 + testsuite/tests/lib-uchar/Makefile | 18 + testsuite/tests/lib-uchar/test.ml | 84 + testsuite/tests/lib-uchar/test.reference | 1 + testsuite/tests/lib-unix/Makefile | 36 + testsuite/tests/lib-unix/cloexec.ml | 51 + testsuite/tests/lib-unix/cloexec.reference | 21 + testsuite/tests/lib-unix/cmdline_prog.c | 10 + testsuite/tests/lib-unix/dup.ml | 5 + testsuite/tests/lib-unix/dup.reference | 1 + testsuite/tests/lib-unix/dup2.ml | 24 + testsuite/tests/lib-unix/dup2.reference | 2 + testsuite/tests/lib-unix/fdstatus.c | 73 + testsuite/tests/lib-unix/pipe_eof.ml | 34 + testsuite/tests/lib-unix/pipe_eof.reference | 1 + testsuite/tests/lib-unix/redirections.ml | 113 + .../tests/lib-unix/redirections.reference | 28 + testsuite/tests/lib-unix/reflector.c | 74 + testsuite/tests/lib-unix/test_unix_cmdline.ml | 28 + .../lib-unix/test_unix_cmdline.reference | 13 + testsuite/tests/link-test/Makefile | 65 + testsuite/tests/link-test/aliases.ml | 1 + testsuite/tests/link-test/external.ml | 2 + testsuite/tests/link-test/external.mli | 1 + .../tests/link-test/external_for_pack.ml | 2 + .../tests/link-test/external_for_pack.mli | 1 + testsuite/tests/link-test/submodule.ml | 2 + testsuite/tests/link-test/test.ml | 2 + testsuite/tests/link-test/test.reference | 3 + testsuite/tests/link-test/use_in_pack.ml | 1 + testsuite/tests/manual-intf-c/Makefile | 40 + testsuite/tests/manual-intf-c/curses.ml | 13 + testsuite/tests/manual-intf-c/curses_stubs.c | 94 + testsuite/tests/manual-intf-c/prog.ml | 9 + testsuite/tests/manual-intf-c/prog2.reference | 2 + .../tests/match-exception-warnings/Makefile | 18 + .../exhaustiveness_warnings.ml | 12 + .../exhaustiveness_warnings.ml.reference | 11 + testsuite/tests/match-exception/Makefile | 18 + testsuite/tests/match-exception/allocation.ml | 25 + .../match-exception/allocation.reference | 1 + .../match-exception/exception_propagation.ml | 17 + .../exception_propagation.reference | 1 + .../tests/match-exception/match_failure.ml | 19 + .../match-exception/match_failure.reference | 1 + .../tests/match-exception/nested_handlers.ml | 45 + .../match-exception/nested_handlers.reference | 1 + .../raise_from_success_continuation.ml | 15 + .../raise_from_success_continuation.reference | 2 + testsuite/tests/match-exception/streams.ml | 37 + .../tests/match-exception/streams.reference | 1 + testsuite/tests/match-exception/tail_calls.ml | 21 + .../match-exception/tail_calls.reference | 1 + testsuite/tests/messages/Makefile | 3 + testsuite/tests/messages/precise_locations.ml | 93 + testsuite/tests/misc-kb/Makefile | 22 + testsuite/tests/misc-kb/equations.ml | 100 + testsuite/tests/misc-kb/equations.mli | 18 + testsuite/tests/misc-kb/kb.ml | 173 + testsuite/tests/misc-kb/kb.mli | 17 + testsuite/tests/misc-kb/kbmain.ml | 67 + testsuite/tests/misc-kb/kbmain.reference | 273 + testsuite/tests/misc-kb/orderings.ml | 84 + testsuite/tests/misc-kb/orderings.mli | 17 + testsuite/tests/misc-kb/terms.ml | 121 + testsuite/tests/misc-kb/terms.mli | 17 + testsuite/tests/misc-unsafe/Makefile | 19 + testsuite/tests/misc-unsafe/almabench.ml | 327 + .../tests/misc-unsafe/almabench.reference | 8 + testsuite/tests/misc-unsafe/fft.ml | 174 + testsuite/tests/misc-unsafe/fft.reference | 15 + testsuite/tests/misc-unsafe/quicksort.ml | 78 + .../tests/misc-unsafe/quicksort.reference | 2 + testsuite/tests/misc-unsafe/soli.ml | 96 + testsuite/tests/misc-unsafe/soli.reference | 50 + testsuite/tests/misc/Makefile | 18 + testsuite/tests/misc/bdd.ml | 217 + testsuite/tests/misc/bdd.reference | 1 + testsuite/tests/misc/boyer.ml | 878 ++ testsuite/tests/misc/boyer.reference | 1 + testsuite/tests/misc/ephetest.ml | 168 + testsuite/tests/misc/ephetest.reference | 29 + testsuite/tests/misc/ephetest2.ml | 149 + testsuite/tests/misc/ephetest2.reference | 5 + testsuite/tests/misc/ephetest3.ml | 121 + testsuite/tests/misc/ephetest3.reference | 18 + testsuite/tests/misc/fib.ml | 9 + testsuite/tests/misc/fib.reference | 1 + testsuite/tests/misc/finaliser.ml | 68 + testsuite/tests/misc/finaliser.reference | 0 testsuite/tests/misc/gcwords.ml | 24 + testsuite/tests/misc/gcwords.reference | 1 + testsuite/tests/misc/hamming.ml | 91 + testsuite/tests/misc/hamming.reference | 100 + testsuite/tests/misc/nucleic.ml | 3223 ++++++++ testsuite/tests/misc/nucleic.reference | 1 + testsuite/tests/misc/pr7168.ml | 77 + testsuite/tests/misc/pr7168.reference | 1 + testsuite/tests/misc/sieve.ml | 42 + testsuite/tests/misc/sieve.reference | 1 + testsuite/tests/misc/sorts.ml | 4476 ++++++++++ testsuite/tests/misc/sorts.reference | 198 + testsuite/tests/misc/takc.ml | 8 + testsuite/tests/misc/takc.reference | 1 + testsuite/tests/misc/taku.ml | 8 + testsuite/tests/misc/taku.reference | 1 + testsuite/tests/misc/weaklifetime.ml | 62 + testsuite/tests/misc/weaklifetime.reference | 0 testsuite/tests/misc/weaklifetime2.ml | 57 + testsuite/tests/misc/weaklifetime2.reference | 2 + testsuite/tests/misc/weaktest.ml | 67 + testsuite/tests/misc/weaktest.reference | 1 + testsuite/tests/no-alias-deps/Makefile | 37 + .../tests/no-alias-deps/aliases.cmo.reference | 15 + testsuite/tests/no-alias-deps/aliases.ml | 5 + .../tests/no-alias-deps/aliases.ml.reference | 5 + testsuite/tests/no-alias-deps/b.cmi.pre | 1 + testsuite/tests/no-alias-deps/c.mli | 1 + testsuite/tests/no-alias-deps/d.mli | 1 + testsuite/tests/opaque/Makefile | 75 + testsuite/tests/opaque/fst/opaque_impl.ml | 2 + testsuite/tests/opaque/fst/opaque_intf.ml | 2 + testsuite/tests/opaque/fst/regular.ml | 2 + testsuite/tests/opaque/intf/opaque_impl.mli | 2 + testsuite/tests/opaque/intf/opaque_intf.mli | 2 + testsuite/tests/opaque/intf/regular.mli | 2 + testsuite/tests/opaque/snd/opaque_impl.ml | 2 + testsuite/tests/opaque/snd/opaque_intf.ml | 2 + testsuite/tests/opaque/snd/regular.ml | 2 + testsuite/tests/opaque/test.ml | 9 + testsuite/tests/parsetree/Makefile | 23 + testsuite/tests/parsetree/source.ml | 7276 +++++++++++++++++ testsuite/tests/parsetree/test.ml | 108 + testsuite/tests/parsetree/test.reference | 0 testsuite/tests/parsing/Makefile | 19 + testsuite/tests/parsing/attributes.ml | 34 + .../tests/parsing/attributes.ml.reference | 153 + testsuite/tests/parsing/docstrings.ml | 16 + .../tests/parsing/docstrings.ml.reference | 146 + testsuite/tests/parsing/extensions.ml | 18 + .../tests/parsing/extensions.ml.reference | 326 + .../parsing/int_and_float_with_modifier.ml | 14 + .../int_and_float_with_modifier.ml.reference | 86 + testsuite/tests/parsing/pr6865.ml | 3 + testsuite/tests/parsing/pr6865.ml.reference | 52 + testsuite/tests/parsing/pr7165.ml | 4 + testsuite/tests/parsing/pr7165.ml.reference | 2 + testsuite/tests/parsing/shortcut_ext_attr.ml | 114 + .../parsing/shortcut_ext_attr.ml.reference | 978 +++ testsuite/tests/ppx-attributes/Makefile | 18 + testsuite/tests/ppx-attributes/warning.ml | 47 + .../tests/ppx-attributes/warning.reference | 0 testsuite/tests/prim-bigstring/Makefile | 8 + .../tests/prim-bigstring/bigstring_access.ml | 119 + .../prim-bigstring/bigstring_access.reference | 6 + .../tests/prim-bigstring/string_access.ml | 106 + .../prim-bigstring/string_access.reference | 6 + testsuite/tests/prim-bswap/Makefile | 17 + testsuite/tests/prim-bswap/bswap.ml | 17 + testsuite/tests/prim-bswap/bswap.reference | 6 + testsuite/tests/prim-revapply/Makefile | 19 + testsuite/tests/prim-revapply/apply.ml | 36 + testsuite/tests/prim-revapply/apply.reference | 10 + testsuite/tests/prim-revapply/revapply.ml | 18 + .../tests/prim-revapply/revapply.reference | 5 + .../missing_set_of_closures/Makefile | 45 + .../regression/missing_set_of_closures/a.ml | 9 + .../regression/missing_set_of_closures/b.ml | 4 + .../regression/missing_set_of_closures/b2.ml | 2 + .../missing_set_of_closures/dir/c.ml | 2 + testsuite/tests/regression/pr3612/Makefile | 21 + .../tests/regression/pr3612/custom_finalize.c | 65 + testsuite/tests/regression/pr3612/pr3612.ml | 21 + .../tests/regression/pr3612/pr3612.reference | 1 + .../tests/regression/pr5080-notes/Makefile | 20 + .../pr5080-notes/pr5080_notes_ok.ml | 4 + testsuite/tests/regression/pr5233/Makefile | 19 + testsuite/tests/regression/pr5233/pr5233.ml | 53 + .../tests/regression/pr5233/pr5233.reference | 2 + testsuite/tests/regression/pr5757/Makefile | 19 + testsuite/tests/regression/pr5757/pr5757.ml | 5 + .../tests/regression/pr5757/pr5757.reference | 1 + testsuite/tests/regression/pr6024/Makefile | 20 + testsuite/tests/regression/pr6024/pr6024.ml | 1 + .../tests/regression/pr6024/pr6024.reference | 1 + testsuite/tests/regression/pr7042/Makefile | 20 + testsuite/tests/regression/pr7042/pr7042.ml | 4 + .../tests/regression/pr7042/pr7042.reference | 1 + testsuite/tests/regression/pr7426/Makefile | 20 + testsuite/tests/regression/pr7426/pr7426.ml | 1 + .../tests/regression/pr7426/pr7426.reference | 0 testsuite/tests/required-external/Makefile | 18 + testsuite/tests/required-external/file.ml | 7 + testsuite/tests/required-external/main.ml | 2 + .../tests/required-external/main.reference | 1 + testsuite/tests/runtime-C-exceptions/Makefile | 7 + .../tests/runtime-C-exceptions/stub_test.c | 20 + testsuite/tests/runtime-C-exceptions/test.ml | 11 + .../tests/runtime-C-exceptions/test.reference | 2 + testsuite/tests/runtime-errors/Makefile | 79 + .../stackoverflow.bytecode.checker | 16 + .../stackoverflow.bytecode.reference | 4 + .../tests/runtime-errors/stackoverflow.ml | 15 + .../stackoverflow.native.checker | 16 + .../stackoverflow.native.reference | 4 + .../runtime-errors/syserror.bytecode.checker | 16 + .../syserror.bytecode.reference | 1 + testsuite/tests/runtime-errors/syserror.ml | 1 + .../runtime-errors/syserror.native.checker | 16 + .../runtime-errors/syserror.native.reference | 1 + .../tests/self-contained-toplevel/Makefile | 34 + .../tests/self-contained-toplevel/foo.ml | 1 + .../self-contained-toplevel/gen_cached_cmi.ml | 4 + .../tests/self-contained-toplevel/input.ml | 1 + .../tests/self-contained-toplevel/main.ml | 13 + .../self-contained-toplevel/main.reference | 1 + testsuite/tests/tool-command-line/Makefile | 54 + .../tests/tool-command-line/unknown-file | 0 .../unknown-file.byte.reference | 1 + .../unknown-file.opt.reference | 1 + testsuite/tests/tool-debugger/basic/Makefile | 61 + .../tests/tool-debugger/basic/debuggee.ml | 2 + .../tool-debugger/basic/debuggee.reference | 5 + .../tests/tool-debugger/basic/input_script | 5 + .../tool-debugger/find-artifacts/Makefile | 70 + .../find-artifacts/debuggee.reference | 6 + .../tool-debugger/find-artifacts/in/blah.ml | 3 + .../tool-debugger/find-artifacts/in/foo.ml | 13 + .../tool-debugger/find-artifacts/input_script | 5 + .../tool-debugger/no_debug_event/Makefile | 60 + .../tests/tool-debugger/no_debug_event/a.ml | 1 + .../tests/tool-debugger/no_debug_event/b.ml | 3 + .../tool-debugger/no_debug_event/input_script | 2 + .../no_debug_event/noev.reference | 4 + testsuite/tests/tool-lexyacc/Makefile | 25 + testsuite/tests/tool-lexyacc/gram_aux.ml | 32 + testsuite/tests/tool-lexyacc/grammar.mly | 99 + testsuite/tests/tool-lexyacc/input | 134 + testsuite/tests/tool-lexyacc/lexgen.ml | 256 + testsuite/tests/tool-lexyacc/main.ml | 105 + testsuite/tests/tool-lexyacc/main.reference | 312 + testsuite/tests/tool-lexyacc/output.ml | 152 + testsuite/tests/tool-lexyacc/scan_aux.ml | 45 + testsuite/tests/tool-lexyacc/scanner.mll | 118 + testsuite/tests/tool-lexyacc/syntax.ml | 26 + testsuite/tests/tool-ocaml/Makefile | 36 + testsuite/tests/tool-ocaml/lib.ml | 42 + testsuite/tests/tool-ocaml/t000.ml | 7 + testsuite/tests/tool-ocaml/t010-const0.ml | 8 + testsuite/tests/tool-ocaml/t010-const1.ml | 8 + testsuite/tests/tool-ocaml/t010-const2.ml | 8 + testsuite/tests/tool-ocaml/t010-const3.ml | 8 + testsuite/tests/tool-ocaml/t011-constint.ml | 8 + testsuite/tests/tool-ocaml/t020.ml | 10 + testsuite/tests/tool-ocaml/t021-pushconst1.ml | 10 + testsuite/tests/tool-ocaml/t021-pushconst2.ml | 10 + testsuite/tests/tool-ocaml/t021-pushconst3.ml | 10 + .../tests/tool-ocaml/t022-pushconstint.ml | 10 + testsuite/tests/tool-ocaml/t040-makeblock1.ml | 13 + testsuite/tests/tool-ocaml/t040-makeblock2.ml | 15 + testsuite/tests/tool-ocaml/t040-makeblock3.ml | 17 + testsuite/tests/tool-ocaml/t041-makeblock.ml | 19 + testsuite/tests/tool-ocaml/t050-getglobal.ml | 8 + .../tests/tool-ocaml/t050-pushgetglobal.ml | 10 + .../tests/tool-ocaml/t051-getglobalfield.ml | 13 + .../tool-ocaml/t051-pushgetglobalfield.ml | 15 + testsuite/tests/tool-ocaml/t060-raise.ml | 15 + testsuite/tests/tool-ocaml/t070-branch.ml | 20 + testsuite/tests/tool-ocaml/t070-branchif.ml | 20 + .../tests/tool-ocaml/t070-branchifnot.ml | 18 + testsuite/tests/tool-ocaml/t071-boolnot.ml | 19 + testsuite/tests/tool-ocaml/t080-eq.ml | 21 + testsuite/tests/tool-ocaml/t080-geint.ml | 21 + testsuite/tests/tool-ocaml/t080-gtint.ml | 20 + testsuite/tests/tool-ocaml/t080-leint.ml | 21 + testsuite/tests/tool-ocaml/t080-ltint.ml | 20 + testsuite/tests/tool-ocaml/t080-neq.ml | 20 + testsuite/tests/tool-ocaml/t090-acc0.ml | 25 + testsuite/tests/tool-ocaml/t090-acc1.ml | 27 + testsuite/tests/tool-ocaml/t090-acc2.ml | 29 + testsuite/tests/tool-ocaml/t090-acc3.ml | 31 + testsuite/tests/tool-ocaml/t090-acc4.ml | 33 + testsuite/tests/tool-ocaml/t090-acc5.ml | 35 + testsuite/tests/tool-ocaml/t090-acc6.ml | 37 + testsuite/tests/tool-ocaml/t090-acc7.ml | 39 + testsuite/tests/tool-ocaml/t091-acc.ml | 41 + testsuite/tests/tool-ocaml/t092-pushacc.ml | 38 + testsuite/tests/tool-ocaml/t092-pushacc0.ml | 22 + testsuite/tests/tool-ocaml/t092-pushacc1.ml | 24 + testsuite/tests/tool-ocaml/t092-pushacc2.ml | 26 + testsuite/tests/tool-ocaml/t092-pushacc3.ml | 28 + testsuite/tests/tool-ocaml/t092-pushacc4.ml | 30 + testsuite/tests/tool-ocaml/t092-pushacc5.ml | 32 + testsuite/tests/tool-ocaml/t092-pushacc6.ml | 34 + testsuite/tests/tool-ocaml/t092-pushacc7.ml | 36 + testsuite/tests/tool-ocaml/t093-pushacc.ml | 38 + testsuite/tests/tool-ocaml/t100-pushtrap.ml | 21 + testsuite/tests/tool-ocaml/t101-poptrap.ml | 21 + testsuite/tests/tool-ocaml/t110-addint.ml | 26 + testsuite/tests/tool-ocaml/t110-andint.ml | 22 + testsuite/tests/tool-ocaml/t110-asrint-1.ml | 22 + testsuite/tests/tool-ocaml/t110-asrint-2.ml | 22 + testsuite/tests/tool-ocaml/t110-divint-1.ml | 22 + testsuite/tests/tool-ocaml/t110-divint-2.ml | 22 + testsuite/tests/tool-ocaml/t110-divint-3.ml | 33 + testsuite/tests/tool-ocaml/t110-lslint.ml | 22 + testsuite/tests/tool-ocaml/t110-lsrint.ml | 22 + testsuite/tests/tool-ocaml/t110-modint-1.ml | 22 + testsuite/tests/tool-ocaml/t110-modint-2.ml | 34 + testsuite/tests/tool-ocaml/t110-mulint.ml | 22 + testsuite/tests/tool-ocaml/t110-negint.ml | 25 + testsuite/tests/tool-ocaml/t110-offsetint.ml | 21 + testsuite/tests/tool-ocaml/t110-orint.ml | 22 + testsuite/tests/tool-ocaml/t110-subint.ml | 26 + testsuite/tests/tool-ocaml/t110-xorint.ml | 22 + .../tests/tool-ocaml/t120-getstringchar.ml | 22 + .../tests/tool-ocaml/t121-setstringchar.ml | 31 + .../tests/tool-ocaml/t130-getvectitem.ml | 24 + testsuite/tests/tool-ocaml/t130-vectlength.ml | 23 + .../tests/tool-ocaml/t131-setvectitem.ml | 33 + testsuite/tests/tool-ocaml/t140-switch-1.ml | 32 + testsuite/tests/tool-ocaml/t140-switch-2.ml | 32 + testsuite/tests/tool-ocaml/t140-switch-3.ml | 31 + testsuite/tests/tool-ocaml/t140-switch-4.ml | 31 + testsuite/tests/tool-ocaml/t141-switch-5.ml | 38 + testsuite/tests/tool-ocaml/t141-switch-6.ml | 38 + testsuite/tests/tool-ocaml/t141-switch-7.ml | 37 + testsuite/tests/tool-ocaml/t142-switch-8.ml | 34 + testsuite/tests/tool-ocaml/t142-switch-9.ml | 34 + testsuite/tests/tool-ocaml/t142-switch-A.ml | 34 + testsuite/tests/tool-ocaml/t150-push-1.ml | 24 + testsuite/tests/tool-ocaml/t150-push-2.ml | 39 + testsuite/tests/tool-ocaml/t160-closure.ml | 19 + testsuite/tests/tool-ocaml/t161-apply1.ml | 42 + testsuite/tests/tool-ocaml/t162-return.ml | 21 + testsuite/tests/tool-ocaml/t163.ml | 23 + testsuite/tests/tool-ocaml/t164-apply2.ml | 24 + testsuite/tests/tool-ocaml/t164-apply3.ml | 25 + testsuite/tests/tool-ocaml/t165-apply.ml | 28 + testsuite/tests/tool-ocaml/t170-envacc2.ml | 37 + testsuite/tests/tool-ocaml/t170-envacc3.ml | 42 + testsuite/tests/tool-ocaml/t170-envacc4.ml | 47 + testsuite/tests/tool-ocaml/t171-envacc.ml | 52 + .../tests/tool-ocaml/t172-pushenvacc1.ml | 34 + .../tests/tool-ocaml/t172-pushenvacc2.ml | 37 + .../tests/tool-ocaml/t172-pushenvacc3.ml | 42 + .../tests/tool-ocaml/t172-pushenvacc4.ml | 47 + testsuite/tests/tool-ocaml/t173-pushenvacc.ml | 52 + testsuite/tests/tool-ocaml/t180-appterm1.ml | 35 + testsuite/tests/tool-ocaml/t180-appterm2.ml | 38 + testsuite/tests/tool-ocaml/t180-appterm3.ml | 39 + testsuite/tests/tool-ocaml/t181-appterm.ml | 40 + .../tests/tool-ocaml/t190-makefloatblock-1.ml | 17 + .../tests/tool-ocaml/t190-makefloatblock-2.ml | 18 + .../tests/tool-ocaml/t190-makefloatblock-3.ml | 19 + testsuite/tests/tool-ocaml/t191-vectlength.ml | 26 + .../tests/tool-ocaml/t192-getfloatfield-1.ml | 23 + .../tests/tool-ocaml/t192-getfloatfield-2.ml | 23 + .../tests/tool-ocaml/t193-setfloatfield-1.ml | 36 + .../tests/tool-ocaml/t193-setfloatfield-2.ml | 36 + testsuite/tests/tool-ocaml/t200-getfield0.ml | 25 + testsuite/tests/tool-ocaml/t200-getfield1.ml | 26 + testsuite/tests/tool-ocaml/t200-getfield2.ml | 27 + testsuite/tests/tool-ocaml/t200-getfield3.ml | 28 + testsuite/tests/tool-ocaml/t201-getfield.ml | 29 + testsuite/tests/tool-ocaml/t210-setfield0.ml | 36 + testsuite/tests/tool-ocaml/t210-setfield1.ml | 38 + testsuite/tests/tool-ocaml/t210-setfield2.ml | 40 + testsuite/tests/tool-ocaml/t210-setfield3.ml | 42 + testsuite/tests/tool-ocaml/t211-setfield.ml | 44 + testsuite/tests/tool-ocaml/t220-assign.ml | 27 + .../tests/tool-ocaml/t230-check_signals.ml | 28 + testsuite/tests/tool-ocaml/t240-c_call1.ml | 27 + testsuite/tests/tool-ocaml/t240-c_call2.ml | 22 + testsuite/tests/tool-ocaml/t240-c_call3.ml | 23 + testsuite/tests/tool-ocaml/t240-c_call4.ml | 32 + testsuite/tests/tool-ocaml/t240-c_call5.ml | 33 + .../tests/tool-ocaml/t250-closurerec-1.ml | 19 + .../tests/tool-ocaml/t250-closurerec-2.ml | 29 + .../tool-ocaml/t251-pushoffsetclosure0.ml | 39 + .../tool-ocaml/t251-pushoffsetclosure2.ml | 34 + .../tool-ocaml/t251-pushoffsetclosurem2.ml | 34 + .../tool-ocaml/t252-pushoffsetclosure.ml | 38 + .../tests/tool-ocaml/t253-offsetclosure0.ml | 34 + .../tests/tool-ocaml/t253-offsetclosure2.ml | 34 + .../tests/tool-ocaml/t253-offsetclosurem2.ml | 34 + .../tests/tool-ocaml/t254-offsetclosure.ml | 37 + testsuite/tests/tool-ocaml/t260-offsetref.ml | 31 + .../tests/tool-ocaml/t270-push_retaddr.ml | 36 + testsuite/tests/tool-ocaml/t300-getmethod.ml | 5885 +++++++++++++ testsuite/tests/tool-ocaml/t301-object.ml | 25 + testsuite/tests/tool-ocaml/t310-alloc-1.ml | 1587 ++++ testsuite/tests/tool-ocaml/t310-alloc-2.ml | 2313 ++++++ testsuite/tests/tool-ocaml/t320-gc-1.ml | 1589 ++++ testsuite/tests/tool-ocaml/t320-gc-2.ml | 1589 ++++ testsuite/tests/tool-ocaml/t320-gc-3.ml | 1589 ++++ testsuite/tests/tool-ocaml/t330-compact-1.ml | 15 + testsuite/tests/tool-ocaml/t330-compact-2.ml | 755 ++ testsuite/tests/tool-ocaml/t330-compact-3.ml | 1589 ++++ testsuite/tests/tool-ocaml/t330-compact-4.ml | 1589 ++++ testsuite/tests/tool-ocaml/t340-weak.ml | 24 + testsuite/tests/tool-ocaml/t350-heapcheck.ml | 25 + testsuite/tests/tool-ocaml/t360-stacks-1.ml | 43 + testsuite/tests/tool-ocaml/t360-stacks-2.ml | 54 + testsuite/tests/tool-ocamlc-open/Makefile | 14 + testsuite/tests/tool-ocamlc-open/a.ml | 3 + testsuite/tests/tool-ocamlc-open/b.ml | 1 + testsuite/tests/tool-ocamldep-modalias/A.ml | 1 + testsuite/tests/tool-ocamldep-modalias/B.ml | 2 + testsuite/tests/tool-ocamldep-modalias/C.ml | 2 + testsuite/tests/tool-ocamldep-modalias/D.ml | 1 + .../tests/tool-ocamldep-modalias/Makefile | 73 + .../tool-ocamldep-modalias/Makefile.build | 43 + .../tool-ocamldep-modalias/Makefile.build2 | 38 + .../depend.mk.reference | 11 + .../depend.mk2.reference | 8 + .../depend.mod.reference | 6 + .../depend.mod2.reference | 4 + .../depend.mod3.reference | 4 + .../tests/tool-ocamldep-modalias/lib.mli | 8 + .../tests/tool-ocamldep-modalias/lib_impl.ml | 8 + .../tests/tool-ocamldep-modalias/main.ml | 3 + testsuite/tests/tool-ocamldoc-2/Makefile | 55 + .../tool-ocamldoc-2/extensible_variant.ml | 20 + .../extensible_variant.reference | 108 + .../tests/tool-ocamldoc-2/inline_records.mli | 48 + .../tool-ocamldoc-2/inline_records.reference | 287 + .../tool-ocamldoc-2/inline_records_bis.ml | 48 + .../inline_records_bis.reference | 286 + testsuite/tests/tool-ocamldoc-2/loop.ml | 3 + .../tests/tool-ocamldoc-2/loop.reference | 36 + .../short_description.reference | 21 + .../tool-ocamldoc-2/short_description.txt | 4 + testsuite/tests/tool-ocamldoc-2/test.mli | 30 + .../tests/tool-ocamldoc-2/test.reference | 74 + testsuite/tests/tool-ocamldoc-2/variants.mli | 38 + .../tests/tool-ocamldoc-2/variants.reference | 190 + .../tool-ocamldoc-html/Inline_records.mli | 45 + .../Inline_records.reference | 289 + .../tests/tool-ocamldoc-html/Linebreaks.mli | 69 + .../tool-ocamldoc-html/Linebreaks.reference | 140 + testsuite/tests/tool-ocamldoc-html/Loop.ml | 3 + .../tests/tool-ocamldoc-html/Loop.reference | 20 + testsuite/tests/tool-ocamldoc-html/Makefile | 62 + .../tool-ocamldoc-html/Module_whitespace.ml | 4 + .../Module_whitespace.reference | 24 + .../tests/tool-ocamldoc-html/Variants.mli | 38 + .../tool-ocamldoc-html/Variants.reference | 232 + .../type_Linebreaks.reference | 27 + .../tool-ocamldoc-man/Inline_records.mli | 45 + .../Inline_records.reference | 201 + testsuite/tests/tool-ocamldoc-man/Makefile | 54 + testsuite/tests/tool-ocamldoc-open/Makefile | 47 + testsuite/tests/tool-ocamldoc-open/Readme | 12 + testsuite/tests/tool-ocamldoc-open/alias.ml | 3 + .../tests/tool-ocamldoc-open/doc.reference | 70 + testsuite/tests/tool-ocamldoc-open/inner.ml | 2 + testsuite/tests/tool-ocamldoc-open/main.ml | 5 + testsuite/tests/tool-ocamldoc/Makefile | 52 + testsuite/tests/tool-ocamldoc/odoc_test.ml | 116 + testsuite/tests/tool-ocamldoc/t01.ml | 22 + testsuite/tests/tool-ocamldoc/t01.reference | 38 + testsuite/tests/tool-ocamldoc/t02.ml | 10 + testsuite/tests/tool-ocamldoc/t02.reference | 12 + testsuite/tests/tool-ocamldoc/t03.ml | 12 + testsuite/tests/tool-ocamldoc/t03.reference | 14 + testsuite/tests/tool-ocamldoc/t04.ml | 20 + testsuite/tests/tool-ocamldoc/t04.reference | 27 + testsuite/tests/tool-ocamldoc/t05.ml | 3 + testsuite/tests/tool-ocamldoc/t05.reference | 6 + .../tests/tool-toplevel-invocation/Makefile | 36 + .../first_arg_fail.txt | 3 + .../first_arg_fail.txt.reference | 1 + .../indirect_first_arg_fail.txt | 2 + .../indirect_first_arg_fail.txt.reference | 1 + .../indirect_last_arg_fail.txt | 2 + .../indirect_last_arg_fail.txt.reference | 1 + .../last_arg_fail.txt | 3 + .../last_arg_fail.txt.reference | 1 + .../tests/tool-toplevel-invocation/test.ml | 1 + .../tool-toplevel-invocation/working_arg.txt | 2 + .../working_arg.txt.reference | 4 + testsuite/tests/tool-toplevel/Makefile | 19 + testsuite/tests/tool-toplevel/pr7060.ml | 6 + .../tests/tool-toplevel/pr7060.ml.reference | 16 + testsuite/tests/tool-toplevel/tracing.ml | 4 + .../tests/tool-toplevel/tracing.ml.reference | 30 + testsuite/tests/translprim/Makefile | 4 + testsuite/tests/translprim/array_spec.ml | 62 + .../tests/translprim/array_spec.ml.reference | 88 + .../tests/translprim/comparison_table.ml | 239 + .../translprim/comparison_table.ml.reference | 375 + testsuite/tests/translprim/module_coercion.ml | 37 + .../translprim/module_coercion.ml.reference | 115 + testsuite/tests/translprim/ref_spec.ml | 54 + .../tests/translprim/ref_spec.ml.reference | 50 + .../typing-extension-constructor/Makefile | 18 + .../typing-extension-constructor/test.ml | 14 + .../test.ml.reference | 12 + testsuite/tests/typing-extensions/Makefile | 3 + testsuite/tests/typing-extensions/cast.ml | 99 + .../tests/typing-extensions/cast.ml.reference | 34 + .../tests/typing-extensions/extensions.ml | 328 + .../typing-extensions/extensions.ml.reference | 134 + testsuite/tests/typing-extensions/msg.ml | 131 + .../tests/typing-extensions/msg.ml.reference | 23 + .../tests/typing-extensions/open_types.ml | 125 + .../typing-extensions/open_types.ml.reference | 107 + testsuite/tests/typing-fstclassmod/Makefile | 22 + .../tests/typing-fstclassmod/fstclassmod.ml | 167 + .../typing-fstclassmod/fstclassmod.reference | 7 + testsuite/tests/typing-gadts/Makefile | 18 + testsuite/tests/typing-gadts/didier.ml | 101 + .../tests/typing-gadts/dynamic_frisch.ml | 709 ++ .../tests/typing-gadts/nested_equations.ml | 84 + testsuite/tests/typing-gadts/omega07.ml | 1213 +++ testsuite/tests/typing-gadts/pr5332.ml | 29 + testsuite/tests/typing-gadts/pr5689.ml | 105 + testsuite/tests/typing-gadts/pr5785.ml | 22 + testsuite/tests/typing-gadts/pr5848.ml | 20 + testsuite/tests/typing-gadts/pr5906.ml | 33 + testsuite/tests/typing-gadts/pr5948.ml | 51 + testsuite/tests/typing-gadts/pr5981.ml | 48 + testsuite/tests/typing-gadts/pr5985.ml | 177 + testsuite/tests/typing-gadts/pr5989.ml | 57 + testsuite/tests/typing-gadts/pr5997.ml | 47 + testsuite/tests/typing-gadts/pr6158.ml | 19 + testsuite/tests/typing-gadts/pr6163.ml | 27 + testsuite/tests/typing-gadts/pr6174.ml | 9 + testsuite/tests/typing-gadts/pr6241.ml | 30 + testsuite/tests/typing-gadts/pr6690.ml | 74 + testsuite/tests/typing-gadts/pr6817.ml | 34 + testsuite/tests/typing-gadts/pr6980.ml | 24 + testsuite/tests/typing-gadts/pr6993_bad.ml | 24 + testsuite/tests/typing-gadts/pr7016.ml | 28 + testsuite/tests/typing-gadts/pr7160.ml | 16 + testsuite/tests/typing-gadts/pr7214.ml | 37 + testsuite/tests/typing-gadts/pr7222.ml | 36 + testsuite/tests/typing-gadts/pr7230.ml | 9 + testsuite/tests/typing-gadts/pr7234.ml | 24 + testsuite/tests/typing-gadts/pr7260.ml | 21 + testsuite/tests/typing-gadts/pr7269.ml | 71 + testsuite/tests/typing-gadts/pr7298.ml | 14 + testsuite/tests/typing-gadts/pr7374.ml | 49 + testsuite/tests/typing-gadts/pr7378.ml | 23 + testsuite/tests/typing-gadts/pr7381.ml | 15 + testsuite/tests/typing-gadts/pr7390.ml | 25 + testsuite/tests/typing-gadts/pr7391.ml | 76 + testsuite/tests/typing-gadts/pr7397.ml | 25 + testsuite/tests/typing-gadts/pr7421.ml | 26 + testsuite/tests/typing-gadts/pr7432.ml | 27 + testsuite/tests/typing-gadts/term-conv.ml | 218 + testsuite/tests/typing-gadts/test.ml | 1072 +++ testsuite/tests/typing-gadts/unify_mb.ml | 241 + testsuite/tests/typing-gadts/yallop_bugs.ml | 71 + testsuite/tests/typing-immediate/Makefile | 18 + testsuite/tests/typing-immediate/immediate.ml | 162 + .../tests/typing-implicit_unpack/Makefile | 18 + .../typing-implicit_unpack/implicit_unpack.ml | 165 + .../implicit_unpack.ml.reference | 184 + testsuite/tests/typing-labels/Makefile | 18 + testsuite/tests/typing-labels/mixin.ml | 155 + testsuite/tests/typing-labels/mixin.reference | 3 + testsuite/tests/typing-labels/mixin2.ml | 190 + .../tests/typing-labels/mixin2.reference | 3 + testsuite/tests/typing-labels/mixin3.ml | 184 + .../tests/typing-labels/mixin3.reference | 3 + testsuite/tests/typing-misc-bugs/Makefile | 17 + .../typing-misc-bugs/core_array_reduced_ok.ml | 94 + .../tests/typing-misc-bugs/pr6303_bad.ml | 3 + .../tests/typing-misc-bugs/pr6946_bad.ml | 2 + testsuite/tests/typing-misc/Makefile | 18 + testsuite/tests/typing-misc/constraints.ml | 112 + testsuite/tests/typing-misc/labels.ml | 27 + testsuite/tests/typing-misc/occur_check.ml | 18 + testsuite/tests/typing-misc/polyvars.ml | 59 + testsuite/tests/typing-misc/pr6939.ml | 15 + testsuite/tests/typing-misc/pr7103.ml | 39 + testsuite/tests/typing-misc/pr7228.ml | 15 + testsuite/tests/typing-misc/printing.ml | 18 + testsuite/tests/typing-misc/records.ml | 112 + testsuite/tests/typing-misc/variant.ml | 20 + testsuite/tests/typing-misc/wellfounded.ml | 16 + testsuite/tests/typing-missing-cmi/Makefile | 25 + testsuite/tests/typing-missing-cmi/a.ml | 1 + testsuite/tests/typing-missing-cmi/b.ml | 1 + testsuite/tests/typing-missing-cmi/c.ml | 10 + testsuite/tests/typing-missing-cmi/main.ml | 1 + .../typing-missing-cmi/main.ml.reference | 5 + testsuite/tests/typing-missing-cmi/main_ok.ml | 1 + .../tests/typing-missing-cmi/subdir/m.ml | 4 + testsuite/tests/typing-modules-bugs/Makefile | 17 + .../gatien_baron_20131019_ok.ml | 31 + .../tests/typing-modules-bugs/pr5164_ok.ml | 9 + .../tests/typing-modules-bugs/pr51_ok.ml | 18 + .../tests/typing-modules-bugs/pr5663_ok.ml | 7 + .../tests/typing-modules-bugs/pr5914_ok.ml | 18 + .../tests/typing-modules-bugs/pr6240_ok.ml | 11 + .../tests/typing-modules-bugs/pr6293_bad.ml | 2 + .../tests/typing-modules-bugs/pr6427_bad.ml | 20 + .../tests/typing-modules-bugs/pr6513_ok.ml | 28 + .../tests/typing-modules-bugs/pr6572_ok.ml | 19 + .../tests/typing-modules-bugs/pr6651_ok.ml | 13 + .../tests/typing-modules-bugs/pr6752_bad.ml | 46 + .../tests/typing-modules-bugs/pr6752_ok.ml | 45 + .../typing-modules-bugs/pr6899_first_bad.ml | 3 + .../tests/typing-modules-bugs/pr6899_ok.ml | 6 + .../typing-modules-bugs/pr6899_second_bad.ml | 5 + .../tests/typing-modules-bugs/pr6944_ok.ml | 4 + .../tests/typing-modules-bugs/pr6954_ok.ml | 11 + .../tests/typing-modules-bugs/pr6981_ok.ml | 10 + .../tests/typing-modules-bugs/pr6982_ok.ml | 26 + .../tests/typing-modules-bugs/pr6985_ok.ml | 7 + .../tests/typing-modules-bugs/pr6992_bad.ml | 15 + .../tests/typing-modules-bugs/pr7036_ok.ml | 21 + .../tests/typing-modules-bugs/pr7082_ok.ml | 7 + .../tests/typing-modules-bugs/pr7112_bad.ml | 5 + .../tests/typing-modules-bugs/pr7112_ok.ml | 4 + .../tests/typing-modules-bugs/pr7152_ok.ml | 115 + .../tests/typing-modules-bugs/pr7182_ok.ml | 3 + .../typing-modules-bugs/pr7305_principal.ml | 29 + .../tests/typing-modules-bugs/pr7414_bad.ml | 55 + testsuite/tests/typing-modules/Makefile | 18 + testsuite/tests/typing-modules/Test.ml | 111 + testsuite/tests/typing-modules/aliases.ml | 754 ++ testsuite/tests/typing-modules/firstclass.ml | 43 + testsuite/tests/typing-modules/generative.ml | 86 + testsuite/tests/typing-modules/pr5911.ml | 24 + testsuite/tests/typing-modules/pr7207.ml | 7 + testsuite/tests/typing-modules/pr7348.ml | 37 + testsuite/tests/typing-modules/printing.ml | 26 + testsuite/tests/typing-modules/recursive.ml | 7 + testsuite/tests/typing-multifile/Makefile | 32 + testsuite/tests/typing-objects-bugs/Makefile | 18 + .../tests/typing-objects-bugs/pr3968_bad.ml | 21 + .../tests/typing-objects-bugs/pr4018_bad.ml | 46 + .../tests/typing-objects-bugs/pr4435_bad.ml | 11 + .../tests/typing-objects-bugs/pr4766_ok.ml | 10 + .../tests/typing-objects-bugs/pr4824_ok.ml | 10 + .../tests/typing-objects-bugs/pr4824a_bad.ml | 6 + .../tests/typing-objects-bugs/pr5156_ok.ml | 10 + .../tests/typing-objects-bugs/pr7284_bad.ml | 33 + .../tests/typing-objects-bugs/pr7293_ok.ml | 11 + .../tests/typing-objects-bugs/woodyatt_ok.ml | 14 + .../typing-objects-bugs/yamagata021012_ok.ml | 193 + testsuite/tests/typing-objects/Exemples.ml | 333 + .../Exemples.ml.principal.reference | 358 + .../typing-objects/Exemples.ml.reference | 360 + testsuite/tests/typing-objects/Makefile | 18 + testsuite/tests/typing-objects/Tests.ml | 336 + .../Tests.ml.principal.reference | 317 + .../tests/typing-objects/Tests.ml.reference | 317 + testsuite/tests/typing-objects/pr5545.ml | 22 + .../pr5545.ml.principal.reference | 6 + .../tests/typing-objects/pr5545.ml.reference | 6 + testsuite/tests/typing-objects/pr5619_bad.ml | 28 + .../pr5619_bad.ml.principal.reference | 18 + .../typing-objects/pr5619_bad.ml.reference | 18 + testsuite/tests/typing-objects/pr5858.ml | 2 + .../tests/typing-objects/pr5858.ml.reference | 7 + testsuite/tests/typing-objects/pr6123_bad.ml | 23 + .../pr6123_bad.ml.principal.reference | 8 + .../typing-objects/pr6123_bad.ml.reference | 8 + testsuite/tests/typing-objects/pr6383.ml | 1 + .../tests/typing-objects/pr6383.ml.reference | 6 + testsuite/tests/typing-objects/pr6907_bad.ml | 7 + .../typing-objects/pr6907_bad.ml.reference | 10 + testsuite/tests/typing-pattern_open/Makefile | 3 + .../tests/typing-pattern_open/pattern_open.ml | 147 + .../pattern_open.ml.reference | 81 + testsuite/tests/typing-poly-bugs/Makefile | 18 + testsuite/tests/typing-poly-bugs/pr5322_ok.ml | 6 + .../tests/typing-poly-bugs/pr5673_bad.ml | 23 + testsuite/tests/typing-poly-bugs/pr5673_ok.ml | 23 + testsuite/tests/typing-poly/Makefile | 18 + testsuite/tests/typing-poly/poly.ml | 1476 ++++ .../tests/typing-polyvariants-bugs-2/Makefile | 26 + .../typing-polyvariants-bugs-2/pr3918a.mli | 1 + .../typing-polyvariants-bugs-2/pr3918b.mli | 1 + .../typing-polyvariants-bugs-2/pr3918c.ml | 10 + .../tests/typing-polyvariants-bugs/Makefile | 18 + .../typing-polyvariants-bugs/pr4775_ok.ml | 11 + .../typing-polyvariants-bugs/pr4933_ok.ml | 15 + .../typing-polyvariants-bugs/pr5057_ok.ml | 14 + .../typing-polyvariants-bugs/pr5057a_bad.ml | 7 + .../typing-polyvariants-bugs/pr7199_ok.ml | 13 + .../privrowsabate_ok.ml | 53 + testsuite/tests/typing-private-bugs/Makefile | 18 + .../tests/typing-private-bugs/pr5026_bad.ml | 11 + .../tests/typing-private-bugs/pr5469_ok.ml | 7 + testsuite/tests/typing-private/Makefile | 18 + testsuite/tests/typing-private/private.ml | 118 + .../private.ml.principal.reference | 127 + .../tests/typing-private/private.ml.reference | 127 + testsuite/tests/typing-recmod/Makefile | 18 + testsuite/tests/typing-recmod/t01bad.ml | 2 + testsuite/tests/typing-recmod/t02bad.ml | 3 + testsuite/tests/typing-recmod/t03ok.ml | 3 + testsuite/tests/typing-recmod/t04bad.ml | 2 + testsuite/tests/typing-recmod/t05bad.ml | 3 + testsuite/tests/typing-recmod/t06ok.ml | 3 + testsuite/tests/typing-recmod/t07bad.ml | 3 + testsuite/tests/typing-recmod/t08bad.ml | 4 + testsuite/tests/typing-recmod/t09bad.ml | 5 + testsuite/tests/typing-recmod/t10ok.ml | 5 + testsuite/tests/typing-recmod/t11bad.ml | 5 + testsuite/tests/typing-recmod/t12bad.ml | 13 + testsuite/tests/typing-recmod/t13ok.ml | 5 + testsuite/tests/typing-recmod/t14bad.ml | 17 + testsuite/tests/typing-recmod/t15bad.ml | 3 + testsuite/tests/typing-recmod/t16ok.ml | 30 + testsuite/tests/typing-recmod/t17ok.ml | 41 + testsuite/tests/typing-recmod/t18ok.ml | 25 + testsuite/tests/typing-recmod/t19ok.ml | 15 + testsuite/tests/typing-recmod/t20ok.ml | 30 + testsuite/tests/typing-recmod/t21ok.ml | 27 + testsuite/tests/typing-recmod/t22ok.ml | 511 ++ testsuite/tests/typing-recmod/t22ok.mli | 134 + testsuite/tests/typing-recordarg/Makefile | 18 + testsuite/tests/typing-recordarg/recordarg.ml | 92 + .../typing-recordarg/recordarg.ml.reference | 67 + testsuite/tests/typing-rectypes-bugs/Makefile | 18 + .../tests/typing-rectypes-bugs/pr5343_bad.ml | 13 + .../tests/typing-rectypes-bugs/pr6174_bad.ml | 3 + .../tests/typing-rectypes-bugs/pr6870_bad.ml | 2 + testsuite/tests/typing-safe-linking/Makefile | 20 + testsuite/tests/typing-safe-linking/a.ml | 6 + testsuite/tests/typing-safe-linking/b_bad.ml | 5 + testsuite/tests/typing-short-paths/Makefile | 19 + testsuite/tests/typing-short-paths/pr5918.ml | 7 + .../typing-short-paths/pr5918.ml.reference | 6 + testsuite/tests/typing-short-paths/pr6836.ml | 6 + .../typing-short-paths/pr6836.ml.reference | 7 + .../tests/typing-short-paths/short-paths.ml | 57 + .../short-paths.ml.reference | 95 + testsuite/tests/typing-signatures/Makefile | 18 + testsuite/tests/typing-signatures/els.ml | 95 + .../tests/typing-signatures/els.ml.reference | 95 + testsuite/tests/typing-signatures/pr6371.ml | 7 + .../typing-signatures/pr6371.ml.reference | 4 + testsuite/tests/typing-signatures/pr6672.ml | 3 + .../typing-signatures/pr6672.ml.reference | 10 + testsuite/tests/typing-sigsubst/Makefile | 18 + testsuite/tests/typing-sigsubst/sigsubst.ml | 40 + .../typing-sigsubst/sigsubst.ml.reference | 40 + testsuite/tests/typing-typeparam/Makefile | 18 + testsuite/tests/typing-typeparam/newtype.ml | 32 + .../typing-typeparam/newtype.ml.reference | 19 + testsuite/tests/typing-unboxed-types/Makefile | 3 + testsuite/tests/typing-unboxed-types/test.ml | 156 + .../typing-unboxed-types/test.ml.reference | 203 + testsuite/tests/typing-unboxed/Makefile | 18 + testsuite/tests/typing-unboxed/test.ml | 129 + .../tests/typing-unboxed/test.ml.reference | 192 + testsuite/tests/typing-warnings/Makefile | 19 + .../ambiguous_guarded_disjunction.ml | 206 + ...ambiguous_guarded_disjunction.ml.reference | 140 + .../tests/typing-warnings/application.ml | 5 + .../typing-warnings/application.ml.reference | 14 + testsuite/tests/typing-warnings/coercions.ml | 22 + .../coercions.ml.principal.reference | 26 + .../typing-warnings/coercions.ml.reference | 18 + .../tests/typing-warnings/exhaustiveness.ml | 113 + .../exhaustiveness.ml.reference | 143 + testsuite/tests/typing-warnings/pr5892.ml | 3 + .../tests/typing-warnings/pr5892.ml.reference | 12 + testsuite/tests/typing-warnings/pr6872.ml | 11 + .../pr6872.ml.principal.reference | 39 + .../tests/typing-warnings/pr6872.ml.reference | 35 + testsuite/tests/typing-warnings/pr7085.ml | 23 + .../tests/typing-warnings/pr7085.ml.reference | 20 + testsuite/tests/typing-warnings/pr7115.ml | 20 + .../tests/typing-warnings/pr7115.ml.reference | 22 + testsuite/tests/typing-warnings/pr7297.ml | 4 + .../tests/typing-warnings/pr7297.ml.reference | 8 + testsuite/tests/typing-warnings/records.ml | 180 + .../records.ml.principal.reference | 321 + .../typing-warnings/records.ml.reference | 313 + .../tests/typing-warnings/unused_types.ml | 76 + .../typing-warnings/unused_types.ml.reference | 58 + .../tests/unboxed-primitive-args/Makefile | 40 + testsuite/tests/unboxed-primitive-args/README | 26 + .../tests/unboxed-primitive-args/common.ml | 286 + .../tests/unboxed-primitive-args/common.mli | 29 + .../tests/unboxed-primitive-args/gen_test.ml | 228 + .../unboxed-primitive-args/main.reference | 0 .../unboxed-primitive-args/test_common.c | 37 + .../unboxed-primitive-args/test_common.h | 44 + testsuite/tests/unwind/Makefile | 41 + testsuite/tests/unwind/README | 9 + testsuite/tests/unwind/driver.ml | 3 + testsuite/tests/unwind/mylib.ml | 20 + testsuite/tests/unwind/mylib.mli | 10 + testsuite/tests/unwind/stack_walker.c | 59 + testsuite/tests/utils/Makefile | 25 + testsuite/tests/utils/edit_distance.ml | 48 + testsuite/tests/utils/edit_distance.reference | 38 + .../test_strongly_connected_components.ml | 29 + ...st_strongly_connected_components.reference | 2 + testsuite/tests/warnings/Makefile | 61 + testsuite/tests/warnings/deprecated_module.ml | 9 + .../tests/warnings/deprecated_module.mli | 13 + .../warnings/deprecated_module.reference | 4 + .../tests/warnings/deprecated_module_use.ml | 6 + .../warnings/deprecated_module_use.reference | 14 + .../tests/warnings/module_without_cmx.mli | 2 + testsuite/tests/warnings/w01.ml | 44 + testsuite/tests/warnings/w01.reference | 15 + testsuite/tests/warnings/w04.ml | 12 + testsuite/tests/warnings/w04.reference | 3 + testsuite/tests/warnings/w06.ml | 6 + testsuite/tests/warnings/w06.reference | 4 + testsuite/tests/warnings/w33.ml | 16 + testsuite/tests/warnings/w33.reference | 4 + testsuite/tests/warnings/w45.ml | 16 + testsuite/tests/warnings/w45.reference | 7 + testsuite/tests/warnings/w47_inline.ml | 15 + testsuite/tests/warnings/w47_inline.reference | 15 + testsuite/tests/warnings/w50.ml | 7 + testsuite/tests/warnings/w50.reference | 4 + testsuite/tests/warnings/w51.ml | 5 + testsuite/tests/warnings/w51.reference | 2 + testsuite/tests/warnings/w51_bis.ml | 5 + testsuite/tests/warnings/w51_bis.reference | 2 + testsuite/tests/warnings/w53.ml | 31 + testsuite/tests/warnings/w53.reference | 26 + testsuite/tests/warnings/w54.ml | 9 + testsuite/tests/warnings/w54.reference | 8 + .../w55.opt_backend.clambda.opt_reference | 12 + .../w55.opt_backend.flambda.opt_reference | 6 + testsuite/tests/warnings/w55.opt_backend.ml | 21 + .../tests/warnings/w55.opt_backend.reference | 0 testsuite/tests/warnings/w58.opt.ml | 2 + .../tests/warnings/w58.opt.opt_reference | 2 + testsuite/tests/warnings/w58.opt.reference | 0 .../w59.opt_backend.clambda.opt_reference | 0 .../w59.opt_backend.flambda.opt_reference | 44 + testsuite/tests/warnings/w59.opt_backend.ml | 44 + .../tests/warnings/w59.opt_backend.reference | 0 testsuite/tests/warnings/w60.ml | 23 + testsuite/tests/warnings/w60.mli | 12 + testsuite/tests/warnings/w60.reference | 0 testsuite/tools/Makefile | 31 + testsuite/tools/expect_test.ml | 366 + testsuite/typing | 40 + tools/.depend | 93 + tools/Makefile | 397 + tools/Makefile.nt | 16 + tools/addlabels.ml | 469 ++ tools/check-typo | 299 + tools/checkstack.c | 43 + tools/ci-build | 209 + tools/cleanup-header | 29 + tools/cmpbyt.ml | 87 + tools/cmt2annot.ml | 214 + tools/cvt_emit.mll | 86 + tools/dumpobj.ml | 580 ++ tools/eqparsetree.ml | 784 ++ tools/gdb-macros | 321 + tools/lexer299.mll | 461 ++ tools/lexer301.mll | 462 ++ tools/lintapidiff.ml | 313 + tools/magic | 11 + tools/make-package-macosx | 138 + tools/make-version-header.sh | 55 + tools/make_opcodes.mll | 47 + tools/msvs-promote-path | 51 + tools/objinfo.ml | 340 + tools/objinfo_helper.c | 100 + tools/ocaml-instr-graph | 116 + tools/ocaml-instr-report | 162 + tools/ocaml-objcopy-macosx | 54 + tools/ocaml299to3.ml | 141 + tools/ocamlcp.ml | 174 + tools/ocamldep.ml | 608 ++ tools/ocamlmklib.ml | 328 + tools/ocamlmktop.ml | 32 + tools/ocamloptp.ml | 221 + tools/ocamlprof.ml | 523 ++ tools/ocamlsize | 64 + tools/primreq.ml | 96 + tools/profiling.ml | 56 + tools/profiling.mli | 20 + tools/read_cmt.ml | 103 + tools/scrapelabels.ml | 290 + tools/stripdebug.ml | 57 + toplevel/expunge.ml | 84 + toplevel/genprintval.ml | 582 ++ toplevel/genprintval.mli | 70 + toplevel/opttopdirs.ml | 199 + toplevel/opttopdirs.mli | 33 + toplevel/opttoploop.ml | 601 ++ toplevel/opttoploop.mli | 132 + toplevel/opttopmain.ml | 255 + toplevel/opttopmain.mli | 18 + toplevel/opttopstart.ml | 16 + toplevel/topdirs.ml | 774 ++ toplevel/topdirs.mli | 36 + toplevel/toploop.ml | 571 ++ toplevel/toploop.mli | 157 + toplevel/topmain.ml | 170 + toplevel/topmain.mli | 18 + toplevel/topstart.ml | 16 + toplevel/trace.ml | 150 + toplevel/trace.mli | 36 + typing/HACKING.adoc | 58 + typing/annot.mli | 24 + typing/btype.ml | 737 ++ typing/btype.mli | 221 + typing/cmi_format.ml | 109 + typing/cmi_format.mli | 49 + typing/cmt_format.ml | 195 + typing/cmt_format.mli | 121 + typing/ctype.ml | 4549 +++++++++++ typing/ctype.mli | 292 + typing/datarepr.ml | 237 + typing/datarepr.mli | 44 + typing/env.ml | 2100 +++++ typing/env.mli | 322 + typing/envaux.ml | 105 + typing/envaux.mli | 36 + typing/ident.ml | 249 + typing/ident.mli | 73 + typing/includeclass.ml | 110 + typing/includeclass.mli | 31 + typing/includecore.ml | 338 + typing/includecore.mli | 53 + typing/includemod.ml | 657 ++ typing/includemod.mli | 58 + typing/mtype.ml | 422 + typing/mtype.mli | 45 + typing/oprint.ml | 667 ++ typing/oprint.mli | 28 + typing/outcometree.mli | 140 + typing/parmatch.ml | 2313 ++++++ typing/parmatch.mli | 81 + typing/path.ml | 101 + typing/path.mli | 45 + typing/predef.ml | 254 + typing/predef.mli | 77 + typing/primitive.ml | 224 + typing/primitive.mli | 71 + typing/printtyp.ml | 1579 ++++ typing/printtyp.mli | 90 + typing/printtyped.ml | 871 ++ typing/printtyped.mli | 23 + typing/stypes.ml | 212 + typing/stypes.mli | 36 + typing/subst.ml | 440 + typing/subst.mli | 62 + typing/tast_mapper.ml | 692 ++ typing/tast_mapper.mli | 67 + typing/typeclass.ml | 1921 +++++ typing/typeclass.mli | 124 + typing/typecore.ml | 4464 ++++++++++ typing/typecore.mli | 152 + typing/typedecl.ml | 2118 +++++ typing/typedecl.mli | 105 + typing/typedtree.ml | 613 ++ typing/typedtree.mli | 664 ++ typing/typedtreeIter.ml | 679 ++ typing/typedtreeIter.mli | 97 + typing/typedtreeMap.ml | 722 ++ typing/typedtreeMap.mli | 94 + typing/typemod.ml | 1837 +++++ typing/typemod.mli | 87 + typing/types.ml | 336 + typing/types.mli | 487 ++ typing/typetexp.ml | 917 +++ typing/typetexp.mli | 113 + typing/untypeast.ml | 813 ++ typing/untypeast.mli | 78 + utils/arg_helper.ml | 127 + utils/arg_helper.mli | 63 + utils/ccomp.ml | 198 + utils/ccomp.mli | 33 + utils/clflags.ml | 393 + utils/clflags.mli | 223 + utils/config.mli | 163 + utils/config.mlp | 183 + utils/consistbl.ml | 66 + utils/consistbl.mli | 62 + utils/identifiable.ml | 242 + utils/identifiable.mli | 96 + utils/misc.ml | 696 ++ utils/misc.mli | 333 + utils/numbers.ml | 48 + utils/numbers.mli | 26 + utils/strongly_connected_components.ml | 200 + utils/strongly_connected_components.mli | 38 + utils/targetint.ml | 98 + utils/targetint.mli | 188 + utils/tbl.ml | 115 + utils/tbl.mli | 33 + utils/terminfo.ml | 26 + utils/terminfo.mli | 26 + utils/timings.ml | 158 + utils/timings.mli | 68 + utils/warnings.ml | 604 ++ utils/warnings.mli | 101 + yacc/Makefile | 63 + yacc/Makefile.nt | 16 + yacc/closure.c | 284 + yacc/defs.h | 361 + yacc/error.c | 323 + yacc/lalr.c | 664 ++ yacc/lr0.c | 621 ++ yacc/main.c | 470 ++ yacc/mkpar.c | 365 + yacc/output.c | 985 +++ yacc/reader.c | 1914 +++++ yacc/skeleton.c | 60 + yacc/symtab.c | 130 + yacc/verbose.c | 349 + yacc/warshall.c | 97 + 2680 files changed, 424926 insertions(+) create mode 100644 .depend create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100644 .gitmodules create mode 100644 .mailmap create mode 100644 .merlin create mode 100644 .ocp-indent create mode 100755 .travis-ci.sh create mode 100644 .travis.yml create mode 100644 CONTRIBUTING.md create mode 100644 Changes create mode 100644 HACKING.adoc create mode 100644 INSTALL.adoc create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 Makefile.nt create mode 100644 Makefile.tools create mode 100644 README.adoc create mode 100644 README.win32.adoc create mode 100644 VERSION create mode 100644 appveyor.yml create mode 100644 appveyor_build.sh create mode 100644 asmcomp/CSEgen.ml create mode 100644 asmcomp/CSEgen.mli create mode 100644 asmcomp/afl_instrument.ml create mode 100644 asmcomp/afl_instrument.mli create mode 100644 asmcomp/amd64/CSE.ml create mode 100644 asmcomp/amd64/NOTES.md create mode 100644 asmcomp/amd64/arch.ml create mode 100644 asmcomp/amd64/emit.mlp create mode 100644 asmcomp/amd64/proc.ml create mode 100644 asmcomp/amd64/reload.ml create mode 100644 asmcomp/amd64/scheduling.ml create mode 100644 asmcomp/amd64/selection.ml create mode 100644 asmcomp/arm/CSE.ml create mode 100644 asmcomp/arm/NOTES.md create mode 100644 asmcomp/arm/arch.ml create mode 100644 asmcomp/arm/emit.mlp create mode 100644 asmcomp/arm/proc.ml create mode 100644 asmcomp/arm/reload.ml create mode 100644 asmcomp/arm/scheduling.ml create mode 100644 asmcomp/arm/selection.ml create mode 100644 asmcomp/arm64/CSE.ml create mode 100644 asmcomp/arm64/NOTES.md create mode 100644 asmcomp/arm64/arch.ml create mode 100644 asmcomp/arm64/emit.mlp create mode 100644 asmcomp/arm64/proc.ml create mode 100644 asmcomp/arm64/reload.ml create mode 100644 asmcomp/arm64/scheduling.ml create mode 100644 asmcomp/arm64/selection.ml create mode 100644 asmcomp/asmgen.ml create mode 100644 asmcomp/asmgen.mli create mode 100644 asmcomp/asmlibrarian.ml create mode 100644 asmcomp/asmlibrarian.mli create mode 100644 asmcomp/asmlink.ml create mode 100644 asmcomp/asmlink.mli create mode 100644 asmcomp/asmpackager.ml create mode 100644 asmcomp/asmpackager.mli create mode 100644 asmcomp/branch_relaxation.ml create mode 100644 asmcomp/branch_relaxation.mli create mode 100644 asmcomp/branch_relaxation_intf.ml create mode 100644 asmcomp/build_export_info.ml create mode 100644 asmcomp/build_export_info.mli create mode 100644 asmcomp/clambda.ml create mode 100644 asmcomp/clambda.mli create mode 100644 asmcomp/closure.ml create mode 100644 asmcomp/closure.mli create mode 100644 asmcomp/closure_offsets.ml create mode 100644 asmcomp/closure_offsets.mli create mode 100644 asmcomp/cmm.ml create mode 100644 asmcomp/cmm.mli create mode 100644 asmcomp/cmmgen.ml create mode 100644 asmcomp/cmmgen.mli create mode 100644 asmcomp/cmx_format.mli create mode 100644 asmcomp/coloring.ml create mode 100644 asmcomp/coloring.mli create mode 100644 asmcomp/comballoc.ml create mode 100644 asmcomp/comballoc.mli create mode 100644 asmcomp/compilenv.ml create mode 100644 asmcomp/compilenv.mli create mode 100644 asmcomp/deadcode.ml create mode 100644 asmcomp/deadcode.mli create mode 100644 asmcomp/emit.mli create mode 100644 asmcomp/emitaux.ml create mode 100644 asmcomp/emitaux.mli create mode 100644 asmcomp/export_info.ml create mode 100644 asmcomp/export_info.mli create mode 100644 asmcomp/export_info_for_pack.ml create mode 100644 asmcomp/export_info_for_pack.mli create mode 100644 asmcomp/flambda_to_clambda.ml create mode 100644 asmcomp/flambda_to_clambda.mli create mode 100644 asmcomp/i386/CSE.ml create mode 100644 asmcomp/i386/NOTES.md create mode 100644 asmcomp/i386/arch.ml create mode 100644 asmcomp/i386/emit.mlp create mode 100644 asmcomp/i386/proc.ml create mode 100644 asmcomp/i386/reload.ml create mode 100644 asmcomp/i386/scheduling.ml create mode 100644 asmcomp/i386/selection.ml create mode 100644 asmcomp/import_approx.ml create mode 100644 asmcomp/import_approx.mli create mode 100644 asmcomp/interf.ml create mode 100644 asmcomp/interf.mli create mode 100644 asmcomp/linearize.ml create mode 100644 asmcomp/linearize.mli create mode 100644 asmcomp/liveness.ml create mode 100644 asmcomp/liveness.mli create mode 100644 asmcomp/mach.ml create mode 100644 asmcomp/mach.mli create mode 100644 asmcomp/power/CSE.ml create mode 100644 asmcomp/power/NOTES.md create mode 100644 asmcomp/power/arch.ml create mode 100644 asmcomp/power/emit.mlp create mode 100644 asmcomp/power/proc.ml create mode 100644 asmcomp/power/reload.ml create mode 100644 asmcomp/power/scheduling.ml create mode 100644 asmcomp/power/selection.ml create mode 100644 asmcomp/printclambda.ml create mode 100644 asmcomp/printclambda.mli create mode 100644 asmcomp/printcmm.ml create mode 100644 asmcomp/printcmm.mli create mode 100644 asmcomp/printlinear.ml create mode 100644 asmcomp/printlinear.mli create mode 100644 asmcomp/printmach.ml create mode 100644 asmcomp/printmach.mli create mode 100644 asmcomp/proc.mli create mode 100644 asmcomp/reg.ml create mode 100644 asmcomp/reg.mli create mode 100644 asmcomp/reload.mli create mode 100644 asmcomp/reloadgen.ml create mode 100644 asmcomp/reloadgen.mli create mode 100644 asmcomp/s390x/CSE.ml create mode 100644 asmcomp/s390x/NOTES.md create mode 100644 asmcomp/s390x/arch.ml create mode 100644 asmcomp/s390x/emit.mlp create mode 100644 asmcomp/s390x/proc.ml create mode 100644 asmcomp/s390x/reload.ml create mode 100644 asmcomp/s390x/scheduling.ml create mode 100644 asmcomp/s390x/selection.ml create mode 100644 asmcomp/schedgen.ml create mode 100644 asmcomp/schedgen.mli create mode 100644 asmcomp/scheduling.mli create mode 100644 asmcomp/selectgen.ml create mode 100644 asmcomp/selectgen.mli create mode 100644 asmcomp/selection.mli create mode 100644 asmcomp/spacetime_profiling.ml create mode 100644 asmcomp/spacetime_profiling.mli create mode 100644 asmcomp/sparc/CSE.ml create mode 100644 asmcomp/sparc/NOTES.md create mode 100644 asmcomp/sparc/arch.ml create mode 100644 asmcomp/sparc/emit.mlp create mode 100644 asmcomp/sparc/proc.ml create mode 100644 asmcomp/sparc/reload.ml create mode 100644 asmcomp/sparc/scheduling.ml create mode 100644 asmcomp/sparc/selection.ml create mode 100644 asmcomp/spill.ml create mode 100644 asmcomp/spill.mli create mode 100644 asmcomp/split.ml create mode 100644 asmcomp/split.mli create mode 100644 asmcomp/strmatch.ml create mode 100644 asmcomp/strmatch.mli create mode 100644 asmcomp/un_anf.ml create mode 100644 asmcomp/un_anf.mli create mode 100644 asmcomp/x86_ast.mli create mode 100644 asmcomp/x86_dsl.ml create mode 100644 asmcomp/x86_dsl.mli create mode 100644 asmcomp/x86_gas.ml create mode 100644 asmcomp/x86_gas.mli create mode 100644 asmcomp/x86_masm.ml create mode 100644 asmcomp/x86_masm.mli create mode 100644 asmcomp/x86_proc.ml create mode 100644 asmcomp/x86_proc.mli create mode 100644 asmrun/.depend create mode 100644 asmrun/Makefile create mode 100644 asmrun/Makefile.nt create mode 100644 asmrun/amd64.S create mode 100644 asmrun/amd64nt.asm create mode 100644 asmrun/arm.S create mode 100644 asmrun/arm64.S create mode 100644 asmrun/backtrace_prim.c create mode 100644 asmrun/clambda_checks.c create mode 100644 asmrun/fail.c create mode 100644 asmrun/i386.S create mode 100644 asmrun/i386nt.asm create mode 100644 asmrun/natdynlink.c create mode 100644 asmrun/power.S create mode 100644 asmrun/roots.c create mode 100644 asmrun/s390x.S create mode 100644 asmrun/signals_asm.c create mode 100644 asmrun/signals_osdep.h create mode 100644 asmrun/spacetime.c create mode 100644 asmrun/spacetime_offline.c create mode 100644 asmrun/spacetime_snapshot.c create mode 100644 asmrun/sparc.S create mode 100644 asmrun/startup.c create mode 100755 boot/ocamlc create mode 100755 boot/ocamldep create mode 100755 boot/ocamllex create mode 100644 bytecomp/bytegen.ml create mode 100644 bytecomp/bytegen.mli create mode 100644 bytecomp/bytelibrarian.ml create mode 100644 bytecomp/bytelibrarian.mli create mode 100644 bytecomp/bytelink.ml create mode 100644 bytecomp/bytelink.mli create mode 100644 bytecomp/bytepackager.ml create mode 100644 bytecomp/bytepackager.mli create mode 100644 bytecomp/bytesections.ml create mode 100644 bytecomp/bytesections.mli create mode 100644 bytecomp/cmo_format.mli create mode 100644 bytecomp/dll.ml create mode 100644 bytecomp/dll.mli create mode 100644 bytecomp/emitcode.ml create mode 100644 bytecomp/emitcode.mli create mode 100644 bytecomp/instruct.ml create mode 100644 bytecomp/instruct.mli create mode 100644 bytecomp/lambda.ml create mode 100644 bytecomp/lambda.mli create mode 100644 bytecomp/matching.ml create mode 100644 bytecomp/matching.mli create mode 100644 bytecomp/meta.ml create mode 100644 bytecomp/meta.mli create mode 100644 bytecomp/printinstr.ml create mode 100644 bytecomp/printinstr.mli create mode 100644 bytecomp/printlambda.ml create mode 100644 bytecomp/printlambda.mli create mode 100644 bytecomp/runtimedef.mli create mode 100644 bytecomp/semantics_of_primitives.ml create mode 100644 bytecomp/semantics_of_primitives.mli create mode 100644 bytecomp/simplif.ml create mode 100644 bytecomp/simplif.mli create mode 100644 bytecomp/switch.ml create mode 100644 bytecomp/switch.mli create mode 100644 bytecomp/symtable.ml create mode 100644 bytecomp/symtable.mli create mode 100644 bytecomp/translattribute.ml create mode 100644 bytecomp/translattribute.mli create mode 100644 bytecomp/translclass.ml create mode 100644 bytecomp/translclass.mli create mode 100644 bytecomp/translcore.ml create mode 100644 bytecomp/translcore.mli create mode 100644 bytecomp/translmod.ml create mode 100644 bytecomp/translmod.mli create mode 100644 bytecomp/translobj.ml create mode 100644 bytecomp/translobj.mli create mode 100644 bytecomp/typeopt.ml create mode 100644 bytecomp/typeopt.mli create mode 100644 byterun/.depend create mode 100644 byterun/Makefile create mode 100644 byterun/Makefile.nt create mode 100644 byterun/afl.c create mode 100644 byterun/alloc.c create mode 100644 byterun/array.c create mode 100644 byterun/backtrace.c create mode 100644 byterun/backtrace_prim.c create mode 100644 byterun/callback.c create mode 100644 byterun/caml/address_class.h create mode 100644 byterun/caml/alloc.h create mode 100644 byterun/caml/backtrace.h create mode 100644 byterun/caml/backtrace_prim.h create mode 100644 byterun/caml/callback.h create mode 100644 byterun/caml/compact.h create mode 100644 byterun/caml/compare.h create mode 100644 byterun/caml/compatibility.h create mode 100644 byterun/caml/config.h create mode 100644 byterun/caml/custom.h create mode 100644 byterun/caml/debugger.h create mode 100644 byterun/caml/dynlink.h create mode 100644 byterun/caml/exec.h create mode 100644 byterun/caml/fail.h create mode 100644 byterun/caml/finalise.h create mode 100644 byterun/caml/fix_code.h create mode 100644 byterun/caml/freelist.h create mode 100644 byterun/caml/gc.h create mode 100644 byterun/caml/gc_ctrl.h create mode 100644 byterun/caml/globroots.h create mode 100644 byterun/caml/hash.h create mode 100644 byterun/caml/hooks.h create mode 100644 byterun/caml/instrtrace.h create mode 100644 byterun/caml/instruct.h create mode 100644 byterun/caml/int64_emul.h create mode 100644 byterun/caml/int64_format.h create mode 100644 byterun/caml/int64_native.h create mode 100644 byterun/caml/interp.h create mode 100644 byterun/caml/intext.h create mode 100644 byterun/caml/io.h create mode 100644 byterun/caml/major_gc.h create mode 100644 byterun/caml/md5.h create mode 100644 byterun/caml/memory.h create mode 100644 byterun/caml/minor_gc.h create mode 100644 byterun/caml/misc.h create mode 100644 byterun/caml/mlvalues.h create mode 100644 byterun/caml/osdeps.h create mode 100644 byterun/caml/prims.h create mode 100644 byterun/caml/printexc.h create mode 100644 byterun/caml/reverse.h create mode 100644 byterun/caml/roots.h create mode 100644 byterun/caml/signals.h create mode 100644 byterun/caml/signals_machdep.h create mode 100644 byterun/caml/spacetime.h create mode 100644 byterun/caml/stack.h create mode 100644 byterun/caml/stacks.h create mode 100644 byterun/caml/startup.h create mode 100644 byterun/caml/startup_aux.h create mode 100644 byterun/caml/sys.h create mode 100644 byterun/caml/ui.h create mode 100644 byterun/caml/weak.h create mode 100644 byterun/compact.c create mode 100644 byterun/compare.c create mode 100644 byterun/custom.c create mode 100644 byterun/debugger.c create mode 100644 byterun/dynlink.c create mode 100644 byterun/extern.c create mode 100644 byterun/fail.c create mode 100644 byterun/finalise.c create mode 100644 byterun/fix_code.c create mode 100644 byterun/floats.c create mode 100644 byterun/freelist.c create mode 100644 byterun/gc_ctrl.c create mode 100644 byterun/globroots.c create mode 100644 byterun/hash.c create mode 100644 byterun/instrtrace.c create mode 100644 byterun/intern.c create mode 100644 byterun/interp.c create mode 100644 byterun/ints.c create mode 100644 byterun/io.c create mode 100644 byterun/lexing.c create mode 100644 byterun/main.c create mode 100644 byterun/major_gc.c create mode 100644 byterun/md5.c create mode 100644 byterun/memory.c create mode 100644 byterun/meta.c create mode 100644 byterun/minor_gc.c create mode 100644 byterun/misc.c create mode 100644 byterun/obj.c create mode 100644 byterun/parsing.c create mode 100644 byterun/printexc.c create mode 100644 byterun/roots.c create mode 100644 byterun/signals.c create mode 100644 byterun/signals_byt.c create mode 100644 byterun/spacetime.c create mode 100644 byterun/stacks.c create mode 100644 byterun/startup.c create mode 100644 byterun/startup_aux.c create mode 100644 byterun/str.c create mode 100644 byterun/sys.c create mode 100644 byterun/terminfo.c create mode 100644 byterun/unix.c create mode 100644 byterun/weak.c create mode 100644 byterun/win32.c create mode 100644 compilerlibs/.gitignore create mode 100644 config/Makefile-templ create mode 100644 config/Makefile.mingw create mode 100644 config/Makefile.mingw64 create mode 100644 config/Makefile.msvc create mode 100644 config/Makefile.msvc64 create mode 100644 config/auto-aux/align.c create mode 100644 config/auto-aux/ansi.c create mode 100644 config/auto-aux/async_io.c create mode 100644 config/auto-aux/cckind.c create mode 100644 config/auto-aux/cfi.S create mode 100644 config/auto-aux/dblalign.c create mode 100644 config/auto-aux/elf.c create mode 100644 config/auto-aux/endian.c create mode 100644 config/auto-aux/getgroups.c create mode 100644 config/auto-aux/gethostbyaddr.c create mode 100644 config/auto-aux/gethostbyname.c create mode 100755 config/auto-aux/hasgot create mode 100644 config/auto-aux/hasgot2 create mode 100755 config/auto-aux/hashbang create mode 100755 config/auto-aux/hashbang2 create mode 100755 config/auto-aux/hashbang3 create mode 100644 config/auto-aux/ia32sse2.c create mode 100644 config/auto-aux/initgroups.c create mode 100644 config/auto-aux/int64align.c create mode 100644 config/auto-aux/mmap-huge.c create mode 100644 config/auto-aux/nanosecond_stat.c create mode 100755 config/auto-aux/runtest create mode 100755 config/auto-aux/searchpath create mode 100644 config/auto-aux/setgroups.c create mode 100644 config/auto-aux/signals.c create mode 100644 config/auto-aux/sizes.c create mode 100644 config/auto-aux/solaris-ld create mode 100644 config/auto-aux/tryassemble create mode 100755 config/auto-aux/trycompile create mode 100755 config/gnu/config.guess create mode 100755 config/gnu/config.sub create mode 100644 config/m-nt.h create mode 100644 config/m-templ.h create mode 100644 config/s-nt.h create mode 100644 config/s-templ.h create mode 100755 configure create mode 100644 debugger/.depend create mode 100644 debugger/Makefile create mode 100644 debugger/Makefile.nt create mode 100644 debugger/breakpoints.ml create mode 100644 debugger/breakpoints.mli create mode 100644 debugger/checkpoints.ml create mode 100644 debugger/checkpoints.mli create mode 100644 debugger/command_line.ml create mode 100644 debugger/command_line.mli create mode 100644 debugger/debugcom.ml create mode 100644 debugger/debugcom.mli create mode 100644 debugger/debugger_config.ml create mode 100644 debugger/debugger_config.mli create mode 100644 debugger/eval.ml create mode 100644 debugger/eval.mli create mode 100644 debugger/events.ml create mode 100644 debugger/events.mli create mode 100644 debugger/exec.ml create mode 100644 debugger/exec.mli create mode 100644 debugger/frames.ml create mode 100644 debugger/frames.mli create mode 100644 debugger/history.ml create mode 100644 debugger/history.mli create mode 100644 debugger/input_handling.ml create mode 100644 debugger/input_handling.mli create mode 100644 debugger/int64ops.ml create mode 100644 debugger/int64ops.mli create mode 100644 debugger/lexer.mli create mode 100644 debugger/lexer.mll create mode 100644 debugger/loadprinter.ml create mode 100644 debugger/loadprinter.mli create mode 100644 debugger/main.ml create mode 100644 debugger/parameters.ml create mode 100644 debugger/parameters.mli create mode 100644 debugger/parser.mly create mode 100644 debugger/parser_aux.mli create mode 100644 debugger/pattern_matching.ml create mode 100644 debugger/pattern_matching.mli create mode 100644 debugger/pos.ml create mode 100644 debugger/pos.mli create mode 100644 debugger/primitives.ml create mode 100644 debugger/primitives.mli create mode 100644 debugger/printval.ml create mode 100644 debugger/printval.mli create mode 100644 debugger/program_loading.ml create mode 100644 debugger/program_loading.mli create mode 100644 debugger/program_management.ml create mode 100644 debugger/program_management.mli create mode 100644 debugger/question.ml create mode 100644 debugger/question.mli create mode 100644 debugger/show_information.ml create mode 100644 debugger/show_information.mli create mode 100644 debugger/show_source.ml create mode 100644 debugger/show_source.mli create mode 100644 debugger/source.ml create mode 100644 debugger/source.mli create mode 100644 debugger/symbols.ml create mode 100644 debugger/symbols.mli create mode 100644 debugger/time_travel.ml create mode 100644 debugger/time_travel.mli create mode 100644 debugger/trap_barrier.ml create mode 100644 debugger/trap_barrier.mli create mode 100644 debugger/unix_tools.ml create mode 100644 debugger/unix_tools.mli create mode 100644 driver/compdynlink.mlno create mode 100644 driver/compenv.ml create mode 100644 driver/compenv.mli create mode 100644 driver/compile.ml create mode 100644 driver/compile.mli create mode 100644 driver/compmisc.ml create mode 100644 driver/compmisc.mli create mode 100644 driver/compplugin.ml create mode 100644 driver/compplugin.mli create mode 100644 driver/errors.ml create mode 100644 driver/errors.mli create mode 100644 driver/main.ml create mode 100644 driver/main.mli create mode 100644 driver/main_args.ml create mode 100644 driver/main_args.mli create mode 100644 driver/ocamlcomp.sh.in create mode 100644 driver/optcompile.ml create mode 100644 driver/optcompile.mli create mode 100644 driver/opterrors.ml create mode 100644 driver/opterrors.mli create mode 100644 driver/optmain.ml create mode 100644 driver/optmain.mli create mode 100644 driver/pparse.ml create mode 100644 driver/pparse.mli create mode 100644 emacs/COPYING create mode 100644 emacs/Makefile create mode 100644 emacs/README create mode 100644 emacs/README.itz create mode 100644 emacs/caml-compat.el create mode 100644 emacs/caml-emacs.el create mode 100644 emacs/caml-font-old.el create mode 100644 emacs/caml-font.el create mode 100644 emacs/caml-help.el create mode 100644 emacs/caml-hilit.el create mode 100644 emacs/caml-types.el create mode 100644 emacs/caml-xemacs.el create mode 100644 emacs/caml.el create mode 100644 emacs/camldebug.el create mode 100644 emacs/inf-caml.el create mode 100644 emacs/ocamltags.in create mode 100644 lex/.depend create mode 100644 lex/Makefile create mode 100644 lex/Makefile.nt create mode 100644 lex/common.ml create mode 100644 lex/common.mli create mode 100644 lex/compact.ml create mode 100644 lex/compact.mli create mode 100644 lex/cset.ml create mode 100644 lex/cset.mli create mode 100644 lex/lexer.mli create mode 100644 lex/lexer.mll create mode 100644 lex/lexgen.ml create mode 100644 lex/lexgen.mli create mode 100644 lex/main.ml create mode 100644 lex/output.ml create mode 100644 lex/output.mli create mode 100644 lex/outputbis.ml create mode 100644 lex/outputbis.mli create mode 100644 lex/parser.mly create mode 100644 lex/syntax.ml create mode 100644 lex/syntax.mli create mode 100644 lex/table.ml create mode 100644 lex/table.mli create mode 100644 man/Makefile create mode 100644 man/ocaml.m create mode 100644 man/ocamlc.m create mode 100644 man/ocamlcp.m create mode 100644 man/ocamldebug.m create mode 100644 man/ocamldep.m create mode 100644 man/ocamldoc.m create mode 100644 man/ocamllex.m create mode 100644 man/ocamlmktop.m create mode 100644 man/ocamlopt.m create mode 100644 man/ocamlprof.m create mode 100644 man/ocamlrun.m create mode 100644 man/ocamlyacc.m create mode 100755 middle_end/alias_analysis.ml create mode 100644 middle_end/alias_analysis.mli create mode 100644 middle_end/allocated_const.ml create mode 100644 middle_end/allocated_const.mli create mode 100755 middle_end/augment_specialised_args.ml create mode 100644 middle_end/augment_specialised_args.mli create mode 100755 middle_end/backend_intf.mli create mode 100644 middle_end/base_types/closure_element.ml create mode 100644 middle_end/base_types/closure_element.mli create mode 100644 middle_end/base_types/closure_id.ml create mode 100644 middle_end/base_types/closure_id.mli create mode 100644 middle_end/base_types/compilation_unit.ml create mode 100644 middle_end/base_types/compilation_unit.mli create mode 100644 middle_end/base_types/export_id.ml create mode 100644 middle_end/base_types/export_id.mli create mode 100644 middle_end/base_types/id_types.ml create mode 100644 middle_end/base_types/id_types.mli create mode 100644 middle_end/base_types/linkage_name.ml create mode 100644 middle_end/base_types/linkage_name.mli create mode 100644 middle_end/base_types/mutable_variable.ml create mode 100644 middle_end/base_types/mutable_variable.mli create mode 100644 middle_end/base_types/set_of_closures_id.ml create mode 100755 middle_end/base_types/set_of_closures_id.mli create mode 100644 middle_end/base_types/set_of_closures_origin.ml create mode 100644 middle_end/base_types/set_of_closures_origin.mli create mode 100644 middle_end/base_types/static_exception.ml create mode 100644 middle_end/base_types/static_exception.mli create mode 100644 middle_end/base_types/symbol.ml create mode 100644 middle_end/base_types/symbol.mli create mode 100644 middle_end/base_types/tag.ml create mode 100644 middle_end/base_types/tag.mli create mode 100644 middle_end/base_types/var_within_closure.ml create mode 100644 middle_end/base_types/var_within_closure.mli create mode 100644 middle_end/base_types/variable.ml create mode 100644 middle_end/base_types/variable.mli create mode 100755 middle_end/closure_conversion.ml create mode 100644 middle_end/closure_conversion.mli create mode 100644 middle_end/closure_conversion_aux.ml create mode 100755 middle_end/closure_conversion_aux.mli create mode 100644 middle_end/debuginfo.ml create mode 100644 middle_end/debuginfo.mli create mode 100644 middle_end/effect_analysis.ml create mode 100644 middle_end/effect_analysis.mli create mode 100644 middle_end/extract_projections.ml create mode 100644 middle_end/extract_projections.mli create mode 100644 middle_end/find_recursive_functions.ml create mode 100644 middle_end/find_recursive_functions.mli create mode 100644 middle_end/flambda.ml create mode 100755 middle_end/flambda.mli create mode 100755 middle_end/flambda_invariants.ml create mode 100644 middle_end/flambda_invariants.mli create mode 100644 middle_end/flambda_iterators.ml create mode 100644 middle_end/flambda_iterators.mli create mode 100644 middle_end/flambda_utils.ml create mode 100644 middle_end/flambda_utils.mli create mode 100644 middle_end/freshening.ml create mode 100644 middle_end/freshening.mli create mode 100755 middle_end/inconstant_idents.ml create mode 100644 middle_end/inconstant_idents.mli create mode 100644 middle_end/initialize_symbol_to_let_symbol.ml create mode 100644 middle_end/initialize_symbol_to_let_symbol.mli create mode 100755 middle_end/inline_and_simplify.ml create mode 100644 middle_end/inline_and_simplify.mli create mode 100644 middle_end/inline_and_simplify_aux.ml create mode 100755 middle_end/inline_and_simplify_aux.mli create mode 100644 middle_end/inlining_cost.ml create mode 100644 middle_end/inlining_cost.mli create mode 100755 middle_end/inlining_decision.ml create mode 100644 middle_end/inlining_decision.mli create mode 100644 middle_end/inlining_decision_intf.mli create mode 100644 middle_end/inlining_stats.ml create mode 100644 middle_end/inlining_stats.mli create mode 100644 middle_end/inlining_stats_types.ml create mode 100644 middle_end/inlining_stats_types.mli create mode 100755 middle_end/inlining_transforms.ml create mode 100644 middle_end/inlining_transforms.mli create mode 100755 middle_end/invariant_params.ml create mode 100644 middle_end/invariant_params.mli create mode 100644 middle_end/lift_code.ml create mode 100644 middle_end/lift_code.mli create mode 100644 middle_end/lift_constants.ml create mode 100644 middle_end/lift_constants.mli create mode 100644 middle_end/lift_let_to_initialize_symbol.ml create mode 100644 middle_end/lift_let_to_initialize_symbol.mli create mode 100644 middle_end/middle_end.ml create mode 100644 middle_end/middle_end.mli create mode 100644 middle_end/pass_wrapper.ml create mode 100644 middle_end/pass_wrapper.mli create mode 100644 middle_end/projection.ml create mode 100644 middle_end/projection.mli create mode 100644 middle_end/ref_to_variables.ml create mode 100644 middle_end/ref_to_variables.mli create mode 100755 middle_end/remove_free_vars_equal_to_args.ml create mode 100644 middle_end/remove_free_vars_equal_to_args.mli create mode 100644 middle_end/remove_unused_arguments.ml create mode 100644 middle_end/remove_unused_arguments.mli create mode 100644 middle_end/remove_unused_closure_vars.ml create mode 100644 middle_end/remove_unused_closure_vars.mli create mode 100644 middle_end/remove_unused_program_constructs.ml create mode 100644 middle_end/remove_unused_program_constructs.mli create mode 100644 middle_end/share_constants.ml create mode 100644 middle_end/share_constants.mli create mode 100644 middle_end/simple_value_approx.ml create mode 100644 middle_end/simple_value_approx.mli create mode 100644 middle_end/simplify_boxed_integer_ops.ml create mode 100644 middle_end/simplify_boxed_integer_ops.mli create mode 100644 middle_end/simplify_boxed_integer_ops_intf.mli create mode 100644 middle_end/simplify_common.ml create mode 100644 middle_end/simplify_common.mli create mode 100644 middle_end/simplify_primitives.ml create mode 100644 middle_end/simplify_primitives.mli create mode 100644 middle_end/unbox_closures.ml create mode 100644 middle_end/unbox_closures.mli create mode 100644 middle_end/unbox_free_vars_of_closures.ml create mode 100644 middle_end/unbox_free_vars_of_closures.mli create mode 100755 middle_end/unbox_specialised_args.ml create mode 100644 middle_end/unbox_specialised_args.mli create mode 100644 ocamldoc/.depend create mode 100644 ocamldoc/Changes.txt create mode 100644 ocamldoc/Makefile create mode 100644 ocamldoc/Makefile.nt create mode 100644 ocamldoc/generators/odoc_literate.ml create mode 100644 ocamldoc/generators/odoc_todo.ml create mode 100644 ocamldoc/ocamldoc.hva create mode 100644 ocamldoc/ocamldoc.sty create mode 100644 ocamldoc/odoc.ml create mode 100644 ocamldoc/odoc_analyse.ml create mode 100644 ocamldoc/odoc_analyse.mli create mode 100644 ocamldoc/odoc_args.ml create mode 100644 ocamldoc/odoc_args.mli create mode 100644 ocamldoc/odoc_ast.ml create mode 100644 ocamldoc/odoc_ast.mli create mode 100644 ocamldoc/odoc_class.ml create mode 100644 ocamldoc/odoc_comments.ml create mode 100644 ocamldoc/odoc_comments.mli create mode 100644 ocamldoc/odoc_comments_global.ml create mode 100644 ocamldoc/odoc_comments_global.mli create mode 100644 ocamldoc/odoc_config.ml create mode 100644 ocamldoc/odoc_config.mli create mode 100644 ocamldoc/odoc_control.ml create mode 100644 ocamldoc/odoc_cross.ml create mode 100644 ocamldoc/odoc_cross.mli create mode 100644 ocamldoc/odoc_dag2html.ml create mode 100644 ocamldoc/odoc_dag2html.mli create mode 100644 ocamldoc/odoc_dep.ml create mode 100644 ocamldoc/odoc_dot.ml create mode 100644 ocamldoc/odoc_env.ml create mode 100644 ocamldoc/odoc_env.mli create mode 100644 ocamldoc/odoc_exception.ml create mode 100644 ocamldoc/odoc_extension.ml create mode 100644 ocamldoc/odoc_gen.ml create mode 100644 ocamldoc/odoc_gen.mli create mode 100644 ocamldoc/odoc_global.ml create mode 100644 ocamldoc/odoc_global.mli create mode 100644 ocamldoc/odoc_html.ml create mode 100644 ocamldoc/odoc_info.ml create mode 100644 ocamldoc/odoc_info.mli create mode 100644 ocamldoc/odoc_inherit.ml create mode 100644 ocamldoc/odoc_latex.ml create mode 100644 ocamldoc/odoc_latex_style.ml create mode 100644 ocamldoc/odoc_lexer.mll create mode 100644 ocamldoc/odoc_man.ml create mode 100644 ocamldoc/odoc_merge.ml create mode 100644 ocamldoc/odoc_merge.mli create mode 100644 ocamldoc/odoc_messages.ml create mode 100644 ocamldoc/odoc_misc.ml create mode 100644 ocamldoc/odoc_misc.mli create mode 100644 ocamldoc/odoc_module.ml create mode 100644 ocamldoc/odoc_name.ml create mode 100644 ocamldoc/odoc_name.mli create mode 100644 ocamldoc/odoc_ocamlhtml.mll create mode 100644 ocamldoc/odoc_parameter.ml create mode 100644 ocamldoc/odoc_parser.mly create mode 100644 ocamldoc/odoc_print.ml create mode 100644 ocamldoc/odoc_print.mli create mode 100644 ocamldoc/odoc_scan.ml create mode 100644 ocamldoc/odoc_search.ml create mode 100644 ocamldoc/odoc_search.mli create mode 100644 ocamldoc/odoc_see_lexer.mll create mode 100644 ocamldoc/odoc_sig.ml create mode 100644 ocamldoc/odoc_sig.mli create mode 100644 ocamldoc/odoc_str.ml create mode 100644 ocamldoc/odoc_str.mli create mode 100644 ocamldoc/odoc_test.ml create mode 100644 ocamldoc/odoc_texi.ml create mode 100644 ocamldoc/odoc_text.ml create mode 100644 ocamldoc/odoc_text.mli create mode 100644 ocamldoc/odoc_text_lexer.mll create mode 100644 ocamldoc/odoc_text_parser.mly create mode 100644 ocamldoc/odoc_to_text.ml create mode 100644 ocamldoc/odoc_type.ml create mode 100644 ocamldoc/odoc_types.ml create mode 100644 ocamldoc/odoc_types.mli create mode 100644 ocamldoc/odoc_value.ml create mode 100755 ocamldoc/remove_DEBUG create mode 100644 otherlibs/Makefile create mode 100644 otherlibs/bigarray/.depend create mode 100644 otherlibs/bigarray/Makefile create mode 100644 otherlibs/bigarray/Makefile.nt create mode 100644 otherlibs/bigarray/bigarray.h create mode 100644 otherlibs/bigarray/bigarray.ml create mode 100644 otherlibs/bigarray/bigarray.mli create mode 100644 otherlibs/bigarray/bigarray_stubs.c create mode 100644 otherlibs/bigarray/mmap_unix.c create mode 100644 otherlibs/bigarray/mmap_win32.c create mode 100644 otherlibs/dynlink/Makefile create mode 100644 otherlibs/dynlink/Makefile.nt create mode 100644 otherlibs/dynlink/dynlink.ml create mode 100644 otherlibs/dynlink/dynlink.mli create mode 100644 otherlibs/dynlink/extract_crc.ml create mode 100644 otherlibs/dynlink/natdynlink.ml create mode 100644 otherlibs/graph/.depend create mode 100644 otherlibs/graph/Makefile create mode 100644 otherlibs/graph/color.c create mode 100644 otherlibs/graph/draw.c create mode 100644 otherlibs/graph/dump_img.c create mode 100644 otherlibs/graph/events.c create mode 100644 otherlibs/graph/fill.c create mode 100644 otherlibs/graph/graphics.ml create mode 100644 otherlibs/graph/graphics.mli create mode 100644 otherlibs/graph/graphicsX11.ml create mode 100644 otherlibs/graph/graphicsX11.mli create mode 100644 otherlibs/graph/image.c create mode 100644 otherlibs/graph/image.h create mode 100644 otherlibs/graph/libgraph.h create mode 100644 otherlibs/graph/make_img.c create mode 100644 otherlibs/graph/open.c create mode 100644 otherlibs/graph/point_col.c create mode 100644 otherlibs/graph/sound.c create mode 100644 otherlibs/graph/subwindow.c create mode 100644 otherlibs/graph/text.c create mode 100644 otherlibs/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/bng.c create mode 100644 otherlibs/num/bng.h create mode 100644 otherlibs/num/bng_amd64.c create mode 100644 otherlibs/num/bng_arm64.c create mode 100644 otherlibs/num/bng_digit.c create mode 100644 otherlibs/num/bng_ia32.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 create mode 100644 otherlibs/num/nat.h create mode 100644 otherlibs/num/nat.ml create mode 100644 otherlibs/num/nat.mli create mode 100644 otherlibs/num/nat_stubs.c create mode 100644 otherlibs/num/num.ml create mode 100644 otherlibs/num/num.mli create mode 100644 otherlibs/num/ratio.ml create mode 100644 otherlibs/num/ratio.mli create mode 100644 otherlibs/raw_spacetime_lib/.depend create mode 100644 otherlibs/raw_spacetime_lib/Makefile create mode 100644 otherlibs/raw_spacetime_lib/Makefile.nt create mode 100644 otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml create mode 100644 otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli create mode 100644 otherlibs/str/.depend create mode 100644 otherlibs/str/Makefile create mode 100644 otherlibs/str/Makefile.nt create mode 100644 otherlibs/str/str.ml create mode 100644 otherlibs/str/str.mli create mode 100644 otherlibs/str/strstubs.c create mode 100644 otherlibs/systhreads/.depend create mode 100644 otherlibs/systhreads/Makefile create mode 100644 otherlibs/systhreads/Makefile.nt create mode 100644 otherlibs/systhreads/condition.ml create mode 100644 otherlibs/systhreads/condition.mli create mode 100644 otherlibs/systhreads/event.ml create mode 100644 otherlibs/systhreads/event.mli create mode 100644 otherlibs/systhreads/mutex.ml create mode 100644 otherlibs/systhreads/mutex.mli create mode 100644 otherlibs/systhreads/st_posix.h create mode 100644 otherlibs/systhreads/st_stubs.c create mode 100644 otherlibs/systhreads/st_win32.h create mode 100644 otherlibs/systhreads/thread.ml create mode 100644 otherlibs/systhreads/thread.mli create mode 100644 otherlibs/systhreads/threadUnix.ml create mode 100644 otherlibs/systhreads/threadUnix.mli create mode 100644 otherlibs/systhreads/threads.h create mode 100644 otherlibs/threads/.depend create mode 100644 otherlibs/threads/Makefile create mode 100644 otherlibs/threads/condition.ml create mode 100644 otherlibs/threads/condition.mli create mode 100644 otherlibs/threads/event.ml create mode 100644 otherlibs/threads/event.mli create mode 100644 otherlibs/threads/marshal.ml create mode 100644 otherlibs/threads/mutex.ml create mode 100644 otherlibs/threads/mutex.mli create mode 100644 otherlibs/threads/pervasives.ml create mode 100644 otherlibs/threads/scheduler.c create mode 100644 otherlibs/threads/thread.ml create mode 100644 otherlibs/threads/thread.mli create mode 100644 otherlibs/threads/threadUnix.ml create mode 100644 otherlibs/threads/threadUnix.mli create mode 100644 otherlibs/threads/unix.ml create mode 100644 otherlibs/unix/.depend create mode 100644 otherlibs/unix/Makefile create mode 100644 otherlibs/unix/accept.c create mode 100644 otherlibs/unix/access.c create mode 100644 otherlibs/unix/addrofstr.c create mode 100644 otherlibs/unix/alarm.c create mode 100644 otherlibs/unix/bind.c create mode 100644 otherlibs/unix/chdir.c create mode 100644 otherlibs/unix/chmod.c create mode 100644 otherlibs/unix/chown.c create mode 100644 otherlibs/unix/chroot.c create mode 100644 otherlibs/unix/close.c create mode 100644 otherlibs/unix/closedir.c create mode 100644 otherlibs/unix/connect.c create mode 100644 otherlibs/unix/cst2constr.c create mode 100644 otherlibs/unix/cst2constr.h create mode 100644 otherlibs/unix/cstringv.c create mode 100644 otherlibs/unix/dup.c create mode 100644 otherlibs/unix/dup2.c create mode 100644 otherlibs/unix/envir.c create mode 100644 otherlibs/unix/errmsg.c create mode 100644 otherlibs/unix/execv.c create mode 100644 otherlibs/unix/execve.c create mode 100644 otherlibs/unix/execvp.c create mode 100644 otherlibs/unix/exit.c create mode 100644 otherlibs/unix/fchmod.c create mode 100644 otherlibs/unix/fchown.c create mode 100644 otherlibs/unix/fcntl.c create mode 100644 otherlibs/unix/fork.c create mode 100644 otherlibs/unix/ftruncate.c create mode 100644 otherlibs/unix/getaddrinfo.c create mode 100644 otherlibs/unix/getcwd.c create mode 100644 otherlibs/unix/getegid.c create mode 100644 otherlibs/unix/geteuid.c create mode 100644 otherlibs/unix/getgid.c create mode 100644 otherlibs/unix/getgr.c create mode 100644 otherlibs/unix/getgroups.c create mode 100644 otherlibs/unix/gethost.c create mode 100644 otherlibs/unix/gethostname.c create mode 100644 otherlibs/unix/getlogin.c create mode 100644 otherlibs/unix/getnameinfo.c create mode 100644 otherlibs/unix/getpeername.c create mode 100644 otherlibs/unix/getpid.c create mode 100644 otherlibs/unix/getppid.c create mode 100644 otherlibs/unix/getproto.c create mode 100644 otherlibs/unix/getpw.c create mode 100644 otherlibs/unix/getserv.c create mode 100644 otherlibs/unix/getsockname.c create mode 100644 otherlibs/unix/gettimeofday.c create mode 100644 otherlibs/unix/getuid.c create mode 100644 otherlibs/unix/gmtime.c create mode 100644 otherlibs/unix/initgroups.c create mode 100644 otherlibs/unix/isatty.c create mode 100644 otherlibs/unix/itimer.c create mode 100644 otherlibs/unix/kill.c create mode 100644 otherlibs/unix/link.c create mode 100644 otherlibs/unix/listen.c create mode 100644 otherlibs/unix/lockf.c create mode 100644 otherlibs/unix/lseek.c create mode 100644 otherlibs/unix/mkdir.c create mode 100644 otherlibs/unix/mkfifo.c create mode 100644 otherlibs/unix/nanosecond_stat.h create mode 100644 otherlibs/unix/nice.c create mode 100644 otherlibs/unix/open.c create mode 100644 otherlibs/unix/opendir.c create mode 100644 otherlibs/unix/pipe.c create mode 100644 otherlibs/unix/putenv.c create mode 100644 otherlibs/unix/read.c create mode 100644 otherlibs/unix/readdir.c create mode 100644 otherlibs/unix/readlink.c create mode 100644 otherlibs/unix/rename.c create mode 100644 otherlibs/unix/rewinddir.c create mode 100644 otherlibs/unix/rmdir.c create mode 100644 otherlibs/unix/select.c create mode 100644 otherlibs/unix/sendrecv.c create mode 100644 otherlibs/unix/setgid.c create mode 100644 otherlibs/unix/setgroups.c create mode 100644 otherlibs/unix/setsid.c create mode 100644 otherlibs/unix/setuid.c create mode 100644 otherlibs/unix/shutdown.c create mode 100644 otherlibs/unix/signals.c create mode 100644 otherlibs/unix/sleep.c create mode 100644 otherlibs/unix/socket.c create mode 100644 otherlibs/unix/socketaddr.c create mode 100644 otherlibs/unix/socketaddr.h create mode 100644 otherlibs/unix/socketpair.c create mode 100644 otherlibs/unix/sockopt.c create mode 100644 otherlibs/unix/stat.c create mode 100644 otherlibs/unix/strofaddr.c create mode 100644 otherlibs/unix/symlink.c create mode 100644 otherlibs/unix/termios.c create mode 100644 otherlibs/unix/time.c create mode 100644 otherlibs/unix/times.c create mode 100644 otherlibs/unix/truncate.c create mode 100644 otherlibs/unix/umask.c create mode 100644 otherlibs/unix/unix.ml create mode 100644 otherlibs/unix/unix.mli create mode 100644 otherlibs/unix/unixLabels.ml create mode 100644 otherlibs/unix/unixLabels.mli create mode 100644 otherlibs/unix/unixsupport.c create mode 100644 otherlibs/unix/unixsupport.h create mode 100644 otherlibs/unix/unlink.c create mode 100644 otherlibs/unix/utimes.c create mode 100644 otherlibs/unix/wait.c create mode 100644 otherlibs/unix/write.c create mode 100644 otherlibs/win32graph/Makefile create mode 100644 otherlibs/win32graph/Makefile.nt create mode 100644 otherlibs/win32graph/draw.c create mode 100755 otherlibs/win32graph/events.c create mode 100644 otherlibs/win32graph/libgraph.h create mode 100644 otherlibs/win32graph/open.c create mode 100644 otherlibs/win32unix/.depend create mode 100644 otherlibs/win32unix/Makefile create mode 100644 otherlibs/win32unix/Makefile.nt create mode 100644 otherlibs/win32unix/accept.c create mode 100644 otherlibs/win32unix/bind.c create mode 100644 otherlibs/win32unix/channels.c create mode 100644 otherlibs/win32unix/close.c create mode 100644 otherlibs/win32unix/close_on.c create mode 100644 otherlibs/win32unix/connect.c create mode 100644 otherlibs/win32unix/createprocess.c create mode 100644 otherlibs/win32unix/dup.c create mode 100644 otherlibs/win32unix/dup2.c create mode 100644 otherlibs/win32unix/errmsg.c create mode 100644 otherlibs/win32unix/getpeername.c create mode 100644 otherlibs/win32unix/getpid.c create mode 100644 otherlibs/win32unix/getsockname.c create mode 100644 otherlibs/win32unix/gettimeofday.c create mode 100644 otherlibs/win32unix/link.c create mode 100644 otherlibs/win32unix/listen.c create mode 100644 otherlibs/win32unix/lockf.c create mode 100644 otherlibs/win32unix/lseek.c create mode 100644 otherlibs/win32unix/mkdir.c create mode 100755 otherlibs/win32unix/nonblock.c create mode 100644 otherlibs/win32unix/open.c create mode 100644 otherlibs/win32unix/pipe.c create mode 100644 otherlibs/win32unix/read.c create mode 100644 otherlibs/win32unix/readlink.c create mode 100644 otherlibs/win32unix/rename.c create mode 100644 otherlibs/win32unix/select.c create mode 100644 otherlibs/win32unix/sendrecv.c create mode 100644 otherlibs/win32unix/shutdown.c create mode 100644 otherlibs/win32unix/sleep.c create mode 100644 otherlibs/win32unix/socket.c create mode 100644 otherlibs/win32unix/socketaddr.h create mode 100644 otherlibs/win32unix/sockopt.c create mode 100644 otherlibs/win32unix/startup.c create mode 100644 otherlibs/win32unix/stat.c create mode 100644 otherlibs/win32unix/symlink.c create mode 100644 otherlibs/win32unix/system.c create mode 100644 otherlibs/win32unix/times.c create mode 100644 otherlibs/win32unix/unix.ml create mode 100644 otherlibs/win32unix/unixsupport.c create mode 100644 otherlibs/win32unix/unixsupport.h create mode 100644 otherlibs/win32unix/windbug.c create mode 100644 otherlibs/win32unix/windbug.h create mode 100644 otherlibs/win32unix/windir.c create mode 100644 otherlibs/win32unix/winlist.c create mode 100644 otherlibs/win32unix/winlist.h create mode 100644 otherlibs/win32unix/winwait.c create mode 100644 otherlibs/win32unix/winworker.c create mode 100644 otherlibs/win32unix/winworker.h create mode 100644 otherlibs/win32unix/write.c create mode 100644 parsing/HACKING.adoc create mode 100644 parsing/ast_helper.ml create mode 100644 parsing/ast_helper.mli create mode 100644 parsing/ast_invariants.ml create mode 100644 parsing/ast_invariants.mli create mode 100755 parsing/ast_iterator.ml create mode 100755 parsing/ast_iterator.mli create mode 100644 parsing/ast_mapper.ml create mode 100644 parsing/ast_mapper.mli create mode 100644 parsing/asttypes.mli create mode 100644 parsing/attr_helper.ml create mode 100644 parsing/attr_helper.mli create mode 100755 parsing/builtin_attributes.ml create mode 100755 parsing/builtin_attributes.mli create mode 100644 parsing/depend.ml create mode 100644 parsing/depend.mli create mode 100644 parsing/docstrings.ml create mode 100644 parsing/docstrings.mli create mode 100644 parsing/lexer.mli create mode 100644 parsing/lexer.mll create mode 100644 parsing/location.ml create mode 100644 parsing/location.mli create mode 100644 parsing/longident.ml create mode 100644 parsing/longident.mli create mode 100644 parsing/parse.ml create mode 100644 parsing/parse.mli create mode 100644 parsing/parser.mly create mode 100644 parsing/parsetree.mli create mode 100644 parsing/pprintast.ml create mode 100644 parsing/pprintast.mli create mode 100644 parsing/printast.ml create mode 100644 parsing/printast.mli create mode 100644 parsing/syntaxerr.ml create mode 100644 parsing/syntaxerr.mli create mode 100644 stdlib/.depend create mode 100755 stdlib/Compflags create mode 100644 stdlib/Makefile create mode 100644 stdlib/Makefile.nt create mode 100644 stdlib/StdlibModules create mode 100644 stdlib/arg.ml create mode 100644 stdlib/arg.mli create mode 100644 stdlib/array.ml create mode 100644 stdlib/array.mli create mode 100644 stdlib/arrayLabels.ml create mode 100644 stdlib/arrayLabels.mli create mode 100644 stdlib/buffer.ml create mode 100644 stdlib/buffer.mli create mode 100644 stdlib/bytes.ml create mode 100644 stdlib/bytes.mli create mode 100644 stdlib/bytesLabels.ml create mode 100644 stdlib/bytesLabels.mli create mode 100644 stdlib/callback.ml create mode 100644 stdlib/callback.mli create mode 100644 stdlib/camlinternalFormat.ml create mode 100644 stdlib/camlinternalFormat.mli create mode 100644 stdlib/camlinternalFormatBasics.ml create mode 100644 stdlib/camlinternalFormatBasics.mli create mode 100644 stdlib/camlinternalLazy.ml create mode 100644 stdlib/camlinternalLazy.mli create mode 100644 stdlib/camlinternalMod.ml create mode 100644 stdlib/camlinternalMod.mli create mode 100644 stdlib/camlinternalOO.ml create mode 100644 stdlib/camlinternalOO.mli create mode 100644 stdlib/char.ml create mode 100644 stdlib/char.mli create mode 100644 stdlib/complex.ml create mode 100644 stdlib/complex.mli create mode 100644 stdlib/digest.ml create mode 100644 stdlib/digest.mli create mode 100644 stdlib/ephemeron.ml create mode 100644 stdlib/ephemeron.mli create mode 100644 stdlib/filename.ml create mode 100644 stdlib/filename.mli create mode 100644 stdlib/format.ml create mode 100644 stdlib/format.mli create mode 100644 stdlib/gc.ml create mode 100644 stdlib/gc.mli create mode 100644 stdlib/genlex.ml create mode 100644 stdlib/genlex.mli create mode 100644 stdlib/hashbang create mode 100644 stdlib/hashtbl.ml create mode 100644 stdlib/hashtbl.mli create mode 100644 stdlib/header.c create mode 100644 stdlib/headernt.c create mode 100644 stdlib/int32.ml create mode 100644 stdlib/int32.mli create mode 100644 stdlib/int64.ml create mode 100644 stdlib/int64.mli create mode 100644 stdlib/lazy.ml create mode 100644 stdlib/lazy.mli create mode 100644 stdlib/lexing.ml create mode 100644 stdlib/lexing.mli create mode 100644 stdlib/list.ml create mode 100644 stdlib/list.mli create mode 100644 stdlib/listLabels.ml create mode 100644 stdlib/listLabels.mli create mode 100644 stdlib/map.ml create mode 100644 stdlib/map.mli create mode 100644 stdlib/marshal.ml create mode 100644 stdlib/marshal.mli create mode 100644 stdlib/moreLabels.ml create mode 100644 stdlib/moreLabels.mli create mode 100644 stdlib/nativeint.ml create mode 100644 stdlib/nativeint.mli create mode 100644 stdlib/obj.ml create mode 100644 stdlib/obj.mli create mode 100644 stdlib/oo.ml create mode 100644 stdlib/oo.mli create mode 100644 stdlib/parsing.ml create mode 100644 stdlib/parsing.mli create mode 100644 stdlib/pervasives.ml create mode 100644 stdlib/pervasives.mli create mode 100644 stdlib/printexc.ml create mode 100644 stdlib/printexc.mli create mode 100644 stdlib/printf.ml create mode 100644 stdlib/printf.mli create mode 100644 stdlib/queue.ml create mode 100644 stdlib/queue.mli create mode 100644 stdlib/random.ml create mode 100644 stdlib/random.mli create mode 100644 stdlib/scanf.ml create mode 100644 stdlib/scanf.mli create mode 100644 stdlib/set.ml create mode 100644 stdlib/set.mli create mode 100644 stdlib/sort.ml create mode 100644 stdlib/sort.mli create mode 100644 stdlib/spacetime.ml create mode 100644 stdlib/spacetime.mli create mode 100644 stdlib/stack.ml create mode 100644 stdlib/stack.mli create mode 100644 stdlib/stdLabels.ml create mode 100644 stdlib/stdLabels.mli create mode 100644 stdlib/std_exit.ml create mode 100644 stdlib/stream.ml create mode 100644 stdlib/stream.mli create mode 100644 stdlib/string.ml create mode 100644 stdlib/string.mli create mode 100644 stdlib/stringLabels.ml create mode 100644 stdlib/stringLabels.mli create mode 100644 stdlib/sys.mli create mode 100644 stdlib/sys.mlp create mode 100644 stdlib/uchar.ml create mode 100644 stdlib/uchar.mli create mode 100644 stdlib/weak.ml create mode 100644 stdlib/weak.mli create mode 100644 testsuite/HACKING.adoc create mode 100644 testsuite/Makefile create mode 100644 testsuite/interactive/lib-gc/Makefile create mode 100644 testsuite/interactive/lib-gc/alloc.ml create mode 100644 testsuite/interactive/lib-graph-2/Makefile create mode 100644 testsuite/interactive/lib-graph-2/graph_test.ml create mode 100644 testsuite/interactive/lib-graph-2/graph_test.reference create mode 100644 testsuite/interactive/lib-graph-3/Makefile create mode 100644 testsuite/interactive/lib-graph-3/sorts.ml create mode 100644 testsuite/interactive/lib-graph-3/sorts.reference create mode 100644 testsuite/interactive/lib-graph/Makefile create mode 100644 testsuite/interactive/lib-graph/graph_example.ml create mode 100644 testsuite/interactive/lib-graph/graph_example.reference create mode 100644 testsuite/interactive/lib-signals/Makefile create mode 100644 testsuite/interactive/lib-signals/signals.ml create mode 100644 testsuite/lib/Makefile create mode 100644 testsuite/lib/testing.ml create mode 100644 testsuite/lib/testing.mli create mode 100644 testsuite/makefiles/Makefile.common create mode 100644 testsuite/makefiles/Makefile.dlambda create mode 100644 testsuite/makefiles/Makefile.dparsetree create mode 100644 testsuite/makefiles/Makefile.expect create mode 100644 testsuite/makefiles/Makefile.okbad create mode 100644 testsuite/makefiles/Makefile.one create mode 100644 testsuite/makefiles/Makefile.several create mode 100644 testsuite/makefiles/Makefile.toplevel create mode 100644 testsuite/makefiles/summarize.awk create mode 100644 testsuite/tests/array-functions/Makefile create mode 100644 testsuite/tests/array-functions/test.ml create mode 100644 testsuite/tests/array-functions/test.reference create mode 100644 testsuite/tests/asmcomp/Makefile create mode 100644 testsuite/tests/asmcomp/alpha.S create mode 100644 testsuite/tests/asmcomp/amd64.S create mode 100644 testsuite/tests/asmcomp/arith.cmm create mode 100644 testsuite/tests/asmcomp/arm.S create mode 100644 testsuite/tests/asmcomp/arm64.S create mode 100755 testsuite/tests/asmcomp/bind_tuples.ml create mode 100644 testsuite/tests/asmcomp/catch-rec.cmm create mode 100644 testsuite/tests/asmcomp/catch-try.cmm create mode 100644 testsuite/tests/asmcomp/checkbound.cmm create mode 100644 testsuite/tests/asmcomp/even-odd-spill.cmm create mode 100644 testsuite/tests/asmcomp/even-odd.cmm create mode 100644 testsuite/tests/asmcomp/fib.cmm create mode 100644 testsuite/tests/asmcomp/hppa.S create mode 100644 testsuite/tests/asmcomp/i386.S create mode 100644 testsuite/tests/asmcomp/i386nt.asm create mode 100644 testsuite/tests/asmcomp/ia64.S create mode 100644 testsuite/tests/asmcomp/integr.cmm create mode 100644 testsuite/tests/asmcomp/is_in_static_data.c create mode 100644 testsuite/tests/asmcomp/is_static.ml create mode 100644 testsuite/tests/asmcomp/is_static_flambda.ml create mode 100644 testsuite/tests/asmcomp/is_static_flambda_dep.ml create mode 100644 testsuite/tests/asmcomp/lexcmm.mli create mode 100644 testsuite/tests/asmcomp/lexcmm.mll create mode 100644 testsuite/tests/asmcomp/m68k.S create mode 100644 testsuite/tests/asmcomp/main.c create mode 100644 testsuite/tests/asmcomp/main.ml create mode 100644 testsuite/tests/asmcomp/mainarith.c create mode 100644 testsuite/tests/asmcomp/mips.s create mode 100644 testsuite/tests/asmcomp/optargs.ml create mode 100644 testsuite/tests/asmcomp/parsecmm.mly create mode 100644 testsuite/tests/asmcomp/parsecmmaux.ml create mode 100644 testsuite/tests/asmcomp/parsecmmaux.mli create mode 100644 testsuite/tests/asmcomp/pgcd.cmm create mode 100644 testsuite/tests/asmcomp/power.S create mode 100644 testsuite/tests/asmcomp/quicksort.cmm create mode 100644 testsuite/tests/asmcomp/quicksort2.cmm create mode 100644 testsuite/tests/asmcomp/register_typing.ml create mode 100644 testsuite/tests/asmcomp/register_typing_switch.ml create mode 100644 testsuite/tests/asmcomp/s390x.S create mode 100644 testsuite/tests/asmcomp/simple_float_const.ml create mode 100644 testsuite/tests/asmcomp/simple_float_const_opaque.ml create mode 100644 testsuite/tests/asmcomp/soli.cmm create mode 100644 testsuite/tests/asmcomp/sparc.S create mode 100644 testsuite/tests/asmcomp/static_float_array_flambda.ml create mode 100644 testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml create mode 100644 testsuite/tests/asmcomp/staticalloc.ml create mode 100644 testsuite/tests/asmcomp/tagged-fib.cmm create mode 100644 testsuite/tests/asmcomp/tagged-integr.cmm create mode 100644 testsuite/tests/asmcomp/tagged-quicksort.cmm create mode 100644 testsuite/tests/asmcomp/tagged-tak.cmm create mode 100644 testsuite/tests/asmcomp/tak.cmm create mode 100644 testsuite/tests/asmcomp/unrolling_flambda.ml create mode 100644 testsuite/tests/asmcomp/unrolling_flambda2.ml create mode 100644 testsuite/tests/ast-invariants/Makefile create mode 100644 testsuite/tests/ast-invariants/test.ml create mode 100644 testsuite/tests/ast-invariants/test.reference create mode 100644 testsuite/tests/backtrace/Makefile create mode 100644 testsuite/tests/backtrace/backtrace..byte.reference create mode 100644 testsuite/tests/backtrace/backtrace..native.reference create mode 100644 testsuite/tests/backtrace/backtrace.a.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace.a.native.reference create mode 100644 testsuite/tests/backtrace/backtrace.b.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace.b.native.reference create mode 100644 testsuite/tests/backtrace/backtrace.c.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace.c.native.reference create mode 100644 testsuite/tests/backtrace/backtrace.d.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace.d.native.reference create mode 100644 testsuite/tests/backtrace/backtrace.ml create mode 100644 testsuite/tests/backtrace/backtrace2.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace2.ml create mode 100644 testsuite/tests/backtrace/backtrace2.native.reference create mode 100644 testsuite/tests/backtrace/backtrace3.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace3.ml create mode 100644 testsuite/tests/backtrace/backtrace3.native.reference create mode 100644 testsuite/tests/backtrace/backtrace_deprecated.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace_deprecated.ml create mode 100644 testsuite/tests/backtrace/backtrace_deprecated.native.reference create mode 100644 testsuite/tests/backtrace/backtrace_slots.byte.reference create mode 100644 testsuite/tests/backtrace/backtrace_slots.ml create mode 100644 testsuite/tests/backtrace/backtrace_slots.native.reference create mode 100644 testsuite/tests/backtrace/backtraces_and_finalizers.ml create mode 100644 testsuite/tests/backtrace/backtraces_and_finalizers.native.reference create mode 100644 testsuite/tests/backtrace/inline_test.byte.reference create mode 100644 testsuite/tests/backtrace/inline_test.ml create mode 100644 testsuite/tests/backtrace/inline_test.native.reference create mode 100644 testsuite/tests/backtrace/inline_traversal_test.byte.reference create mode 100644 testsuite/tests/backtrace/inline_traversal_test.ml create mode 100644 testsuite/tests/backtrace/inline_traversal_test.native.reference create mode 100644 testsuite/tests/backtrace/pr6920_why_at.byte.reference create mode 100644 testsuite/tests/backtrace/pr6920_why_at.ml create mode 100644 testsuite/tests/backtrace/pr6920_why_at.native.reference create mode 100644 testsuite/tests/backtrace/pr6920_why_swallow.byte.reference create mode 100644 testsuite/tests/backtrace/pr6920_why_swallow.ml create mode 100644 testsuite/tests/backtrace/pr6920_why_swallow.native.reference create mode 100644 testsuite/tests/backtrace/raw_backtrace.byte.reference create mode 100644 testsuite/tests/backtrace/raw_backtrace.ml create mode 100644 testsuite/tests/backtrace/raw_backtrace.native.reference create mode 100644 testsuite/tests/basic-float/Makefile create mode 100644 testsuite/tests/basic-float/tfloat_hex.ml create mode 100644 testsuite/tests/basic-float/tfloat_hex.reference create mode 100644 testsuite/tests/basic-float/tfloat_record.ml create mode 100644 testsuite/tests/basic-float/tfloat_record.reference create mode 100644 testsuite/tests/basic-float/zero_sized_float_arrays.ml create mode 100644 testsuite/tests/basic-float/zero_sized_float_arrays.reference create mode 100644 testsuite/tests/basic-io-2/Makefile create mode 100644 testsuite/tests/basic-io-2/io.ml create mode 100644 testsuite/tests/basic-io-2/io.reference create mode 100644 testsuite/tests/basic-io-2/test-file-short-lines create mode 100644 testsuite/tests/basic-io/Makefile create mode 100644 testsuite/tests/basic-io/wc.ml create mode 100644 testsuite/tests/basic-io/wc.reference create mode 100644 testsuite/tests/basic-manyargs/Makefile create mode 100644 testsuite/tests/basic-manyargs/manyargs.ml create mode 100644 testsuite/tests/basic-manyargs/manyargs.reference create mode 100644 testsuite/tests/basic-manyargs/manyargsprim.c create mode 100644 testsuite/tests/basic-modules/Makefile create mode 100644 testsuite/tests/basic-modules/main.ml create mode 100644 testsuite/tests/basic-modules/main.mli create mode 100644 testsuite/tests/basic-modules/main.reference create mode 100644 testsuite/tests/basic-modules/offset.ml create mode 100644 testsuite/tests/basic-modules/pr6726.ml create mode 100644 testsuite/tests/basic-modules/pr7427.ml create mode 100644 testsuite/tests/basic-more/Makefile create mode 100644 testsuite/tests/basic-more/bounds.ml create mode 100644 testsuite/tests/basic-more/bounds.reference create mode 100644 testsuite/tests/basic-more/div_by_zero.ml create mode 100644 testsuite/tests/basic-more/div_by_zero.reference create mode 100644 testsuite/tests/basic-more/function_in_ref.ml create mode 100644 testsuite/tests/basic-more/function_in_ref.reference create mode 100644 testsuite/tests/basic-more/if_in_if.ml create mode 100644 testsuite/tests/basic-more/if_in_if.reference create mode 100644 testsuite/tests/basic-more/morematch.ml create mode 100644 testsuite/tests/basic-more/morematch.reference create mode 100644 testsuite/tests/basic-more/opaque_prim.ml create mode 100644 testsuite/tests/basic-more/opaque_prim.reference create mode 100644 testsuite/tests/basic-more/pr2719.ml create mode 100644 testsuite/tests/basic-more/pr2719.reference create mode 100644 testsuite/tests/basic-more/pr6216.ml create mode 100644 testsuite/tests/basic-more/pr6216.reference create mode 100644 testsuite/tests/basic-more/record_evaluation_order.ml create mode 100644 testsuite/tests/basic-more/record_evaluation_order.reference create mode 100644 testsuite/tests/basic-more/sequential_and_or.ml create mode 100644 testsuite/tests/basic-more/sequential_and_or.reference create mode 100644 testsuite/tests/basic-more/structural_constants.ml create mode 100644 testsuite/tests/basic-more/structural_constants.reference create mode 100644 testsuite/tests/basic-more/tbuffer.ml create mode 100644 testsuite/tests/basic-more/tbuffer.reference create mode 100644 testsuite/tests/basic-more/testrandom.ml create mode 100644 testsuite/tests/basic-more/testrandom.reference create mode 100644 testsuite/tests/basic-more/tformat.ml create mode 100644 testsuite/tests/basic-more/tformat.reference create mode 100644 testsuite/tests/basic-more/top_level_patterns.ml create mode 100644 testsuite/tests/basic-more/top_level_patterns.reference create mode 100644 testsuite/tests/basic-more/tprintf.ml create mode 100644 testsuite/tests/basic-more/tprintf.reference create mode 100644 testsuite/tests/basic-multdef/Makefile create mode 100644 testsuite/tests/basic-multdef/multdef.ml create mode 100644 testsuite/tests/basic-multdef/multdef.mli create mode 100644 testsuite/tests/basic-multdef/usemultdef.ml create mode 100644 testsuite/tests/basic-multdef/usemultdef.reference create mode 100644 testsuite/tests/basic-private/Makefile create mode 100644 testsuite/tests/basic-private/length.ml create mode 100644 testsuite/tests/basic-private/length.mli create mode 100644 testsuite/tests/basic-private/tlength.ml create mode 100644 testsuite/tests/basic-private/tlength.reference create mode 100644 testsuite/tests/basic/Makefile create mode 100644 testsuite/tests/basic/arrays.ml create mode 100644 testsuite/tests/basic/arrays.reference create mode 100644 testsuite/tests/basic/bigints.ml create mode 100644 testsuite/tests/basic/bigints.reference create mode 100644 testsuite/tests/basic/boxedints.ml create mode 100644 testsuite/tests/basic/boxedints.reference create mode 100644 testsuite/tests/basic/constprop.ml create mode 100644 testsuite/tests/basic/constprop.mlp create mode 100644 testsuite/tests/basic/constprop.reference create mode 100644 testsuite/tests/basic/divint.ml create mode 100644 testsuite/tests/basic/divint.reference create mode 100644 testsuite/tests/basic/equality.ml create mode 100644 testsuite/tests/basic/equality.reference create mode 100644 testsuite/tests/basic/eval_order_1.ml create mode 100644 testsuite/tests/basic/eval_order_1.reference create mode 100644 testsuite/tests/basic/eval_order_2.ml create mode 100644 testsuite/tests/basic/eval_order_2.reference create mode 100644 testsuite/tests/basic/eval_order_3.ml create mode 100644 testsuite/tests/basic/eval_order_3.reference create mode 100644 testsuite/tests/basic/eval_order_4.ml create mode 100644 testsuite/tests/basic/eval_order_4.reference create mode 100644 testsuite/tests/basic/float.ml create mode 100644 testsuite/tests/basic/float.reference create mode 100644 testsuite/tests/basic/float_physical_equality.ml create mode 100644 testsuite/tests/basic/float_physical_equality.reference create mode 100644 testsuite/tests/basic/includestruct.ml create mode 100644 testsuite/tests/basic/includestruct.reference create mode 100755 testsuite/tests/basic/localexn.ml create mode 100644 testsuite/tests/basic/localexn.reference create mode 100644 testsuite/tests/basic/maps.ml create mode 100644 testsuite/tests/basic/maps.reference create mode 100644 testsuite/tests/basic/min_int.ml create mode 100644 testsuite/tests/basic/min_int.reference create mode 100755 testsuite/tests/basic/opt_variants.ml create mode 100644 testsuite/tests/basic/opt_variants.reference create mode 100644 testsuite/tests/basic/patmatch.ml create mode 100644 testsuite/tests/basic/patmatch.reference create mode 100644 testsuite/tests/basic/pr6322.ml.in create mode 100644 testsuite/tests/basic/pr6322.reference create mode 100644 testsuite/tests/basic/pr7533.ml create mode 100644 testsuite/tests/basic/pr7533.reference create mode 100644 testsuite/tests/basic/recvalues.ml create mode 100644 testsuite/tests/basic/recvalues.reference create mode 100644 testsuite/tests/basic/sets.ml create mode 100644 testsuite/tests/basic/sets.reference create mode 100644 testsuite/tests/basic/stringmatch.ml create mode 100644 testsuite/tests/basic/stringmatch.reference create mode 100644 testsuite/tests/basic/switch_opts.ml create mode 100644 testsuite/tests/basic/switch_opts.reference create mode 100644 testsuite/tests/basic/tailcalls.ml create mode 100644 testsuite/tests/basic/tailcalls.reference create mode 100644 testsuite/tests/basic/zero_divided_by_n.ml create mode 100644 testsuite/tests/basic/zero_divided_by_n.reference create mode 100644 testsuite/tests/callback/Makefile create mode 100644 testsuite/tests/callback/callbackprim.c create mode 100644 testsuite/tests/callback/reference create mode 100644 testsuite/tests/callback/tcallback.ml create mode 100644 testsuite/tests/docstrings/Makefile create mode 100644 testsuite/tests/docstrings/empty.ml create mode 100644 testsuite/tests/docstrings/empty.ml.reference create mode 100644 testsuite/tests/embedded/Makefile create mode 100644 testsuite/tests/embedded/cmcaml.ml create mode 100644 testsuite/tests/embedded/cmmain.c create mode 100644 testsuite/tests/embedded/cmstub.c create mode 100644 testsuite/tests/embedded/program.reference create mode 100644 testsuite/tests/exotic-syntax/Makefile create mode 100644 testsuite/tests/exotic-syntax/exotic.ml create mode 100644 testsuite/tests/exotic-syntax/exotic.reference create mode 100644 testsuite/tests/extension-constructor/Makefile create mode 100644 testsuite/tests/extension-constructor/test.ml create mode 100644 testsuite/tests/extension-constructor/test.reference create mode 100644 testsuite/tests/flambda/Makefile create mode 100644 testsuite/tests/flambda/gpr998.ml create mode 100644 testsuite/tests/flambda/gpr998.reference create mode 100644 testsuite/tests/float-unboxing/Makefile create mode 100644 testsuite/tests/float-unboxing/float_flambda.ml create mode 100644 testsuite/tests/float-unboxing/float_subst_boxed_number.ml create mode 100644 testsuite/tests/float-unboxing/float_subst_boxed_number.reference create mode 100644 testsuite/tests/formats-transition/Makefile create mode 100644 testsuite/tests/formats-transition/deprecated_unsigned_printers.ml create mode 100644 testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference create mode 100644 testsuite/tests/formats-transition/ignored_scan_counters.ml create mode 100644 testsuite/tests/formats-transition/ignored_scan_counters.ml.reference create mode 100644 testsuite/tests/formats-transition/legacy_incompatible_flags.ml create mode 100644 testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference create mode 100644 testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml create mode 100644 testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference create mode 100644 testsuite/tests/formatting/Makefile create mode 100644 testsuite/tests/formatting/margins.ml create mode 100644 testsuite/tests/formatting/margins.ml.reference create mode 100644 testsuite/tests/gc-roots/Makefile create mode 100644 testsuite/tests/gc-roots/globroots.ml create mode 100644 testsuite/tests/gc-roots/globroots.reference create mode 100644 testsuite/tests/gc-roots/globrootsprim.c create mode 100644 testsuite/tests/int64-unboxing/Makefile create mode 100644 testsuite/tests/int64-unboxing/stubs.c create mode 100644 testsuite/tests/int64-unboxing/test.ml create mode 100644 testsuite/tests/int64-unboxing/test.reference create mode 100644 testsuite/tests/lazy/Makefile create mode 100644 testsuite/tests/lazy/lazy1.ml create mode 100644 testsuite/tests/lazy/lazy1.reference create mode 100644 testsuite/tests/letrec/Makefile create mode 100644 testsuite/tests/letrec/backreferences.ml create mode 100644 testsuite/tests/letrec/backreferences.reference create mode 100644 testsuite/tests/letrec/class_1.ml create mode 100644 testsuite/tests/letrec/class_1.reference create mode 100644 testsuite/tests/letrec/class_2.ml create mode 100644 testsuite/tests/letrec/class_2.reference create mode 100644 testsuite/tests/letrec/evaluation_order_1.ml create mode 100644 testsuite/tests/letrec/evaluation_order_1.reference create mode 100644 testsuite/tests/letrec/evaluation_order_2.ml create mode 100644 testsuite/tests/letrec/evaluation_order_2.reference create mode 100644 testsuite/tests/letrec/evaluation_order_3.ml create mode 100644 testsuite/tests/letrec/evaluation_order_3.reference create mode 100644 testsuite/tests/letrec/float_block_1.ml create mode 100644 testsuite/tests/letrec/float_block_1.reference create mode 100644 testsuite/tests/letrec/float_block_2.ml create mode 100644 testsuite/tests/letrec/float_block_2.reference create mode 100644 testsuite/tests/letrec/lists.ml create mode 100644 testsuite/tests/letrec/lists.reference create mode 100644 testsuite/tests/letrec/mixing_value_closures_1.ml create mode 100644 testsuite/tests/letrec/mixing_value_closures_1.reference create mode 100644 testsuite/tests/letrec/mixing_value_closures_2.ml create mode 100644 testsuite/tests/letrec/mixing_value_closures_2.reference create mode 100644 testsuite/tests/letrec/mutual_functions.ml create mode 100644 testsuite/tests/letrec/mutual_functions.reference create mode 100644 testsuite/tests/letrec/record_with.ml create mode 100644 testsuite/tests/letrec/record_with.reference create mode 100644 testsuite/tests/lib-arg/Makefile create mode 100644 testsuite/tests/lib-arg/testarg.ml create mode 100644 testsuite/tests/lib-arg/testarg.reference create mode 100644 testsuite/tests/lib-arg/testerror.ml create mode 100644 testsuite/tests/lib-arg/testerror.reference create mode 100644 testsuite/tests/lib-bigarray-2/Makefile create mode 100644 testsuite/tests/lib-bigarray-2/bigarrf.f create mode 100644 testsuite/tests/lib-bigarray-2/bigarrfml.ml create mode 100644 testsuite/tests/lib-bigarray-2/bigarrfml.reference create mode 100644 testsuite/tests/lib-bigarray-2/bigarrfstub.c create mode 100644 testsuite/tests/lib-bigarray-file/Makefile create mode 100644 testsuite/tests/lib-bigarray-file/mapfile.ml create mode 100644 testsuite/tests/lib-bigarray-file/mapfile.reference create mode 100644 testsuite/tests/lib-bigarray/Makefile create mode 100644 testsuite/tests/lib-bigarray/bigarrays.ml create mode 100644 testsuite/tests/lib-bigarray/bigarrays.reference create mode 100644 testsuite/tests/lib-bigarray/fftba.ml create mode 100644 testsuite/tests/lib-bigarray/fftba.reference create mode 100644 testsuite/tests/lib-bigarray/pr5115.ml create mode 100644 testsuite/tests/lib-bigarray/pr5115.reference create mode 100644 testsuite/tests/lib-bigarray/weak_bigarray.ml create mode 100644 testsuite/tests/lib-bigarray/weak_bigarray.reference create mode 100644 testsuite/tests/lib-buffer/Makefile create mode 100644 testsuite/tests/lib-buffer/test.ml create mode 100644 testsuite/tests/lib-buffer/test.reference create mode 100644 testsuite/tests/lib-bytes/Makefile create mode 100644 testsuite/tests/lib-bytes/test_bytes.ml create mode 100644 testsuite/tests/lib-bytes/test_bytes.reference create mode 100644 testsuite/tests/lib-digest/Makefile create mode 100644 testsuite/tests/lib-digest/md5.ml create mode 100644 testsuite/tests/lib-digest/md5.reference create mode 100644 testsuite/tests/lib-dynlink-bytecode/Makefile create mode 100644 testsuite/tests/lib-dynlink-bytecode/custom.reference create mode 100644 testsuite/tests/lib-dynlink-bytecode/main.ml create mode 100644 testsuite/tests/lib-dynlink-bytecode/main.reference create mode 100644 testsuite/tests/lib-dynlink-bytecode/plug1.ml create mode 100644 testsuite/tests/lib-dynlink-bytecode/plug2.ml create mode 100644 testsuite/tests/lib-dynlink-bytecode/registry.ml create mode 100644 testsuite/tests/lib-dynlink-bytecode/static.reference create mode 100644 testsuite/tests/lib-dynlink-bytecode/stub1.c create mode 100644 testsuite/tests/lib-dynlink-bytecode/stub2.c create mode 100644 testsuite/tests/lib-dynlink-csharp/Makefile create mode 100644 testsuite/tests/lib-dynlink-csharp/bytecode.reference create mode 100755 testsuite/tests/lib-dynlink-csharp/entry.c create mode 100755 testsuite/tests/lib-dynlink-csharp/main.cs create mode 100755 testsuite/tests/lib-dynlink-csharp/main.ml create mode 100644 testsuite/tests/lib-dynlink-csharp/native.reference create mode 100755 testsuite/tests/lib-dynlink-csharp/plugin.ml create mode 100644 testsuite/tests/lib-dynlink-native/Makefile create mode 100755 testsuite/tests/lib-dynlink-native/a.ml create mode 100644 testsuite/tests/lib-dynlink-native/api.ml create mode 100755 testsuite/tests/lib-dynlink-native/b.ml create mode 100644 testsuite/tests/lib-dynlink-native/bug.ml create mode 100755 testsuite/tests/lib-dynlink-native/c.ml create mode 100644 testsuite/tests/lib-dynlink-native/factorial.c create mode 100644 testsuite/tests/lib-dynlink-native/main.ml create mode 100644 testsuite/tests/lib-dynlink-native/pack_client.ml create mode 100644 testsuite/tests/lib-dynlink-native/packed1.ml create mode 100644 testsuite/tests/lib-dynlink-native/packed1_client.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin.mli create mode 100644 testsuite/tests/lib-dynlink-native/plugin2.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin4.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin_ext.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin_high_arity.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin_ref.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin_simple.ml create mode 100644 testsuite/tests/lib-dynlink-native/plugin_thread.ml create mode 100644 testsuite/tests/lib-dynlink-native/reference create mode 100644 testsuite/tests/lib-dynlink-native/sub/api.ml create mode 100644 testsuite/tests/lib-dynlink-native/sub/api.mli create mode 100644 testsuite/tests/lib-dynlink-native/sub/plugin.ml create mode 100644 testsuite/tests/lib-dynlink-native/sub/plugin3.ml create mode 100644 testsuite/tests/lib-filename/Makefile create mode 100755 testsuite/tests/lib-filename/extension.ml create mode 100644 testsuite/tests/lib-filename/extension.reference create mode 100644 testsuite/tests/lib-format/Makefile create mode 100644 testsuite/tests/lib-format/pr6824.ml create mode 100644 testsuite/tests/lib-format/pr6824.reference create mode 100644 testsuite/tests/lib-format/tformat.ml create mode 100644 testsuite/tests/lib-format/tformat.reference create mode 100644 testsuite/tests/lib-hashtbl/Makefile create mode 100644 testsuite/tests/lib-hashtbl/hfun.ml create mode 100644 testsuite/tests/lib-hashtbl/hfun.reference create mode 100644 testsuite/tests/lib-hashtbl/htbl.ml create mode 100644 testsuite/tests/lib-hashtbl/htbl.reference create mode 100644 testsuite/tests/lib-marshal/Makefile create mode 100644 testsuite/tests/lib-marshal/intext.ml create mode 100644 testsuite/tests/lib-marshal/intext.reference create mode 100644 testsuite/tests/lib-marshal/intextaux.c create mode 100644 testsuite/tests/lib-num-2/Makefile create mode 100644 testsuite/tests/lib-num-2/pi_big_int.ml create mode 100644 testsuite/tests/lib-num-2/pi_big_int.reference create mode 100644 testsuite/tests/lib-num-2/pi_num.ml create mode 100644 testsuite/tests/lib-num-2/pi_num.reference create mode 100644 testsuite/tests/lib-num/Makefile create mode 100644 testsuite/tests/lib-num/end_test.ml create mode 100644 testsuite/tests/lib-num/end_test.reference create mode 100644 testsuite/tests/lib-num/test.ml create mode 100644 testsuite/tests/lib-num/test_big_ints.ml create mode 100644 testsuite/tests/lib-num/test_io.ml create mode 100644 testsuite/tests/lib-num/test_nats.ml create mode 100644 testsuite/tests/lib-num/test_nums.ml create mode 100644 testsuite/tests/lib-num/test_ratios.ml create mode 100755 testsuite/tests/lib-obj/Makefile create mode 100755 testsuite/tests/lib-obj/reachable_words.ml create mode 100644 testsuite/tests/lib-obj/reachable_words.reference create mode 100644 testsuite/tests/lib-printf/Makefile create mode 100644 testsuite/tests/lib-printf/pr6534.ml create mode 100644 testsuite/tests/lib-printf/pr6534.reference create mode 100644 testsuite/tests/lib-printf/pr6938.ml create mode 100644 testsuite/tests/lib-printf/pr6938.reference create mode 100644 testsuite/tests/lib-printf/tprintf.ml create mode 100644 testsuite/tests/lib-printf/tprintf.reference create mode 100644 testsuite/tests/lib-queue/Makefile create mode 100644 testsuite/tests/lib-queue/test.ml create mode 100644 testsuite/tests/lib-queue/test.reference create mode 100644 testsuite/tests/lib-random/Makefile create mode 100644 testsuite/tests/lib-random/rand.ml create mode 100644 testsuite/tests/lib-random/rand.reference create mode 100644 testsuite/tests/lib-scanf-2/Makefile create mode 100644 testsuite/tests/lib-scanf-2/reference create mode 100644 testsuite/tests/lib-scanf-2/tscanf2_io.ml create mode 100644 testsuite/tests/lib-scanf-2/tscanf2_master.ml create mode 100644 testsuite/tests/lib-scanf-2/tscanf2_slave.ml create mode 100644 testsuite/tests/lib-scanf/Makefile create mode 100644 testsuite/tests/lib-scanf/tscanf.ml create mode 100644 testsuite/tests/lib-scanf/tscanf.reference create mode 100644 testsuite/tests/lib-set/Makefile create mode 100644 testsuite/tests/lib-set/testmap.ml create mode 100644 testsuite/tests/lib-set/testmap.reference create mode 100644 testsuite/tests/lib-set/testset.ml create mode 100644 testsuite/tests/lib-set/testset.reference create mode 100644 testsuite/tests/lib-stack/Makefile create mode 100644 testsuite/tests/lib-stack/test.ml create mode 100644 testsuite/tests/lib-stack/test.reference create mode 100644 testsuite/tests/lib-stdlabels/Makefile create mode 100644 testsuite/tests/lib-stdlabels/test_stdlabels.ml create mode 100644 testsuite/tests/lib-stdlabels/test_stdlabels.reference create mode 100644 testsuite/tests/lib-str/Makefile create mode 100644 testsuite/tests/lib-str/t01.ml create mode 100644 testsuite/tests/lib-str/t01.reference create mode 100644 testsuite/tests/lib-stream/Makefile create mode 100644 testsuite/tests/lib-stream/count_concat_bug.ml create mode 100644 testsuite/tests/lib-stream/count_concat_bug.reference create mode 100644 testsuite/tests/lib-string/Makefile create mode 100644 testsuite/tests/lib-string/test_string.ml create mode 100644 testsuite/tests/lib-string/test_string.reference create mode 100644 testsuite/tests/lib-systhreads/Makefile create mode 100644 testsuite/tests/lib-systhreads/testfork.ml create mode 100644 testsuite/tests/lib-systhreads/testfork.precheck create mode 100644 testsuite/tests/lib-systhreads/testfork.reference create mode 100644 testsuite/tests/lib-threads/Makefile create mode 100644 testsuite/tests/lib-threads/backtrace_threads.ml create mode 100644 testsuite/tests/lib-threads/backtrace_threads.reference create mode 100644 testsuite/tests/lib-threads/bank.ml create mode 100644 testsuite/tests/lib-threads/bank.reference create mode 100644 testsuite/tests/lib-threads/beat.ml create mode 100644 testsuite/tests/lib-threads/beat.reference create mode 100644 testsuite/tests/lib-threads/bufchan.ml create mode 100644 testsuite/tests/lib-threads/bufchan.reference create mode 100644 testsuite/tests/lib-threads/close.ml create mode 100644 testsuite/tests/lib-threads/close.reference create mode 100644 testsuite/tests/lib-threads/fileio.ml create mode 100644 testsuite/tests/lib-threads/fileio.reference create mode 100644 testsuite/tests/lib-threads/pr4466.ml create mode 100644 testsuite/tests/lib-threads/pr4466.reference create mode 100644 testsuite/tests/lib-threads/pr5325.ml create mode 100644 testsuite/tests/lib-threads/pr5325.reference create mode 100644 testsuite/tests/lib-threads/prodcons.ml create mode 100644 testsuite/tests/lib-threads/prodcons.reference create mode 100644 testsuite/tests/lib-threads/prodcons2.ml create mode 100644 testsuite/tests/lib-threads/prodcons2.reference create mode 100644 testsuite/tests/lib-threads/sieve.ml create mode 100644 testsuite/tests/lib-threads/sieve.reference create mode 100644 testsuite/tests/lib-threads/sigint.c create mode 100644 testsuite/tests/lib-threads/signal.checker create mode 100644 testsuite/tests/lib-threads/signal.ml create mode 100644 testsuite/tests/lib-threads/signal.precheck create mode 100644 testsuite/tests/lib-threads/signal.runner create mode 100644 testsuite/tests/lib-threads/signal2.checker create mode 100644 testsuite/tests/lib-threads/signal2.ml create mode 100644 testsuite/tests/lib-threads/signal2.precheck create mode 100644 testsuite/tests/lib-threads/signal2.runner create mode 100644 testsuite/tests/lib-threads/sockets.ml create mode 100644 testsuite/tests/lib-threads/sockets.reference create mode 100644 testsuite/tests/lib-threads/socketsbuf.ml create mode 100644 testsuite/tests/lib-threads/socketsbuf.reference create mode 100644 testsuite/tests/lib-threads/swapchan.checker create mode 100644 testsuite/tests/lib-threads/swapchan.ml create mode 100644 testsuite/tests/lib-threads/swapchan.reference create mode 100644 testsuite/tests/lib-threads/tls.checker create mode 100644 testsuite/tests/lib-threads/tls.ml create mode 100644 testsuite/tests/lib-threads/tls.reference create mode 100644 testsuite/tests/lib-threads/token1.reference create mode 100644 testsuite/tests/lib-threads/token2.reference create mode 100644 testsuite/tests/lib-threads/torture.ml create mode 100644 testsuite/tests/lib-threads/torture.reference create mode 100644 testsuite/tests/lib-uchar/Makefile create mode 100644 testsuite/tests/lib-uchar/test.ml create mode 100644 testsuite/tests/lib-uchar/test.reference create mode 100644 testsuite/tests/lib-unix/Makefile create mode 100644 testsuite/tests/lib-unix/cloexec.ml create mode 100644 testsuite/tests/lib-unix/cloexec.reference create mode 100644 testsuite/tests/lib-unix/cmdline_prog.c create mode 100644 testsuite/tests/lib-unix/dup.ml create mode 100644 testsuite/tests/lib-unix/dup.reference create mode 100644 testsuite/tests/lib-unix/dup2.ml create mode 100644 testsuite/tests/lib-unix/dup2.reference create mode 100644 testsuite/tests/lib-unix/fdstatus.c create mode 100644 testsuite/tests/lib-unix/pipe_eof.ml create mode 100644 testsuite/tests/lib-unix/pipe_eof.reference create mode 100644 testsuite/tests/lib-unix/redirections.ml create mode 100644 testsuite/tests/lib-unix/redirections.reference create mode 100644 testsuite/tests/lib-unix/reflector.c create mode 100644 testsuite/tests/lib-unix/test_unix_cmdline.ml create mode 100644 testsuite/tests/lib-unix/test_unix_cmdline.reference create mode 100644 testsuite/tests/link-test/Makefile create mode 100644 testsuite/tests/link-test/aliases.ml create mode 100644 testsuite/tests/link-test/external.ml create mode 100644 testsuite/tests/link-test/external.mli create mode 100644 testsuite/tests/link-test/external_for_pack.ml create mode 100644 testsuite/tests/link-test/external_for_pack.mli create mode 100644 testsuite/tests/link-test/submodule.ml create mode 100644 testsuite/tests/link-test/test.ml create mode 100644 testsuite/tests/link-test/test.reference create mode 100644 testsuite/tests/link-test/use_in_pack.ml create mode 100644 testsuite/tests/manual-intf-c/Makefile create mode 100644 testsuite/tests/manual-intf-c/curses.ml create mode 100644 testsuite/tests/manual-intf-c/curses_stubs.c create mode 100644 testsuite/tests/manual-intf-c/prog.ml create mode 100644 testsuite/tests/manual-intf-c/prog2.reference create mode 100644 testsuite/tests/match-exception-warnings/Makefile create mode 100644 testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml create mode 100644 testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference create mode 100644 testsuite/tests/match-exception/Makefile create mode 100644 testsuite/tests/match-exception/allocation.ml create mode 100644 testsuite/tests/match-exception/allocation.reference create mode 100644 testsuite/tests/match-exception/exception_propagation.ml create mode 100644 testsuite/tests/match-exception/exception_propagation.reference create mode 100644 testsuite/tests/match-exception/match_failure.ml create mode 100644 testsuite/tests/match-exception/match_failure.reference create mode 100644 testsuite/tests/match-exception/nested_handlers.ml create mode 100644 testsuite/tests/match-exception/nested_handlers.reference create mode 100644 testsuite/tests/match-exception/raise_from_success_continuation.ml create mode 100644 testsuite/tests/match-exception/raise_from_success_continuation.reference create mode 100644 testsuite/tests/match-exception/streams.ml create mode 100644 testsuite/tests/match-exception/streams.reference create mode 100644 testsuite/tests/match-exception/tail_calls.ml create mode 100644 testsuite/tests/match-exception/tail_calls.reference create mode 100644 testsuite/tests/messages/Makefile create mode 100644 testsuite/tests/messages/precise_locations.ml create mode 100644 testsuite/tests/misc-kb/Makefile create mode 100644 testsuite/tests/misc-kb/equations.ml create mode 100644 testsuite/tests/misc-kb/equations.mli create mode 100644 testsuite/tests/misc-kb/kb.ml create mode 100644 testsuite/tests/misc-kb/kb.mli create mode 100644 testsuite/tests/misc-kb/kbmain.ml create mode 100644 testsuite/tests/misc-kb/kbmain.reference create mode 100644 testsuite/tests/misc-kb/orderings.ml create mode 100644 testsuite/tests/misc-kb/orderings.mli create mode 100644 testsuite/tests/misc-kb/terms.ml create mode 100644 testsuite/tests/misc-kb/terms.mli create mode 100644 testsuite/tests/misc-unsafe/Makefile create mode 100644 testsuite/tests/misc-unsafe/almabench.ml create mode 100644 testsuite/tests/misc-unsafe/almabench.reference create mode 100644 testsuite/tests/misc-unsafe/fft.ml create mode 100644 testsuite/tests/misc-unsafe/fft.reference create mode 100644 testsuite/tests/misc-unsafe/quicksort.ml create mode 100644 testsuite/tests/misc-unsafe/quicksort.reference create mode 100644 testsuite/tests/misc-unsafe/soli.ml create mode 100644 testsuite/tests/misc-unsafe/soli.reference create mode 100644 testsuite/tests/misc/Makefile create mode 100644 testsuite/tests/misc/bdd.ml create mode 100644 testsuite/tests/misc/bdd.reference create mode 100644 testsuite/tests/misc/boyer.ml create mode 100644 testsuite/tests/misc/boyer.reference create mode 100644 testsuite/tests/misc/ephetest.ml create mode 100644 testsuite/tests/misc/ephetest.reference create mode 100644 testsuite/tests/misc/ephetest2.ml create mode 100644 testsuite/tests/misc/ephetest2.reference create mode 100644 testsuite/tests/misc/ephetest3.ml create mode 100644 testsuite/tests/misc/ephetest3.reference create mode 100644 testsuite/tests/misc/fib.ml create mode 100644 testsuite/tests/misc/fib.reference create mode 100644 testsuite/tests/misc/finaliser.ml create mode 100644 testsuite/tests/misc/finaliser.reference create mode 100644 testsuite/tests/misc/gcwords.ml create mode 100644 testsuite/tests/misc/gcwords.reference create mode 100644 testsuite/tests/misc/hamming.ml create mode 100644 testsuite/tests/misc/hamming.reference create mode 100644 testsuite/tests/misc/nucleic.ml create mode 100644 testsuite/tests/misc/nucleic.reference create mode 100644 testsuite/tests/misc/pr7168.ml create mode 100644 testsuite/tests/misc/pr7168.reference create mode 100644 testsuite/tests/misc/sieve.ml create mode 100644 testsuite/tests/misc/sieve.reference create mode 100644 testsuite/tests/misc/sorts.ml create mode 100644 testsuite/tests/misc/sorts.reference create mode 100644 testsuite/tests/misc/takc.ml create mode 100644 testsuite/tests/misc/takc.reference create mode 100644 testsuite/tests/misc/taku.ml create mode 100644 testsuite/tests/misc/taku.reference create mode 100644 testsuite/tests/misc/weaklifetime.ml create mode 100644 testsuite/tests/misc/weaklifetime.reference create mode 100644 testsuite/tests/misc/weaklifetime2.ml create mode 100644 testsuite/tests/misc/weaklifetime2.reference create mode 100644 testsuite/tests/misc/weaktest.ml create mode 100644 testsuite/tests/misc/weaktest.reference create mode 100644 testsuite/tests/no-alias-deps/Makefile create mode 100644 testsuite/tests/no-alias-deps/aliases.cmo.reference create mode 100644 testsuite/tests/no-alias-deps/aliases.ml create mode 100644 testsuite/tests/no-alias-deps/aliases.ml.reference create mode 100644 testsuite/tests/no-alias-deps/b.cmi.pre create mode 100644 testsuite/tests/no-alias-deps/c.mli create mode 100644 testsuite/tests/no-alias-deps/d.mli create mode 100644 testsuite/tests/opaque/Makefile create mode 100644 testsuite/tests/opaque/fst/opaque_impl.ml create mode 100644 testsuite/tests/opaque/fst/opaque_intf.ml create mode 100644 testsuite/tests/opaque/fst/regular.ml create mode 100644 testsuite/tests/opaque/intf/opaque_impl.mli create mode 100644 testsuite/tests/opaque/intf/opaque_intf.mli create mode 100644 testsuite/tests/opaque/intf/regular.mli create mode 100644 testsuite/tests/opaque/snd/opaque_impl.ml create mode 100644 testsuite/tests/opaque/snd/opaque_intf.ml create mode 100644 testsuite/tests/opaque/snd/regular.ml create mode 100644 testsuite/tests/opaque/test.ml create mode 100644 testsuite/tests/parsetree/Makefile create mode 100644 testsuite/tests/parsetree/source.ml create mode 100644 testsuite/tests/parsetree/test.ml create mode 100644 testsuite/tests/parsetree/test.reference create mode 100644 testsuite/tests/parsing/Makefile create mode 100644 testsuite/tests/parsing/attributes.ml create mode 100644 testsuite/tests/parsing/attributes.ml.reference create mode 100644 testsuite/tests/parsing/docstrings.ml create mode 100644 testsuite/tests/parsing/docstrings.ml.reference create mode 100644 testsuite/tests/parsing/extensions.ml create mode 100644 testsuite/tests/parsing/extensions.ml.reference create mode 100644 testsuite/tests/parsing/int_and_float_with_modifier.ml create mode 100644 testsuite/tests/parsing/int_and_float_with_modifier.ml.reference create mode 100644 testsuite/tests/parsing/pr6865.ml create mode 100644 testsuite/tests/parsing/pr6865.ml.reference create mode 100644 testsuite/tests/parsing/pr7165.ml create mode 100644 testsuite/tests/parsing/pr7165.ml.reference create mode 100644 testsuite/tests/parsing/shortcut_ext_attr.ml create mode 100644 testsuite/tests/parsing/shortcut_ext_attr.ml.reference create mode 100644 testsuite/tests/ppx-attributes/Makefile create mode 100644 testsuite/tests/ppx-attributes/warning.ml create mode 100644 testsuite/tests/ppx-attributes/warning.reference create mode 100644 testsuite/tests/prim-bigstring/Makefile create mode 100644 testsuite/tests/prim-bigstring/bigstring_access.ml create mode 100644 testsuite/tests/prim-bigstring/bigstring_access.reference create mode 100644 testsuite/tests/prim-bigstring/string_access.ml create mode 100644 testsuite/tests/prim-bigstring/string_access.reference create mode 100644 testsuite/tests/prim-bswap/Makefile create mode 100644 testsuite/tests/prim-bswap/bswap.ml create mode 100644 testsuite/tests/prim-bswap/bswap.reference create mode 100644 testsuite/tests/prim-revapply/Makefile create mode 100644 testsuite/tests/prim-revapply/apply.ml create mode 100644 testsuite/tests/prim-revapply/apply.reference create mode 100644 testsuite/tests/prim-revapply/revapply.ml create mode 100644 testsuite/tests/prim-revapply/revapply.reference create mode 100644 testsuite/tests/regression/missing_set_of_closures/Makefile create mode 100644 testsuite/tests/regression/missing_set_of_closures/a.ml create mode 100644 testsuite/tests/regression/missing_set_of_closures/b.ml create mode 100644 testsuite/tests/regression/missing_set_of_closures/b2.ml create mode 100644 testsuite/tests/regression/missing_set_of_closures/dir/c.ml create mode 100644 testsuite/tests/regression/pr3612/Makefile create mode 100644 testsuite/tests/regression/pr3612/custom_finalize.c create mode 100644 testsuite/tests/regression/pr3612/pr3612.ml create mode 100644 testsuite/tests/regression/pr3612/pr3612.reference create mode 100644 testsuite/tests/regression/pr5080-notes/Makefile create mode 100644 testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml create mode 100644 testsuite/tests/regression/pr5233/Makefile create mode 100644 testsuite/tests/regression/pr5233/pr5233.ml create mode 100644 testsuite/tests/regression/pr5233/pr5233.reference create mode 100644 testsuite/tests/regression/pr5757/Makefile create mode 100644 testsuite/tests/regression/pr5757/pr5757.ml create mode 100644 testsuite/tests/regression/pr5757/pr5757.reference create mode 100644 testsuite/tests/regression/pr6024/Makefile create mode 100644 testsuite/tests/regression/pr6024/pr6024.ml create mode 100644 testsuite/tests/regression/pr6024/pr6024.reference create mode 100644 testsuite/tests/regression/pr7042/Makefile create mode 100644 testsuite/tests/regression/pr7042/pr7042.ml create mode 100644 testsuite/tests/regression/pr7042/pr7042.reference create mode 100644 testsuite/tests/regression/pr7426/Makefile create mode 100644 testsuite/tests/regression/pr7426/pr7426.ml create mode 100644 testsuite/tests/regression/pr7426/pr7426.reference create mode 100644 testsuite/tests/required-external/Makefile create mode 100644 testsuite/tests/required-external/file.ml create mode 100644 testsuite/tests/required-external/main.ml create mode 100644 testsuite/tests/required-external/main.reference create mode 100644 testsuite/tests/runtime-C-exceptions/Makefile create mode 100644 testsuite/tests/runtime-C-exceptions/stub_test.c create mode 100644 testsuite/tests/runtime-C-exceptions/test.ml create mode 100644 testsuite/tests/runtime-C-exceptions/test.reference create mode 100644 testsuite/tests/runtime-errors/Makefile create mode 100644 testsuite/tests/runtime-errors/stackoverflow.bytecode.checker create mode 100644 testsuite/tests/runtime-errors/stackoverflow.bytecode.reference create mode 100644 testsuite/tests/runtime-errors/stackoverflow.ml create mode 100644 testsuite/tests/runtime-errors/stackoverflow.native.checker create mode 100644 testsuite/tests/runtime-errors/stackoverflow.native.reference create mode 100644 testsuite/tests/runtime-errors/syserror.bytecode.checker create mode 100644 testsuite/tests/runtime-errors/syserror.bytecode.reference create mode 100644 testsuite/tests/runtime-errors/syserror.ml create mode 100644 testsuite/tests/runtime-errors/syserror.native.checker create mode 100644 testsuite/tests/runtime-errors/syserror.native.reference create mode 100644 testsuite/tests/self-contained-toplevel/Makefile create mode 100644 testsuite/tests/self-contained-toplevel/foo.ml create mode 100644 testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml create mode 100644 testsuite/tests/self-contained-toplevel/input.ml create mode 100644 testsuite/tests/self-contained-toplevel/main.ml create mode 100644 testsuite/tests/self-contained-toplevel/main.reference create mode 100644 testsuite/tests/tool-command-line/Makefile create mode 100644 testsuite/tests/tool-command-line/unknown-file create mode 100644 testsuite/tests/tool-command-line/unknown-file.byte.reference create mode 100644 testsuite/tests/tool-command-line/unknown-file.opt.reference create mode 100644 testsuite/tests/tool-debugger/basic/Makefile create mode 100644 testsuite/tests/tool-debugger/basic/debuggee.ml create mode 100644 testsuite/tests/tool-debugger/basic/debuggee.reference create mode 100755 testsuite/tests/tool-debugger/basic/input_script create mode 100644 testsuite/tests/tool-debugger/find-artifacts/Makefile create mode 100644 testsuite/tests/tool-debugger/find-artifacts/debuggee.reference create mode 100644 testsuite/tests/tool-debugger/find-artifacts/in/blah.ml create mode 100644 testsuite/tests/tool-debugger/find-artifacts/in/foo.ml create mode 100644 testsuite/tests/tool-debugger/find-artifacts/input_script create mode 100644 testsuite/tests/tool-debugger/no_debug_event/Makefile create mode 100644 testsuite/tests/tool-debugger/no_debug_event/a.ml create mode 100644 testsuite/tests/tool-debugger/no_debug_event/b.ml create mode 100644 testsuite/tests/tool-debugger/no_debug_event/input_script create mode 100644 testsuite/tests/tool-debugger/no_debug_event/noev.reference create mode 100644 testsuite/tests/tool-lexyacc/Makefile create mode 100644 testsuite/tests/tool-lexyacc/gram_aux.ml create mode 100644 testsuite/tests/tool-lexyacc/grammar.mly create mode 100644 testsuite/tests/tool-lexyacc/input create mode 100644 testsuite/tests/tool-lexyacc/lexgen.ml create mode 100644 testsuite/tests/tool-lexyacc/main.ml create mode 100644 testsuite/tests/tool-lexyacc/main.reference create mode 100644 testsuite/tests/tool-lexyacc/output.ml create mode 100644 testsuite/tests/tool-lexyacc/scan_aux.ml create mode 100644 testsuite/tests/tool-lexyacc/scanner.mll create mode 100644 testsuite/tests/tool-lexyacc/syntax.ml create mode 100644 testsuite/tests/tool-ocaml/Makefile create mode 100644 testsuite/tests/tool-ocaml/lib.ml create mode 100644 testsuite/tests/tool-ocaml/t000.ml create mode 100644 testsuite/tests/tool-ocaml/t010-const0.ml create mode 100644 testsuite/tests/tool-ocaml/t010-const1.ml create mode 100644 testsuite/tests/tool-ocaml/t010-const2.ml create mode 100644 testsuite/tests/tool-ocaml/t010-const3.ml create mode 100644 testsuite/tests/tool-ocaml/t011-constint.ml create mode 100644 testsuite/tests/tool-ocaml/t020.ml create mode 100644 testsuite/tests/tool-ocaml/t021-pushconst1.ml create mode 100644 testsuite/tests/tool-ocaml/t021-pushconst2.ml create mode 100644 testsuite/tests/tool-ocaml/t021-pushconst3.ml create mode 100644 testsuite/tests/tool-ocaml/t022-pushconstint.ml create mode 100644 testsuite/tests/tool-ocaml/t040-makeblock1.ml create mode 100644 testsuite/tests/tool-ocaml/t040-makeblock2.ml create mode 100644 testsuite/tests/tool-ocaml/t040-makeblock3.ml create mode 100644 testsuite/tests/tool-ocaml/t041-makeblock.ml create mode 100644 testsuite/tests/tool-ocaml/t050-getglobal.ml create mode 100644 testsuite/tests/tool-ocaml/t050-pushgetglobal.ml create mode 100644 testsuite/tests/tool-ocaml/t051-getglobalfield.ml create mode 100644 testsuite/tests/tool-ocaml/t051-pushgetglobalfield.ml create mode 100644 testsuite/tests/tool-ocaml/t060-raise.ml create mode 100644 testsuite/tests/tool-ocaml/t070-branch.ml create mode 100644 testsuite/tests/tool-ocaml/t070-branchif.ml create mode 100644 testsuite/tests/tool-ocaml/t070-branchifnot.ml create mode 100644 testsuite/tests/tool-ocaml/t071-boolnot.ml create mode 100644 testsuite/tests/tool-ocaml/t080-eq.ml create mode 100644 testsuite/tests/tool-ocaml/t080-geint.ml create mode 100644 testsuite/tests/tool-ocaml/t080-gtint.ml create mode 100644 testsuite/tests/tool-ocaml/t080-leint.ml create mode 100644 testsuite/tests/tool-ocaml/t080-ltint.ml create mode 100644 testsuite/tests/tool-ocaml/t080-neq.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc0.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc1.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc2.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc3.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc4.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc5.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc6.ml create mode 100644 testsuite/tests/tool-ocaml/t090-acc7.ml create mode 100644 testsuite/tests/tool-ocaml/t091-acc.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc0.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc1.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc2.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc3.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc4.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc5.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc6.ml create mode 100644 testsuite/tests/tool-ocaml/t092-pushacc7.ml create mode 100644 testsuite/tests/tool-ocaml/t093-pushacc.ml create mode 100644 testsuite/tests/tool-ocaml/t100-pushtrap.ml create mode 100644 testsuite/tests/tool-ocaml/t101-poptrap.ml create mode 100644 testsuite/tests/tool-ocaml/t110-addint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-andint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-asrint-1.ml create mode 100644 testsuite/tests/tool-ocaml/t110-asrint-2.ml create mode 100644 testsuite/tests/tool-ocaml/t110-divint-1.ml create mode 100644 testsuite/tests/tool-ocaml/t110-divint-2.ml create mode 100644 testsuite/tests/tool-ocaml/t110-divint-3.ml create mode 100644 testsuite/tests/tool-ocaml/t110-lslint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-lsrint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-modint-1.ml create mode 100644 testsuite/tests/tool-ocaml/t110-modint-2.ml create mode 100644 testsuite/tests/tool-ocaml/t110-mulint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-negint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-offsetint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-orint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-subint.ml create mode 100644 testsuite/tests/tool-ocaml/t110-xorint.ml create mode 100644 testsuite/tests/tool-ocaml/t120-getstringchar.ml create mode 100644 testsuite/tests/tool-ocaml/t121-setstringchar.ml create mode 100644 testsuite/tests/tool-ocaml/t130-getvectitem.ml create mode 100644 testsuite/tests/tool-ocaml/t130-vectlength.ml create mode 100644 testsuite/tests/tool-ocaml/t131-setvectitem.ml create mode 100644 testsuite/tests/tool-ocaml/t140-switch-1.ml create mode 100644 testsuite/tests/tool-ocaml/t140-switch-2.ml create mode 100644 testsuite/tests/tool-ocaml/t140-switch-3.ml create mode 100644 testsuite/tests/tool-ocaml/t140-switch-4.ml create mode 100644 testsuite/tests/tool-ocaml/t141-switch-5.ml create mode 100644 testsuite/tests/tool-ocaml/t141-switch-6.ml create mode 100644 testsuite/tests/tool-ocaml/t141-switch-7.ml create mode 100644 testsuite/tests/tool-ocaml/t142-switch-8.ml create mode 100644 testsuite/tests/tool-ocaml/t142-switch-9.ml create mode 100644 testsuite/tests/tool-ocaml/t142-switch-A.ml create mode 100644 testsuite/tests/tool-ocaml/t150-push-1.ml create mode 100644 testsuite/tests/tool-ocaml/t150-push-2.ml create mode 100644 testsuite/tests/tool-ocaml/t160-closure.ml create mode 100644 testsuite/tests/tool-ocaml/t161-apply1.ml create mode 100644 testsuite/tests/tool-ocaml/t162-return.ml create mode 100644 testsuite/tests/tool-ocaml/t163.ml create mode 100644 testsuite/tests/tool-ocaml/t164-apply2.ml create mode 100644 testsuite/tests/tool-ocaml/t164-apply3.ml create mode 100644 testsuite/tests/tool-ocaml/t165-apply.ml create mode 100644 testsuite/tests/tool-ocaml/t170-envacc2.ml create mode 100644 testsuite/tests/tool-ocaml/t170-envacc3.ml create mode 100644 testsuite/tests/tool-ocaml/t170-envacc4.ml create mode 100644 testsuite/tests/tool-ocaml/t171-envacc.ml create mode 100644 testsuite/tests/tool-ocaml/t172-pushenvacc1.ml create mode 100644 testsuite/tests/tool-ocaml/t172-pushenvacc2.ml create mode 100644 testsuite/tests/tool-ocaml/t172-pushenvacc3.ml create mode 100644 testsuite/tests/tool-ocaml/t172-pushenvacc4.ml create mode 100644 testsuite/tests/tool-ocaml/t173-pushenvacc.ml create mode 100644 testsuite/tests/tool-ocaml/t180-appterm1.ml create mode 100644 testsuite/tests/tool-ocaml/t180-appterm2.ml create mode 100644 testsuite/tests/tool-ocaml/t180-appterm3.ml create mode 100644 testsuite/tests/tool-ocaml/t181-appterm.ml create mode 100644 testsuite/tests/tool-ocaml/t190-makefloatblock-1.ml create mode 100644 testsuite/tests/tool-ocaml/t190-makefloatblock-2.ml create mode 100644 testsuite/tests/tool-ocaml/t190-makefloatblock-3.ml create mode 100644 testsuite/tests/tool-ocaml/t191-vectlength.ml create mode 100644 testsuite/tests/tool-ocaml/t192-getfloatfield-1.ml create mode 100644 testsuite/tests/tool-ocaml/t192-getfloatfield-2.ml create mode 100644 testsuite/tests/tool-ocaml/t193-setfloatfield-1.ml create mode 100644 testsuite/tests/tool-ocaml/t193-setfloatfield-2.ml create mode 100644 testsuite/tests/tool-ocaml/t200-getfield0.ml create mode 100644 testsuite/tests/tool-ocaml/t200-getfield1.ml create mode 100644 testsuite/tests/tool-ocaml/t200-getfield2.ml create mode 100644 testsuite/tests/tool-ocaml/t200-getfield3.ml create mode 100644 testsuite/tests/tool-ocaml/t201-getfield.ml create mode 100644 testsuite/tests/tool-ocaml/t210-setfield0.ml create mode 100644 testsuite/tests/tool-ocaml/t210-setfield1.ml create mode 100644 testsuite/tests/tool-ocaml/t210-setfield2.ml create mode 100644 testsuite/tests/tool-ocaml/t210-setfield3.ml create mode 100644 testsuite/tests/tool-ocaml/t211-setfield.ml create mode 100644 testsuite/tests/tool-ocaml/t220-assign.ml create mode 100644 testsuite/tests/tool-ocaml/t230-check_signals.ml create mode 100644 testsuite/tests/tool-ocaml/t240-c_call1.ml create mode 100644 testsuite/tests/tool-ocaml/t240-c_call2.ml create mode 100644 testsuite/tests/tool-ocaml/t240-c_call3.ml create mode 100644 testsuite/tests/tool-ocaml/t240-c_call4.ml create mode 100644 testsuite/tests/tool-ocaml/t240-c_call5.ml create mode 100644 testsuite/tests/tool-ocaml/t250-closurerec-1.ml create mode 100644 testsuite/tests/tool-ocaml/t250-closurerec-2.ml create mode 100644 testsuite/tests/tool-ocaml/t251-pushoffsetclosure0.ml create mode 100644 testsuite/tests/tool-ocaml/t251-pushoffsetclosure2.ml create mode 100644 testsuite/tests/tool-ocaml/t251-pushoffsetclosurem2.ml create mode 100644 testsuite/tests/tool-ocaml/t252-pushoffsetclosure.ml create mode 100644 testsuite/tests/tool-ocaml/t253-offsetclosure0.ml create mode 100644 testsuite/tests/tool-ocaml/t253-offsetclosure2.ml create mode 100644 testsuite/tests/tool-ocaml/t253-offsetclosurem2.ml create mode 100644 testsuite/tests/tool-ocaml/t254-offsetclosure.ml create mode 100644 testsuite/tests/tool-ocaml/t260-offsetref.ml create mode 100644 testsuite/tests/tool-ocaml/t270-push_retaddr.ml create mode 100644 testsuite/tests/tool-ocaml/t300-getmethod.ml create mode 100644 testsuite/tests/tool-ocaml/t301-object.ml create mode 100644 testsuite/tests/tool-ocaml/t310-alloc-1.ml create mode 100644 testsuite/tests/tool-ocaml/t310-alloc-2.ml create mode 100644 testsuite/tests/tool-ocaml/t320-gc-1.ml create mode 100644 testsuite/tests/tool-ocaml/t320-gc-2.ml create mode 100644 testsuite/tests/tool-ocaml/t320-gc-3.ml create mode 100644 testsuite/tests/tool-ocaml/t330-compact-1.ml create mode 100644 testsuite/tests/tool-ocaml/t330-compact-2.ml create mode 100644 testsuite/tests/tool-ocaml/t330-compact-3.ml create mode 100644 testsuite/tests/tool-ocaml/t330-compact-4.ml create mode 100644 testsuite/tests/tool-ocaml/t340-weak.ml create mode 100644 testsuite/tests/tool-ocaml/t350-heapcheck.ml create mode 100644 testsuite/tests/tool-ocaml/t360-stacks-1.ml create mode 100644 testsuite/tests/tool-ocaml/t360-stacks-2.ml create mode 100644 testsuite/tests/tool-ocamlc-open/Makefile create mode 100644 testsuite/tests/tool-ocamlc-open/a.ml create mode 100644 testsuite/tests/tool-ocamlc-open/b.ml create mode 100644 testsuite/tests/tool-ocamldep-modalias/A.ml create mode 100644 testsuite/tests/tool-ocamldep-modalias/B.ml create mode 100644 testsuite/tests/tool-ocamldep-modalias/C.ml create mode 100644 testsuite/tests/tool-ocamldep-modalias/D.ml create mode 100644 testsuite/tests/tool-ocamldep-modalias/Makefile create mode 100644 testsuite/tests/tool-ocamldep-modalias/Makefile.build create mode 100644 testsuite/tests/tool-ocamldep-modalias/Makefile.build2 create mode 100644 testsuite/tests/tool-ocamldep-modalias/depend.mk.reference create mode 100644 testsuite/tests/tool-ocamldep-modalias/depend.mk2.reference create mode 100644 testsuite/tests/tool-ocamldep-modalias/depend.mod.reference create mode 100644 testsuite/tests/tool-ocamldep-modalias/depend.mod2.reference create mode 100644 testsuite/tests/tool-ocamldep-modalias/depend.mod3.reference create mode 100644 testsuite/tests/tool-ocamldep-modalias/lib.mli create mode 100644 testsuite/tests/tool-ocamldep-modalias/lib_impl.ml create mode 100644 testsuite/tests/tool-ocamldep-modalias/main.ml create mode 100644 testsuite/tests/tool-ocamldoc-2/Makefile create mode 100644 testsuite/tests/tool-ocamldoc-2/extensible_variant.ml create mode 100644 testsuite/tests/tool-ocamldoc-2/extensible_variant.reference create mode 100644 testsuite/tests/tool-ocamldoc-2/inline_records.mli create mode 100644 testsuite/tests/tool-ocamldoc-2/inline_records.reference create mode 100644 testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml create mode 100644 testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference create mode 100644 testsuite/tests/tool-ocamldoc-2/loop.ml create mode 100644 testsuite/tests/tool-ocamldoc-2/loop.reference create mode 100644 testsuite/tests/tool-ocamldoc-2/short_description.reference create mode 100644 testsuite/tests/tool-ocamldoc-2/short_description.txt create mode 100644 testsuite/tests/tool-ocamldoc-2/test.mli create mode 100644 testsuite/tests/tool-ocamldoc-2/test.reference create mode 100644 testsuite/tests/tool-ocamldoc-2/variants.mli create mode 100644 testsuite/tests/tool-ocamldoc-2/variants.reference create mode 100644 testsuite/tests/tool-ocamldoc-html/Inline_records.mli create mode 100644 testsuite/tests/tool-ocamldoc-html/Inline_records.reference create mode 100644 testsuite/tests/tool-ocamldoc-html/Linebreaks.mli create mode 100644 testsuite/tests/tool-ocamldoc-html/Linebreaks.reference create mode 100644 testsuite/tests/tool-ocamldoc-html/Loop.ml create mode 100644 testsuite/tests/tool-ocamldoc-html/Loop.reference create mode 100644 testsuite/tests/tool-ocamldoc-html/Makefile create mode 100644 testsuite/tests/tool-ocamldoc-html/Module_whitespace.ml create mode 100644 testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference create mode 100644 testsuite/tests/tool-ocamldoc-html/Variants.mli create mode 100644 testsuite/tests/tool-ocamldoc-html/Variants.reference create mode 100644 testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference create mode 100644 testsuite/tests/tool-ocamldoc-man/Inline_records.mli create mode 100644 testsuite/tests/tool-ocamldoc-man/Inline_records.reference create mode 100644 testsuite/tests/tool-ocamldoc-man/Makefile create mode 100644 testsuite/tests/tool-ocamldoc-open/Makefile create mode 100644 testsuite/tests/tool-ocamldoc-open/Readme create mode 100644 testsuite/tests/tool-ocamldoc-open/alias.ml create mode 100644 testsuite/tests/tool-ocamldoc-open/doc.reference create mode 100644 testsuite/tests/tool-ocamldoc-open/inner.ml create mode 100644 testsuite/tests/tool-ocamldoc-open/main.ml create mode 100644 testsuite/tests/tool-ocamldoc/Makefile create mode 100644 testsuite/tests/tool-ocamldoc/odoc_test.ml create mode 100644 testsuite/tests/tool-ocamldoc/t01.ml create mode 100644 testsuite/tests/tool-ocamldoc/t01.reference create mode 100644 testsuite/tests/tool-ocamldoc/t02.ml create mode 100644 testsuite/tests/tool-ocamldoc/t02.reference create mode 100644 testsuite/tests/tool-ocamldoc/t03.ml create mode 100644 testsuite/tests/tool-ocamldoc/t03.reference create mode 100644 testsuite/tests/tool-ocamldoc/t04.ml create mode 100644 testsuite/tests/tool-ocamldoc/t04.reference create mode 100644 testsuite/tests/tool-ocamldoc/t05.ml create mode 100644 testsuite/tests/tool-ocamldoc/t05.reference create mode 100644 testsuite/tests/tool-toplevel-invocation/Makefile create mode 100644 testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt create mode 100644 testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt.reference create mode 100644 testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt create mode 100644 testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt.reference create mode 100644 testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt create mode 100644 testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt.reference create mode 100644 testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt create mode 100644 testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt.reference create mode 100644 testsuite/tests/tool-toplevel-invocation/test.ml create mode 100644 testsuite/tests/tool-toplevel-invocation/working_arg.txt create mode 100644 testsuite/tests/tool-toplevel-invocation/working_arg.txt.reference create mode 100644 testsuite/tests/tool-toplevel/Makefile create mode 100644 testsuite/tests/tool-toplevel/pr7060.ml create mode 100644 testsuite/tests/tool-toplevel/pr7060.ml.reference create mode 100644 testsuite/tests/tool-toplevel/tracing.ml create mode 100644 testsuite/tests/tool-toplevel/tracing.ml.reference create mode 100644 testsuite/tests/translprim/Makefile create mode 100644 testsuite/tests/translprim/array_spec.ml create mode 100644 testsuite/tests/translprim/array_spec.ml.reference create mode 100644 testsuite/tests/translprim/comparison_table.ml create mode 100644 testsuite/tests/translprim/comparison_table.ml.reference create mode 100644 testsuite/tests/translprim/module_coercion.ml create mode 100644 testsuite/tests/translprim/module_coercion.ml.reference create mode 100644 testsuite/tests/translprim/ref_spec.ml create mode 100644 testsuite/tests/translprim/ref_spec.ml.reference create mode 100644 testsuite/tests/typing-extension-constructor/Makefile create mode 100644 testsuite/tests/typing-extension-constructor/test.ml create mode 100644 testsuite/tests/typing-extension-constructor/test.ml.reference create mode 100644 testsuite/tests/typing-extensions/Makefile create mode 100644 testsuite/tests/typing-extensions/cast.ml create mode 100644 testsuite/tests/typing-extensions/cast.ml.reference create mode 100644 testsuite/tests/typing-extensions/extensions.ml create mode 100644 testsuite/tests/typing-extensions/extensions.ml.reference create mode 100644 testsuite/tests/typing-extensions/msg.ml create mode 100644 testsuite/tests/typing-extensions/msg.ml.reference create mode 100644 testsuite/tests/typing-extensions/open_types.ml create mode 100644 testsuite/tests/typing-extensions/open_types.ml.reference create mode 100644 testsuite/tests/typing-fstclassmod/Makefile create mode 100644 testsuite/tests/typing-fstclassmod/fstclassmod.ml create mode 100644 testsuite/tests/typing-fstclassmod/fstclassmod.reference create mode 100644 testsuite/tests/typing-gadts/Makefile create mode 100644 testsuite/tests/typing-gadts/didier.ml create mode 100644 testsuite/tests/typing-gadts/dynamic_frisch.ml create mode 100644 testsuite/tests/typing-gadts/nested_equations.ml create mode 100644 testsuite/tests/typing-gadts/omega07.ml create mode 100644 testsuite/tests/typing-gadts/pr5332.ml create mode 100644 testsuite/tests/typing-gadts/pr5689.ml create mode 100644 testsuite/tests/typing-gadts/pr5785.ml create mode 100644 testsuite/tests/typing-gadts/pr5848.ml create mode 100644 testsuite/tests/typing-gadts/pr5906.ml create mode 100644 testsuite/tests/typing-gadts/pr5948.ml create mode 100644 testsuite/tests/typing-gadts/pr5981.ml create mode 100644 testsuite/tests/typing-gadts/pr5985.ml create mode 100644 testsuite/tests/typing-gadts/pr5989.ml create mode 100644 testsuite/tests/typing-gadts/pr5997.ml create mode 100644 testsuite/tests/typing-gadts/pr6158.ml create mode 100644 testsuite/tests/typing-gadts/pr6163.ml create mode 100644 testsuite/tests/typing-gadts/pr6174.ml create mode 100644 testsuite/tests/typing-gadts/pr6241.ml create mode 100644 testsuite/tests/typing-gadts/pr6690.ml create mode 100644 testsuite/tests/typing-gadts/pr6817.ml create mode 100644 testsuite/tests/typing-gadts/pr6980.ml create mode 100644 testsuite/tests/typing-gadts/pr6993_bad.ml create mode 100644 testsuite/tests/typing-gadts/pr7016.ml create mode 100644 testsuite/tests/typing-gadts/pr7160.ml create mode 100644 testsuite/tests/typing-gadts/pr7214.ml create mode 100644 testsuite/tests/typing-gadts/pr7222.ml create mode 100644 testsuite/tests/typing-gadts/pr7230.ml create mode 100644 testsuite/tests/typing-gadts/pr7234.ml create mode 100644 testsuite/tests/typing-gadts/pr7260.ml create mode 100644 testsuite/tests/typing-gadts/pr7269.ml create mode 100644 testsuite/tests/typing-gadts/pr7298.ml create mode 100644 testsuite/tests/typing-gadts/pr7374.ml create mode 100644 testsuite/tests/typing-gadts/pr7378.ml create mode 100644 testsuite/tests/typing-gadts/pr7381.ml create mode 100644 testsuite/tests/typing-gadts/pr7390.ml create mode 100644 testsuite/tests/typing-gadts/pr7391.ml create mode 100644 testsuite/tests/typing-gadts/pr7397.ml create mode 100644 testsuite/tests/typing-gadts/pr7421.ml create mode 100644 testsuite/tests/typing-gadts/pr7432.ml create mode 100644 testsuite/tests/typing-gadts/term-conv.ml create mode 100644 testsuite/tests/typing-gadts/test.ml create mode 100644 testsuite/tests/typing-gadts/unify_mb.ml create mode 100644 testsuite/tests/typing-gadts/yallop_bugs.ml create mode 100644 testsuite/tests/typing-immediate/Makefile create mode 100644 testsuite/tests/typing-immediate/immediate.ml create mode 100644 testsuite/tests/typing-implicit_unpack/Makefile create mode 100644 testsuite/tests/typing-implicit_unpack/implicit_unpack.ml create mode 100644 testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference create mode 100644 testsuite/tests/typing-labels/Makefile create mode 100644 testsuite/tests/typing-labels/mixin.ml create mode 100644 testsuite/tests/typing-labels/mixin.reference create mode 100644 testsuite/tests/typing-labels/mixin2.ml create mode 100644 testsuite/tests/typing-labels/mixin2.reference create mode 100644 testsuite/tests/typing-labels/mixin3.ml create mode 100644 testsuite/tests/typing-labels/mixin3.reference create mode 100644 testsuite/tests/typing-misc-bugs/Makefile create mode 100644 testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml create mode 100644 testsuite/tests/typing-misc-bugs/pr6303_bad.ml create mode 100644 testsuite/tests/typing-misc-bugs/pr6946_bad.ml create mode 100644 testsuite/tests/typing-misc/Makefile create mode 100644 testsuite/tests/typing-misc/constraints.ml create mode 100644 testsuite/tests/typing-misc/labels.ml create mode 100644 testsuite/tests/typing-misc/occur_check.ml create mode 100644 testsuite/tests/typing-misc/polyvars.ml create mode 100755 testsuite/tests/typing-misc/pr6939.ml create mode 100644 testsuite/tests/typing-misc/pr7103.ml create mode 100755 testsuite/tests/typing-misc/pr7228.ml create mode 100644 testsuite/tests/typing-misc/printing.ml create mode 100644 testsuite/tests/typing-misc/records.ml create mode 100644 testsuite/tests/typing-misc/variant.ml create mode 100644 testsuite/tests/typing-misc/wellfounded.ml create mode 100644 testsuite/tests/typing-missing-cmi/Makefile create mode 100644 testsuite/tests/typing-missing-cmi/a.ml create mode 100644 testsuite/tests/typing-missing-cmi/b.ml create mode 100644 testsuite/tests/typing-missing-cmi/c.ml create mode 100644 testsuite/tests/typing-missing-cmi/main.ml create mode 100644 testsuite/tests/typing-missing-cmi/main.ml.reference create mode 100644 testsuite/tests/typing-missing-cmi/main_ok.ml create mode 100644 testsuite/tests/typing-missing-cmi/subdir/m.ml create mode 100644 testsuite/tests/typing-modules-bugs/Makefile create mode 100644 testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr5164_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr51_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr5663_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr5914_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6240_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6293_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6427_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6513_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6572_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6651_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6752_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6752_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6899_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6944_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6954_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6981_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6982_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6985_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr6992_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7036_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7082_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7112_bad.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7112_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7152_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7182_ok.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7305_principal.ml create mode 100644 testsuite/tests/typing-modules-bugs/pr7414_bad.ml create mode 100644 testsuite/tests/typing-modules/Makefile create mode 100644 testsuite/tests/typing-modules/Test.ml create mode 100644 testsuite/tests/typing-modules/aliases.ml create mode 100644 testsuite/tests/typing-modules/firstclass.ml create mode 100644 testsuite/tests/typing-modules/generative.ml create mode 100644 testsuite/tests/typing-modules/pr5911.ml create mode 100644 testsuite/tests/typing-modules/pr7207.ml create mode 100644 testsuite/tests/typing-modules/pr7348.ml create mode 100644 testsuite/tests/typing-modules/printing.ml create mode 100644 testsuite/tests/typing-modules/recursive.ml create mode 100644 testsuite/tests/typing-multifile/Makefile create mode 100644 testsuite/tests/typing-objects-bugs/Makefile create mode 100644 testsuite/tests/typing-objects-bugs/pr3968_bad.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr4018_bad.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr4435_bad.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr4766_ok.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr4824_ok.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr4824a_bad.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr5156_ok.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr7284_bad.ml create mode 100644 testsuite/tests/typing-objects-bugs/pr7293_ok.ml create mode 100644 testsuite/tests/typing-objects-bugs/woodyatt_ok.ml create mode 100644 testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml create mode 100644 testsuite/tests/typing-objects/Exemples.ml create mode 100644 testsuite/tests/typing-objects/Exemples.ml.principal.reference create mode 100644 testsuite/tests/typing-objects/Exemples.ml.reference create mode 100644 testsuite/tests/typing-objects/Makefile create mode 100644 testsuite/tests/typing-objects/Tests.ml create mode 100644 testsuite/tests/typing-objects/Tests.ml.principal.reference create mode 100644 testsuite/tests/typing-objects/Tests.ml.reference create mode 100644 testsuite/tests/typing-objects/pr5545.ml create mode 100644 testsuite/tests/typing-objects/pr5545.ml.principal.reference create mode 100644 testsuite/tests/typing-objects/pr5545.ml.reference create mode 100644 testsuite/tests/typing-objects/pr5619_bad.ml create mode 100644 testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference create mode 100644 testsuite/tests/typing-objects/pr5619_bad.ml.reference create mode 100644 testsuite/tests/typing-objects/pr5858.ml create mode 100644 testsuite/tests/typing-objects/pr5858.ml.reference create mode 100644 testsuite/tests/typing-objects/pr6123_bad.ml create mode 100644 testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference create mode 100644 testsuite/tests/typing-objects/pr6123_bad.ml.reference create mode 100644 testsuite/tests/typing-objects/pr6383.ml create mode 100644 testsuite/tests/typing-objects/pr6383.ml.reference create mode 100644 testsuite/tests/typing-objects/pr6907_bad.ml create mode 100644 testsuite/tests/typing-objects/pr6907_bad.ml.reference create mode 100644 testsuite/tests/typing-pattern_open/Makefile create mode 100644 testsuite/tests/typing-pattern_open/pattern_open.ml create mode 100644 testsuite/tests/typing-pattern_open/pattern_open.ml.reference create mode 100644 testsuite/tests/typing-poly-bugs/Makefile create mode 100644 testsuite/tests/typing-poly-bugs/pr5322_ok.ml create mode 100644 testsuite/tests/typing-poly-bugs/pr5673_bad.ml create mode 100644 testsuite/tests/typing-poly-bugs/pr5673_ok.ml create mode 100644 testsuite/tests/typing-poly/Makefile create mode 100644 testsuite/tests/typing-poly/poly.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs-2/Makefile create mode 100644 testsuite/tests/typing-polyvariants-bugs-2/pr3918a.mli create mode 100644 testsuite/tests/typing-polyvariants-bugs-2/pr3918b.mli create mode 100644 testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs/Makefile create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml create mode 100644 testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml create mode 100644 testsuite/tests/typing-private-bugs/Makefile create mode 100644 testsuite/tests/typing-private-bugs/pr5026_bad.ml create mode 100644 testsuite/tests/typing-private-bugs/pr5469_ok.ml create mode 100644 testsuite/tests/typing-private/Makefile create mode 100644 testsuite/tests/typing-private/private.ml create mode 100644 testsuite/tests/typing-private/private.ml.principal.reference create mode 100644 testsuite/tests/typing-private/private.ml.reference create mode 100644 testsuite/tests/typing-recmod/Makefile create mode 100644 testsuite/tests/typing-recmod/t01bad.ml create mode 100644 testsuite/tests/typing-recmod/t02bad.ml create mode 100644 testsuite/tests/typing-recmod/t03ok.ml create mode 100644 testsuite/tests/typing-recmod/t04bad.ml create mode 100644 testsuite/tests/typing-recmod/t05bad.ml create mode 100644 testsuite/tests/typing-recmod/t06ok.ml create mode 100644 testsuite/tests/typing-recmod/t07bad.ml create mode 100644 testsuite/tests/typing-recmod/t08bad.ml create mode 100644 testsuite/tests/typing-recmod/t09bad.ml create mode 100644 testsuite/tests/typing-recmod/t10ok.ml create mode 100644 testsuite/tests/typing-recmod/t11bad.ml create mode 100644 testsuite/tests/typing-recmod/t12bad.ml create mode 100644 testsuite/tests/typing-recmod/t13ok.ml create mode 100644 testsuite/tests/typing-recmod/t14bad.ml create mode 100644 testsuite/tests/typing-recmod/t15bad.ml create mode 100644 testsuite/tests/typing-recmod/t16ok.ml create mode 100644 testsuite/tests/typing-recmod/t17ok.ml create mode 100644 testsuite/tests/typing-recmod/t18ok.ml create mode 100644 testsuite/tests/typing-recmod/t19ok.ml create mode 100644 testsuite/tests/typing-recmod/t20ok.ml create mode 100644 testsuite/tests/typing-recmod/t21ok.ml create mode 100644 testsuite/tests/typing-recmod/t22ok.ml create mode 100644 testsuite/tests/typing-recmod/t22ok.mli create mode 100644 testsuite/tests/typing-recordarg/Makefile create mode 100644 testsuite/tests/typing-recordarg/recordarg.ml create mode 100644 testsuite/tests/typing-recordarg/recordarg.ml.reference create mode 100644 testsuite/tests/typing-rectypes-bugs/Makefile create mode 100644 testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml create mode 100644 testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml create mode 100644 testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml create mode 100644 testsuite/tests/typing-safe-linking/Makefile create mode 100644 testsuite/tests/typing-safe-linking/a.ml create mode 100644 testsuite/tests/typing-safe-linking/b_bad.ml create mode 100644 testsuite/tests/typing-short-paths/Makefile create mode 100644 testsuite/tests/typing-short-paths/pr5918.ml create mode 100644 testsuite/tests/typing-short-paths/pr5918.ml.reference create mode 100644 testsuite/tests/typing-short-paths/pr6836.ml create mode 100644 testsuite/tests/typing-short-paths/pr6836.ml.reference create mode 100644 testsuite/tests/typing-short-paths/short-paths.ml create mode 100644 testsuite/tests/typing-short-paths/short-paths.ml.reference create mode 100644 testsuite/tests/typing-signatures/Makefile create mode 100644 testsuite/tests/typing-signatures/els.ml create mode 100644 testsuite/tests/typing-signatures/els.ml.reference create mode 100644 testsuite/tests/typing-signatures/pr6371.ml create mode 100644 testsuite/tests/typing-signatures/pr6371.ml.reference create mode 100644 testsuite/tests/typing-signatures/pr6672.ml create mode 100644 testsuite/tests/typing-signatures/pr6672.ml.reference create mode 100644 testsuite/tests/typing-sigsubst/Makefile create mode 100644 testsuite/tests/typing-sigsubst/sigsubst.ml create mode 100644 testsuite/tests/typing-sigsubst/sigsubst.ml.reference create mode 100644 testsuite/tests/typing-typeparam/Makefile create mode 100644 testsuite/tests/typing-typeparam/newtype.ml create mode 100644 testsuite/tests/typing-typeparam/newtype.ml.reference create mode 100644 testsuite/tests/typing-unboxed-types/Makefile create mode 100644 testsuite/tests/typing-unboxed-types/test.ml create mode 100644 testsuite/tests/typing-unboxed-types/test.ml.reference create mode 100644 testsuite/tests/typing-unboxed/Makefile create mode 100644 testsuite/tests/typing-unboxed/test.ml create mode 100644 testsuite/tests/typing-unboxed/test.ml.reference create mode 100644 testsuite/tests/typing-warnings/Makefile create mode 100644 testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml create mode 100644 testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference create mode 100644 testsuite/tests/typing-warnings/application.ml create mode 100644 testsuite/tests/typing-warnings/application.ml.reference create mode 100644 testsuite/tests/typing-warnings/coercions.ml create mode 100644 testsuite/tests/typing-warnings/coercions.ml.principal.reference create mode 100644 testsuite/tests/typing-warnings/coercions.ml.reference create mode 100644 testsuite/tests/typing-warnings/exhaustiveness.ml create mode 100644 testsuite/tests/typing-warnings/exhaustiveness.ml.reference create mode 100644 testsuite/tests/typing-warnings/pr5892.ml create mode 100644 testsuite/tests/typing-warnings/pr5892.ml.reference create mode 100644 testsuite/tests/typing-warnings/pr6872.ml create mode 100644 testsuite/tests/typing-warnings/pr6872.ml.principal.reference create mode 100644 testsuite/tests/typing-warnings/pr6872.ml.reference create mode 100644 testsuite/tests/typing-warnings/pr7085.ml create mode 100644 testsuite/tests/typing-warnings/pr7085.ml.reference create mode 100755 testsuite/tests/typing-warnings/pr7115.ml create mode 100644 testsuite/tests/typing-warnings/pr7115.ml.reference create mode 100644 testsuite/tests/typing-warnings/pr7297.ml create mode 100644 testsuite/tests/typing-warnings/pr7297.ml.reference create mode 100644 testsuite/tests/typing-warnings/records.ml create mode 100644 testsuite/tests/typing-warnings/records.ml.principal.reference create mode 100644 testsuite/tests/typing-warnings/records.ml.reference create mode 100644 testsuite/tests/typing-warnings/unused_types.ml create mode 100644 testsuite/tests/typing-warnings/unused_types.ml.reference create mode 100644 testsuite/tests/unboxed-primitive-args/Makefile create mode 100644 testsuite/tests/unboxed-primitive-args/README create mode 100644 testsuite/tests/unboxed-primitive-args/common.ml create mode 100644 testsuite/tests/unboxed-primitive-args/common.mli create mode 100644 testsuite/tests/unboxed-primitive-args/gen_test.ml create mode 100644 testsuite/tests/unboxed-primitive-args/main.reference create mode 100644 testsuite/tests/unboxed-primitive-args/test_common.c create mode 100644 testsuite/tests/unboxed-primitive-args/test_common.h create mode 100644 testsuite/tests/unwind/Makefile create mode 100644 testsuite/tests/unwind/README create mode 100644 testsuite/tests/unwind/driver.ml create mode 100644 testsuite/tests/unwind/mylib.ml create mode 100644 testsuite/tests/unwind/mylib.mli create mode 100644 testsuite/tests/unwind/stack_walker.c create mode 100644 testsuite/tests/utils/Makefile create mode 100644 testsuite/tests/utils/edit_distance.ml create mode 100644 testsuite/tests/utils/edit_distance.reference create mode 100644 testsuite/tests/utils/test_strongly_connected_components.ml create mode 100644 testsuite/tests/utils/test_strongly_connected_components.reference create mode 100644 testsuite/tests/warnings/Makefile create mode 100755 testsuite/tests/warnings/deprecated_module.ml create mode 100755 testsuite/tests/warnings/deprecated_module.mli create mode 100644 testsuite/tests/warnings/deprecated_module.reference create mode 100755 testsuite/tests/warnings/deprecated_module_use.ml create mode 100644 testsuite/tests/warnings/deprecated_module_use.reference create mode 100644 testsuite/tests/warnings/module_without_cmx.mli create mode 100644 testsuite/tests/warnings/w01.ml create mode 100644 testsuite/tests/warnings/w01.reference create mode 100644 testsuite/tests/warnings/w04.ml create mode 100644 testsuite/tests/warnings/w04.reference create mode 100644 testsuite/tests/warnings/w06.ml create mode 100644 testsuite/tests/warnings/w06.reference create mode 100644 testsuite/tests/warnings/w33.ml create mode 100644 testsuite/tests/warnings/w33.reference create mode 100755 testsuite/tests/warnings/w45.ml create mode 100644 testsuite/tests/warnings/w45.reference create mode 100644 testsuite/tests/warnings/w47_inline.ml create mode 100644 testsuite/tests/warnings/w47_inline.reference create mode 100755 testsuite/tests/warnings/w50.ml create mode 100644 testsuite/tests/warnings/w50.reference create mode 100644 testsuite/tests/warnings/w51.ml create mode 100644 testsuite/tests/warnings/w51.reference create mode 100644 testsuite/tests/warnings/w51_bis.ml create mode 100644 testsuite/tests/warnings/w51_bis.reference create mode 100644 testsuite/tests/warnings/w53.ml create mode 100644 testsuite/tests/warnings/w53.reference create mode 100644 testsuite/tests/warnings/w54.ml create mode 100644 testsuite/tests/warnings/w54.reference create mode 100644 testsuite/tests/warnings/w55.opt_backend.clambda.opt_reference create mode 100644 testsuite/tests/warnings/w55.opt_backend.flambda.opt_reference create mode 100644 testsuite/tests/warnings/w55.opt_backend.ml create mode 100644 testsuite/tests/warnings/w55.opt_backend.reference create mode 100644 testsuite/tests/warnings/w58.opt.ml create mode 100644 testsuite/tests/warnings/w58.opt.opt_reference create mode 100644 testsuite/tests/warnings/w58.opt.reference create mode 100644 testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference create mode 100644 testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference create mode 100644 testsuite/tests/warnings/w59.opt_backend.ml create mode 100644 testsuite/tests/warnings/w59.opt_backend.reference create mode 100755 testsuite/tests/warnings/w60.ml create mode 100755 testsuite/tests/warnings/w60.mli create mode 100644 testsuite/tests/warnings/w60.reference create mode 100644 testsuite/tools/Makefile create mode 100644 testsuite/tools/expect_test.ml create mode 100644 testsuite/typing create mode 100644 tools/.depend create mode 100644 tools/Makefile create mode 100644 tools/Makefile.nt create mode 100644 tools/addlabels.ml create mode 100755 tools/check-typo create mode 100644 tools/checkstack.c create mode 100755 tools/ci-build create mode 100644 tools/cleanup-header create mode 100644 tools/cmpbyt.ml create mode 100644 tools/cmt2annot.ml create mode 100644 tools/cvt_emit.mll create mode 100644 tools/dumpobj.ml create mode 100644 tools/eqparsetree.ml create mode 100644 tools/gdb-macros create mode 100644 tools/lexer299.mll create mode 100644 tools/lexer301.mll create mode 100644 tools/lintapidiff.ml create mode 100644 tools/magic create mode 100755 tools/make-package-macosx create mode 100755 tools/make-version-header.sh create mode 100644 tools/make_opcodes.mll create mode 100755 tools/msvs-promote-path create mode 100644 tools/objinfo.ml create mode 100644 tools/objinfo_helper.c create mode 100755 tools/ocaml-instr-graph create mode 100755 tools/ocaml-instr-report create mode 100755 tools/ocaml-objcopy-macosx create mode 100644 tools/ocaml299to3.ml create mode 100644 tools/ocamlcp.ml create mode 100644 tools/ocamldep.ml create mode 100644 tools/ocamlmklib.ml create mode 100644 tools/ocamlmktop.ml create mode 100644 tools/ocamloptp.ml create mode 100644 tools/ocamlprof.ml create mode 100755 tools/ocamlsize create mode 100644 tools/primreq.ml create mode 100644 tools/profiling.ml create mode 100644 tools/profiling.mli create mode 100644 tools/read_cmt.ml create mode 100644 tools/scrapelabels.ml create mode 100644 tools/stripdebug.ml create mode 100644 toplevel/expunge.ml create mode 100644 toplevel/genprintval.ml create mode 100644 toplevel/genprintval.mli create mode 100644 toplevel/opttopdirs.ml create mode 100644 toplevel/opttopdirs.mli create mode 100644 toplevel/opttoploop.ml create mode 100644 toplevel/opttoploop.mli create mode 100644 toplevel/opttopmain.ml create mode 100644 toplevel/opttopmain.mli create mode 100644 toplevel/opttopstart.ml create mode 100644 toplevel/topdirs.ml create mode 100644 toplevel/topdirs.mli create mode 100644 toplevel/toploop.ml create mode 100644 toplevel/toploop.mli create mode 100644 toplevel/topmain.ml create mode 100644 toplevel/topmain.mli create mode 100644 toplevel/topstart.ml create mode 100644 toplevel/trace.ml create mode 100644 toplevel/trace.mli create mode 100644 typing/HACKING.adoc create mode 100644 typing/annot.mli create mode 100644 typing/btype.ml create mode 100644 typing/btype.mli create mode 100644 typing/cmi_format.ml create mode 100644 typing/cmi_format.mli create mode 100644 typing/cmt_format.ml create mode 100644 typing/cmt_format.mli create mode 100644 typing/ctype.ml create mode 100644 typing/ctype.mli create mode 100644 typing/datarepr.ml create mode 100644 typing/datarepr.mli create mode 100644 typing/env.ml create mode 100644 typing/env.mli create mode 100644 typing/envaux.ml create mode 100644 typing/envaux.mli create mode 100644 typing/ident.ml create mode 100644 typing/ident.mli create mode 100644 typing/includeclass.ml create mode 100644 typing/includeclass.mli create mode 100644 typing/includecore.ml create mode 100644 typing/includecore.mli create mode 100644 typing/includemod.ml create mode 100644 typing/includemod.mli create mode 100644 typing/mtype.ml create mode 100644 typing/mtype.mli create mode 100644 typing/oprint.ml create mode 100644 typing/oprint.mli create mode 100644 typing/outcometree.mli create mode 100644 typing/parmatch.ml create mode 100644 typing/parmatch.mli create mode 100644 typing/path.ml create mode 100644 typing/path.mli create mode 100644 typing/predef.ml create mode 100644 typing/predef.mli create mode 100644 typing/primitive.ml create mode 100644 typing/primitive.mli create mode 100644 typing/printtyp.ml create mode 100644 typing/printtyp.mli create mode 100644 typing/printtyped.ml create mode 100644 typing/printtyped.mli create mode 100644 typing/stypes.ml create mode 100644 typing/stypes.mli create mode 100644 typing/subst.ml create mode 100644 typing/subst.mli create mode 100644 typing/tast_mapper.ml create mode 100644 typing/tast_mapper.mli create mode 100644 typing/typeclass.ml create mode 100644 typing/typeclass.mli create mode 100644 typing/typecore.ml create mode 100644 typing/typecore.mli create mode 100644 typing/typedecl.ml create mode 100644 typing/typedecl.mli create mode 100644 typing/typedtree.ml create mode 100644 typing/typedtree.mli create mode 100644 typing/typedtreeIter.ml create mode 100644 typing/typedtreeIter.mli create mode 100644 typing/typedtreeMap.ml create mode 100644 typing/typedtreeMap.mli create mode 100644 typing/typemod.ml create mode 100644 typing/typemod.mli create mode 100644 typing/types.ml create mode 100644 typing/types.mli create mode 100644 typing/typetexp.ml create mode 100644 typing/typetexp.mli create mode 100644 typing/untypeast.ml create mode 100644 typing/untypeast.mli create mode 100644 utils/arg_helper.ml create mode 100644 utils/arg_helper.mli create mode 100644 utils/ccomp.ml create mode 100644 utils/ccomp.mli create mode 100644 utils/clflags.ml create mode 100644 utils/clflags.mli create mode 100644 utils/config.mli create mode 100644 utils/config.mlp create mode 100644 utils/consistbl.ml create mode 100644 utils/consistbl.mli create mode 100644 utils/identifiable.ml create mode 100644 utils/identifiable.mli create mode 100644 utils/misc.ml create mode 100644 utils/misc.mli create mode 100644 utils/numbers.ml create mode 100644 utils/numbers.mli create mode 100644 utils/strongly_connected_components.ml create mode 100644 utils/strongly_connected_components.mli create mode 100644 utils/targetint.ml create mode 100644 utils/targetint.mli create mode 100644 utils/tbl.ml create mode 100644 utils/tbl.mli create mode 100644 utils/terminfo.ml create mode 100644 utils/terminfo.mli create mode 100644 utils/timings.ml create mode 100644 utils/timings.mli create mode 100644 utils/warnings.ml create mode 100644 utils/warnings.mli create mode 100644 yacc/Makefile create mode 100644 yacc/Makefile.nt create mode 100644 yacc/closure.c create mode 100644 yacc/defs.h create mode 100644 yacc/error.c create mode 100644 yacc/lalr.c create mode 100644 yacc/lr0.c create mode 100644 yacc/main.c create mode 100644 yacc/mkpar.c create mode 100644 yacc/output.c create mode 100644 yacc/reader.c create mode 100644 yacc/skeleton.c create mode 100644 yacc/symtab.c create mode 100644 yacc/verbose.c create mode 100644 yacc/warshall.c diff --git a/.depend b/.depend new file mode 100644 index 00000000..b46b8e42 --- /dev/null +++ b/.depend @@ -0,0 +1,2228 @@ +utils/arg_helper.cmo : utils/arg_helper.cmi +utils/arg_helper.cmx : utils/arg_helper.cmi +utils/arg_helper.cmi : +utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \ + utils/ccomp.cmi +utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \ + utils/ccomp.cmi +utils/ccomp.cmi : +utils/clflags.cmo : utils/numbers.cmi utils/misc.cmi utils/config.cmi \ + utils/arg_helper.cmi utils/clflags.cmi +utils/clflags.cmx : utils/numbers.cmx utils/misc.cmx utils/config.cmx \ + utils/arg_helper.cmx utils/clflags.cmi +utils/clflags.cmi : utils/misc.cmi +utils/config.cmo : utils/config.cmi +utils/config.cmx : utils/config.cmi +utils/config.cmi : +utils/consistbl.cmo : utils/consistbl.cmi +utils/consistbl.cmx : utils/consistbl.cmi +utils/consistbl.cmi : +utils/identifiable.cmo : utils/misc.cmi utils/identifiable.cmi +utils/identifiable.cmx : utils/misc.cmx utils/identifiable.cmi +utils/identifiable.cmi : +utils/misc.cmo : utils/misc.cmi +utils/misc.cmx : utils/misc.cmi +utils/misc.cmi : +utils/numbers.cmo : utils/identifiable.cmi utils/numbers.cmi +utils/numbers.cmx : utils/identifiable.cmx utils/numbers.cmi +utils/numbers.cmi : utils/identifiable.cmi +utils/strongly_connected_components.cmo : utils/numbers.cmi utils/misc.cmi \ + utils/identifiable.cmi utils/strongly_connected_components.cmi +utils/strongly_connected_components.cmx : utils/numbers.cmx utils/misc.cmx \ + utils/identifiable.cmx utils/strongly_connected_components.cmi +utils/strongly_connected_components.cmi : utils/identifiable.cmi +utils/targetint.cmo : utils/misc.cmi utils/targetint.cmi +utils/targetint.cmx : utils/misc.cmx utils/targetint.cmi +utils/targetint.cmi : +utils/tbl.cmo : utils/tbl.cmi +utils/tbl.cmx : utils/tbl.cmi +utils/tbl.cmi : +utils/terminfo.cmo : utils/terminfo.cmi +utils/terminfo.cmx : utils/terminfo.cmi +utils/terminfo.cmi : +utils/timings.cmo : utils/timings.cmi +utils/timings.cmx : utils/timings.cmi +utils/timings.cmi : +utils/warnings.cmo : utils/misc.cmi utils/warnings.cmi +utils/warnings.cmx : utils/misc.cmx utils/warnings.cmi +utils/warnings.cmi : +parsing/ast_helper.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi +parsing/ast_helper.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ + parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \ + parsing/asttypes.cmi parsing/ast_helper.cmi +parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi +parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ + parsing/longident.cmi parsing/builtin_attributes.cmi parsing/asttypes.cmi \ + parsing/ast_iterator.cmi parsing/ast_invariants.cmi +parsing/ast_invariants.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ + parsing/longident.cmx parsing/builtin_attributes.cmx parsing/asttypes.cmi \ + parsing/ast_iterator.cmx parsing/ast_invariants.cmi +parsing/ast_invariants.cmi : parsing/parsetree.cmi +parsing/ast_iterator.cmo : parsing/parsetree.cmi parsing/location.cmi \ + parsing/ast_iterator.cmi +parsing/ast_iterator.cmx : parsing/parsetree.cmi parsing/location.cmx \ + parsing/ast_iterator.cmi +parsing/ast_iterator.cmi : parsing/parsetree.cmi parsing/location.cmi +parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi utils/config.cmi \ + utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + parsing/ast_mapper.cmi +parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx utils/config.cmx \ + utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + parsing/ast_mapper.cmi +parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi +parsing/asttypes.cmi : parsing/location.cmi +parsing/attr_helper.cmo : parsing/parsetree.cmi parsing/location.cmi \ + parsing/asttypes.cmi parsing/attr_helper.cmi +parsing/attr_helper.cmx : parsing/parsetree.cmi parsing/location.cmx \ + parsing/asttypes.cmi parsing/attr_helper.cmi +parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/asttypes.cmi +parsing/builtin_attributes.cmo : utils/warnings.cmi parsing/parsetree.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \ + parsing/builtin_attributes.cmi +parsing/builtin_attributes.cmx : utils/warnings.cmx parsing/parsetree.cmi \ + parsing/location.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \ + parsing/builtin_attributes.cmi +parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/ast_iterator.cmi +parsing/depend.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ + parsing/builtin_attributes.cmi parsing/asttypes.cmi parsing/depend.cmi +parsing/depend.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ + parsing/builtin_attributes.cmx parsing/asttypes.cmi parsing/depend.cmi +parsing/depend.cmi : parsing/parsetree.cmi parsing/longident.cmi +parsing/docstrings.cmo : utils/warnings.cmi parsing/parsetree.cmi \ + parsing/location.cmi parsing/docstrings.cmi +parsing/docstrings.cmx : utils/warnings.cmx parsing/parsetree.cmi \ + parsing/location.cmx parsing/docstrings.cmi +parsing/docstrings.cmi : parsing/parsetree.cmi parsing/location.cmi +parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ + parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi +parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ + parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi +parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi +parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi utils/misc.cmi \ + utils/clflags.cmi parsing/location.cmi +parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx utils/misc.cmx \ + utils/clflags.cmx parsing/location.cmi +parsing/location.cmi : utils/warnings.cmi +parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi +parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi +parsing/longident.cmi : +parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ + parsing/location.cmi parsing/lexer.cmi parsing/docstrings.cmi \ + parsing/parse.cmi +parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ + parsing/location.cmx parsing/lexer.cmx parsing/docstrings.cmx \ + parsing/parse.cmi +parsing/parse.cmi : parsing/parsetree.cmi +parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \ + utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + parsing/parser.cmi +parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ + parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \ + utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + parsing/parser.cmi +parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/docstrings.cmi +parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ + parsing/asttypes.cmi +parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi parsing/pprintast.cmi +parsing/pprintast.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx parsing/pprintast.cmi +parsing/pprintast.cmi : parsing/parsetree.cmi +parsing/printast.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ + parsing/printast.cmi +parsing/printast.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ + parsing/printast.cmi +parsing/printast.cmi : parsing/parsetree.cmi +parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi +parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi +parsing/syntaxerr.cmi : parsing/location.cmi +typing/annot.cmi : parsing/location.cmi +typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/btype.cmi +typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/btype.cmi +typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi +typing/cmi_format.cmo : typing/types.cmi parsing/location.cmi \ + utils/config.cmi typing/cmi_format.cmi +typing/cmi_format.cmx : typing/types.cmx parsing/location.cmx \ + utils/config.cmx typing/cmi_format.cmi +typing/cmi_format.cmi : typing/types.cmi +typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi \ + typing/tast_mapper.cmi utils/misc.cmi parsing/location.cmi \ + parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \ + utils/clflags.cmi typing/cmt_format.cmi +typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/tast_mapper.cmx utils/misc.cmx parsing/location.cmx \ + parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \ + utils/clflags.cmx typing/cmt_format.cmi +typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/location.cmi typing/env.cmi typing/cmi_format.cmi +typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/predef.cmi \ + typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/ctype.cmi +typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/predef.cmx \ + typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/ctype.cmi +typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ + typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/datarepr.cmi +typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ + typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/datarepr.cmi +typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi +typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ + typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \ + typing/cmi_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/asttypes.cmi typing/env.cmi +typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ + typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ + typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/asttypes.cmi typing/env.cmi +typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \ + typing/path.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi utils/consistbl.cmi typing/cmi_format.cmi \ + parsing/asttypes.cmi +typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ + typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/envaux.cmi +typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ + typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/envaux.cmi +typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi +typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi +typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi +typing/ident.cmi : utils/identifiable.cmi +typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ + typing/ctype.cmi typing/includeclass.cmi +typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \ + typing/ctype.cmx typing/includeclass.cmi +typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi +typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \ + typing/path.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi +typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/path.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi +typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/ident.cmi typing/env.cmi +typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ + typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi typing/path.cmi \ + typing/mtype.cmi utils/misc.cmi parsing/location.cmi \ + typing/includecore.cmi typing/includeclass.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \ + typing/includemod.cmi +typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ + typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx typing/path.cmx \ + typing/mtype.cmx utils/misc.cmx parsing/location.cmx \ + typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \ + typing/includemod.cmi +typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/path.cmi parsing/location.cmi typing/includecore.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi +typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ + typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/mtype.cmi +typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ + typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/mtype.cmi +typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ + typing/env.cmi +typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \ + typing/oprint.cmi +typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ + typing/oprint.cmi +typing/oprint.cmi : typing/outcometree.cmi +typing/outcometree.cmi : parsing/asttypes.cmi +typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \ + typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \ + typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \ + utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/btype.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi typing/parmatch.cmi +typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \ + typing/types.cmx typing/typedtreeIter.cmx typing/typedtree.cmx \ + typing/subst.cmx typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \ + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/btype.cmx \ + parsing/asttypes.cmi parsing/ast_helper.cmx typing/parmatch.cmi +typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.cmi +typing/path.cmo : typing/ident.cmi typing/path.cmi +typing/path.cmx : typing/ident.cmx typing/path.cmi +typing/path.cmi : typing/ident.cmi +typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ + parsing/location.cmi typing/ident.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/predef.cmi +typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/parsetree.cmi \ + parsing/location.cmx typing/ident.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/predef.cmi +typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi +typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \ + typing/outcometree.cmi utils/misc.cmi parsing/location.cmi \ + parsing/attr_helper.cmi typing/primitive.cmi +typing/primitive.cmx : utils/warnings.cmx parsing/parsetree.cmi \ + typing/outcometree.cmi utils/misc.cmx parsing/location.cmx \ + parsing/attr_helper.cmx typing/primitive.cmi +typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \ + parsing/location.cmi +typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \ + typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ + parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/printtyp.cmi +typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \ + typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ + parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/printtyp.cmi +typing/printtyp.cmi : typing/types.cmi typing/path.cmi \ + typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \ + typing/env.cmi parsing/asttypes.cmi +typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \ + typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi +typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \ + typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi +typing/printtyped.cmi : typing/typedtree.cmi +typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \ + parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi +typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \ + parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi +typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ + typing/annot.cmi +typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/ast_mapper.cmi typing/subst.cmi +typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi +typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi +typing/tast_mapper.cmo : typing/typedtree.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/tast_mapper.cmi +typing/tast_mapper.cmx : typing/typedtree.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/tast_mapper.cmi +typing/tast_mapper.cmi : typing/typedtree.cmi typing/env.cmi \ + parsing/asttypes.cmi +typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ + typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/includeclass.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \ + parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi typing/typeclass.cmi +typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ + typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/includeclass.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \ + parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx typing/typeclass.cmi +typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi +typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ + typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \ + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \ + utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ + utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \ + typing/typecore.cmi +typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ + typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \ + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \ + utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \ + parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \ + typing/typecore.cmi +typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi +typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/subst.cmi \ + typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ + typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \ + utils/config.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/attr_helper.cmi parsing/asttypes.cmi \ + parsing/ast_iterator.cmi parsing/ast_helper.cmi typing/typedecl.cmi +typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/subst.cmx \ + typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \ + typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \ + utils/config.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/attr_helper.cmx parsing/asttypes.cmi \ + parsing/ast_iterator.cmx parsing/ast_helper.cmx typing/typedecl.cmi +typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/includecore.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi +typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \ + typing/typedtree.cmi +typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \ + typing/typedtree.cmi +typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +typing/typedtreeIter.cmo : typing/typedtree.cmi utils/misc.cmi \ + parsing/asttypes.cmi typing/typedtreeIter.cmi +typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \ + parsing/asttypes.cmi typing/typedtreeIter.cmi +typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi +typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ + typing/typedtreeMap.cmi +typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ + typing/typedtreeMap.cmi +typing/typedtreeMap.cmi : typing/typedtree.cmi +typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ + typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ + typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \ + typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \ + typing/cmi_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \ + typing/annot.cmi typing/typemod.cmi +typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ + typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ + typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi \ + typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/includemod.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \ + typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \ + typing/annot.cmi typing/typemod.cmi +typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ + typing/env.cmi typing/cmi_format.cmi parsing/asttypes.cmi +typing/types.cmo : typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/types.cmi +typing/types.cmx : typing/primitive.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/types.cmi +typing/types.cmi : typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi +typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi \ + typing/ctype.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + typing/typetexp.cmi +typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/env.cmx \ + typing/ctype.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + typing/typetexp.cmi +typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.cmi +typing/untypeast.cmo : typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi typing/untypeast.cmi +typing/untypeast.cmx : typing/typedtree.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx typing/untypeast.cmi +typing/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + parsing/asttypes.cmi +bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ + typing/primitive.cmi utils/misc.cmi bytecomp/matching.cmi \ + bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ + utils/config.cmi parsing/asttypes.cmi bytecomp/bytegen.cmi +bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ + typing/primitive.cmx utils/misc.cmx bytecomp/matching.cmx \ + bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ + utils/config.cmx parsing/asttypes.cmi bytecomp/bytegen.cmi +bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi +bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi +bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \ + utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi +bytecomp/bytelibrarian.cmi : +bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \ + bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ + bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \ + bytecomp/bytesections.cmi bytecomp/bytelink.cmi +bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ + bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ + bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ + bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \ + bytecomp/bytesections.cmx bytecomp/bytelink.cmi +bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi +bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ + typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \ + parsing/location.cmi bytecomp/instruct.cmi typing/ident.cmi \ + typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ + bytecomp/bytegen.cmi bytecomp/bytepackager.cmi +bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ + typing/subst.cmx bytecomp/printlambda.cmx typing/path.cmx utils/misc.cmx \ + parsing/location.cmx bytecomp/instruct.cmx typing/ident.cmx \ + typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ + bytecomp/bytegen.cmx bytecomp/bytepackager.cmi +bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi +bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi +bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi +bytecomp/bytesections.cmi : +bytecomp/cmo_format.cmi : utils/tbl.cmi bytecomp/lambda.cmi typing/ident.cmi +bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi +bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi +bytecomp/dll.cmi : +bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ + bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ + parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/emitcode.cmi +bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ + bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ + parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/emitcode.cmi +bytecomp/emitcode.cmi : bytecomp/instruct.cmi typing/ident.cmi \ + bytecomp/cmo_format.cmi +bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + bytecomp/instruct.cmi +bytecomp/instruct.cmx : typing/types.cmx typing/subst.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/instruct.cmi +bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi bytecomp/lambda.cmi +bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ + parsing/asttypes.cmi bytecomp/lambda.cmi +bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +bytecomp/matching.cmo : typing/types.cmi bytecomp/typeopt.cmi \ + typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/matching.cmi +bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \ + typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/matching.cmi +bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi +bytecomp/meta.cmo : bytecomp/instruct.cmi bytecomp/meta.cmi +bytecomp/meta.cmx : bytecomp/instruct.cmx bytecomp/meta.cmi +bytecomp/meta.cmi : bytecomp/instruct.cmi +bytecomp/opcodes.cmo : +bytecomp/opcodes.cmx : +bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \ + bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ + bytecomp/printinstr.cmi +bytecomp/printinstr.cmx : bytecomp/printlambda.cmx parsing/location.cmx \ + bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ + bytecomp/printinstr.cmi +bytecomp/printinstr.cmi : bytecomp/instruct.cmi +bytecomp/printlambda.cmo : typing/types.cmi typing/primitive.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + parsing/asttypes.cmi bytecomp/printlambda.cmi +bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + parsing/asttypes.cmi bytecomp/printlambda.cmi +bytecomp/printlambda.cmi : bytecomp/lambda.cmi +bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi +bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi +bytecomp/runtimedef.cmi : +bytecomp/semantics_of_primitives.cmo : bytecomp/lambda.cmi \ + bytecomp/semantics_of_primitives.cmi +bytecomp/semantics_of_primitives.cmx : bytecomp/lambda.cmx \ + bytecomp/semantics_of_primitives.cmi +bytecomp/semantics_of_primitives.cmi : bytecomp/lambda.cmi +bytecomp/simplif.cmo : utils/warnings.cmi utils/tbl.cmi typing/stypes.cmi \ + utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ + bytecomp/simplif.cmi +bytecomp/simplif.cmx : utils/warnings.cmx utils/tbl.cmx typing/stypes.cmx \ + utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ + bytecomp/simplif.cmi +bytecomp/simplif.cmi : utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi +bytecomp/switch.cmo : bytecomp/switch.cmi +bytecomp/switch.cmx : bytecomp/switch.cmi +bytecomp/switch.cmi : +bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ + typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytesections.cmi \ + parsing/asttypes.cmi bytecomp/symtable.cmi +bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ + typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \ + parsing/asttypes.cmi bytecomp/symtable.cmi +bytecomp/symtable.cmi : utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ + bytecomp/cmo_format.cmi +bytecomp/translattribute.cmo : utils/warnings.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi bytecomp/lambda.cmi utils/config.cmi \ + bytecomp/translattribute.cmi +bytecomp/translattribute.cmx : utils/warnings.cmx typing/typedtree.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx bytecomp/lambda.cmx utils/config.cmx \ + bytecomp/translattribute.cmi +bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \ + parsing/location.cmi bytecomp/lambda.cmi +bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ + typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ + typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi +bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \ + typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ + typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi +bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi +bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \ + typing/typedtree.cmi typing/typecore.cmi bytecomp/translobj.cmi \ + bytecomp/translattribute.cmi typing/primitive.cmi typing/predef.cmi \ + typing/path.cmi typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \ + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi +bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/translobj.cmx \ + bytecomp/translattribute.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \ + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi +bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/primitive.cmi typing/path.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \ + bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ + bytecomp/translattribute.cmi typing/printtyp.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi typing/mtype.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ + parsing/asttypes.cmi bytecomp/translmod.cmi +bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \ + bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ + bytecomp/translattribute.cmx typing/printtyp.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx typing/mtype.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ + parsing/asttypes.cmi bytecomp/translmod.cmi +bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi +bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translobj.cmi +bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translobj.cmi +bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ + typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi +bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/typedecl.cmx typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi +bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + bytecomp/lambda.cmi typing/env.cmi +asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo +asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx +asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/cmm.cmx asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmi : asmcomp/mach.cmi +asmcomp/afl_instrument.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + parsing/asttypes.cmi asmcomp/afl_instrument.cmi +asmcomp/afl_instrument.cmx : bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + parsing/asttypes.cmi asmcomp/afl_instrument.cmi +asmcomp/afl_instrument.cmi : asmcomp/cmm.cmi +asmcomp/arch.cmo : utils/config.cmi utils/clflags.cmi +asmcomp/arch.cmx : utils/config.cmx utils/clflags.cmx +asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \ + utils/timings.cmi middle_end/base_types/symbol.cmi asmcomp/split.cmi \ + asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ + asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ + asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \ + typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ + asmcomp/liveness.cmi middle_end/base_types/linkage_name.cmi \ + asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/interf.cmi \ + typing/ident.cmi asmcomp/flambda_to_clambda.cmi middle_end/flambda.cmi \ + asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \ + asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \ + asmcomp/closure.cmi utils/clflags.cmi asmcomp/clambda.cmi asmcomp/CSE.cmo \ + asmcomp/build_export_info.cmi asmcomp/asmgen.cmi +asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.cmx \ + utils/timings.cmx middle_end/base_types/symbol.cmx asmcomp/split.cmx \ + asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ + asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ + asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ + typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ + asmcomp/liveness.cmx middle_end/base_types/linkage_name.cmx \ + asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/interf.cmx \ + typing/ident.cmx asmcomp/flambda_to_clambda.cmx middle_end/flambda.cmx \ + asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \ + asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \ + asmcomp/closure.cmx utils/clflags.cmx asmcomp/clambda.cmx asmcomp/CSE.cmx \ + asmcomp/build_export_info.cmx asmcomp/asmgen.cmi +asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda.cmi asmcomp/cmm.cmi middle_end/backend_intf.cmi +asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ + asmcomp/export_info.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi +asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \ + asmcomp/export_info.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \ + utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmi +asmcomp/asmlibrarian.cmi : +asmcomp/asmlink.cmo : utils/timings.cmi bytecomp/runtimedef.cmi \ + utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ + utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \ + utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi +asmcomp/asmlink.cmx : utils/timings.cmx bytecomp/runtimedef.cmx \ + utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ + utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ + utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi +asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi +asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ + utils/timings.cmi utils/misc.cmi middle_end/middle_end.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/export_info_for_pack.cmi asmcomp/export_info.cmi typing/env.cmi \ + utils/config.cmi asmcomp/compilenv.cmi \ + middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \ + utils/clflags.cmi utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ + asmcomp/asmpackager.cmi +asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ + utils/timings.cmx utils/misc.cmx middle_end/middle_end.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + asmcomp/export_info_for_pack.cmx asmcomp/export_info.cmx typing/env.cmx \ + utils/config.cmx asmcomp/compilenv.cmx \ + middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \ + utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ + asmcomp/asmpackager.cmi +asmcomp/asmpackager.cmi : typing/env.cmi middle_end/backend_intf.cmi +asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \ + asmcomp/branch_relaxation.cmi +asmcomp/branch_relaxation.cmx : utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/branch_relaxation_intf.cmx \ + asmcomp/branch_relaxation.cmi +asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \ + asmcomp/branch_relaxation_intf.cmo +asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo +asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx +asmcomp/build_export_info.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \ + middle_end/invariant_params.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi \ + middle_end/base_types/export_id.cmi asmcomp/compilenv.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi middle_end/allocated_const.cmi \ + asmcomp/build_export_info.cmi +asmcomp/build_export_info.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \ + middle_end/invariant_params.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx asmcomp/export_info.cmx \ + middle_end/base_types/export_id.cmx asmcomp/compilenv.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi middle_end/allocated_const.cmx \ + asmcomp/build_export_info.cmi +asmcomp/build_export_info.cmi : middle_end/flambda.cmi \ + asmcomp/export_info.cmi middle_end/backend_intf.cmi +asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi +asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi +asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi parsing/asttypes.cmi +asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \ + bytecomp/simplif.cmi bytecomp/semantics_of_primitives.cmi \ + typing/primitive.cmi utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/arch.cmo asmcomp/closure.cmi +asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \ + bytecomp/simplif.cmx bytecomp/semantics_of_primitives.cmx \ + typing/primitive.cmx utils/misc.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/arch.cmx asmcomp/closure.cmi +asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi +asmcomp/closure_offsets.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi utils/misc.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \ + asmcomp/closure_offsets.cmi +asmcomp/closure_offsets.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx utils/misc.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \ + asmcomp/closure_offsets.cmi +asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_id.cmi +asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ + asmcomp/cmm.cmi +asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ + asmcomp/cmm.cmi +asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi parsing/asttypes.cmi +asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi bytecomp/switch.cmi \ + asmcomp/strmatch.cmi asmcomp/proc.cmi bytecomp/printlambda.cmi \ + typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ + asmcomp/afl_instrument.cmi asmcomp/cmmgen.cmi +asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx bytecomp/switch.cmx \ + asmcomp/strmatch.cmx asmcomp/proc.cmx bytecomp/printlambda.cmx \ + typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ + asmcomp/afl_instrument.cmx asmcomp/cmmgen.cmi +asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ + asmcomp/clambda.cmi +asmcomp/cmx_format.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi +asmcomp/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi +asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi +asmcomp/coloring.cmi : +asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ + asmcomp/arch.cmo asmcomp/comballoc.cmi +asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ + asmcomp/arch.cmx asmcomp/comballoc.cmi +asmcomp/comballoc.cmi : asmcomp/mach.cmi +asmcomp/compilenv.cmo : utils/warnings.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \ + parsing/location.cmi middle_end/base_types/linkage_name.cmi \ + typing/ident.cmi middle_end/flambda.cmi asmcomp/export_info.cmi \ + typing/env.cmi utils/config.cmi \ + middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + asmcomp/clambda.cmi asmcomp/compilenv.cmi +asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \ + parsing/location.cmx middle_end/base_types/linkage_name.cmx \ + typing/ident.cmx middle_end/flambda.cmx asmcomp/export_info.cmx \ + typing/env.cmx utils/config.cmx \ + middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/compilenv.cmi : utils/timings.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi \ + middle_end/base_types/linkage_name.cmi typing/ident.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi \ + middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \ + middle_end/base_types/closure_id.cmi asmcomp/clambda.cmi +asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + utils/config.cmi asmcomp/deadcode.cmi +asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + utils/config.cmx asmcomp/deadcode.cmi +asmcomp/deadcode.cmi : asmcomp/mach.cmi +asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \ + asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \ + asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/linearize.cmi asmcomp/emitaux.cmi middle_end/debuginfo.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/branch_relaxation.cmi asmcomp/arch.cmo asmcomp/emit.cmi +asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \ + asmcomp/x86_gas.cmx asmcomp/x86_dsl.cmx asmcomp/x86_ast.cmi \ + asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/linearize.cmx asmcomp/emitaux.cmx middle_end/debuginfo.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/branch_relaxation.cmx asmcomp/arch.cmx asmcomp/emit.cmi +asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi +asmcomp/emitaux.cmo : middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi +asmcomp/emitaux.cmx : middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi +asmcomp/emitaux.cmi : middle_end/debuginfo.cmi +asmcomp/export_info.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \ + middle_end/base_types/export_id.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi asmcomp/export_info.cmi +asmcomp/export_info.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/simple_value_approx.cmx \ + middle_end/base_types/set_of_closures_id.cmx middle_end/flambda.cmx \ + middle_end/base_types/export_id.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx asmcomp/export_info.cmi +asmcomp/export_info.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \ + middle_end/base_types/export_id.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi +asmcomp/export_info_for_pack.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi \ + middle_end/base_types/export_id.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi asmcomp/export_info_for_pack.cmi +asmcomp/export_info_for_pack.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/symbol.cmx \ + middle_end/base_types/set_of_closures_origin.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx asmcomp/export_info.cmx \ + middle_end/base_types/export_id.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx asmcomp/export_info_for_pack.cmi +asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi \ + middle_end/base_types/compilation_unit.cmi +asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_id.cmi typing/primitive.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + utils/misc.cmi middle_end/base_types/linkage_name.cmi typing/ident.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + asmcomp/export_info.cmi middle_end/debuginfo.cmi asmcomp/compilenv.cmi \ + asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi asmcomp/clambda.cmi middle_end/allocated_const.cmi \ + asmcomp/flambda_to_clambda.cmi +asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/base_types/set_of_closures_id.cmx typing/primitive.cmx \ + utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \ + utils/misc.cmx middle_end/base_types/linkage_name.cmx typing/ident.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + asmcomp/export_info.cmx middle_end/debuginfo.cmx asmcomp/compilenv.cmx \ + asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx asmcomp/clambda.cmx middle_end/allocated_const.cmx \ + asmcomp/flambda_to_clambda.cmi +asmcomp/flambda_to_clambda.cmi : middle_end/base_types/symbol.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi asmcomp/clambda.cmi +asmcomp/import_approx.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \ + middle_end/freshening.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi \ + middle_end/base_types/export_id.cmi asmcomp/compilenv.cmi \ + middle_end/base_types/closure_id.cmi asmcomp/import_approx.cmi +asmcomp/import_approx.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/symbol.cmx middle_end/simple_value_approx.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \ + middle_end/freshening.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx asmcomp/export_info.cmx \ + middle_end/base_types/export_id.cmx asmcomp/compilenv.cmx \ + middle_end/base_types/closure_id.cmx asmcomp/import_approx.cmi +asmcomp/import_approx.cmi : middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi +asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi asmcomp/interf.cmi +asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/cmm.cmx asmcomp/interf.cmi +asmcomp/interf.cmi : asmcomp/mach.cmi +asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi asmcomp/linearize.cmi +asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ + asmcomp/mach.cmx middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx asmcomp/linearize.cmi +asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi +asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi utils/config.cmi \ + asmcomp/cmm.cmi asmcomp/liveness.cmi +asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx utils/config.cmx \ + asmcomp/cmm.cmx asmcomp/liveness.cmi +asmcomp/liveness.cmi : asmcomp/mach.cmi +asmcomp/mach.cmo : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/mach.cmi +asmcomp/mach.cmx : asmcomp/reg.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/mach.cmi +asmcomp/mach.cmi : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo +asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ + typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/printclambda.cmi +asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ + typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/printclambda.cmi +asmcomp/printclambda.cmi : asmcomp/clambda.cmi +asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi parsing/asttypes.cmi \ + asmcomp/printcmm.cmi +asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx asmcomp/cmm.cmx parsing/asttypes.cmi \ + asmcomp/printcmm.cmi +asmcomp/printcmm.cmi : middle_end/debuginfo.cmi asmcomp/cmm.cmi +asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/printcmm.cmi \ + asmcomp/mach.cmi asmcomp/linearize.cmi middle_end/debuginfo.cmi \ + asmcomp/printlinear.cmi +asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/printcmm.cmx \ + asmcomp/mach.cmx asmcomp/linearize.cmx middle_end/debuginfo.cmx \ + asmcomp/printlinear.cmi +asmcomp/printlinear.cmi : asmcomp/linearize.cmi +asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printcmm.cmi asmcomp/mach.cmi middle_end/debuginfo.cmi \ + utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi +asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printcmm.cmx asmcomp/mach.cmx middle_end/debuginfo.cmx \ + utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi +asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \ + asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/proc.cmi +asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \ + asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/proc.cmi +asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi +asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi +asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi +asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi +asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi +asmcomp/reload.cmi : asmcomp/mach.cmi +asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/reloadgen.cmi +asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/reloadgen.cmi +asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/schedgen.cmi +asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/schedgen.cmi +asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi +asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmi : asmcomp/linearize.cmi +asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ + asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ + typing/ident.cmi middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ + asmcomp/selectgen.cmi +asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ + asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ + typing/ident.cmx middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ + asmcomp/selectgen.cmi +asmcomp/selectgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo +asmcomp/selection.cmo : asmcomp/spacetime_profiling.cmi \ + asmcomp/selectgen.cmi asmcomp/proc.cmi asmcomp/mach.cmi utils/config.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx : asmcomp/spacetime_profiling.cmx \ + asmcomp/selectgen.cmx asmcomp/proc.cmx asmcomp/mach.cmx utils/config.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi +asmcomp/spacetime_profiling.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi utils/config.cmi asmcomp/cmm.cmi \ + parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/spacetime_profiling.cmi +asmcomp/spacetime_profiling.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx utils/config.cmx asmcomp/cmm.cmx \ + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/spacetime_profiling.cmi +asmcomp/spacetime_profiling.cmi : asmcomp/selectgen.cmi +asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi +asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ + asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/spill.cmi +asmcomp/spill.cmi : asmcomp/mach.cmi +asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/split.cmi +asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/split.cmi +asmcomp/split.cmi : asmcomp/mach.cmi +asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi parsing/asttypes.cmi \ + asmcomp/arch.cmo asmcomp/strmatch.cmi +asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/debuginfo.cmx asmcomp/cmm.cmx parsing/asttypes.cmi \ + asmcomp/arch.cmx asmcomp/strmatch.cmi +asmcomp/strmatch.cmi : middle_end/debuginfo.cmi asmcomp/cmm.cmi +asmcomp/un_anf.cmo : bytecomp/semantics_of_primitives.cmi \ + asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \ + typing/ident.cmi middle_end/debuginfo.cmi utils/clflags.cmi \ + asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/un_anf.cmi +asmcomp/un_anf.cmx : bytecomp/semantics_of_primitives.cmx \ + asmcomp/printclambda.cmx utils/misc.cmx bytecomp/lambda.cmx \ + typing/ident.cmx middle_end/debuginfo.cmx utils/clflags.cmx \ + asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/un_anf.cmi +asmcomp/un_anf.cmi : asmcomp/clambda.cmi +asmcomp/x86_ast.cmi : +asmcomp/x86_dsl.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ + asmcomp/x86_dsl.cmi +asmcomp/x86_dsl.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ + asmcomp/x86_dsl.cmi +asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi +asmcomp/x86_gas.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ + utils/misc.cmi asmcomp/x86_gas.cmi +asmcomp/x86_gas.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ + utils/misc.cmx asmcomp/x86_gas.cmi +asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi +asmcomp/x86_masm.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ + asmcomp/x86_masm.cmi +asmcomp/x86_masm.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ + asmcomp/x86_masm.cmi +asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi +asmcomp/x86_proc.cmo : asmcomp/x86_ast.cmi utils/config.cmi \ + utils/clflags.cmi utils/ccomp.cmi asmcomp/x86_proc.cmi +asmcomp/x86_proc.cmx : asmcomp/x86_ast.cmi utils/config.cmx \ + utils/clflags.cmx utils/ccomp.cmx asmcomp/x86_proc.cmi +asmcomp/x86_proc.cmi : asmcomp/x86_ast.cmi +middle_end/alias_analysis.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + utils/misc.cmi bytecomp/lambda.cmi middle_end/flambda.cmi \ + parsing/asttypes.cmi middle_end/allocated_const.cmi \ + middle_end/alias_analysis.cmi +middle_end/alias_analysis.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + utils/misc.cmx bytecomp/lambda.cmx middle_end/flambda.cmx \ + parsing/asttypes.cmi middle_end/allocated_const.cmx \ + middle_end/alias_analysis.cmi +middle_end/alias_analysis.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + bytecomp/lambda.cmi middle_end/flambda.cmi parsing/asttypes.cmi \ + middle_end/allocated_const.cmi +middle_end/allocated_const.cmo : middle_end/allocated_const.cmi +middle_end/allocated_const.cmx : middle_end/allocated_const.cmi +middle_end/allocated_const.cmi : +middle_end/augment_specialised_args.cmo : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/pass_wrapper.cmi utils/misc.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + utils/identifiable.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi +middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \ + middle_end/projection.cmx middle_end/pass_wrapper.cmx utils/misc.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \ + utils/identifiable.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi +middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/inlining_cost.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi +middle_end/backend_intf.cmi : middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi typing/ident.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi bytecomp/simplif.cmi \ + bytecomp/printlambda.cmi typing/predef.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + parsing/location.cmi middle_end/base_types/linkage_name.cmi \ + middle_end/lift_code.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi utils/config.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi \ + middle_end/closure_conversion_aux.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi middle_end/closure_conversion.cmi +middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx bytecomp/simplif.cmx \ + bytecomp/printlambda.cmx typing/predef.cmx utils/numbers.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + parsing/location.cmx middle_end/base_types/linkage_name.cmx \ + middle_end/lift_code.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + middle_end/debuginfo.cmx utils/config.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx \ + middle_end/closure_conversion_aux.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi middle_end/closure_conversion.cmi +middle_end/closure_conversion.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/closure_conversion_aux.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/closure_conversion_aux.cmi +middle_end/closure_conversion_aux.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx utils/numbers.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + middle_end/closure_conversion_aux.cmi +middle_end/closure_conversion_aux.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/mutable_variable.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi +middle_end/debuginfo.cmo : parsing/location.cmi middle_end/debuginfo.cmi +middle_end/debuginfo.cmx : parsing/location.cmx middle_end/debuginfo.cmi +middle_end/debuginfo.cmi : parsing/location.cmi +middle_end/effect_analysis.cmo : bytecomp/semantics_of_primitives.cmi \ + utils/misc.cmi bytecomp/lambda.cmi middle_end/flambda.cmi \ + middle_end/effect_analysis.cmi +middle_end/effect_analysis.cmx : bytecomp/semantics_of_primitives.cmx \ + utils/misc.cmx bytecomp/lambda.cmx middle_end/flambda.cmx \ + middle_end/effect_analysis.cmi +middle_end/effect_analysis.cmi : middle_end/flambda.cmi +middle_end/extract_projections.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/simple_value_approx.cmi middle_end/projection.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/freshening.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + middle_end/base_types/closure_id.cmi middle_end/extract_projections.cmi +middle_end/extract_projections.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/simple_value_approx.cmx middle_end/projection.cmx \ + middle_end/inline_and_simplify_aux.cmx middle_end/freshening.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/base_types/closure_id.cmx middle_end/extract_projections.cmi +middle_end/extract_projections.cmi : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi +middle_end/find_recursive_functions.cmo : middle_end/base_types/variable.cmi \ + utils/strongly_connected_components.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/find_recursive_functions.cmi +middle_end/find_recursive_functions.cmx : middle_end/base_types/variable.cmx \ + utils/strongly_connected_components.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/find_recursive_functions.cmi +middle_end/find_recursive_functions.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/flambda.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + bytecomp/printlambda.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + parsing/asttypes.cmi middle_end/allocated_const.cmi \ + middle_end/flambda.cmi +middle_end/flambda.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/base_types/set_of_closures_origin.cmx \ + middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \ + bytecomp/printlambda.cmx utils/numbers.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + bytecomp/lambda.cmx utils/identifiable.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + parsing/asttypes.cmi middle_end/allocated_const.cmx \ + middle_end/flambda.cmi +middle_end/flambda.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \ + middle_end/allocated_const.cmi +middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + bytecomp/printlambda.cmi utils/numbers.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \ + middle_end/allocated_const.cmi middle_end/flambda_invariants.cmi +middle_end/flambda_invariants.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/base_types/set_of_closures_origin.cmx \ + middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \ + bytecomp/printlambda.cmx utils/numbers.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx parsing/asttypes.cmi \ + middle_end/allocated_const.cmx middle_end/flambda_invariants.cmi +middle_end/flambda_invariants.cmi : middle_end/flambda.cmi +middle_end/flambda_iterators.cmo : middle_end/base_types/variable.cmi \ + utils/misc.cmi middle_end/flambda.cmi middle_end/flambda_iterators.cmi +middle_end/flambda_iterators.cmx : middle_end/base_types/variable.cmx \ + utils/misc.cmx middle_end/flambda.cmx middle_end/flambda_iterators.cmi +middle_end/flambda_iterators.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi middle_end/flambda.cmi +middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi bytecomp/switch.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + middle_end/base_types/linkage_name.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \ + middle_end/allocated_const.cmi middle_end/flambda_utils.cmi +middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/symbol.cmx bytecomp/switch.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + middle_end/base_types/linkage_name.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \ + middle_end/allocated_const.cmx middle_end/flambda_utils.cmi +middle_end/flambda_utils.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + bytecomp/switch.cmi middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \ + middle_end/backend_intf.cmi +middle_end/freshening.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi middle_end/projection.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + utils/identifiable.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + middle_end/base_types/closure_id.cmi middle_end/freshening.cmi +middle_end/freshening.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx middle_end/projection.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + utils/identifiable.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/base_types/closure_id.cmx middle_end/freshening.cmi +middle_end/freshening.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/mutable_variable.cmi middle_end/flambda.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/inconstant_idents.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/numbers.cmi \ + utils/misc.cmi bytecomp/lambda.cmi utils/identifiable.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \ + parsing/asttypes.cmi middle_end/inconstant_idents.cmi +middle_end/inconstant_idents.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/symbol.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/numbers.cmx \ + utils/misc.cmx bytecomp/lambda.cmx utils/identifiable.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \ + parsing/asttypes.cmi middle_end/inconstant_idents.cmi +middle_end/inconstant_idents.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \ + middle_end/base_types/compilation_unit.cmi middle_end/backend_intf.cmi +middle_end/initialize_symbol_to_let_symbol.cmo : \ + middle_end/base_types/variable.cmi utils/misc.cmi middle_end/flambda.cmi \ + middle_end/initialize_symbol_to_let_symbol.cmi +middle_end/initialize_symbol_to_let_symbol.cmx : \ + middle_end/base_types/variable.cmx utils/misc.cmx middle_end/flambda.cmx \ + middle_end/initialize_symbol_to_let_symbol.cmi +middle_end/initialize_symbol_to_let_symbol.cmi : middle_end/flambda.cmi +middle_end/inline_and_simplify.cmo : utils/warnings.cmi \ + middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/unbox_specialised_args.cmi \ + middle_end/unbox_free_vars_of_closures.cmi middle_end/unbox_closures.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/simplify_primitives.cmi middle_end/simple_value_approx.cmi \ + middle_end/remove_unused_arguments.cmi \ + middle_end/remove_free_vars_equal_to_args.cmi middle_end/projection.cmi \ + typing/predef.cmi utils/misc.cmi parsing/location.cmi \ + middle_end/lift_code.cmi bytecomp/lambda.cmi \ + middle_end/invariant_params.cmi middle_end/inlining_stats.cmi \ + middle_end/inlining_decision.cmi middle_end/inlining_cost.cmi \ + middle_end/inline_and_simplify_aux.cmi typing/ident.cmi \ + middle_end/freshening.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/effect_analysis.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi middle_end/backend_intf.cmi \ + middle_end/allocated_const.cmi middle_end/inline_and_simplify.cmi +middle_end/inline_and_simplify.cmx : utils/warnings.cmx \ + middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/unbox_specialised_args.cmx \ + middle_end/unbox_free_vars_of_closures.cmx middle_end/unbox_closures.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/simplify_primitives.cmx middle_end/simple_value_approx.cmx \ + middle_end/remove_unused_arguments.cmx \ + middle_end/remove_free_vars_equal_to_args.cmx middle_end/projection.cmx \ + typing/predef.cmx utils/misc.cmx parsing/location.cmx \ + middle_end/lift_code.cmx bytecomp/lambda.cmx \ + middle_end/invariant_params.cmx middle_end/inlining_stats.cmx \ + middle_end/inlining_decision.cmx middle_end/inlining_cost.cmx \ + middle_end/inline_and_simplify_aux.cmx typing/ident.cmx \ + middle_end/freshening.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/effect_analysis.cmx \ + middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx middle_end/backend_intf.cmi \ + middle_end/allocated_const.cmx middle_end/inline_and_simplify.cmi +middle_end/inline_and_simplify.cmi : middle_end/base_types/variable.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/inline_and_simplify_aux.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \ + utils/misc.cmi middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \ + middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi +middle_end/inline_and_simplify_aux.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/symbol.cmx \ + middle_end/base_types/static_exception.cmx \ + middle_end/simple_value_approx.cmx \ + middle_end/base_types/set_of_closures_origin.cmx \ + middle_end/projection.cmx middle_end/base_types/mutable_variable.cmx \ + utils/misc.cmx middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \ + middle_end/freshening.cmx middle_end/flambda.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi +middle_end/inline_and_simplify_aux.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \ + middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \ + middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi +middle_end/inlining_cost.cmo : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi typing/primitive.cmi utils/misc.cmi \ + bytecomp/lambda.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi utils/clflags.cmi middle_end/inlining_cost.cmi +middle_end/inlining_cost.cmx : middle_end/base_types/variable.cmx \ + middle_end/projection.cmx typing/primitive.cmx utils/misc.cmx \ + bytecomp/lambda.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx utils/clflags.cmx middle_end/inlining_cost.cmi +middle_end/inlining_cost.cmi : middle_end/projection.cmi \ + middle_end/flambda.cmi +middle_end/inlining_decision.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \ + middle_end/inlining_transforms.cmi middle_end/inlining_stats_types.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + middle_end/find_recursive_functions.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/inlining_decision.cmi +middle_end/inlining_decision.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/simple_value_approx.cmx utils/misc.cmx bytecomp/lambda.cmx \ + middle_end/inlining_transforms.cmx middle_end/inlining_stats_types.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + middle_end/find_recursive_functions.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/inlining_decision.cmi +middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_decision_intf.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi +middle_end/inlining_decision_intf.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/inlining_stats.cmo : utils/misc.cmi \ + middle_end/inlining_stats_types.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/inlining_stats.cmi +middle_end/inlining_stats.cmx : utils/misc.cmx \ + middle_end/inlining_stats_types.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/inlining_stats.cmi +middle_end/inlining_stats.cmi : middle_end/inlining_stats_types.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi +middle_end/inlining_stats_types.cmo : middle_end/inlining_cost.cmi \ + middle_end/inlining_stats_types.cmi +middle_end/inlining_stats_types.cmx : middle_end/inlining_cost.cmx \ + middle_end/inlining_stats_types.cmi +middle_end/inlining_stats_types.cmi : middle_end/inlining_cost.cmi +middle_end/inlining_transforms.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/freshening.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \ + middle_end/inlining_transforms.cmi +middle_end/inlining_transforms.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/simple_value_approx.cmx utils/misc.cmx bytecomp/lambda.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \ + middle_end/freshening.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \ + middle_end/inlining_transforms.cmi +middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_decision_intf.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi +middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi middle_end/invariant_params.cmi +middle_end/invariant_params.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi middle_end/invariant_params.cmi +middle_end/invariant_params.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/lift_code.cmo : middle_end/base_types/variable.cmi \ + utils/strongly_connected_components.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/lift_code.cmi +middle_end/lift_code.cmx : middle_end/base_types/variable.cmx \ + utils/strongly_connected_components.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/lift_code.cmi +middle_end/lift_code.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi +middle_end/lift_constants.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + utils/strongly_connected_components.cmi \ + middle_end/simple_value_approx.cmi utils/misc.cmi \ + middle_end/base_types/linkage_name.cmi middle_end/inconstant_idents.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \ + parsing/asttypes.cmi middle_end/allocated_const.cmi \ + middle_end/alias_analysis.cmi middle_end/lift_constants.cmi +middle_end/lift_constants.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + utils/strongly_connected_components.cmx \ + middle_end/simple_value_approx.cmx utils/misc.cmx \ + middle_end/base_types/linkage_name.cmx middle_end/inconstant_idents.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \ + parsing/asttypes.cmi middle_end/allocated_const.cmx \ + middle_end/alias_analysis.cmx middle_end/lift_constants.cmi +middle_end/lift_constants.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/lift_let_to_initialize_symbol.cmo : \ + middle_end/base_types/variable.cmi middle_end/base_types/tag.cmi \ + middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi parsing/asttypes.cmi \ + middle_end/lift_let_to_initialize_symbol.cmi +middle_end/lift_let_to_initialize_symbol.cmx : \ + middle_end/base_types/variable.cmx middle_end/base_types/tag.cmx \ + middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/debuginfo.cmx parsing/asttypes.cmi \ + middle_end/lift_let_to_initialize_symbol.cmi +middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/middle_end.cmo : utils/warnings.cmi \ + middle_end/base_types/variable.cmi utils/timings.cmi \ + middle_end/base_types/symbol.cmi middle_end/share_constants.cmi \ + middle_end/remove_unused_program_constructs.cmi \ + middle_end/remove_unused_closure_vars.cmi middle_end/ref_to_variables.cmi \ + utils/misc.cmi parsing/location.cmi \ + middle_end/lift_let_to_initialize_symbol.cmi \ + middle_end/lift_constants.cmi middle_end/lift_code.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify.cmi \ + middle_end/initialize_symbol_to_let_symbol.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda_invariants.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmi \ + utils/clflags.cmi middle_end/backend_intf.cmi middle_end/middle_end.cmi +middle_end/middle_end.cmx : utils/warnings.cmx \ + middle_end/base_types/variable.cmx utils/timings.cmx \ + middle_end/base_types/symbol.cmx middle_end/share_constants.cmx \ + middle_end/remove_unused_program_constructs.cmx \ + middle_end/remove_unused_closure_vars.cmx middle_end/ref_to_variables.cmx \ + utils/misc.cmx parsing/location.cmx \ + middle_end/lift_let_to_initialize_symbol.cmx \ + middle_end/lift_constants.cmx middle_end/lift_code.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify.cmx \ + middle_end/initialize_symbol_to_let_symbol.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda_invariants.cmx \ + middle_end/flambda.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/closure_id.cmx middle_end/closure_conversion.cmx \ + utils/clflags.cmx middle_end/backend_intf.cmi middle_end/middle_end.cmi +middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \ + typing/ident.cmi middle_end/flambda.cmi middle_end/backend_intf.cmi +middle_end/pass_wrapper.cmo : utils/clflags.cmi middle_end/pass_wrapper.cmi +middle_end/pass_wrapper.cmx : utils/clflags.cmx middle_end/pass_wrapper.cmi +middle_end/pass_wrapper.cmi : +middle_end/projection.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \ + middle_end/base_types/closure_id.cmi middle_end/projection.cmi +middle_end/projection.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx utils/identifiable.cmx \ + middle_end/base_types/closure_id.cmx middle_end/projection.cmi +middle_end/projection.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/ref_to_variables.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ + bytecomp/lambda.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi parsing/asttypes.cmi \ + middle_end/ref_to_variables.cmi +middle_end/ref_to_variables.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/mutable_variable.cmx utils/misc.cmx \ + bytecomp/lambda.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx parsing/asttypes.cmi \ + middle_end/ref_to_variables.cmi +middle_end/ref_to_variables.cmi : middle_end/flambda.cmi +middle_end/remove_free_vars_equal_to_args.cmo : \ + middle_end/base_types/variable.cmi middle_end/pass_wrapper.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda.cmi \ + middle_end/remove_free_vars_equal_to_args.cmi +middle_end/remove_free_vars_equal_to_args.cmx : \ + middle_end/base_types/variable.cmx middle_end/pass_wrapper.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda.cmx \ + middle_end/remove_free_vars_equal_to_args.cmi +middle_end/remove_free_vars_equal_to_args.cmi : middle_end/flambda.cmi +middle_end/remove_unused_arguments.cmo : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/invariant_params.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/find_recursive_functions.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/remove_unused_arguments.cmi +middle_end/remove_unused_arguments.cmx : middle_end/base_types/variable.cmx \ + middle_end/projection.cmx middle_end/invariant_params.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/find_recursive_functions.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/remove_unused_arguments.cmi +middle_end/remove_unused_arguments.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/remove_unused_closure_vars.cmo : \ + middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + middle_end/base_types/closure_id.cmi \ + middle_end/remove_unused_closure_vars.cmi +middle_end/remove_unused_closure_vars.cmx : \ + middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/base_types/closure_id.cmx \ + middle_end/remove_unused_closure_vars.cmi +middle_end/remove_unused_closure_vars.cmi : middle_end/flambda.cmi +middle_end/remove_unused_program_constructs.cmo : \ + middle_end/base_types/symbol.cmi utils/misc.cmi middle_end/flambda.cmi \ + middle_end/effect_analysis.cmi \ + middle_end/remove_unused_program_constructs.cmi +middle_end/remove_unused_program_constructs.cmx : \ + middle_end/base_types/symbol.cmx utils/misc.cmx middle_end/flambda.cmx \ + middle_end/effect_analysis.cmx \ + middle_end/remove_unused_program_constructs.cmi +middle_end/remove_unused_program_constructs.cmi : middle_end/flambda.cmi +middle_end/share_constants.cmo : middle_end/base_types/symbol.cmi \ + middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ + middle_end/share_constants.cmi +middle_end/share_constants.cmx : middle_end/base_types/symbol.cmx \ + middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ + middle_end/share_constants.cmi +middle_end/share_constants.cmi : middle_end/flambda.cmi +middle_end/simple_value_approx.cmo : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \ + bytecomp/lambda.cmi middle_end/inlining_cost.cmi \ + middle_end/freshening.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/base_types/export_id.cmi \ + middle_end/effect_analysis.cmi middle_end/base_types/closure_id.cmi \ + middle_end/allocated_const.cmi middle_end/simple_value_approx.cmi +middle_end/simple_value_approx.cmx : middle_end/base_types/variable.cmx \ + middle_end/base_types/var_within_closure.cmx \ + middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ + middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \ + bytecomp/lambda.cmx middle_end/inlining_cost.cmx \ + middle_end/freshening.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/base_types/export_id.cmx \ + middle_end/effect_analysis.cmx middle_end/base_types/closure_id.cmx \ + middle_end/allocated_const.cmx middle_end/simple_value_approx.cmi +middle_end/simple_value_approx.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/set_of_closures_id.cmi bytecomp/lambda.cmi \ + middle_end/freshening.cmi middle_end/flambda.cmi \ + middle_end/base_types/export_id.cmi middle_end/base_types/closure_id.cmi +middle_end/simplify_boxed_integer_ops.cmo : middle_end/simplify_common.cmi \ + middle_end/simplify_boxed_integer_ops_intf.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/simplify_boxed_integer_ops.cmi +middle_end/simplify_boxed_integer_ops.cmx : middle_end/simplify_common.cmx \ + middle_end/simplify_boxed_integer_ops_intf.cmi \ + middle_end/simple_value_approx.cmx bytecomp/lambda.cmx \ + middle_end/inlining_cost.cmx middle_end/simplify_boxed_integer_ops.cmi +middle_end/simplify_boxed_integer_ops.cmi : \ + middle_end/simplify_boxed_integer_ops_intf.cmi +middle_end/simplify_boxed_integer_ops_intf.cmi : \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/flambda.cmi +middle_end/simplify_common.cmo : middle_end/simple_value_approx.cmi \ + bytecomp/lambda.cmi middle_end/inlining_cost.cmi \ + middle_end/effect_analysis.cmi middle_end/simplify_common.cmi +middle_end/simplify_common.cmx : middle_end/simple_value_approx.cmx \ + bytecomp/lambda.cmx middle_end/inlining_cost.cmx \ + middle_end/effect_analysis.cmx middle_end/simplify_common.cmi +middle_end/simplify_common.cmi : middle_end/simple_value_approx.cmi \ + bytecomp/lambda.cmi middle_end/inlining_cost.cmi middle_end/flambda.cmi +middle_end/simplify_primitives.cmo : middle_end/base_types/tag.cmi \ + middle_end/base_types/symbol.cmi middle_end/simplify_common.cmi \ + middle_end/simplify_boxed_integer_ops.cmi \ + middle_end/simple_value_approx.cmi bytecomp/semantics_of_primitives.cmi \ + utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \ + middle_end/flambda.cmi utils/clflags.cmi parsing/asttypes.cmi \ + middle_end/simplify_primitives.cmi +middle_end/simplify_primitives.cmx : middle_end/base_types/tag.cmx \ + middle_end/base_types/symbol.cmx middle_end/simplify_common.cmx \ + middle_end/simplify_boxed_integer_ops.cmx \ + middle_end/simple_value_approx.cmx bytecomp/semantics_of_primitives.cmx \ + utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \ + middle_end/flambda.cmx utils/clflags.cmx parsing/asttypes.cmi \ + middle_end/simplify_primitives.cmi +middle_end/simplify_primitives.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi +middle_end/unbox_closures.cmo : middle_end/base_types/variable.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \ + utils/clflags.cmi middle_end/augment_specialised_args.cmi \ + middle_end/unbox_closures.cmi +middle_end/unbox_closures.cmx : middle_end/base_types/variable.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \ + utils/clflags.cmx middle_end/augment_specialised_args.cmx \ + middle_end/unbox_closures.cmi +middle_end/unbox_closures.cmi : middle_end/base_types/variable.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi +middle_end/unbox_free_vars_of_closures.cmo : \ + middle_end/base_types/variable.cmi middle_end/projection.cmi \ + middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \ + middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ + middle_end/flambda.cmi middle_end/extract_projections.cmi \ + utils/clflags.cmi middle_end/unbox_free_vars_of_closures.cmi +middle_end/unbox_free_vars_of_closures.cmx : \ + middle_end/base_types/variable.cmx middle_end/projection.cmx \ + middle_end/pass_wrapper.cmx utils/misc.cmx middle_end/inlining_cost.cmx \ + middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/extract_projections.cmx \ + utils/clflags.cmx middle_end/unbox_free_vars_of_closures.cmi +middle_end/unbox_free_vars_of_closures.cmi : middle_end/inlining_cost.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi +middle_end/unbox_specialised_args.cmo : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/invariant_params.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/extract_projections.cmi utils/clflags.cmi \ + middle_end/augment_specialised_args.cmi \ + middle_end/unbox_specialised_args.cmi +middle_end/unbox_specialised_args.cmx : middle_end/base_types/variable.cmx \ + middle_end/projection.cmx middle_end/invariant_params.cmx \ + middle_end/inline_and_simplify_aux.cmx middle_end/flambda.cmx \ + middle_end/extract_projections.cmx utils/clflags.cmx \ + middle_end/augment_specialised_args.cmx \ + middle_end/unbox_specialised_args.cmi +middle_end/unbox_specialised_args.cmi : middle_end/base_types/variable.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi +middle_end/base_types/closure_element.cmo : \ + middle_end/base_types/variable.cmi \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/closure_element.cmx : \ + middle_end/base_types/variable.cmx \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/closure_element.cmi : \ + middle_end/base_types/variable.cmi utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/closure_id.cmo : \ + middle_end/base_types/closure_element.cmi \ + middle_end/base_types/closure_id.cmi +middle_end/base_types/closure_id.cmx : \ + middle_end/base_types/closure_element.cmx \ + middle_end/base_types/closure_id.cmi +middle_end/base_types/closure_id.cmi : \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/compilation_unit.cmo : utils/misc.cmi \ + middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.cmi +middle_end/base_types/compilation_unit.cmx : utils/misc.cmx \ + middle_end/base_types/linkage_name.cmx utils/identifiable.cmx \ + typing/ident.cmx middle_end/base_types/compilation_unit.cmi +middle_end/base_types/compilation_unit.cmi : \ + middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \ + typing/ident.cmi +middle_end/base_types/export_id.cmo : utils/identifiable.cmi \ + middle_end/base_types/id_types.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/export_id.cmi +middle_end/base_types/export_id.cmx : utils/identifiable.cmx \ + middle_end/base_types/id_types.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/export_id.cmi +middle_end/base_types/export_id.cmi : utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/id_types.cmo : utils/identifiable.cmi \ + middle_end/base_types/id_types.cmi +middle_end/base_types/id_types.cmx : utils/identifiable.cmx \ + middle_end/base_types/id_types.cmi +middle_end/base_types/id_types.cmi : utils/identifiable.cmi +middle_end/base_types/linkage_name.cmo : utils/identifiable.cmi \ + middle_end/base_types/linkage_name.cmi +middle_end/base_types/linkage_name.cmx : utils/identifiable.cmx \ + middle_end/base_types/linkage_name.cmi +middle_end/base_types/linkage_name.cmi : utils/identifiable.cmi +middle_end/base_types/mutable_variable.cmo : utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/mutable_variable.cmi +middle_end/base_types/mutable_variable.cmx : utils/identifiable.cmx \ + typing/ident.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/mutable_variable.cmi +middle_end/base_types/mutable_variable.cmi : utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.cmi +middle_end/base_types/set_of_closures_id.cmo : utils/identifiable.cmi \ + middle_end/base_types/id_types.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/set_of_closures_id.cmi +middle_end/base_types/set_of_closures_id.cmx : utils/identifiable.cmx \ + middle_end/base_types/id_types.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/set_of_closures_id.cmi +middle_end/base_types/set_of_closures_id.cmi : utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/set_of_closures_origin.cmo : \ + middle_end/base_types/set_of_closures_id.cmi \ + middle_end/base_types/set_of_closures_origin.cmi +middle_end/base_types/set_of_closures_origin.cmx : \ + middle_end/base_types/set_of_closures_id.cmx \ + middle_end/base_types/set_of_closures_origin.cmi +middle_end/base_types/set_of_closures_origin.cmi : \ + middle_end/base_types/set_of_closures_id.cmi utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi +middle_end/base_types/static_exception.cmo : utils/numbers.cmi \ + bytecomp/lambda.cmi middle_end/base_types/static_exception.cmi +middle_end/base_types/static_exception.cmx : utils/numbers.cmx \ + bytecomp/lambda.cmx middle_end/base_types/static_exception.cmi +middle_end/base_types/static_exception.cmi : utils/identifiable.cmi +middle_end/base_types/symbol.cmo : utils/misc.cmi \ + middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/symbol.cmi +middle_end/base_types/symbol.cmx : utils/misc.cmx \ + middle_end/base_types/linkage_name.cmx utils/identifiable.cmx \ + middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/symbol.cmi +middle_end/base_types/symbol.cmi : middle_end/base_types/linkage_name.cmi \ + utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi +middle_end/base_types/tag.cmo : utils/numbers.cmi utils/misc.cmi \ + utils/identifiable.cmi middle_end/base_types/tag.cmi +middle_end/base_types/tag.cmx : utils/numbers.cmx utils/misc.cmx \ + utils/identifiable.cmx middle_end/base_types/tag.cmi +middle_end/base_types/tag.cmi : utils/identifiable.cmi +middle_end/base_types/var_within_closure.cmo : \ + middle_end/base_types/closure_element.cmi \ + middle_end/base_types/var_within_closure.cmi +middle_end/base_types/var_within_closure.cmx : \ + middle_end/base_types/closure_element.cmx \ + middle_end/base_types/var_within_closure.cmi +middle_end/base_types/var_within_closure.cmi : \ + middle_end/base_types/closure_element.cmi +middle_end/base_types/variable.cmo : utils/misc.cmi utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/variable.cmi +middle_end/base_types/variable.cmx : utils/misc.cmx utils/identifiable.cmx \ + typing/ident.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/base_types/variable.cmi +middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \ + middle_end/base_types/compilation_unit.cmi +driver/compdynlink.cmi : +driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/compenv.cmi +driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/compenv.cmi +driver/compenv.cmi : +driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \ + typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ + utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \ + typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ + bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \ + driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \ + typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \ + driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ + bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi +driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ + utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \ + typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ + bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \ + driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \ + typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \ + driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ + bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi +driver/compile.cmi : +driver/compmisc.cmo : utils/warnings.cmi typing/typemod.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \ + parsing/asttypes.cmi driver/compmisc.cmi +driver/compmisc.cmx : utils/warnings.cmx typing/typemod.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx utils/config.cmx driver/compenv.cmx utils/clflags.cmx \ + parsing/asttypes.cmi driver/compmisc.cmi +driver/compmisc.cmi : typing/env.cmi +driver/compplugin.cmo : utils/misc.cmi parsing/location.cmi utils/config.cmi \ + driver/compmisc.cmi driver/compenv.cmi driver/compdynlink.cmi \ + utils/clflags.cmi driver/compplugin.cmi +driver/compplugin.cmx : utils/misc.cmx parsing/location.cmx utils/config.cmx \ + driver/compmisc.cmx driver/compenv.cmx driver/compdynlink.cmi \ + utils/clflags.cmx driver/compplugin.cmi +driver/compplugin.cmi : +driver/errors.cmo : parsing/location.cmi driver/errors.cmi +driver/errors.cmx : parsing/location.cmx driver/errors.cmi +driver/errors.cmi : +driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \ + driver/main_args.cmi parsing/location.cmi utils/config.cmi \ + driver/compplugin.cmi driver/compmisc.cmi driver/compile.cmi \ + driver/compenv.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi +driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \ + driver/main_args.cmx parsing/location.cmx utils/config.cmx \ + driver/compplugin.cmx driver/compmisc.cmx driver/compile.cmx \ + driver/compenv.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \ + bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi +driver/main.cmi : +driver/main_args.cmo : utils/warnings.cmi utils/config.cmi utils/clflags.cmi \ + driver/main_args.cmi +driver/main_args.cmx : utils/warnings.cmx utils/config.cmx utils/clflags.cmx \ + driver/main_args.cmi +driver/main_args.cmi : +driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ + typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ + utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \ + typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ + parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \ + utils/misc.cmi middle_end/middle_end.cmi bytecomp/lambda.cmi \ + typing/includemod.cmi typing/env.cmi utils/config.cmi driver/compmisc.cmi \ + asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \ + parsing/builtin_attributes.cmi asmcomp/asmgen.cmi driver/optcompile.cmi +driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ + utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \ + typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ + parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \ + utils/misc.cmx middle_end/middle_end.cmx bytecomp/lambda.cmx \ + typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \ + asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \ + parsing/builtin_attributes.cmx asmcomp/asmgen.cmx driver/optcompile.cmi +driver/optcompile.cmi : middle_end/backend_intf.cmi +driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi +driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi +driver/opterrors.cmi : +driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi asmcomp/proc.cmi \ + asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.cmi \ + driver/main_args.cmi parsing/location.cmi asmcomp/import_approx.cmi \ + utils/config.cmi driver/compplugin.cmi driver/compmisc.cmi \ + asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \ + asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi +driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx asmcomp/proc.cmx \ + asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.cmx \ + driver/main_args.cmx parsing/location.cmx asmcomp/import_approx.cmx \ + utils/config.cmx driver/compplugin.cmx driver/compmisc.cmx \ + asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \ + asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi +driver/optmain.cmi : +driver/pparse.cmo : utils/timings.cmi parsing/parsetree.cmi \ + parsing/parse.cmi utils/misc.cmi parsing/location.cmi utils/config.cmi \ + utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \ + parsing/ast_invariants.cmi driver/pparse.cmi +driver/pparse.cmx : utils/timings.cmx parsing/parsetree.cmi \ + parsing/parse.cmx utils/misc.cmx parsing/location.cmx utils/config.cmx \ + utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \ + parsing/ast_invariants.cmx driver/pparse.cmi +driver/pparse.cmi : parsing/parsetree.cmi utils/misc.cmi +toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ + utils/misc.cmi typing/ident.cmi bytecomp/bytesections.cmi +toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ + utils/misc.cmx typing/ident.cmx bytecomp/bytesections.cmx +toplevel/genprintval.cmo : typing/types.cmi typing/printtyp.cmi \ + typing/predef.cmi typing/path.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \ + typing/env.cmi typing/datarepr.cmi typing/ctype.cmi typing/btype.cmi \ + toplevel/genprintval.cmi +toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \ + typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \ + typing/env.cmx typing/datarepr.cmx typing/ctype.cmx typing/btype.cmx \ + toplevel/genprintval.cmi +toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ + typing/outcometree.cmi typing/env.cmi +toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \ + typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \ + parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/config.cmi driver/compdynlink.cmi utils/clflags.cmi \ + asmcomp/asmlink.cmi toplevel/opttopdirs.cmi +toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \ + typing/printtyp.cmx toplevel/opttoploop.cmx utils/misc.cmx \ + parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/config.cmx driver/compdynlink.cmi utils/clflags.cmx \ + asmcomp/asmlink.cmx toplevel/opttopdirs.cmi +toplevel/opttopdirs.cmi : parsing/longident.cmi +toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ + bytecomp/translmod.cmi utils/timings.cmi bytecomp/simplif.cmi \ + asmcomp/proc.cmi typing/printtyped.cmi typing/printtyp.cmi \ + bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \ + parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi middle_end/middle_end.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ + bytecomp/lambda.cmi typing/includemod.cmi asmcomp/import_approx.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ + driver/compmisc.cmi asmcomp/compilenv.cmi driver/compdynlink.cmi \ + utils/clflags.cmi typing/btype.cmi middle_end/backend_intf.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi asmcomp/asmlink.cmi \ + asmcomp/asmgen.cmi asmcomp/arch.cmo toplevel/opttoploop.cmi +toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ + bytecomp/translmod.cmx utils/timings.cmx bytecomp/simplif.cmx \ + asmcomp/proc.cmx typing/printtyped.cmx typing/printtyp.cmx \ + bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \ + parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx middle_end/middle_end.cmx \ + parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ + bytecomp/lambda.cmx typing/includemod.cmx asmcomp/import_approx.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ + driver/compmisc.cmx asmcomp/compilenv.cmx driver/compdynlink.cmi \ + utils/clflags.cmx typing/btype.cmx middle_end/backend_intf.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmx asmcomp/asmlink.cmx \ + asmcomp/asmgen.cmx asmcomp/arch.cmx toplevel/opttoploop.cmi +toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \ + typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi +toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ + toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \ + driver/main_args.cmi parsing/location.cmi utils/config.cmi \ + driver/compplugin.cmi driver/compenv.cmi utils/clflags.cmi \ + toplevel/opttopmain.cmi +toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ + toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \ + driver/main_args.cmx parsing/location.cmx utils/config.cmx \ + driver/compplugin.cmx driver/compenv.cmx utils/clflags.cmx \ + toplevel/opttopmain.cmi +toplevel/opttopmain.cmi : +toplevel/opttopstart.cmo : toplevel/opttopmain.cmi +toplevel/opttopstart.cmx : toplevel/opttopmain.cmx +toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi toplevel/trace.cmi toplevel/toploop.cmi \ + bytecomp/symtable.cmi typing/printtyp.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi bytecomp/opcodes.cmo utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi bytecomp/dll.cmi typing/ctype.cmi \ + utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + toplevel/topdirs.cmi +toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx toplevel/trace.cmx toplevel/toploop.cmx \ + bytecomp/symtable.cmx typing/printtyp.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi bytecomp/opcodes.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx bytecomp/dll.cmx typing/ctype.cmx \ + utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + toplevel/topdirs.cmi +toplevel/topdirs.cmi : parsing/longident.cmi +toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \ + typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \ + bytecomp/simplif.cmi typing/printtyped.cmi typing/printtyp.cmi \ + bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \ + typing/predef.cmi parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \ + bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ + utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ + bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi toplevel/toploop.cmi +toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \ + typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \ + bytecomp/simplif.cmx typing/printtyped.cmx typing/printtyp.cmx \ + bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \ + typing/predef.cmx parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \ + bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ + utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ + bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx toplevel/toploop.cmi +toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ + parsing/location.cmi typing/env.cmi +toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ + toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ + parsing/location.cmi utils/config.cmi driver/compplugin.cmi \ + driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi +toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ + toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ + parsing/location.cmx utils/config.cmx driver/compplugin.cmx \ + driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi +toplevel/topmain.cmi : +toplevel/topstart.cmo : toplevel/topmain.cmi +toplevel/topstart.cmx : toplevel/topmain.cmx +toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi typing/ctype.cmi \ + parsing/asttypes.cmi toplevel/trace.cmi +toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \ + parsing/asttypes.cmi toplevel/trace.cmi +toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ + typing/env.cmi +driver/compdynlink.cmx : asmcomp/cmx_format.cmi driver/compdynlink.cmi +driver/compdynlink.cmo : bytecomp/symtable.cmi bytecomp/opcodes.cmo \ + utils/misc.cmi bytecomp/meta.cmi bytecomp/dll.cmi utils/consistbl.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi typing/cmi_format.cmi \ + driver/compdynlink.cmi diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..b3eabd77 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,169 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Damien Doligez, projet Gallium, INRIA * +#* * +#* Copyright 2015 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# Default behaviour, for if core.autocrlf isn't set +* text=auto + +# Binary files +/boot/ocamlc binary +/boot/ocamllex binary +/boot/ocamldep binary +*.gif binary +*.png binary +*.tfm binary + +# 'union' merge driver just unions textual content in case of conflict +# http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/ +/.mailmap merge=union +/Changes merge=union + +# No header for text files (would be too obtrusive). +*.md ocaml-typo=missing-header +README* ocaml-typo=missing-header +*.adoc ocaml-typo=missing-header,long-line,unused-prop + +/.mailmap ocaml-typo=long-line,missing-header,non-ascii +/.merlin ocaml-typo=missing-header +/Changes ocaml-typo=non-ascii,missing-header +/INSTALL ocaml-typo=missing-header +/LICENSE ocaml-typo=long-line,very-long-line,missing-header +/appveyor.yml ocaml-typo=long-line,very-long-line + + +asmcomp/*/emit.mlp ocaml-typo=tab,long-line,unused-prop +asmcomp/power/NOTES.md ocaml-typo=missing-header,long-line + +asmrun/i386.S ocaml-typo=long-line + +config/gnu ocaml-typo=prune + +emacs/*.el ocaml-typo=long-line,unused-prop +emacs/COPYING ocaml-typo=tab,non-printing,missing-header +emacs/ocamltags.in ocaml-typo=non-printing + +experimental ocaml-typo=prune + +manual ocaml-typo=prune + +ocamlbuild/* ocaml-typo=long-line +ocamlbuild/AUTHORS ocaml-typo=missing-header +ocamlbuild/ChangeLog ocaml-typo=tab,missing-header +ocamlbuild/TODO ocaml-typo=missing-header + +ocamldoc/Changes.txt ocaml-typo=missing-header +ocamldoc/ocamldoc.sty ocaml-typo=missing-header + +otherlibs/win32unix/readlink.c ocaml-typo=long-line +otherlibs/win32unix/stat.c ocaml-typo=long-line +otherlibs/win32unix/symlink.c ocaml-typo=long-line + +stdlib/hashbang ocaml-typo=white-at-eol,missing-lf + +testsuite/tests/** ocaml-typo=missing-header +testsuite/tests/lib-bigarray-2/bigarrf.f ocaml-typo=missing-header,tab +testsuite/tests/misc-unsafe/almabench.ml ocaml-typo=missing-header,long-line +testsuite/typing ocaml-typo=missing-header + +tools/magic ocaml-typo=missing-header + +yacc/*.[ch] ocaml-typo=long-line,very-long-line,unused-prop + +# Line-ending specifications, for Windows interoperability +*.sh text eol=lf +*.sh.in text eol=lf +*.awk text eol=lf + +# Test suite command fragments +*.checker text eol=lf +*.precheck text eol=lf +*.runner text eol=lf + +configure text eol=lf +config/auto-aux/hasgot text eol=lf +config/auto-aux/hasgot2 text eol=lf +config/auto-aux/runtest text eol=lf +config/auto-aux/searchpath text eol=lf +config/auto-aux/solaris-ld text eol=lf +config/auto-aux/tryassemble text eol=lf +config/auto-aux/trycompile text eol=lf +config/gnu/config.guess text eol=lf +config/gnu/config.sub text eol=lf +ocamldoc/remove_DEBUG text eol=lf +stdlib/Compflags text eol=lf +stdlib/sharpbang text eol=lf +tools/check-typo text eol=lf +tools/ci-build text eol=lf +tools/cleanup-header text eol=lf +tools/msvs-promote-path text eol=lf +tools/gdb-macros text eol=lf +tools/magic text eol=lf +tools/make-opcodes text eol=lf +tools/make-package-macosx text eol=lf +tools/ocaml-objcopy-macosx text eol=lf +tools/ocamlmktop.tpl text eol=lf +tools/ocamlsize text eol=lf + +# These two are cat scripts, so may not actually require this +config/auto-aux/sharpbang text eol=lf +config/auto-aux/sharpbang2 text eol=lf + +# Similarly, these are all Perl scripts, so may not actually require this +manual/tools/caml-tex text eol=lf +manual/tools/format-intf text eol=lf +manual/tools/htmlcut text eol=lf +manual/tools/htmltbl text eol=lf +manual/tools/htmlthread text eol=lf +manual/tools/texexpand text eol=lf + +# Checking out the parsetree test files with \r\n endings causes all the +# locations to change, so use \n endings only, even on Windows +testsuite/tests/parsing/*.ml text eol=lf + +# Similarly, the docstring tests fail for the same reason on Windows +testsuite/tests/docstrings/empty.ml text eol=lf + +# And w04.ml +testsuite/tests/warnings/w04.ml text eol=lf + +# These are forced to \n to allow the Cygwin testsuite to pass on a +# Windows-checkout +testsuite/tests/formatting/margins.ml text eol=lf +testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml text eol=lf +testsuite/tests/typing-extension-constructor/test.ml text eol=lf +testsuite/tests/typing-extensions/extensions.ml text eol=lf +testsuite/tests/typing-extensions/open_types.ml text eol=lf +testsuite/tests/typing-objects/Exemples.ml text eol=lf +testsuite/tests/typing-objects/pr5619_bad.ml text eol=lf +testsuite/tests/typing-objects/pr6123_bad.ml text eol=lf +testsuite/tests/typing-objects/pr6907_bad.ml text eol=lf +testsuite/tests/typing-objects/Tests.ml text eol=lf +testsuite/tests/typing-pattern_open/pattern_open.ml text eol=lf +testsuite/tests/typing-private/private.ml text eol=lf +testsuite/tests/typing-recordarg/recordarg.ml text eol=lf +testsuite/tests/typing-short-paths/pr5918.ml text eol=lf +testsuite/tests/typing-sigsubst/sigsubst.ml text eol=lf +testsuite/tests/typing-typeparam/newtype.ml text eol=lf +testsuite/tests/typing-unboxed/test.ml text eol=lf +testsuite/tests/typing-unboxed-types/test.ml text eol=lf +testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml text eol=lf +testsuite/tests/typing-warnings/application.ml text eol=lf +testsuite/tests/typing-warnings/coercions.ml text eol=lf +testsuite/tests/typing-warnings/exhaustiveness.ml text eol=lf +testsuite/tests/typing-warnings/pr6872.ml text eol=lf +testsuite/tests/typing-warnings/pr7085.ml text eol=lf +testsuite/tests/typing-warnings/pr7115.ml text eol=lf +testsuite/tests/typing-warnings/pr7297.ml text eol=lf +testsuite/tests/typing-warnings/records.ml text eol=lf +testsuite/tests/typing-warnings/unused_types.ml text eol=lf diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..04da75db --- /dev/null +++ b/.gitignore @@ -0,0 +1,373 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Damien Doligez, projet Gallium, INRIA * +#* * +#* Copyright 2015 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# general patterns + +*.o +*.a +*.so +*.obj +*.lib +*.dll +*.cm[ioxat] +*.cmx[as] +*.cmti +*.annot +*.exe +*.exe.manifest +.depend +.depend.nt +.DS_Store +*.out +*.out.dSYM +*.swp + +# local to root directory + +/ocamlc +/ocamlc.opt +/expunge +/ocaml +/ocamlopt +/ocamlopt.opt +/package-macosx +/ocamlnat + +# specific files and patterns in sub-directories + +/asmcomp/emit.ml +/asmcomp/arch.ml +/asmcomp/proc.ml +/asmcomp/selection.ml +/asmcomp/reload.ml +/asmcomp/scheduling.ml +/asmcomp/CSE.ml + +/asmrun/*.p.c +/asmrun/*.d.c +/asmrun/alloc.c +/asmrun/afl.c +/asmrun/array.c +/asmrun/backtrace.c +/asmrun/callback.c +/asmrun/compact.c +/asmrun/compare.c +/asmrun/custom.c +/asmrun/debugger.c +/asmrun/dynlink.c +/asmrun/extern.c +/asmrun/finalise.c +/asmrun/floats.c +/asmrun/freelist.c +/asmrun/gc_ctrl.c +/asmrun/globroots.c +/asmrun/hash.c +/asmrun/intern.c +/asmrun/ints.c +/asmrun/io.c +/asmrun/lexing.c +/asmrun/main.c +/asmrun/major_gc.c +/asmrun/md5.c +/asmrun/memory.c +/asmrun/meta.c +/asmrun/minor_gc.c +/asmrun/misc.c +/asmrun/obj.c +/asmrun/parsing.c +/asmrun/printexc.c +/asmrun/signals.c +/asmrun/startup_aux.c +/asmrun/str.c +/asmrun/sys.c +/asmrun/terminfo.c +/asmrun/unix.c +/asmrun/weak.c +/asmrun/win32.c + +/boot/Saved +/boot/ocamlrun +/boot/ocamlyacc +/boot/camlheader + +/bytecomp/runtimedef.ml +/bytecomp/opcodes.ml + +/byterun/caml/jumptbl.h +/byterun/primitives +/byterun/prims.c +/byterun/caml/opnames.h +/byterun/caml/version.h +/byterun/ocamlrun +/byterun/ocamlrund +/byterun/ocamlruni +/byterun/ld.conf +/byterun/interp.a.lst +/byterun/*.[sd]obj +/byterun/.gdb_history +/byterun/*.d.c +/byterun/*.pic.c + +/config/m.h +/config/s.h +/config/Makefile +/config/auto-aux/hashbang4 + +/debugger/lexer.ml +/debugger/parser.ml +/debugger/parser.mli +/debugger/ocamldebug +/driver/compdynlink.mlopt +/driver/compdynlink.mlbyte +/driver/compdynlink.mli + +/emacs/ocamltags +/emacs/*.elc + +/experimental/garrigue/*.out +/experimental/garrigue/*.out2 + +/lex/parser.ml +/lex/parser.mli +/lex/lexer.ml +/lex/ocamllex +/lex/ocamllex.opt +/lex/parser.output + +/manual/manual/cmds/warnings-help.etex +/manual/manual/warnings-help.etex + +/ocamlbuild/ocamlbuild_config.ml +/ocamlbuild/lexers.ml +/ocamlbuild/glob_lexer.ml +/ocamlbuild/ocamlbuild.native +/ocamlbuild/ocamlbuild.byte + +/ocamldoc/ocamldoc +/ocamldoc/ocamldoc.opt +/ocamldoc/odoc_crc.ml +/ocamldoc/odoc_lexer.ml +/ocamldoc/odoc_ocamlhtml.ml +/ocamldoc/odoc_parser.ml +/ocamldoc/odoc_parser.mli +/ocamldoc/odoc_see_lexer.ml +/ocamldoc/odoc_text_lexer.ml +/ocamldoc/odoc_text_parser.ml +/ocamldoc/odoc_text_parser.mli +/ocamldoc/stdlib_man +/ocamldoc/stdlib_html +/ocamldoc/*.output +/ocamldoc/test_stdlib +/ocamldoc/test_latex +/ocamldoc/test + +/otherlibs/dynlink/extract_crc +/otherlibs/systhreads/thread.ml +/otherlibs/threads/marshal.mli +/otherlibs/threads/pervasives.mli +/otherlibs/threads/unix.mli +/otherlibs/win32graph/graphics.ml +/otherlibs/win32graph/graphics.mli +/otherlibs/win32unix/unixLabels.ml* +/otherlibs/win32unix/unix.mli +/otherlibs/win32unix/access.c +/otherlibs/win32unix/addrofstr.c +/otherlibs/win32unix/chdir.c +/otherlibs/win32unix/chmod.c +/otherlibs/win32unix/cst2constr.c +/otherlibs/win32unix/cstringv.c +/otherlibs/win32unix/envir.c +/otherlibs/win32unix/execv.c +/otherlibs/win32unix/execve.c +/otherlibs/win32unix/execvp.c +/otherlibs/win32unix/exit.c +/otherlibs/win32unix/getaddrinfo.c +/otherlibs/win32unix/getcwd.c +/otherlibs/win32unix/gethost.c +/otherlibs/win32unix/gethostname.c +/otherlibs/win32unix/getnameinfo.c +/otherlibs/win32unix/getproto.c +/otherlibs/win32unix/getserv.c +/otherlibs/win32unix/gmtime.c +/otherlibs/win32unix/putenv.c +/otherlibs/win32unix/rmdir.c +/otherlibs/win32unix/socketaddr.c +/otherlibs/win32unix/strofaddr.c +/otherlibs/win32unix/time.c +/otherlibs/win32unix/unlink.c +/otherlibs/win32unix/utimes.c + +/parsing/parser.ml +/parsing/parser.mli +/parsing/lexer.ml +/parsing/lexer_tmp.mll +/parsing/lexer_tmp.ml +/parsing/linenum.ml +/parsing/parser.output +/parsing/parser.automaton +/parsing/parser.conflicts + +/stdlib/camlheader +/stdlib/target_camlheader +/stdlib/camlheader[di] +/stdlib/target_camlheader[di] +/stdlib/camlheader_ur +/stdlib/labelled-* +/stdlib/caml +/stdlib/sys.ml + +/testsuite/**/*.result +/testsuite/**/*.opt_result +/testsuite/**/*.corrected +/testsuite/**/*.byte +/testsuite/**/*.native +/testsuite/**/program +/testsuite/**/_log + +/testsuite/_retries + +/testsuite/tests/asmcomp/codegen +/testsuite/tests/asmcomp/parsecmm.ml +/testsuite/tests/asmcomp/parsecmm.mli +/testsuite/tests/asmcomp/lexcmm.ml +/testsuite/tests/asmcomp/*.s +/testsuite/tests/asmcomp/*.out.manifest + +/testsuite/tests/basic/*.safe-string +/testsuite/tests/basic/pr6322.ml + +/testsuite/tests/embedded/caml + +/testsuite/tests/float-unboxing/*.flambda +/testsuite/tests/float-unboxing/float_inline.ml + +/testsuite/tests/lib-dynlink-bytecode/main +/testsuite/tests/lib-dynlink-bytecode/static +/testsuite/tests/lib-dynlink-bytecode/custom +/testsuite/tests/lib-dynlink-bytecode/marshal.data +/testsuite/tests/lib-dynlink-bytecode/caml + +/testsuite/tests/lib-dynlink-native/mypack.pack.s +/testsuite/tests/lib-dynlink-native/mypack.pack.asm +/testsuite/tests/lib-dynlink-native/result +/testsuite/tests/lib-dynlink-native/main +/testsuite/tests/lib-dynlink-native/marshal.data +/testsuite/tests/lib-dynlink-native/caml + +/testsuite/tests/lib-scanf/tscanf_data + +/testsuite/tests/lib-threads/*.byt + +/testsuite/tests/opaque/*/*.mli + +/testsuite/tests/runtime-errors/*.bytecode + +/testsuite/tests/self-contained-toplevel/cached_cmi.ml + +/testsuite/tests/tool-debugger/**/compiler-libs +/testsuite/tests/tool-debugger/find-artifacts/out +/testsuite/tests/tool-debugger/no_debug_event/out +/testsuite/tests/tool-debugger/no_debug_event/c + +/testsuite/tests/tool-ocamldep-modalias/*.byt* +/testsuite/tests/tool-ocamldep-modalias/*.opt* +/testsuite/tests/tool-ocamldep-modalias/depend.mk +/testsuite/tests/tool-ocamldep-modalias/depend.mk2 +/testsuite/tests/tool-ocamldep-modalias/depend.mod +/testsuite/tests/tool-ocamldep-modalias/depend.mod2 +/testsuite/tests/tool-ocamldep-modalias/depend.mod3 + +/testsuite/tests/tool-ocamldoc/*.html +/testsuite/tests/tool-ocamldoc/*.sty +/testsuite/tests/tool-ocamldoc/*.css + +/testsuite/tests/tool-ocamldoc-2/ocamldoc.sty + +/testsuite/tests/tool-ocamldoc-html/*.html +/testsuite/tests/tool-ocamldoc-html/style.css + +/testsuite/tests/tool-ocamldoc-man/*.3o + +/testsuite/tests/tool-ocamldoc-open/alias.odoc +/testsuite/tests/tool-ocamldoc-open/inner.odoc +/testsuite/tests/tool-ocamldoc-open/main.odoc +/testsuite/tests/tool-ocamldoc-open/ocamldoc.sty + +/testsuite/tests/tool-lexyacc/scanner.ml +/testsuite/tests/tool-lexyacc/grammar.mli +/testsuite/tests/tool-lexyacc/grammar.ml + +/testsuite/tests/typing-multifile/a.ml +/testsuite/tests/typing-multifile/b.ml +/testsuite/tests/typing-multifile/c.ml + +/testsuite/tests/unboxed-primitive-args/main.ml +/testsuite/tests/unboxed-primitive-args/stubs.c + +/testsuite/tests/unwind/unwind_test + +/testsuite/tests/warnings/w55.opt.opt_result +/testsuite/tests/warnings/w58.opt.opt_result + +/testsuite/tools/expect_test + +/tools/ocamldep +/tools/ocamldep.opt +/tools/ocamldep.bak +/tools/ocamlprof +/tools/ocamlprof.opt +/tools/opnames.ml +/tools/dumpobj +/tools/dumpobj.opt +/tools/dumpapprox +/tools/ocamlobjinfo +/tools/ocamlobjinfo.opt +/tools/cvt_emit +/tools/cvt_emit.opt +/tools/cvt_emit.bak +/tools/cvt_emit.ml +/tools/ocamlcp +/tools/ocamlcp.opt +/tools/ocamloptp +/tools/ocamloptp.opt +/tools/ocamlmktop +/tools/ocamlmktop.opt +/tools/primreq +/tools/primreq.opt +/tools/ocamldumpobj +/tools/keywords +/tools/lexer299.ml +/tools/ocaml299to3 +/tools/ocamlmklib +/tools/ocamlmklib.opt +/tools/ocamlmklibconfig.ml +/tools/lexer301.ml +/tools/scrapelabels +/tools/addlabels +/tools/objinfo_helper +/tools/read_cmt +/tools/read_cmt.opt +/tools/cmpbyt +/tools/cmpbyt.opt +/tools/stripdebug +/tools/stripdebug.opt +/tools/make_opcodes +/tools/make_opcodes.ml + +/utils/config.ml + +/yacc/ocamlyacc +/yacc/version.h +/yacc/.gdb_history diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..dca1e0d2 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "flexdll"] + path = flexdll + url = https://github.com/alainfrisch/flexdll.git diff --git a/.mailmap b/.mailmap new file mode 100644 index 00000000..b4483d02 --- /dev/null +++ b/.mailmap @@ -0,0 +1,84 @@ +# The format of this file is generally of the form +# +# for example: +# Proper Name +# +# Proper Name Commit Name +# +# See the MAPPING AUTHORS section of 'man git-shortlog' for more details. + +# Such a remapping may be useful in particular for tracking authorship +# of commits erroneously made under an obscure alias or email adress. +# (Some Name , pour ne pas le citer) + +Alain Frisch alainfrisch + + + + + + + + +cvs2svn +Damien Doligez Some Name +Damien Doligez doligez +Mohamed Iguernelala +Jérémie Dimino + +# The aliases below correspond to preference expressed by +# contributors on the name under which they credited, for example +# if they use an opaque nickname from github or mantis: +# +# Preferred Name nickname +# or +# Preferred Name +# Preferred Name +# to indicate a preference associated to a Mantis account. + +Florian Angeletti octachron +Gabriel Radanne Drup +Pierre Weis pierreweis +John Christopher McAlpine chrismamo1 +Runhang Li marklrh +Francis Souther FDSouthern +Simon Cruanes +Frederic Bour +David Sheets +David Allsopp +David Allsopp +Tim Cuthbertson +Grégoire Henry +Julien Moutinho +Adam Borowski +Mikhail Mandrykin +Maverick Woo +Andi McClure +Michael Grünewald +Michael O'Connor +Florian Angeletti +Kenji Tokudome +Philippe Veber +Valentin Gatien-Baron +Stephen Dolan +Junsong Li +Junsong Li +Christophe Raffali +Anton Bachin +Reed Wilson +David Scott +Martin Neuhäußer +Goswin von Brederlow +Thomas Leonard +Thomas Leonard +Adrien Nader +Sébastien Hinderer +Gabriel Scherer +Immanuel Litzroth +Jacques Le Normand + +# These contributors prefer to be referred to pseudonymously + + +tkob tkob +ygrek ygrek diff --git a/.merlin b/.merlin new file mode 100644 index 00000000..38628a47 --- /dev/null +++ b/.merlin @@ -0,0 +1,56 @@ +S ./asmcomp +B ./asmcomp + +S ./middle_end +B ./middle_end + +S ./middle_end/base_types +B ./middle_end/base_types + +S ./bytecomp +B ./bytecomp + +S ./driver +B ./driver + +S ./lex +B ./lex + +S ./otherlibs/bigarray +B ./otherlibs/bigarray + +S ./otherlibs/dynlink +B ./otherlibs/dynlink + +S ./otherlibs/graph +B ./otherlibs/graph + +S ./otherlibs/num +B ./otherlibs/num + +S ./otherlibs/str +B ./otherlibs/str + +S ./otherlibs/systhreads +B ./otherlibs/systhreads + +S ./otherlibs/threads +B ./otherlibs/threads + +S ./otherlibs/unix +B ./otherlibs/unix + +S ./parsing +B ./parsing + +S ./stdlib +B ./stdlib + +S ./toplevel +B ./toplevel + +S ./typing +B ./typing + +S ./utils +B ./utils diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 00000000..324a3827 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1,2 @@ +match_clause=4 +strict_with=auto diff --git a/.travis-ci.sh b/.travis-ci.sh new file mode 100755 index 00000000..2722fef3 --- /dev/null +++ b/.travis-ci.sh @@ -0,0 +1,150 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Anil Madhavapeddy, OCaml Labs * +#* * +#* Copyright 2014 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +PREFIX=~/local + +BuildAndTest () { + case $XARCH in + i386) + cat< /dev/null \ + && CheckNoChangesMessage || echo pass +} + +CheckNoChangesMessage () { + if test -n "$(git log --grep="[Nn]o [Cc]hange.* needed" --max-count=1 $TRAVIS_COMMIT_RANGE)" + then echo pass + elif test -n "$(curl https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels \ + | grep 'no-change-entry-needed')" + then echo pass + else exit 1 + fi +} + +CheckTestsuiteModified () { + cat< /dev/null \ + && exit 1 || echo pass +} + +case $CI_KIND in +build) BuildAndTest;; +changes) + case $TRAVIS_EVENT_TYPE in + pull_request) CheckChangesModified;; + esac;; +tests) + case $TRAVIS_EVENT_TYPE in + pull_request) CheckTestsuiteModified;; + esac;; +*) echo unknown CI kind + exit 1 + ;; +esac diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..40701ea4 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,28 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Anil Madhavapeddy, OCaml Labs * +#* * +#* Copyright 2014 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +sudo: false +language: c +git: + submodules: false +script: bash -ex .travis-ci.sh +matrix: + include: + - env: CI_KIND=build XARCH=i386 + - env: CI_KIND=build XARCH=i386 CONFIG_ARG=-flambda OCAMLRUNPARAM=b,v=0 + - env: CI_KIND=changes + - env: CI_KIND=tests + allow_failures: + - env: CI_KIND=tests diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..fb6fabb3 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,359 @@ +# How to contribute changes + +:+1::tada: First off, thank you for taking time to contribute! :tada::+1: + +The following is a set of guidelines for proposing changes to the +OCaml distribution. These are just guidelines, not rules, use your +best judgment and feel free to propose changes to this document itself +in a pull request. + +This document assumes that you have a patch against the sources of the +compiler distribution, that you wish to submit to the OCaml +maintainers upstream. See [INSTALL.adoc](INSTALL.adoc) for details on +how to build the compiler distribution from sources. See +[HACKING.adoc](HACKING.adoc) for details on how to modify the sources. + +## Contribution + +Modifying its sources is far from the only way to contribute to the +OCaml distribution. Bug reports (in particular when they come with +a reproducible example), simple typos or clarifications in the +documentation also help, and help evaluating and integrating existing +change proposals also help. Providing good answers on the discussion +forums, or asking the good questions that highlight deficiencies in +existing documentations, also help. We currently have more +contributors willing to propose changes than contributors willing to +review other people's changes, so more eyes on the existing change +requests is a good way to increase the integration bandwidth of +external contributions. + +There are also many valuable ways to contribute to the wider OCaml +ecosystem that do not involve changes to the OCaml distribution. + +The rest of the document is concerned with the form of change +proposals against the OCaml distribution. (Code changes, but also +improvement to documentation or implementation comments, which are +valuable changes on their own.) + + +## Coding guidelines + +You should not leave trailing whitespace; not have line longer than 80 +columns, not use tab characters (spaces only), and not use non-ASCII +characters. These typographical rules can be checked with the script +`tools/check-typo`. + +Otherwise, there are no strongly enforced guidelines specific to the +compiler -- and, as a result, the style may differ in the different +parts of the compiler. The general [OCaml Programming +Guidelines](https://ocaml.org/learn/tutorials/guidelines.html) are +good to keep in mind, and otherwise we strive for good taste and local +consistency (following the code located around your change). + +If you strongly feel that a style-related change would improve quality +of the existing code (for example, giving more descriptive names to +some variables throughout a module, factoring repeated code patterns +as auxiliary functions, or adding comments to document a part of the +code that you had trouble understanding), you can have code cleanup +commits at the beginning of your patch series, or submit code cleanups +as your change proposal. Those cleanups should remain separate commits +from the functional changes in the rest of the patch series; it is +easier to review commits that are specifically marked as exactly +preserving the code semantics. + + +## Test you must. + +Whenever applicable, merge requests must come with tests +exercising the affected features: regression tests for bug fixes, +and correctness tests for new features (including corner cases and +failure cases). For regression tests, testing other aspects of the +feature (in particular, related edge cases) that are not currently +covered is a good way to catch other instances of bugs -- this did +happen several times in the past. Warnings and errors should also +be tested. + +Tests go in the sub-directories of `testsuite/tests`. Running +`make all` in `testsuite/` runs all tests (this takes +a few minutes), and you can use `make one DIR=tests/foo` to run +the tests of a specific sub-directory. There are many kind of tests +already, so the easiest way to start is to extend or copy an +existing test. + +In general, running a test produces one (or several) `.result` file, +that are compared to one (or several) `.reference` file present in the +repository; the test succeeds if they are identical. If your patch +breaks a test, diffing the `.result` and `.reference` file is a way to +see what went wrong. Some reasonable compiler changes affect the +compiler output in way that make those outputs differ (for example +slight modifications of warning or error messages may break all tests +checking warnings). If you are positive that the new `.result` file +is correct (and that the change in behavior does not endanger +backward compatibility), you can replace the old `.reference` file +with it. Finally, when adding new tests, do not forget to include your +`.reference` files (but not `.result`) in the versioned repository. + +Testing is also a way to make sure reviewers see working +(and failing) examples of the feature you fix, extend or +introduce, rather than just an abstract description of it. + + +### Run tests before sending a PR + +You should run all the tests before creating the merge request or +pushing new commits (even if Travis will also do it for you): `make +tests` (this takes a few minutes). + +Unfortunately some of the `lib-threads` test are non-deterministic +and fail once in a while (it's hard to test these well). If they +consistently break after your change, you should investigate, but if +you only see a transient failure once and your change has no reason +to affect threading, it's probably not your fault. + + +## Description of the proposed change + +### In the merge request interface + +The description of the merge request must contain a precise +explanation of the proposed change. + +Before going in the implementation details, you should include +a summary of the change, and a high-level description of the design +of the proposed change, with example use-cases. + +### In the patches + +If some of the explanations you provide for the merge request would +make sense as comments in the code, or documentation in the manual, +you should include them there as well. + +In-code comments help make the codebase more accessible to newcomers +(many places in the compiler could benefit from a few +extra explanations), and they are also useful to code reviewers. In +particular, any subtlety in code that cannot be made +self-explanatory should come with an explanation in comment. If you +add some non-obvious code specifically to fix a bug, include the +issue number in comments. + +Do not assume that code reviewers are all experts in the existing +codebase. If you use subtle code, add a comment, even if the same +kind of code is used somewhere else in the same module. (If this is +a common and useful domain-specific idiom that is already explained +somewhere, pointing to this explanation in your commit message is +better than adding redundant explanations.) + +### User documentation + +Changes affecting the compiler libraries should be reflected in the +documentation comments of the relevant `.mli` files. + +It is recommended to included changes to the OCaml Reference Manual +(in particular for any change in the surface language), which is now +part of the main repository (under `manual/`). + +Finally, changes in command-line options should be integrated in the +manual, but also in the man pages present in the `man/` sub-directory +of the OCaml distribution. + +### Changelog + +Any user-visible change should have a `Changes` entry: + +- in the right section (named sections if major feature, generic + "Bug fixes" and "Feature requests" otherwise) + +- using the label "`*`" if it breaks existing programs, "`-`" otherwise + +- with the issue number `PR#{N}` if from mantis, `GPR#{N}` if from github + (several numbers separated by commas can be used) + +- maintaining the order: each section lists Mantis PRs first in ascending + numerical order, followed by Github PRs in ascending numerical order, + followed by changes that are not related to a PR. + +- with a concise readable description of the change (possibly taken + from a commit message, but it should make sense to end-users + reading release notes) + +- crediting the people that worked on the feature + + The people that wrote the code should be credited of course, + but also substantial code reviews or design advice, and the + reporter of the bug (if applicable) or designer of the + feature request (if novel). + +- following the format + + {label} {issue number(s)}: {readable description} + ({credits}) + + note that the `{credits}` should be on their own line, aligned with the + issue number for readability + (`{readable description}` can be multiline to not overflow 80 + columns, and should be aligned with the issue number as well.) + +This changelog can be included in the main commit, if the merge +request is just one patch, or as a separate commit, if it's +a patch series and no particular commit feels best suited to +receive the Changelog entry. + +(Do not under-estimate the importance of a good changelog. Users do + read the release notes, and things forgotten from the changelog + will cause pain or regrets down the line.) + + +## Clean patch series + +Clean patch series are useful, both during the review process and +for code maintenance after it has been merged. Before submitting +your request, you should rebase your patch series: + +- on top of the OCaml branch in which you want to merge + (usually `trunk`), solving any conflicts. + +- into a few well-separated, self-contained patches (github PRs + can generate gazillions of micro-changes) + +- erasing history that does not make sense after the issue is merged + (back-and-forth between different designs, etc. The PR number + allows interested people to go back to the original discussion if + needed.) + +- bisectable: the distribution should be in a good state after + the application of each patch (in particular, later commits that + fix bugs in previous commits should always be squashed into the commit + they fix) + +- with readable commit messages (this is for future developers + needing to understand a change that happened in the past). Commit + messages should not overflow 80 columns, with the following format: + + {one-liner header description (with issue number if applicable)} + {blank line} + {one or several paragraphs of explanation if needed} + +During review, you may make many other changes to the patch +series. You can rebase it on the fly (if you `git push -f` on the +branch of the pull request in your personal clone, Github will +update the pull request automatically; remember to always create +a new branch for any) or wait until the discussion has converged, +once we agree the request is ready for merging. Doing a good +rebase is grunt work that takes some time and care (use `git +log -u` to make sure the rebase patches make sense), but: + +- It is easier and faster to do for the author of the patch than + for others (if rebasing against the current trunk creates + a conflict with another change you don't understand well, feel + free to ask). + +- Maintainers are usually short on time, and asking them to do + a rebase means they have less time to review and merge other + contributions. + +- The long-term benefits of keeping a clean, bisectable history + cannot be overstated. Imagine that in three years, under the + pressure of a coming release, a contributor ends up somewhere in + the middle of your patch series, wondering if or why it is the + cause of a specific issue. Wasting his or her time then + (with a "yolo" commit message, a big ugly commit of unrelated + changes, or an un-testable intermediary state) is a sure way to + generate ill will. + +## Contributing to the standard library + +Contributions to the standard library are very welcome. There is some +widespread belief in the community than the stdlib is somehow "frozen" +and that its evolutions are mostly driven by the need of the OCaml +compiler itself. Let's be clear: this is just plain wrong. The +compiler is happy with its own local utility functions, and many +recent additions to the stdlib are not used by the compiler. + +Another common and wrong idea is that core OCaml maintainers don't +really care about the standard library. This is not true, and won't +be unless one of the "alternative standard" libraries really gains +enough "market share" in the community. + +So: please contribute! + +Obviously, the proposals to evolve the standard library will be +evaluated with very high standards, similar to those applied to the +evolution of the surface langage, and much higher than those for +internal compiler changes (optimizations, etc). + +A key property of the standard library is its stability. Backward +compatibility is not an absolute technical requirement (any addition +to/of a module can break existing code, formally), but breakage should +be limited as much as possible (and assessed, when relevant). A +corollary is that any addition creates a long-term support commitment. +For instance, once a concrete type or function is made public, +changing the exposed definition cannot be done easily. + +There is no plan to extend dramatically the functional domain covered +by the standard library. For instance, proposals to include support +for XML, JSON, or network protocols are very likely to be rejected. Such +domains are better treated by external libraries. Small additions to +existing modules are much simpler to get in, even more so (but not +necessarily) when: + + - they cannot easily be implemented externally, or when + - they facilitate communication between independent external + libraries, or when + - they fill obvious gaps. + +Of course, standard guidelines apply as well: proper documentation, +proper tests, portability (yes, also Windows!), good justification for +why the change is desirable and why it should go into stdlib. + +So: be prepared for some serious review process! But yes, yes, +contributions are welcome and appreciated. Promised. + + +## Contributor License Agreement + +We distinguish two kind of contributions: + +- Small changes that do not bear a specific mark of their authors + (another developer recreating the change without access to the + original patch would write an indistinguishable patch), and are thus + not protected by copyright, do not require any particular + paperwork. This is convenient for everyone, and of course does not + mean that those contributions are of lesser importance. (For example + a bugfix can be obvious once a bug is understood, reported and + reproduced, and yet invaluable for users.) + +- Larger changes that are covered by copyright. For them, we require + contributors to sign a Contributor License Agreement (CLA), which + gives [INRIA](http://www.inria.fr/en/) (Institut National de + Recherche en Informatique et en Automatique) the rights to integrate + the contribution, maintain it, evolve it, and redistribute it under + the license of its choice. This is not a copyright *assignment* + (as requested by the Free Software Foundation for example), + contributors retain the copyright on their contribution, and can use + it as they see fit. The OCaml CLA is lightly adapted from [the + CLA](https://www.apache.org/licenses/icla.txt) of the Apache + Foundation, and is available in two versions: [for individual + contributors](http://caml.inria.fr/pub/docs/CLA-individual.doc) and + [for corporations](http://caml.inria.fr/pub/docs/CLA-corporate.doc). + +You must understand that, by proposing a contribution for integration +in the OCaml distribution, you accept that it be considered under one +of those regimes. In particular, in all cases you give INRIA the +permission to freely re-license the OCaml distribution including the +contribution. + +This ability to re-license allows INRIA to provide members of the +[Caml Consortium](http://caml.inria.fr/consortium/) with a license on +the Caml code base that is more permissive than the public license. + +### How to sign the CLA + +If your contribution is large enough, you should sign the CLA. If you +are contributing on your own behalf, you should sign [the individual +CLA](http://caml.inria.fr/pub/docs/CLA-individual.doc). For corporate +contributions, if your employer has not already done so, they should +sign [the corporate +CLA](http://caml.inria.fr/pub/docs/CLA-corporate.doc). Review the CLA, +sign it, and send it -- scanned PDF by email, or postail mail -- to +Xavier Leroy ([contact +info](http://gallium.inria.fr/%7Exleroy/contact.html)). diff --git a/Changes b/Changes new file mode 100644 index 00000000..cc59f635 --- /dev/null +++ b/Changes @@ -0,0 +1,6338 @@ +OCaml 4.05.0 (13 Jul 2017): +--------------------------- + +(Changes that can break existing programs are marked with a "*") + +### Language features: + +### Code generation and optimizations: + +- MPR#7201, GPR#954: Correct wrong optimisation of "0 / " + and "0 mod " in the case when was a non-constant + evaluating to zero + (Mark Shinwell, review by Gabriel Scherer, Leo White and Xavier Leroy) + +- MPR#7357, GPR#832: Improve compilation time for toplevel + include(struct ... end : sig ... end) + (Alain Frisch, report by Hongbo Zhang, review by Jacques Garrigue) + +- MPR#7533, GPR#1173: Correctly perform side effects for certain + cases of "/" and "mod" + (Mark Shinwell, report by Jan Mitgaard) + +- GPR#504: Instrumentation support for fuzzing with afl-fuzz. + (Stephen Dolan, review by Alain Frisch, Pierre Chambart, Mark + Shinwell, Gabriel Scherer and Damien Doligez) + +- GPR#863, GPR#1068, GPR#1069: Optimise matches with constant + results to lookup tables. + (Stephen Dolan, review by Gabriel Scherer, Pierre Chambart, + Mark Shinwell, and bug report by Gabriel Scherer) + +- GPR#1150: Fix typo in arm64 assembler directives + (KC Sivaramakrishnan) + +### Runtime system: + +- MPR#385, GPR#953: Add caml_startup_exn + (Mark Shinwell) + +- MPR#7423, GPR#946: expose new exception-raising functions + `void caml_{failwith,invalid_argument}_value(value msg)` + in addition to + `void caml_{failwith,invalid_argument}(char const *msg)`. + The previous functions would not free their message argument, so + were inconvient for dynamically-allocated messages; the messages + passed to the new functions are handled by the garbage collector. + (Gabriel Scherer, review by Mark Shinwell, request by Immanuel Litzroth) + +- MPR#7557, GPR#1213: More security for getenv + (Damien Doligez, reports by Seth Arnold and Eric Milliken, review by + Xavier Leroy, David Allsopp, Stephen Dolan, Hannes Mehnert) + +- GPR#795: remove 256-character limitation on Sys.executable_name + (Xavier Leroy) + +- GPR#891: Use -fno-builtin-memcmp when building runtime with gcc. + (Leo White) + +### Type system: + +- MPR#6608, GPR#901: unify record types when overriding all fields + (Tadeu Zagallo and Gabriel Scherer, report by Jeremy Yallop, + review by David Allsopp, Jacques Garrigue) + +* MPR#7414, GPR#929: Soundness bug with non-generalized type variables and + functors. + (Jacques Garrigue, report by Leo White) + +### Compiler user-interface and warnings: + +- MPR#7050, GPR#748 GPR#843 GPR#864: new `-args/-args0 ` parameters to + provide extra command-line arguments in a file -- see documentation. + User programs may implement similar options using the new `Expand` + constructor of the `Arg` module. + (Bernhard Schommer, review by Jérémie Dimino, Gabriel Scherer + and Damien Doligez, discussion with Alain Frisch and Xavier Leroy, + feature request from the Coq team) + +- MPR#7137, GPR#960: "-open" command line flag now accepts + a module path (not a module name) + (Arseniy Alekseyev and Leo White) + +- MPR#7172, GPR#970: add extra (ocamlc -config) options + int_size, word_size, ext_exe + (Gabriel Scherer, request by Daniel Bünzli) + +- MPR#7315, GPR#736: refine some error locations + (Gabriel Scherer and Alain Frisch, report by Matej Košík) + +- MPR#7473, GPR#1025: perform proper globbing for command-line arguments on + Windows + (Jonathan Protzenko) + +- MPR#7479: make sure "ocamlc -pack" is only given .cmo and .cmi files, + and that "ocamlopt -pack" is only given .cmx and .cmi files. + (Xavier Leroy) + +- GPR#796: allow compiler plugins to declare their own arguments. + (Fabrice Le Fessant) + +- GPR#829: better error when opening a module aliased to a functor + (Alain Frisch) + +- GPR#911: ocamlc/ocamlopt do not pass warnings-related options to C + compiler when called to compile third-party C source files + (Sébastien Hinderer, review by Adrien Nader and David Allsopp) + +- GPR#915: fix -dsource (pprintast.ml) bugs + (Runhang Li, review by Alain Frisch) + +* GPR#933: ocamlopt -p now reports an error on platforms that do not + support profiling with gprof; dummy profiling libraries are no longer + installed on such platforms. + This can be tested with ocamlopt -config + (Sébastien Hinderer) + +- GPR#1009: "ocamlc -c -linkall" and "ocamlopt -c -linkall" can now be used + to set the "always link" flag on individual compilation units. This + controls linking with finer granularity than "-a -linkall", which sets + the "always link" flag on all units of the given library. + (Xavier Leroy) + +- GPR#1015: add option "-plugin PLUGIN" to ocamldep too. Use compilerlibs + to build ocamldep. + (Fabrice Le Fessant) + +- GPR#1027: various improvements to -dtimings, mostly including time + spent in subprocesses like preprocessors + (Valentin Gatien-Baron, review by Gabriel Scherer) + +- GPR#1098: the compiler now takes the boolean "OCAML_COLOR" environment + variable into account if "-color" is not provided. This allows users + to override the default behaviour without modifying invocations of ocaml + manually. + (Hannes Mehnert, Guillaume Bury, + review by Daniel Bünzli, Gabriel Scherer, Damien Doligez) + +### Standard library: + +- MPR#6975, GPR#902: Truncate function added to stdlib Buffer module + (Dhruv Makwana, review by Alain Frisch and Gabriel Scherer) + +- MPR#7279, GPR#710: `Weak.get_copy` `Ephemeron.*_copy` doesn't copy + custom blocks anymore + (François Bobot, Alain Frisch, bug reported by Martin R. Neuhäußer, + review by Thomas Braibant and Damien Doligez) + +* MPR#7500, GPR#1081: Remove Uchar.dump + (Daniel Bünzli) + +- GPR#760: Add a functions List.compare_lengths and + List.compare_length_with to avoid full list length computations + (Fabrice Le Fessant, review by Leo White, Josh Berdine and Gabriel Scherer) + +- GPR#778: Arg: added option Expand that allows to expand a string + argument to a string array of new arguments + (Bernhard Schommer, review by Gabriel Scherer and Jérémie Dimino) + +- GPR#849: Expose a Spacetime.enabled value + (Leo White) + +- GPR#885: Option-returning variants of stdlib functions + (Alain Frisch, review by David Allsopp and Bart Jacobs) + +- GPR#869: Add find_first, find_first_opt, find_last, find_last_opt to + maps and sets. Find the first or last binding or element + satisfying a monotonic predicate. + (Gabriel de Perthuis, with contributions from Alain Frisch, review by + Hezekiah M. Carty and Simon Cruanes, initial report by Gerd Stolpmann) + +- GPR#875: Add missing functions to ArrayLabels, BytesLabels, + ListLabels, MoreLabels, StringLabels so they are compatible with + non-labeled counterparts. Also add missing @@ocaml.deprecated attributes + in StringLabels and BytesLabels. + (Roma Sokolov, review by Gabriel Scherer, Jacques Garrigue, + Gabriel Radanne, Alain Frisch) + +- GPR#999: Arg, do not repeat the usage message thrice when reporting an error + (this was a regression in 4.03) + (Florian Angeletti, review by Gabriel Scherer) + +- GPR#1042: Fix escaping of command-line arguments in + Unix.create_process{,_env} under Windows. Arguments with tabs should now + be received verbatim by the child process. + (Nicolas Ojeda Bar, Andreas Hauptmann review by Xavier Leroy) + +### Debugging and profiling: + +- MPR#7258: ocamldebug's "install_printer" command had problems with + module aliases + (Xavier Leroy) + +- GPR#378: Add [Printexc.raise_with_backtrace] to raise an exception using + an explicit backtrace + (François Bobot, review by Gabriel Scherer, Xavier Leroy, Damien Doligez, + Frédéric Bour) + +### Manual and documentation: + +- MPR#6597, GPR#1030: add forward references to language extensions + that extend non-terminal symbols in the language reference section. + (Florian Angeletti, review by Gabriel Scherer) + +- MPR#7497, GPR#1095: manual, enable numbering for table of contents + (Florian Angeletti, request by Daniel Bünzli) + +- MPR#7539, GPR#1181: manual, update dead links in ocamldoc chapter + (Florian Angeletti) + +- GPR#633: manpage and manual documentation for the `-opaque` option + (Konstantin Romanov, Gabriel Scherer, review by Mark Shinwell) + +- GPR#751, GPR#925: add a HACKING.adoc file to contain various + tips and tricks for people hacking on the repository. See also + CONTRIBUTING.md for advice on sending contributions upstream. + (Gabriel Scherer and Gabriel Radanne, review by David Allsopp, + inspired by John Whitington) + +- GPR#916: new tool lintapidiff, use it to update the manual with + @since annotations for API changes introduced between 4.00-4.05. + (Edwin Török, review by Gabriel Scherer, discussion with Alain Frisch, + David Allsopp, Sébastien Hinderer, Damien Doligez and Xavier Leroy) + +- GPR#939: activate the caml_example environment in the language + extensions section of the manual. Convert some existing code + examples to this format. + (Florian Angeletti) + +- GPR#1082: clarify that the use of quoted string for preprocessed + foreign quotations still requires the use of an extension node + [%foo ...] to mark non-standard interpretation. + (Gabriel Scherer, request by Matthew Wahab in GPR#1066, + review by Florian Angeletti) + +### Other libraries: + +- MPR#7158: Event.sync, Mutex.create, Condition.create cause too many GCs. + The fix is to no longer consider mutexes and condition variables + as rare kernel resources. + (Xavier Leroy) + +- MPR#7264: document the different behaviors of Unix.lockf under POSIX + and under Win32. + (Xavier Leroy, report by David Allsopp) + +- MPR#7339, GPR#787: Support the '0 dimension' case for bigarrays + (see Bigarray documentation) + (Laurent Mazare, + review by Gabriel Scherer, Alain Frisch and Hezekiah M. Carty) + +* MPR#7342, GPR#797: fix Unix.read on pipes with no data left on Windows + it previously raised an EPIPE error, it now returns 0 like other OSes + (Jonathan Protzenko, review by Andreas Hauptmann and Damien Doligez) + +- GPR#650: in the Unix library, add `?cloexec:bool` optional arguments to + functions that create file descriptors (`dup`, `dup2`, `pipe`, `socket`, + `socketpair`, `accept`). Implement these optional arguments in the + most atomic manner provided by the operating system to set (or clear) + the close-on-exec flag at the same time the file descriptor is created, + reducing the risk of race conditions with `exec` or `create_process` + calls running in other threads, and improving security. Also: add a + `O_KEEPEXEC` flag for `openfile` by symmetry with `O_CLOEXEC`. + (Xavier Leroy, review by Mark Shinwell, David Allsopp and Alain Frisch, + request by Romain Beauxis) + +- GPR#996: correctly update caml_top_of_stack in systhreads + (Fabrice Le Fessant) + +### Toplevel: + +- MPR#7060, GPR#1035: Print exceptions in installed custom printers + (Tadeu Zagallo, review by David Allsopp) + +### Tools: + +- MPR#5163: ocamlobjinfo, dump globals defined by bytecode executables + (Stéphane Glondu) + +- MPR#7333: ocamldoc, use the first sentence of text file as + a short description in overviews. + (Florian Angeletti) + +- GPR#848: ocamldoc, escape link targets in HTML output + (Etienne Millon, review by Gabriel Scherer, Florian Angeletti and + Daniel Bünzli) + +- GPR#986: ocamldoc, use relative paths in error message + to solve ocamlbuild+doc usability issue (ocaml/ocamlbuild#79) + (Gabriel Scherer, review by Florian Angeletti, discussion with Daniel Bünzli) + +- GPR#1017: ocamldoc, add an option to detect code fragments that could be + transformed into a cross-reference to a known element. + (Florian Angeletti, review and suggestion by David Allsopp) + +- clarify ocamldoc text parsing error messages + (Gabriel Scherer) + +### Compiler distribution build system: + +- MPR#7377: remove -std=gnu99 for newer gcc versions + (Damien Doligez, report by ygrek) + +- MPR#7452, GPR#1228: tweak GCC options to try to avoid the + Skylake/Kaby lake bug + (Damien Doligez, review by David Allsopp, Xavier Leroy and Mark Shinwell) + +- GPR#693: fail on unexpected errors or warnings within caml_example + environment. + (Florian Angeletti) + +- GPR#803: new ocamllex-based tool to extract bytecode compiler + opcode information from C headers. + (Nicolas Ojeda Bar) + +- GPR#827: install missing mli and cmti files, new make target + install-compiler-sources for installation of compiler-libs ml files + (Hendrik Tews) + +- GPR#887: allow -with-frame-pointers if clang is used as compiler on Linux + (Bernhard Schommer) + +- GPR#898: fix locale-dependence of primitive list order, + detected through reproducible-builds.org. + (Hannes Mehnert, review by Gabriel Scherer and Ximin Luo) + +- GPR#907: Remove unused variable from the build system + (Sébastien Hinderer, review by whitequark, Gabriel Scherer, Adrien Nader) + +- GPR#911: Clarify the use of C compiler related variables in the build system. + (Sébastien Hinderer, review by Adrien Nader, Alain Frisch, David Allsopp) + +- GPR#919: use clang as preprocessor assembler if clang is used as compiler + (Bernhard Schommer) + +- GPR#927: improve the detection of hashbang support in the configure script + (Armaël Guéneau) + +- GPR#932: install ocaml{c,lex}->ocaml{c,lex}.byte symlink correctly + when the opt target is built but opt.opt target is not. + (whitequark, review by Gabriel Scherer) + +- GPR#935: allow build in Android's termux + (ygrek, review by Gabriel Scherer) + +- GPR#984: Fix compilation of compiler distribution when Spacetime + enabled + (Mark Shinwell) + +- GPR#991: On Windows, fix installation when native compiler is not + built + (Sébastien Hinderer, review by David Allsopp) + +- GPR#1033: merge Unix and Windows build systems in the root directory + (Sébastien Hinderer, review by Damien Doligez and Adrien Nader) + +- GPR#1047: Make .depend files generated for C sources more portable + (Sébastien Hinderer, review by Xavier Leroy and David Allsopp) + +- GPR#1076: Simplify ocamlyacc's build system + (Sébastien Hinderer, review by David Allsopp) + +### Compiler distribution build system: Makefile factorization + +The compiler distribution build system (the set of Makefiles used to +build the compiler distribution) traditionally had separate Makefiles +for Unix and Windows, which lead to some amount of duplication and +subtle differences and technical debt in general -- for people working +on the compiler distribution, but also cross-compilation or porting to +new systems. During the 4.05 development period, Sébastien Hinderer +worked on harmonizing the build rules and merging the two build +systems. + +* Some changes were made to the config/Makefile file which + is exported as $(ocamlc -where)/Makefile.config, and on + which some advanced users might rely. The changes are + as follows: + - a BYTERUN variable was added that points to the installed ocamlrun + - the PARTIALLD variable was removed (PACKLD is more complete) + - the always-empty DLLCCCOMPOPTS was removed + - the SHARED variable was removed; its value is "shared" or "noshared", + which duplicates the existing and more convenient + SUPPORTS_SHARED_LIBRARIES variable whose value is "true" or "false". + + Note that Makefile.config may change further in the future and relying + on it is a bit fragile. We plan to make `ocamlc -config` easier to use + for scripting purposes, and have a stable interface there. If you rely + on Makefile.config, you may want to get in touch with Sébastien Hinderer + or participate to MPR#7116 (Allow easy retrieval of Makefile.config's values) + or MPR#7172 (More information in ocamlc -config). + +The complete list of changes is listed below. + +- GPR#705: update Makefile.nt so that ocamlnat compiles + for non-Cygwin Windows ports. + (Sébastien Hinderer, review by Alain Frisch) + +- GPR#729: Make sure ocamlnat is built with a $(EXE) extension, merge + rules between Unix and Windows Makefiles + (Sébastien Hinderer, review by Alain Frisch) + +- GPR#762: Merge build systems in the yacc/ directory. + (Sébastien Hinderer, review by David Allsopp, Alain Frisch) + +- GPR#764: Merge build systems in the debugger/ directory. + (Sébastien Hinderer, review by Alain Frisch) + +- GPR#785: Merge build systems in otherlibs/systhreads/ + (Sébastien Hinderer, review by Alain Frisch, David Allsopp, + testing and regression fix by Jérémie Dimino) + +- GPR#788: Merge build systems in subdirectories of otherlibs/. + (Sébastien Hinderer, review by Alain Frisch) + +- GPR#808, GPR#906: Merge Unix and Windows build systems + in the ocamldoc/ directory + (Sébastien Hinderer, review by Alain Frisch) + +- GPR#812: Merge build systems in the tools/ subdirectory + (Sébastien Hinderer, review by Alain Frisch) + +- GPR#866: Merge build systems in the stdlib/ directory + (Sébastien Hinderer, review by David Allsopp and Adrien Nader) + +- GPR#941: Merge Unix and Windows build systems in the asmrun/ directory + (Sébastien Hinderer, review by Mark Shinwell, Adrien Nader, + Xavier Leroy, David Allsopp, Damien Doligez) + +- GPR#981: Merge build systems in the byterun/ directory + (Sébastien Hinderer, review by Adrien Nader) + +- GPR#1033, GPR#1048: Merge build systems in the root directory + (Sébastien Hinderer, review by Adrien Nader and Damien Doligez, + testing and regression fix by Andreas Hauptmann) + +### Internal/compiler-libs changes: + +- GPR#673: distinguish initialization of block fields from mutation in lambda. + (Frédéric Bour, review by Xavier Leroy, Stephen Dolan and Mark Shinwell) + +- GPR#744, GPR#781: fix duplicate self-reference in imported cmi_crcs + list in .cmti files + avoid rebuilding cmi_info record when creating + .cmti files + (Alain Frisch, report by Daniel Bünzli, review by Jérémie Dimino) + +- GPR#881: change `Outcometree.out_variant` to be more general. + `Ovar_name of out_ident * out_type list` becomes `Ovar_type of out_type`. + (Valentin Gatien-Baron, review by Leo White) + +- GPR#908: refactor PIC-handling in the s390x backend + (Gabriel Scherer, review by Xavier Leroy and Mark Shinwell) + +### Bug fixes + +- MPR#5115: protect all byterun/fail.c functions against + uninitialized caml_global_data (only changes the bytecode behavior) + (Gabriel Scherer, review by Xavier Leroy) + +- MPR#6136, GPR#967: Fix Closure so that overapplication evaluation order + matches the bytecode compiler and Flambda. + (Mark Shinwell, report by Jeremy Yallop, review by Frédéric Bour) + +- MPR#6550, GPR#1094: Allow creation of empty .cmxa files on macOS + (Mark Shinwell) + +- MPR#6594, GPR#955: Remove "Istore_symbol" specific operation on x86-64. + This is more robust and in particular avoids assembly failures on Win64. + (Mark Shinwell, review by Xavier Leroy, testing by David Allsopp and + Olivier Andrieu) + +- MPR#6903: Unix.execvpe doesn't change environment on Cygwin + (Xavier Leroy, report by Adrien Nader) + +- MPR#6987: Strange error message probably caused by + universal variable escape (with polymorphic variants) + (Jacques Garrigue, report by Mikhail Mandrykin and Leo White) + +- MPR#7216, GPR#949: don't require double parens in Functor((val x)) + (Jacques Garrigue, review by Valentin Gatien-Baron) + +- MPR#7331: ocamldoc, avoid infinite loop in presence of self alias, + i.e. module rec M:sig end = M + (Florian Angeletti, review Gabriel Scherer) + +- MPR#7346, GPR#966: Fix evaluation order problem whereby expressions could + be incorrectly re-ordered when compiling with Flambda. This also fixes one + example of evaluation order in the native code compiler not matching the + bytecode compiler (even when not using Flambda) + (Mark Shinwell, Leo White, code review by Pierre Chambart) + +- MPR#7348: Private row variables can escape their scope + (Jacques Garrigue, report by Leo White) + +- MPR#7407: Two not-quite-standard C idioms rejected by SUNWSPro compilers + (Xavier Leroy) + +- MPR#7421: Soundness bug with GADTs and lazy + (Jacques Garrigue, report by Leo White) + +- MPR#7424: Typechecker diverges on unboxed type declaration + (Jacques Garrigue, report by Stephen Dolan) + +- MPR#7426, GPR#965: Fix fatal error during object compilation (also + introduces new [Pfield_computed] and [Psetfield_computed] primitives) + (Mark Shinwell, report by Ulrich Singer) + +- MPR#7427, GPR#959: Don't delete let bodies in Cmmgen + (Mark Shinwell, report by Valentin Gatien-Baron) + +- MPR#7432: Linking modules compiled with -labels and -nolabels is not safe + (Jacques Garrigue, report by Jeremy Yallop) + +- MPR#7437: typing assert failure with nonrec priv + (Jacques Garrigue, report by Anil Madhavapeddy) + +- MPR#7438: warning +34 exposes #row with private types + (Alain Frisch, report by Anil Madhavapeddy) + +- MPR#7443, GPR#990: spurious unused open warning with local open in patterns + (Florian Angeletti, report by Gabriel Scherer) + +- MPR#7504: fix warning 8 with unconstrained records + (Florian Angeletti, report by John Whitington) + +- MPR#7456, GPR#1092: fix slow compilation on source files containing a lot + of similar debugging information location entries + (Mark Shinwell) + +- GPR#795: remove 256-character limitation on Sys.executable_name + (Xavier Leroy) + +- GPR#805, GPR#815, GPR#833: check for integer overflow in String.concat + (Jeremy Yallop, + review by Damien Doligez, Alain Frisch, Daniel Bünzli, Fabrice Le Fessant) + +- GPR#881: short-paths did not apply to some polymorphic variants + (Valentin Gatien-Baron, review by Leo White) + +- GPR#886: Fix Ctype.moregeneral's handling of row_name + (Leo White, review by Jacques Garrigue) + +- GPR#934: check for integer overflow in Bytes.extend + (Jeremy Yallop, review by Gabriel Scherer) + +- GPR#956: Keep possibly-effectful expressions when optimizing multiplication + by zero. + (Jeremy Yallop, review by Nicolás Ojeda Bär, Xavier Leroy and Mark Shinwell) + +- GPR#977: Catch Out_of_range in ocamldebug's "list" command + (Yunxing Dai) + +- GPR#983: Avoid removing effectful expressions in Closure, and + eliminate more non-effectful ones + (Alain Frisch, review by Mark Shinwell and Gabriel Scherer) + +- GPR#987: alloc_sockaddr: don't assume a null terminator. It is not inserted + on macOS by system calls that fill in a struct sockaddr (e.g. getsockname). + (Anton Bachin) + +- GPR#998: Do not delete unused closures in un_anf.ml. + (Leo White, review by Mark Shinwell and Pierre Chambart) + +- GPR#1019: Fix fatal error in Flambda mode "[functions] does not map set of + closures ID" + (Pierre Chambart, code review by Mark Shinwell and Leo White) + +- GPR#1075: Ensure that zero-sized float arrays have zero tags. + (Mark Shinwell, Leo White, review by Xavier Leroy) + +* GPR#1088: Gc.minor_words now returns accurate numbers. + (Stephen Dolan, review by Pierre Chambart and Xavier Leroy) + +OCaml 4.04.2 (23 Jun 2017): +--------------------------- + +### Security fix: + +- PR#7557: Local privilege escalation issue with ocaml binaries. + (Damien Doligez, report by Eric Milliken, review by Xavier Leroy) + +OCaml 4.04.1 (14 Apr 2017): +--------------------------- + +- PR#7501, GPR#1089: Consider arrays of length zero as constants + when using Flambda. + (Pierre Chambart, review by Mark Shinwell and Leo White) + +### Standard library: + +- PR#7403, GPR#894: fix a bug in Set.map as introduced in 4.04.0 + (Gabriel Scherer, report by Thomas Leonard) + +### Tools: + +- PR#7411: ocamldoc, avoid nested 
 tags in module description.
+  (Florian Angeletti, report by user 'kosik')
+
+- PR#7488: ocamldoc, wrong Latex output for variant types
+  with constructors without arguments.
+  (Florian Angeletti, report by Xavier Leroy)
+
+### Build system:
+
+- PR#7373, GPR#1023: New flexlink target in Makefile.nt to bootstrap the
+  flexlink binary only, rather than the flexlink binary and the FlexDLL C
+  objects.
+  (David Allsopp)
+
+### Bug fixes
+
+- PR#7369: Str.regexp raises "Invalid_argument: index out of bounds"
+  (Damien Doligez, report by John Whitington)
+
+- PR#7373, GPR#1023: Fix ocamlmklib with bootstrapped FlexDLL. Bootstrapped
+  FlexDLL objects are now installed to a subdirectory flexdll of the Standard
+  Library which allows the compilers to pick them up explicitly and also
+  ocamlmklib to include them without unnecessarily adding the entire Standard
+  Library.
+  (David Allsopp)
+
+- PR#7385, GPR#1057: fix incorrect timestamps returned by Unix.stat on Windows
+  when either TZ is set or system date is in DST.
+  (David Allsopp, report and initial fix by Nicolás Ojeda Bär, review and
+   superior implementation suggestion by Xavier Leroy)
+
+- PR#7405, GPR#903: s390x: Fix address of caml_raise_exn in native dynlink modules
+  (Richard Jones, review by Xavier Leroy)
+
+- PR#7417, GPR#930: ensure 16 byte stack alignment inside caml_allocN on x86-64
+  for ocaml build with WITH_FRAME_POINTERS defined
+  (Christoph Cullmann)
+
+- PR#7456, GPR#1092: fix slow compilation on source files containing a lot
+  of similar debugging information location entries
+  (Mark Shinwell)
+
+- PR#7457: a case of double free in the systhreads library (POSIX implementation)
+  (Xavier Leroy, report by Chet Murthy)
+
+- PR#7460, GPR#1011: catch uncaught exception when unknown files are passed
+  as argument (regression in 4.04.0)
+  (Bernhard Schommer, review by Florian Angeletti and Gabriel Scherer,
+   report by Stephen Dolan)
+
+- PR#7505: Memory cannot be released after calling
+    Bigarray.Genarray.change_layout.
+  (Damien Doligez and Xavier Leroy, report by Liang Wang)
+
+- PR#7511, GPR#1133: Unboxed type with unboxed argument should not be accepted
+  (Damien Doligez, review by Jeremy Yallop and Leo White)
+
+- GPR#912: Fix segfault in Unix.create_process on Windows caused by wrong header
+  configuration.
+  (David Allsopp)
+
+- GPR#980: add dynlink options to ocamlbytecomp.cmxa to allow ocamlopt.opt
+  to load plugins. See http://github.com/OCamlPro/ocamlc-plugins for examples.
+  (Fabrice Le Fessant, review by David Allsopp)
+
+- GPR#992: caml-types.el: Fix missing format argument, so that it can show kind
+  of call at point correctly.
+  (Chunhui He)
+
+- GPR#1043: Allow Windows CRLF line-endings in ocamlyacc on Unix and Cygwin.
+  (David Allsopp, review by Damien Doligez and Xavier Leroy)
+
+- GPR#1072: Fix segfault in Sys.runtime_parameters when exception backtraces
+  are enabled.
+  (Olivier Andrieu)
+
+OCaml 4.04.0 (4 Nov 2016):
+--------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+### Language features:
+
+- PR#7233: Support GADT equations on non-local abstract types
+  (Jacques Garrigue)
+
+- GPR#187, GPR#578: Local opening of modules in a pattern.
+  Syntax: "M.(p)", "M.[p]","M.[| p |]", "M.{p}"
+  (Florian Angeletti, Jacques Garrigue, review by Alain Frisch)
+
+- GPR#301: local exception declarations "let exception ... in"
+  (Alain Frisch)
+
+- GPR#508: Allow shortcut for extension on semicolons: ;%foo
+  (Jérémie Dimino)
+
+- GPR#606: optimized representation for immutable records with a single
+  field, and concrete types with a single constructor with a single argument.
+  This is triggered with a [@@unboxed] attribute on the type definition.
+  Currently mutually recursive datatypes are not well supported, this
+  limitation should be lifted in the future (see MPR#7364).
+  (Damien Doligez)
+
+### Compiler user-interface and warnings:
+
+* PR#6475, GPR#464: interpret all command-line options before compiling any
+  files, changes (improves) the semantics of repeated -o options or -o
+  combined with -c see the super-detailed commit message at
+  https://github.com/ocaml/ocaml/commit/da56cf6dfdc13c09905c2e07f1d4849c8346eec8
+  (whitequark)
+
+- PR#7139: clarify the wording of Warning 38
+  (Unused exception or extension constructor)
+  (Gabriel Scherer)
+
+* PR#7147, GPR#475: add colors when reporting errors generated by ppx rewriters.
+  Remove the `Location.errorf_prefixed` function which is no longer relevant
+  (Simon Cruanes, Jérémie Dimino)
+
+- PR#7169, GPR#501: clarify the wording of Warning 8
+  (Non-exhaustivity warning for pattern matching)
+  (Florian Angeletti, review and report by Gabriel Scherer)
+
+* GPR#591: Improve support for OCAMLPARAM: (i) do not use objects
+  files with -a, -pack, -shared; (ii) use "before" objects in the toplevel
+  (but not "after" objects); (iii) use -I dirs in the toplevel,
+  (iv) fix bug where -I dirs were ignored when using threads
+  (Marc Lasson, review by Damien Doligez and Alain Frisch)
+
+- GPR#648: New -plugin option for ocamlc and ocamlopt, to dynamically extend
+  the compilers at runtime.
+  (Fabrice Le Fessant)
+
+- GPR#684: Detect unused module declarations
+  (Alain Frisch)
+
+- GPR#706: Add a settable Env.Persistent_signature.load function so
+  that cmi files can be loaded from other sources. This can be used to
+  create self-contained toplevels.
+  (Jérémie Dimino)
+
+### Standard library:
+
+- PR#6279, GPR#553: implement Set.map
+  (Gabriel Scherer)
+
+- PR#6820, GPR#560: Add Obj.reachable_words to compute the
+  "transitive" heap size of a value
+  (Alain Frisch, review by Mark Shinwell and Damien Doligez)
+
+- GPR#473: Provide `Sys.backend_type` so that user can write backend-specific
+  code in some cases (for example,  code generator).
+  (Hongbo Zhang)
+
+- GPR#589: Add a non-allocating function to recover the number of
+  allocated minor words.
+  (Pierre Chambart, review by Damien Doligez and Gabriel Scherer)
+
+- GPR#626: String.split_on_char
+  (Alain Frisch)
+
+- GPR#669: Filename.extension and Filename.remove_extension
+  (Alain Frisch, request by Edgar Aroutiounian, review by Daniel Bünzli
+  and Damien Doligez)
+
+- GPR#674: support unknown Sys.os_type in Filename, defaulting to Unix
+  (Filename would previously fail at initialization time for
+   Sys.os_type values other than "Unix", "Win32" and "Cygwin";
+   mirage-os uses "xen")
+  (Anil Madhavapeddy)
+
+- GPR#772 %string_safe_set and %string_unsafe_set are deprecated aliases
+  for %bytes_safe_set and %bytes_unsafe_set.
+  (Hongbo Zhang and Damien Doligez)
+
+### Other libraries
+
+- MPR#4834, GPR#592: Add a Biggarray.Genarray.change_layout function
+  to switch bigarrays between C and fortran layouts.
+  (Guillaume Hennequin, review by Florian Angeletti)
+
+### Code generation and optimizations:
+
+- PR#4747, GPR#328: Optimize Hashtbl by using in-place updates of its
+  internal bucket lists.  All operations run in constant stack size
+  and are usually faster, except Hashtbl.copy which can be much
+  slower
+  (Alain Frisch)
+
+- PR#6217, GPR#538: Optimize performance of record update:
+  no more performance cliff when { foo with t1 = ..; t2 = ...; ... }
+  hits 6 updated fields
+  (Olivier Nicole, review by Thomas Braibant and Pierre Chambart)
+
+- PR#7023, GPR#336: Better unboxing strategy
+  (Alain Frisch, Pierre Chambart)
+
+- PR#7244, GPR#840: Ocamlopt + flambda requires a lot of memory
+  to compile large array literal expressions
+  (Pierre Chambart, review by Mark Shinwell)
+
+- PR#7291, GPR#780: Handle specialisation of recursive function that does
+  not always preserve the arguments
+  (Pierre Chambart, Mark Shinwell, report by Simon Cruanes)
+
+- PR#7328, GPR#702: Do not eliminate boxed int divisions by zero and
+  avoid checking twice if divisor is zero with flambda.
+  (Pierre Chambart, report by Jeremy Yallop)
+
+- GPR#427: Obj.is_block is now an inlined OCaml function instead of a
+  C external.  This should be faster.
+  (Demi Obenour)
+
+- GPR#580: Optimize immutable float records
+  (Pierre Chambart, review by Mark Shinwell)
+
+- GPR#602: Do not generate dummy code to force module linking
+  (Pierre Chambart, reviewed by Jacques Garrigue)
+
+- GPR#703: Optimize some constant string operations when the "-safe-string"
+  configure time option is enabled.
+  (Pierre Chambart)
+
+- GPR#707: Load cross module information during a meet
+  (Pierre Chambart, report by Leo White, review by Mark Shinwell)
+
+- GPR#709: Share a few more equal switch branches
+  (Pierre Chambart, review by Gabriel Scherer)
+
+- GPR#712: Small improvements to type-based optimizations for array
+  and lazy
+  (Alain Frisch, review by Pierre Chambart)
+
+- GPR#714: Prevent warning 59 from triggering on Lazy of constants
+  (Pierre Chambart, review by Leo White)
+
+- GPR#723 Sort emitted functions according to source location
+  (Pierre Chambart, review by Mark Shinwell)
+
+- Lack of type normalization lead to missing simple compilation for "lazy x"
+  (Alain Frisch)
+
+### Runtime system:
+
+- PR#7203, GPR#534: Add a new primitive caml_alloc_float_array to allocate an
+  array of floats
+  (Thomas Braibant)
+
+- PR#7210, GPR#562: Allows to register finalisation function that are
+  called only when a value will never be reachable anymore. The
+  drawbacks compared to the existing one is that the finalisation
+  function is not called with the value as argument. These finalisers
+  are registered with `GC.finalise_last`
+  (François Bobot reviewed by Damien Doligez and Leo White)
+
+- GPR#247: In previous OCaml versions, inlining caused stack frames to
+  disappear from stacktraces. This made debugging harder in presence of
+  optimizations, and flambda was going to make this worse. The debugging
+  information produced by the compiler now enables the reconstruction of the
+  original backtrace. Use `Printexc.get_raw_backtrace_next_slot` to traverse
+  the list of inlined stack frames.
+  (Frédéric Bour, review by Mark Shinwell and Xavier Leroy)
+
+- GPR#590: Do not perform compaction if the real overhead is less than expected
+  (Thomas Braibant)
+
+### Tools:
+
+- PR#7189: toplevel #show, follow chains of module aliases
+  (Gabriel Scherer, report by Daniel Bünzli, review by Thomas Refis)
+
+- PR#7248: have ocamldep interpret -open arguments in left-to-right order
+  (Gabriel Scherer, report by Anton Bachin)
+
+- PR#7272, GPR#798: ocamldoc, missing line breaks in type_*.html files
+  (Florian Angeletti)
+
+- PR#7290: ocamldoc, improved support for inline records
+  (Florian Angeletti)
+
+- PR#7323, GPR#750: ensure "ocamllex -ml" works with -safe-string
+  (Hongbo Zhang)
+
+- PR#7350, GPR#806: ocamldoc, add viewport metadata to generated html pages
+  (Florian Angeletti, request by Daniel Bünzli)
+
+- GPR#452: Make the output of ocamldep more stable
+  (Alain Frisch)
+
+- GPR#548: empty documentation comments
+  (Florian Angeletti)
+
+- GPR#575: Add the -no-version option to the toplevel
+  (Sébastien Hinderer)
+
+- GPR#598: Add a --strict option to ocamlyacc treat conflicts as errors
+  (this option is now used for the compiler's parser)
+  (Jeremy Yallop)
+
+- GPR#613: make ocamldoc use -open arguments
+  (Florian Angeletti)
+
+- GPR#718: ocamldoc, fix order of extensible variant constructors
+  (Florian Angeletti)
+
+### Debugging and profiling:
+
+- GPR#585: Spacetime, a new memory profiler (Mark Shinwell, Leo White)
+
+### Manual and documentation:
+
+- PR#7007, PR#7311: document the existence of OCAMLPARAM and
+  ocaml_compiler_internal_params
+  (Damien Doligez, reports by Wim Lewis and Gabriel Scherer)
+
+- PR#7243: warn users against using WinZip to unpack the source archive
+  (Damien Doligez, report by Shayne Fletcher)
+
+- PR#7245, GPR#565: clarification to the wording and documentation
+  of Warning 52 (fragile constant pattern)
+  (Gabriel Scherer, William, Adrien Nader, Jacques Garrigue)
+
+- #PR7265, GPR#769: Restore 4.02.3 behaviour of Unix.fstat, if the
+  file descriptor doesn't wrap a regular file (win32unix only)
+  (Andreas Hauptmann, review by David Allsopp)
+
+- PR#7288: flatten : Avoid confusion
+  (Damien Doligez, report by user 'tormen')
+
+- PR#7355: Gc.finalise and lazy values
+  (Jeremy Yallop)
+
+- GPR#842: Document that [Store_field] must not be used to populate
+  arrays of values declared using [CAMLlocalN] (Mark Shinwell)
+
+### Compiler distribution build system:
+
+- GPR#324: Compiler developers: Adding new primitives to the
+  standard runtime doesn't require anymore to run `make bootstrap`
+  (François Bobot)
+
+- GPR#384: Fix compilation using old Microsoft C Compilers not
+  supporting secure CRT functions (SDK Visual Studio 2005 compiler and
+  earlier) and standard 64-bit integer literals (Visual Studio .NET
+  2002 and earlier)
+  (David Allsopp)
+
+- GPR#507: More sharing between Unix and Windows makefiles
+  (whitequark, review by Alain Frisch)
+
+* GPR#512, GPR#587: Installed `ocamlc`, `ocamlopt`, and `ocamllex` are
+  now the native-code versions of the tools, if those versions were
+  built.
+  (Demi Obenour)
+
+- GPR#525: fix build on OpenIndiana
+  (Sergey Avseyev, review by Damien Doligez)
+
+- GPR#687: "./configure -safe-string" to get a system where
+  "-unsafe-string" is not allowed, thus giving stronger non-local
+  guarantees about immutability of strings
+  (Alain Frisch, review by Hezekiah M. Carty)
+
+### Bug fixes:
+
+* PR#6505: Missed Type-error leads to a segfault upon record access.
+  (Jacques Garrigue, extra report by Stephen Dolan)
+  Proper fix required a more restrictive approach to recursive types:
+  mutually recursive types are seen as abstract types (i.e. non-contractive)
+  when checking the well-foundedness of the recursion.
+
+* PR#6752: Nominal types and scope escaping.
+  Revert to strict scope for non-generalizable type variables, cf. Mantis.
+  Note that this is actually stricter than the behavior before 4.03,
+  cf. PR#7313, meaning that you may sometimes need to add type annotations
+  to explicitly instantiate non-generalizable type variables.
+  (Jacques Garrigue, following discussion with Jeremy Yallop,
+   Nicolas Ojeda Bar and Alain Frisch)
+
+- PR#7112: Aliased arguments ignored for equality of module types
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7134: compiler forcing aliases it shouldn't while reporting type errors
+  (Jacques Garrigue, report and suggestion by sliquister)
+
+- PR#7153: document that Unix.SOCK_SEQPACKET is not really usable.
+
+- PR#7165, GPR#494: uncaught exception on invalid lexer directive
+  (Gabriel Scherer, report by KC Sivaramakrishnan using afl-fuzz)
+
+- PR#7257, GPR#583: revert a 4.03 change of behavior on (Unix.sleep 0.),
+  it now calls (nano)sleep for 0 seconds as in (< 4.03) versions.
+  (Hannes Mehnert, review by Damien Doligez)
+
+- PR#7260: GADT + subtyping compile time crash
+  (Jacques Garrigue, report by Nicolas Ojeda Bar)
+
+- PR#7269: Segfault from conjunctive constraints in GADT
+  (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#7276: Support more than FD_SETSIZE sockets in Windows' emulation
+  of select
+  (David Scott, review by Alain Frisch)
+
+* PR#7278: Prevent private inline records from being mutated
+  (Alain Frisch, report by Pierre Chambart)
+
+- PR#7284: Bug in mcomp_fields leads to segfault
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7285: Relaxed value restriction broken with principal
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7297: -strict-sequence turns off Warning 21
+  (Jacques Garrigue, report by Valentin Gatien-Baron)
+
+- PR#7299: remove access to OCaml heap inside blocking section in win32unix
+  (David Allsopp, report by Andreas Hauptmann)
+
+- PR#7300: remove access to OCaml heap inside blocking in Unix.sleep on Windows
+  (David Allsopp)
+
+- PR#7305: -principal causes loop in type checker when compiling
+  (Jacques Garrigue, report by Anil Madhavapeddy, analysis by Leo White)
+
+- PR#7330: Missing exhaustivity check for extensible variant
+  (Jacques Garrigue, report by Elarnon *)
+
+- PR#7374: Contractiveness check unsound with constraints
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7378: GADT constructors can be re-exposed with an incompatible type
+  (Jacques Garrigue, report by Alain Frisch)
+
+- PR#7389: Unsoundness in GADT exhaustiveness with existential variables
+  (Jacques Garrigue, report by Stephen Dolan)
+
+* GPR#533: Thread library: fixed [Thread.wait_signal] so that it
+  converts back the signal number returned by [sigwait] to an
+  OS-independent number
+  (Jérémie Dimino)
+
+- GPR#600: (similar to GPR#555) ensure that register typing constraints are
+  respected at N-way join points in the control flow graph
+  (Mark Shinwell)
+
+- GPR#672: Fix float_of_hex parser to correctly reject some invalid forms
+  (Bogdan Tătăroiu, review by Thomas Braibant and Alain Frisch)
+
+- GPR#700: Fix maximum weak bucket size
+  (Nicolas Ojeda Bar, review by François Bobot)
+
+- GPR#708 Allow more module aliases in strengthening (Leo White)
+
+- GPR#713, PR#7301: Fix wrong code generation involving lazy values in Flambda
+  mode
+  (Mark Shinwell, review by Pierre Chambart and Alain Frisch)
+
+- GPR#721: Fix infinite loop in flambda due to [@@specialise] annotations
+
+- GPR#779: Building native runtime on Windows could fail when bootstrapping
+  FlexDLL if there was also a system-installed flexlink
+  (David Allsopp, report Michael Soegtrop)
+
+- GPR#805, GPR#815, GPR#833: check for integer overflow in String.concat
+  (Jeremy Yallop,
+   review by Damien Doligez, Alain Frisch, Daniel Bünzli, Fabrice Le Fessant)
+
+- GPR#810: check for integer overflow in Array.concat
+  (Jeremy Yallop)
+
+- GPR#814: fix the Buffer.add_substring bounds check to handle overflow
+  (Jeremy Yallop)
+
+- GPR#880: Fix [@@inline] with default parameters in flambda (Leo White)
+
+### Internal/compiler-libs changes:
+
+- PR#7200, GPR#539: Improve, fix, and add test for parsing/pprintast.ml
+  (Runhang Li, David Sheets, Alain Frisch)
+
+- GPR#351: make driver/pparse.ml functions type-safe
+  (Gabriel Scherer, Dmitrii Kosarev, review by Jérémie Dimino)
+
+- GPR#516: Improve Texp_record constructor representation, and
+  propagate updated record type information
+  (Pierre Chambart, review by Alain Frisch)
+
+- GPR#678: Graphics.close_graph crashes 64-bit Windows ports (re-implementation
+  of PR#3963)
+  (David Allsopp)
+
+- GPR#679: delay registration of docstring after the mapper is applied
+  (Hugo Heuzard, review by Leo White)
+
+- GPR#872: don't attach (**/**) comments to any particular node
+  (Thomas Refis, review by Leo White)
+
+OCaml 4.03.0 (25 Apr 2016):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+### Language features:
+
+- PR#5528: inline records for constructor arguments
+  (Alain Frisch)
+
+- PR#6220, PR#6403, PR#6437, PR#6801:
+  Improved redundancy and exhaustiveness checks for GADTs.
+  Namely, the redundancy checker now checks whether the uncovered pattern
+  of the pattern is actually inhabited, exploding at most one wild card.
+  This is also done for exhaustiveness when there is only one case.
+  Additionally, one can now write unreachable cases, of the form
+  "pat -> .", which are treated by the redundancy check.
+  (Jacques Garrigue)
+
+- PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type
+  constructors
+  (Alain Frisch)
+
+- PR#6714: allow [@@ocaml.warning] on most structure and signature items:
+  values, modules, module types
+  (whitequark)
+
+- PR#6806: Syntax shortcut for putting a type annotation on a record field:
+  { f1 : typ = e } is sugar for { f1 = (e : typ) }
+  { f1 : typ } is sugar for { f1 = (f1 : typ) }
+  (Valentin Gatien-Baron, review by Jérémie Dimino)
+
+- PR#6806: Allow type annotations before the "->" in "fun  -> "
+  fun x y : (int * int) -> (x, y)
+  (Valentin Gatien-Baron, review by Jérémie Dimino)
+
+- GPR#26: support for "(type a b)" as syntactic sugar for "(type a) (type b)"
+  (Gabriel Scherer)
+
+- GPR#42: short functor type syntax: "S -> T" for "functor (_ : S) -> T"
+  (Leo White)
+
+- GPR#88: allow field punning in object copying expressions:
+  {< x; y; >} is sugar for {< x = x; y = y; >}
+  (Jeremy Yallop)
+
+- GPR#112: octal escape sequences for char and string literals
+  "Make it \o033[1mBOLD\o033[0m"
+  (Rafaël Bocquet, request by John Whitington)
+
+- GPR#167: allow to annotate externals' arguments and result types so
+  they can be unboxed or untagged: [@unboxed], [@untagged]. Supports
+  untagging int and unboxing int32, int64, nativeint and float.
+  (Jérémie Dimino, Mark Shinwell)
+
+- GPR#173: [@inline] and [@inlined] attributes (for function declarations
+  and call sites respectively) to control inlining
+  (Pierre Chambart, Mark Shinwell)
+
+- GPR#188: accept [@@immediate] attribute on type declarations to mark types
+  that are represented at runtime by an integer
+  (Will Crichton, reviewed by Leo White)
+
+* GPR#234: allow "[]" as a user-defined constructor. Demand parenthesis
+  around "::" when using "::" as user-defined constructor:
+  code using "| :: of ..." must change to "| (::) of ...".
+  (Runhang Li, review by Damien Doligez)
+
+- GPR#240: replace special annotations on externals by attributes:
+  * "float" is generalized to [@@unboxed]
+  * "noalloc" becomes [@@noalloc]
+  Deprecate "float" and "noalloc".
+  (Jérémie Dimino)
+
+- GPR#254: @ocaml.warn_on_literal_pattern attribute on constructors to
+  warn when the argument is matches against a constant pattern.  This
+  attribute is applied on predefined exception constructors which
+  carry purely informational (with no stability guarantee) messages.
+  (Alain Frisch)
+
+- GPR#268: hexadecimal notation for floating-point literals: -0x1.ffffp+987
+  In OCaml source code, FP literals can be written using the hexadecimal
+  notation 0xp from ISO C99.
+  (Xavier Leroy)
+
+- GPR#273: allow to get the extension slot of an extension constructor
+  by writing [%extension_constructor ]
+  (Jérémie Dimino)
+
+- GPR#282: change short-paths penalty heuristic to assign the same cost to
+  idents containing double underscores as to idents starting with an underscore
+  (Thomas Refis, Leo White)
+
+- PR#6681 GPR#326: signature items are now accepted as payloads for
+  extension and attributes, using the syntax [%foo: SIG ] or [@foo: SIG ].
+  Examples: "[%%client: val foo : int]" or "val%client foo : int".
+  (Alain Frisch and Gabriel Radanne)
+
+* GPR#342: Allow shortcuts for extension and attributes on all keywords:
+  module%foo, class[@foo], etc.
+  The attribute in "let[@foo] .. in .." is now attached to the value binding,
+  not to the expression.
+  (Gabriel Radanne)
+
+### Compilers:
+
+* PR#4231, PR#5461: warning 31 is now fatal by default
+  (Warning 31: A module is linked twice in the same executable.)
+  This is an interim solution; double-linking of modules has dangerous
+  semantics, eg. exception constructors end up with two distinct declarations.
+  (Alain Frisch)
+
+- PR#4800: better compilation of tuple assignment
+  (Gabriel Scherer and Alain Frisch)
+
+- PR#5995: keep -for-pack into account to name exceptions;
+  -for-pack should now be used during bytecode compilation as well
+  (Alain Frisch, report by Christophe Troestler)
+
+- PR#6400: better error message for '_' used as an expression
+  (Alain Frisch, report by whitequark)
+
+- PR#6501: harden the native-code generator against certain uses of "%identity"
+  (Xavier Leroy, report by Antoine Miné)
+
+- PR#6636: add --version option
+  (whitequark)
+
+- PR#6679: fix pprintast printing of constraints in type declarations
+  (Alain Frisch, report by Jun Furuse)
+
+- PR#6737: fix Typedtree attributes on (fun x -> body) expressions
+  (Alain Frisch, report by Oleg Kiselyov)
+
+* PR#6865: remove special case for parsing "let _ = expr" in structures
+  (Jérémie Dimino, Alain Frisch)
+
+* PR#6438, PR#7059, GPR#315: Pattern guard disables exhaustiveness check
+  (function Some x when x = 0 -> ()) will now raise warning 8 (non-exhaustive)
+  instead of warning 25 (all clauses are guarded). 25 isn't raised anymore.
+  Projects that set warning 8 as an error may fail to compile (presumably
+  this is the semantics they wanted).
+  (Alain Frisch, request by Martin Jambon and John Whitington)
+
+- PR#6920: fix debug informations around uses of %apply or %revapply
+  (Jérémie Dimino, report by Daniel Bünzli)
+
+- PR#6939: Segfault with improper use of let-rec
+  (Alain Frisch)
+
+- PR#6943: native-code generator for POWER/PowerPC 64 bits, both in
+  big-endian (ppc64) and little-endian (ppc64le) configuration.
+  (Xavier Leroy, with inspiration from RedHat's unofficial ppc64 and ppc64le
+  ports)
+
+- PR#6979: better code generation in x86-32 backend for copying floats to
+  the stack
+  (Marc Lasson, review by Xavier Leroy)
+
+- PR#7018: fix missing identifier renaming during inlining
+  (Alain Frisch, review by Xavier Leroy)
+
+- PR#7022, GPR#259: unbox float and boxed ints earlier, avoid second pass
+  (Alain Frisch)
+
+- PR#7026, GPR#288: remove write barrier for polymorphic variants without
+  arguments
+  (Simon Cruanes)
+
+- PR#7031: new warning 57, ambiguous guarded or-patterns
+  (Luc Maranget, Gabriel Scherer, report by Martin Clochard and Claude Marché)
+
+- PR#7064, GPR#316: allowing to mark compilation units and sub-modules as
+  deprecated
+  (Alain Frisch)
+
+- PR#7067: fix performance regression (wrt. 4.01) in the native compiler
+  for long nested structures
+  (Alain Frisch, report by Daniel Bünzli, review by Jacques Garrigue)
+
+- PR#7097: fix strange syntax error message around illegal packaged module
+  signature constraints
+  (Alain Frisch, report by Jun Furuse)
+
+- PR#7118, PR#7120, GPR#408, GPR#476: Bug fixed in stack unwinding
+  metadata generation. Was a cause of crashes in GUI programs on OS X.
+  (Bart Jacobs, review by Mark Shinwell)
+
+- PR#7168: Exceeding stack limit in bytecode can lead to a crash.
+  (Jacques-Henri Jourdan)
+
+- PR#7232: Strange Pprintast output with ppx_deriving
+  (Damien Doligez, report by Anton Bachin)
+
+- GPR#17: some cmm optimizations of integer operations with constants
+  (Stephen Dolan, review by Pierre Chambart)
+
+- GPR#89: improve type-specialization of unapplied primitives:
+  unapplied annotations (compare : int -> _),
+  type propagation (List.sort compare [1;2;3])
+  and propagation from module signatures now lead to specialization
+  (Frédéric Bour, review by Gabriel Scherer)
+
+- GPR#107: Prevent more unnecessary float boxing, especially in `if` and `match`
+  (Vladimir Brankov, review by Alain Frisch)
+
+- GPR#109: new (lazy) unboxing strategy for float and int references
+  (Vladimir Brankov, review by Alain Frisch)
+
+- GPR#115: More precise typing of values at the C-- and Mach level.
+  (Xavier Leroy, review by Pierre Chambart)
+
+- GPR#132: Flambda: new intermediate language and "middle-end" optimizers
+  (Pierre Chambart, Mark Shinwell, Leo White)
+
+- GPR#212, PR#7226, GPR#542: emit column position in gas assembly `.loc`
+  (Frédéric Bour, Anton Bachin)
+
+- GPR#207: Colors in compiler messages (warnings, errors)
+  configure with -color {auto|always|never} or TERM=dumb
+  (Simon Cruanes, review by Gabriel Scherer)
+
+- GPR#258: more precise information on PowerPC instruction sizes
+  (Pierre Chambart, Xavier Leroy)
+
+- GPR#263: improve code generation for if-equivalents of (&&) and (||)
+  (Pierre Chambart)
+
+- GPR#270: Make [transl_exception_constructor] generate [Immutable] blocks
+  (Mark Shinwell)
+
+- GPR#271: Fix incorrect mutability flag when records are built using "with"
+  (Mark Shinwell)
+
+- GPR#275: native-code generator for IBM z System running Linux.
+  In memoriam Gene Amdahl, 1922-2015.
+  (Bill O'Farrell, Tristan Amini, Xavier Leroy)
+
+- GPR#282: relax short-paths safety check in presence of module aliases, take
+  penalty into account while building the printing map.
+  (Thomas Refis, Leo White)
+
+- GPR#306: Instrument the compiler to debug performance regressions
+  (Pierre Chambart)
+
+- GPR#319: add warning 58 for missing cmx files, and
+  extend -opaque option to mli files: a missing .cmx does not warn
+  if the corresponding .cmi is compiled -opaque.
+  (Leo White)
+
+- GPR#388: OCAML_FLEXLINK environment variable allows overriding flexlink
+  command (David Allsopp)
+
+- GPR#392: put all parsetree invariants in a new module Ast_invariants
+  (Jérémie Dimino)
+
+- GPR#407: don't display the name of compiled .c files when calling the
+  Microsoft C Compiler (same as the assembler).
+  (David Allsopp)
+
+- GPR#431: permit constant float arrays to be eligible for pattern match
+  branch merging
+  (Pierre Chambart)
+
+- GPR#455: provide more debugging information to Js_of_ocaml
+  (Jérôme Vouillon)
+
+- GPR#514, GPR#554: Added several command-line flags to explicitly enable
+  settings that are currently the default:
+  `-alias-deps`, `-app-funct`, `-no-keep-docs`, `-no-keep-locs`,
+  `-no-principal`, `-no-rectypes`, `-no-strict-formats`
+  (Demi Obenour)
+
+- GPR#545: use reraise to preserve backtrace on
+  `match .. with exception e -> raise e`
+  (Nicolas Ojeda Bar, review by Gabriel Scherer)
+
+### Runtime system:
+
+* GPR#596: make string/bytes distinguishable in the underlying
+  compiler implementation; caml_fill_string and caml_create_string are
+  deprecated and will be removed in the future, please use
+  caml_fill_bytes and caml_create_bytes for migration
+  (Hongbo Zhang, review by Damien Doligez, Alain Frisch, and Hugo Heuzard)
+
+- PR#3612, PR#92: allow allocating custom block with finalizers
+  in the minor heap.
+  (Pierre Chambart)
+
+* PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown
+  types {,u}int{32,64}.
+  C stubs may have to be updated as {,u}int{32,64}_t are not defined anymore.
+  (Xavier Leroy)
+
+- PR#6760: closures evaluated in the toplevel can now be marshalled
+  (whitequark, review by Jacques-Henri Jourdan)
+
+- PR#6902, GPR#210: emit a runtime warning on stderr
+  when finalizing an I/O channel which is still open:
+    "channel opened on file '...' dies without being closed"
+  this is controlled by OCAMLRUNPARAM=W=1 or with Sys.enable_runtime_warnings.
+  The behavior of affected program is not changed,
+  but they should still be fixed.
+  (Alain Frisch, review by Damien Doligez)
+
+- Signal handling: for read-and-clear, use GCC/Clang atomic builtins
+  if available.
+  (Xavier Leroy)
+
+- PR#6910, GPR#224: marshaling (output_value, input_value, et al)
+  now support marshaled data bigger than 4 Gb.
+  (Xavier Leroy)
+
+* GPR#226: select higher levels of optimization for GCC >= 3.4 and Clang
+  when compiling the run-time system and C stub code.
+  "-std=gnu99 -O2 -fno-strict-aliasing -fwrapv" is used by default.
+  This also affects default flags for user stubs compiled with "ocamlc -c foo.c"
+  and may uncover bugs in them.
+  (Xavier Leroy)
+
+- GPR#262: Multiple GC roots per compilation unit
+  (Pierre Chambart, Mark Shinwell, review by Damien Doligez)
+
+* GPR#297: Several changes to improve the worst-case GC pause time.
+  Changes Gc.control and Gc.major_slice and adds functions to the Gc module.
+  (Damien Doligez, with help from François Bobot, Thomas Braibant, Leo White)
+
+- GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit
+  (Louis Gesbert, review by Alain Frisch)
+
+### Standard library:
+
+- PR#1460, GPR#230: Array.map2, Array.iter2
+  (John Christopher McAlpine)
+
+- PR#5197, GPR#63: Arg: allow flags such as --flag=arg as well as --flag arg
+  (Richard Jones)
+
+- PR#6017, PR#7034, GPR#267: More efficient ifprintf implementation
+  (Jeremy Yallop, review by Gabriel Scherer)
+
+- PR#6296: Some documentation on the floating-point representations
+    recognized by Pervasives.float_of_string
+  (Xavier Leroy)
+
+- PR#6316: Scanf.scanf failure on %u formats when reading big integers
+  (Xavier Leroy, Benoît Vaugon)
+
+- PR#6321: guarantee that "hypot infinity nan = infinity"
+  (for conformance with ISO C99)
+  (Xavier Leroy)
+
+- PR#6390, GPR#36: expose Sys.{int_size,max_wosize} for js_of_ocaml portability
+  (Hugo Heuzard)
+
+- PR#6449: Add Map.union
+  (Alain Frisch)
+
+* PR#6494: Add 'equal' functions in modules
+  Bytes, Char, Digest, Int32, Int64, Nativeint, and String
+  Users defining their own modules with signature 'module type of Int32'
+  have to extend their implementation.
+  (Romain Calascibetta)
+
+* PR#6524, GPR#79: Filename: Optional ?perms argument to open_temp_file
+  May break partial applications of the function (fix by passing ?perms:None)
+  (Daniel Bünzli, review by Jacques-Pascal Deplaix)
+
+* PR#6525, GPR#80: Add Uchar module to the standard library
+  May introduce module name conflicts with existing projects.
+  (Daniel Bünzli, review by Yoriyuki Yamagata and Damien Doligez)
+
+- PR#6577: improve performance of %L, %l, %n, %S, %C format specifiers
+  (Alain Frisch)
+
+- PR#6585: fix memory leak in win32unix/createprocess.c
+  (Alain Frisch, report by user 'aha')
+
+- PR#6645, GPR#174: Guarantee that Set.add, Set.remove, Set.filter
+  return the original set if no change is required
+  (Alain Frisch, Mohamed Iguernlala)
+
+- PR#6649, GPR#222: accept (int_of_string "+3")
+  (John Christopher McAlpine)
+
+- PR#6694, PR#6695, GPR#124: deprecate functions using ISO-8859-1 character set
+  in Char, Bytes, String and provide alternatives *_acii using US-ASCII.
+  Affected functions:
+    {Char,String,Bytes}.{uppercase,lowercase},
+    {String,Bytes}.{capitalize,uncaptialize}
+  (whitequark, review by Damien Doligez)
+
+- GPR#22: Add the Ephemeron module that implements ephemerons and weak
+  hash table
+  (François Bobot, review by Damien Doligez, Daniel Bünzli,
+  Alain Frisch, Pierre Chambart)
+
+- GPR#164: more efficient (branchless) implementation of Pervasives.compare
+  specialized at type 'float'.
+  (Vladimir Brankov)
+
+- GPR#175: Guarantee that Map.add, Map.remove, Map.filter
+  return the original map if no change is required.
+  (Mohamed Iguernlala)
+
+- GPR#201: generalize types of Printf.{ifprintf,ikfprintf}
+  (Maxence Guesdon)
+
+- GPR#216: add the missing POSIX.1-2001 signals in Sys
+  (Guillaume Bury)
+
+- GPR#239: remove type-unsafe code from Stream
+  (Pierre Chambart, review by Gabriel Scherer and Jeremy Yallop)
+
+- GPR#250: Check for negative start element in Array.sub
+  (Jeremy Yallop)
+
+- GPR#265: new implementation of Queue avoiding Obj.magic
+  (Jérémie Dimino)
+
+- GPR#268, GPR#303: '%h' and '%H' modifiers for printf and scanf to
+  support floating-point numbers in hexadecimal notation
+  (Xavier Leroy, Benoît Vaugon)
+
+- GPR#272: Switch classify_float to [@@unboxed]
+  (Alain Frisch)
+
+- Improve speed of classify_float by not going through fpclassify()
+  (Alain Frisch, Xavier Leroy)
+
+- GPR#277: Switch the following externals to [@@unboxed]:
+  * {Nativeint,Int32,Int64}.{of,to}_float
+  * Int{32,64}.float_of_bits
+  * Int{32,64}.bits_of_float
+  (Jérémie Dimino)
+
+- GPR#281: Switch the following externals to [@@unboxed]:
+  * Sys.time (and [@@noalloc])
+  * Pervasives.ldexp (and [@@noalloc])
+  * Pervasives.compare for float, nativeint, int32, int64.
+  (François Bobot)
+
+- PR#3622, GPR#195: add function Stack.fold
+  (Simon Cruanes)
+
+- GPR#329: Add exists, for_all,  mem and memq functions in Array
+  (Bernhard Schommer)
+
+- GPR#337: Add [Hashtbl.filter_map_inplace]
+  (Alain Frisch)
+
+- GPR#356: Add [Format.kasprintf]
+  (Jérémie Dimino, Mark Shinwell)
+
+### Type system:
+
+- PR#5545: Type annotations on methods cannot control the choice of abbreviation
+  (Jacques Garrigue)
+
+* PR#6465: allow incremental weakening of module aliases.
+  This is done by adding equations to submodules when expanding aliases.
+  In theory this may be incompatible is some corner cases defining a module
+  type through inference, but no breakage known on published code.
+  (Jacques Garrigue)
+
+- PR#6593: Functor application in tests/basic-modules fails after commit 15405
+  (Jacques Garrigue)
+
+### Toplevel and debugger:
+
+- PR#6113: Add descriptions to directives, and display them via #help
+  (Nick Giannarakis, Berke Durak, Francis Southern and Gabriel Scherer)
+
+- PR#6396: Warnings-as-errors not properly flushed in the toplevel
+  (Alain Frisch)
+
+- PR#6401: use proper error reporting for toplevel environment initialization:
+  no more Env.Error(_) at start time
+  (Gabriel Scherer, Alain Frisch)
+
+- PR#6468: toplevel now supports backtraces if invoked with OCAMLRUNPARAM=b
+  (whitequark and Jake Donham,
+   review by Gabriel Scherer and Jacques-Henri Jourdan)
+
+- PR#6906: wrong error location for unmatched paren with #use in toplevel
+  (Damien Doligez, report by Kenichi Asai)
+
+- PR#6935, GPR#298: crash in debugger when load_printer is given a directory
+  (Junsong Li, review by Gabriel Scherer)
+
+- PR#7081: report preprocessor warnings in the toplevel
+  (Valentin Gatien-Baron, review by Jérémie Dimino)
+
+- PR#7098: Loss of ppx context in toplevel after an exception
+  (Alain Frisch, report by whitequark)
+
+- PR#7101: The toplevel does not close in_channel for libraries specified on
+  its command line
+  (Alain Frisch)
+
+- PR#7119: the toplevel does not respect [@@@warning]
+  (Alain Frisch, report by Gabriel Radanne)
+
+### Other libraries:
+
+* Unix library: channels created by Unix.in_channel_of_descr or
+  Unix.out_channel_of_descr no longer support text mode under Windows.
+  Calling [set_binary_mode_{in,out} chan false] on these channels
+  now causes an error.
+  (Xavier Leroy)
+
+- PR#4023 and GPR#68: add Unix.sleepf (sleep with sub-second resolution)
+  (Evgenii Lepikhin and Xavier Leroy)
+
+* Protect Unix.sleep against interruptions by handled signals.
+  Before, a handled signal could cause Unix.sleep to return early.
+  Now, the sleep is restarted until the given time is elapsed.
+  (Xavier Leroy)
+
+* PR#6120, GPR#462: implement Unix.symlink and Unix.readlink on
+  Windows. Unix.symlink has a new optional argument to_dir (ignored on
+  non-native Windows platforms). stat functions reimplemented to avoid
+  buggy Microsoft CRT implementations (native Windows only)
+  (David Allsopp, review by Daniel Bünzli)
+
+- PR#6263: add kind_size_in_bytes and size_in_bytes functions
+  to Bigarray module.
+  (Runhang Li, review by Mark Shinwell)
+
+- PR#6289: Unix.utimes uses the current time only if both arguments
+    are exactly 0.0.  Also, use sub-second resolution if available.
+  (Xavier Leroy, report by Christophe Troestler)
+
+- PR#6896: serious reimplementation of Big_int.float_of_big_int and
+  Ratio.float_of_ratio, ensuring that the result is correctly rounded.
+  (Xavier Leroy)
+
+- PR#6989: in Str library, make sure that all \(...\) groups are binding
+    and can be consulted with Str.matched_group.  There used to be
+    a limitation to 32 binding groups.
+  (Xavier Leroy)
+
+- PR#7013: spurious wake-up in the Event module
+  (Xavier Leroy)
+
+- PR#7024: in documentation of Str regular expressions, clarify what
+    "end of line" means for "^" and "$" regexps.
+  (Xavier Leroy, question by Fredrik Lindgren)
+
+- PR#7209: do not run at_exit handlers in [Unix.create_process] and
+  similar functions when the [exec] call fails in the child process
+  (Jérémie Dimino)
+
+### OCamldep:
+
+- GPR#286: add support for module aliases
+  (Jacques Garrigue)
+
+### Manual:
+
+- GPR#302: The OCaml reference manual is now included in the manual/
+  subdirectory of the main OCaml source repository. Contributions to
+  the manual are warmly welcome.
+  (François Bobot, review by Florian Angeletti)
+
+- PR#6601: replace strcpy with caml_strdup in sample code
+  (Christopher Zimmermann)
+
+- PR#6676: ongoing simplification of the "Language Extensions" section
+  (Alain Frisch, John Whitington)
+
+- PR#6898: Update win32 support documentation of the Unix library
+  (Damien Doligez, report by Daniel Bünzli)
+
+- PR#7092, GPR#379: Add missing documentation for new 4.03 features
+  (Florian Angeletti)
+
+- PR#7094, GPR#468, GPR#551: add new section 8.5 to document warnings
+  The general idea is to document warnings that may require explanations.
+  Currently documented warnings are:
+  - 52: Fragile constant pattern.
+  - 57: Ambiguous or-pattern variables under guard
+  (Florian Angeletti and Gabriel Scherer)
+
+- PR#7109, GPR#380: Fix bigarray documentation layout
+  (Florian Angeletti, Leo White)
+
+### Bug fixes:
+
+- PR#3612: memory leak in bigarray read from file
+  (Pierre Chambart, report by Gary Huber)
+
+* PR#4166, PR#6956: force linking when calling external C primitives
+  (Jacques Garrigue, reports by Markus Mottl and Christophe Troestler)
+
+* PR#4466, PR#5325: under Windows, concurrent read and write operations
+    on the same socket could block unexpectedly.  Fixed by keeping sockets
+    in asynchronous mode rather than creating them in synchronous mode.
+  (Xavier Leroy)
+
+* PR#4539: change exception string raised when comparing functional values
+  May break programs matching on the string argument of Invalid_argument.
+  Matching on the string argument of Invalid_argument or Failure is a
+  programming mistake: these strings may change in future versions.
+  (Nicolas Braud-Santoni, report by Eric Cooper)
+
+- PR#4832: Filling bigarrays may block out runtime
+  (Markus Mottl)
+
+- PR#5663: program rejected due to nongeneralizable type variable that
+    appears nowhere
+  (Jacques Garrigue, report by Stephen Weeks)
+
+- PR#5780: report more informative type names in GADTs error messages
+  (Jacques Garrigue, report by Sebastien Furic)
+
+- PR#5887: move the byterun/*.h headers to byterun/caml/*.h to avoid header
+    name clashes
+  (Jérôme Vouillon and Adrien Nader and whitequark)
+
+* PR#6081: ocaml now adds script's directory to search path, not current
+    directory
+  (Thomas Leonard and Damien Doligez)
+
+- PR#6108, PR#6802: fail cleanly if dynlink.cma or ocamltoplevel.cma
+    are loaded inside the toplevel loop.
+  (Xavier Leroy)
+
+- PR#6171: Confusing error message when a type escapes its scope.
+  (Jacques Garrigue and Leo White, report by John Whitington)
+
+- PR#6340: Incorrect handling of \r when processing "Windows" source files
+  (Damien Doligez, report by David Allsopp)
+
+- PR#6342: Incorrect error message when type constraints differ
+  (Alain Frisch, report by Philippe Wang)
+
+* PR#6521: {Bytes,Char,String}.escaped were locale-dependent
+  we now escape all non-ASCII-printable instead of a locale-dependent subset.
+  (Damien Doligez, report by Jun Furuse)
+
+- PR#6526: ocamllex should not warn on unescaped newline inside comments
+  (Damien Doligez, report by user 'dhekir')
+
+- PR#6341: ocamldoc -colorize-code adds spurious 
 tags to 
 blocks
+  (Maxence Guesdon, report by Damien Doligez)
+
+- PR#6560: Wrong failure message for {Int32,Int64,NativeInt}.of_string
+  It reported (Failure "int_of_string"), now "Int32.of_string" etc.
+  (Maxime Dénès and Gabriel Scherer)
+
+- PR#6648: show_module should indicate its elision
+  (Jacques Garrigue, report by Leo White)
+
+- PR#6650: Cty_constr not handled correctly by Subst
+  (Jacques Garrigue, report by Leo White)
+
+- PR#6651: Failing component lookup
+  (Jacques Garrigue, report by Leo White)
+
+* PR#6664: Crash when finalising lazy values of the wrong type.
+  (Damien Doligez)
+
+- PR#6672: Unused variance specification allowed in with constraint
+  (Jacques Garrigue, report by Leo White)
+
+- PR#6677: Allow to disable warning 39 (useless "rec") with [@ocaml.warning]
+  applied to the first value binding of the would-be "rec" declaration
+  (Alain Frisch, report by Jun Furuse)
+
+- PR#6744: Univars can escape through polymorphic variants (partial fix)
+  (Jacques Garrigue, report by Leo White)
+
+- PR#6752: Extensible variant types and scope escaping
+  A side-effect of the fix is that (ocamlc -i) sometimes reports
+  (type-sound) invalid signature, with a type used before its declaration.
+  (Jacques Garrigue, report by Maxence Guesdon)
+
+- PR#6762: improve warning 45 in presence of re-exported type definitions
+  (Warning 45: open statement shadows the constructor)
+  (Alain Frisch, report by Olivier Andrieu)
+
+- PR#6776: Failure to kill the "tick" thread, segfault when exiting the runtime
+  (Damien Doligez, report by Thomas Braibant)
+
+- PR#6780: Poor error message for wrong -farch and -ffpu options (ocamlopt, ARM)
+  (Xavier Leroy, report by whitequark)
+
+- PR#6805: Duplicated expression in case of hole in a non-failing switch.
+  (Luc Maranget)
+
+* PR#6808: the parsing of OCAMLRUNPARAM is too lax
+  (Damien Doligez)
+
+- PR#6874: Inefficient code generated for module function arguments
+  (Jacques Garrigue, report by Markus Mottl)
+
+- PR#6888: The list command of ocamldebug uses the wrong file
+  (Damien Doligez, report by Pierre-Marie Pédrot)
+
+- PR#6897: Bad error message for some pattern matching on extensible variants
+  (Alain Frisch, report by Gabriel Radanne)
+
+- PR#6899: Optional parameters and non generalizable type variables
+  (Thomas Refis and Leo White)
+
+- PR#6907: Stack overflow printing error in class declaration
+  (Jacques Garrigue, report by Ivan Gotovchits)
+
+- PR#6931: Incorrect error message on type error inside record construction
+  (Damien Doligez, report by Leo White)
+
+- PR#6938: fix regression on "%047.27{l,L,n}{d,i,x,X,o,u}"
+  (Benoît Vaugon, report by Arduino Cascella)
+
+- PR#6944: let module X = Path in … is not typed as a module alias
+  (Jacques Garrigue, report by Frédéric Bour)
+
+- PR#6945 and GPR#227: protect Sys and Unix functions against string
+    arguments containing the null character '\000'
+  (Simon Cruanes and Xavier Leroy, report by Daniel Bünzli)
+
+- PR#6946: Uncaught exception with wrong type for "%ignore"
+  (Jacques Garrigue, report by Leo White)
+
+- PR#6954: Infinite loop in type checker with module aliases
+  (Jacques Garrigue, report by Markus Mottl)
+
+- PR#6972, GPR#276: 4.02.3 regression on documentation comments in .cmt files
+  (Leo White, report by Olivier Andrieu)
+
+- PR#6977: String literals in comments interpret escape sequences
+  (Damien Doligez, report by Daniel Bünzli and David Sheets)
+
+- PR#6980: Assert failure from polymorphic variants and existentials
+  (Jacques Garrigue, report by Leo White)
+
+- PR#6981: Ctype.Unify(_) with associated functor arg refering to previous one
+  (Jacques Garrigue, report by Nicholas Labich)
+
+- PR#6982: unexpected type error when packing a module alias
+  (Jacques Garrigue, report by Valentin Gatien-Baron)
+
+- PR#6985: `module type of struct include Bar end exposes
+           %s#row when Bar contains private row types
+  (Jacques Garrigue, report by Nicholas Labich)
+
+- PR#6992: Segfault from bug in GADT/module typing
+  (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#6993: Segfault from recursive modules violating exhaustiveness assumptions
+  (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#6998: Typer fails reading unnecessary cmis with -no-alias-deps and -w -49
+  (Leo White, report by Valentin Gatien-Baron)
+
+- PR#7003: String.sub may cause segmentation fault on sizes above 2^31
+  (Damien Doligez, report by Radek Micek)
+
+- PR#7008: Fatal error in ocamlc with empty compilation unit name
+  (Damien Doligez, report by Cesar Kunz)
+
+- PR#7012: Variable name forgotten when it starts with a capital letter
+  (Jacques Garrigue, Gabriel Scherer,
+   report by Thomas Leonard and Florian Angeletti)
+
+- PR#7016: fix Stack overflow in GADT typing
+  Note: Equi-recursive types are considered when checking GADT pattern
+  exhaustiveness, even when -rectypes is not used.
+  (Jacques Garrigue, report by Mikhail Mandrykin)
+
+- PR#7030: libasmrun_shared.so fails to build on SPARC Solaris
+  (report and fix by Patrick Star)
+
+- PR#7036: Module alias is not taken into account when checking module
+  type compatibility (in a class type)
+  (Jacques Garrigue)
+
+- PR#7037: more reproducible builds, don't put temp file names into objects
+  (Xavier Leroy)
+
+- PR#7038: out of memory condition in caml_io_mutex_lock
+  (Xavier Leroy, report by Marc Lasson)
+
+- PR#7039: Unix.getsockname returns garbage for unnamed PF_UNIX sockets
+  (Xavier Leroy)
+
+- PR#7042 and GPR#295: CSE optimization confuses the FP literals +0.0 and -0.0
+  (Xavier Leroy)
+
+- PR#7075: Fix repetitions in ocamldoc generated documentation
+  (Florian Angeletti)
+
+- PR#7082: Object type in recursive module's `with` annotation
+  (Jacques Garrigue and Alain Frisch, report by Nicholas Labich)
+
+- PR#7096: ocamldoc uses an incorrect subscript/superscript style
+  (Gabriel Scherer, report by user 'pierpa')
+
+- PR#7108: ocamldoc, have -html preserve custom/extended html generators
+  (Armaël Guéneau)
+
+- PR#7111: reject empty let bindings instead of printing incorrect syntax
+  (Jérémie Dimino)
+
+* PR#7113: -safe-string can break GADT compatibility check
+  bytes and string are now considered compatible even with -safe-string,
+  which may break exhaustivity for code assuming they were disjoint
+  (Jacques Garrigue, report by Jeremy Yallop)
+
+- PR#7115: shadowing in a branch of a GADT match breaks unused variable warning
+  (Alain Frisch, report by Valentin Gatien-Baron)
+
+- PR#7133, GPR#450: generate local jump labels on OS X
+  (Bart Jacobs)
+
+- PR#7135: only warn about ground coercions in -principal mode
+  (Jacques Garrigue, report by Jeremy Yallop)
+
+* PR#7152: Typing equality involving non-generalizable type variable
+  A side-effect of the fix is that, for deeply nested non generalizable
+  type variables, having an interface file may no longer be sufficient,
+  and you may have to add a local type annotation (cf PR#7313)
+  (Jacques Garrigue, report by François Bobot)
+
+- PR#7160: Type synonym definitions can weaken gadt constructor types
+  (Jacques Garrigue, report by Mikhail Mandrykin)
+
+- PR#7181: Misleading error message with GADTs and polymorphic variants
+  (Jacques Garrigue, report by Pierre Chambart)
+
+- PR#7182: Assertion failure with recursive modules and externals
+  (Jacques Garrigue, report by Jeremy Yallop)
+
+- PR#7196: "let open" is not correctly pretty-printed to the left of a ';'
+  (Gabriel Scherer, report by Christophe Raffalli)
+
+- PR#7214: Assertion failure in Env.add_gadt_instances
+  (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#7220: fix a memory leak when using both threads and exception backtraces
+  (Gabriel Scherer, review by François Bobot, report by Rob Hoes)
+
+- PR#7222: Escaped existential type
+  (Jacques Garrigue, report by Florian Angeletti)
+
+- PR#7230: Scrutinee discarded in match with only refutation cases
+  (Jacques Garrigue, report by Jeremy Yallop)
+
+- PR#7234: Compatibility check wrong for abstract type constructors
+  (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#7324: OCaml 4.03.0 type checker dies with an assert failure when
+  given some cyclic recusive module expression
+  (Jacques Garrigue, report by jmcarthur)
+
+- PR#7368: Manual major GC fails to compact the heap
+  (Krzysztof Pszeniczny)
+
+- GPR#205: Clear caml_backtrace_last_exn before registering as root
+  (report and fix by Frédéric Bour)
+
+- GPR#220: minor -dsource error on recursive modules
+  (Hongbo Zhang)
+
+- GPR#228: fix a dangling internal pointer in (bytecode )debug_info
+  (Gabriel Scherer and Mark Shinwell and Xavier Leroy)
+
+- GPR#233: Make CamlinternalMod.init_mod robust to optimization
+  (Pierre Chambart, Mark Shinwell)
+
+- GPR#249: fix a few hardcoded ar commands
+  (Daniel Bünzli)
+
+- GPR#251: fix cross-compilation with ocamldoc enabled
+  (whitequark)
+
+- GPR#280: Fix stdlib dependencies for .p.cmx
+  (Pierre Chambart, Mark Shinwell)
+
+- GPR#283: Fix memory leaks in intern.c when OOM is raised
+  (Marc Lasson, review by Alain Frisch)
+
+- GPR#22: Fix the cleaning of weak pointers. In very rare cases
+  accessing a value during the cleaning of the weak pointers could
+  result in the value being removed from one weak arrays and kept in
+  another one. That breaks the property that a value is removed from a
+  weak pointer only when it is dead and garbage collected.
+  (François Bobot, review by Damien Doligez)
+
+- GPR#313: Prevent quadratic cases in CSE
+  (Pierre Chambart, review by Xavier Leroy)
+
+- PR#6795, PR#6996: Make ocamldep report errors passed in
+  [%ocaml.error] extension points
+  (Jérémie Dimino)
+
+- GPR#355: make ocamlnat build again
+  (Jérémie Dimino, Thomas Refis)
+
+- GPR#405: fix compilation under Visual Studio 2015
+  (David Allsopp)
+
+- GPR#441: better type error location in presence of type constraints
+  (Thomas Refis, report by Arseniy Alekseyev)
+
+- GPR#477: reallow docstrings inside object types, and inside polymorphic
+  variant and arrow types
+  (Thomas Refis)
+
+### Features wishes:
+
+- PR#4518, GPR#29: change location format for reporting errors in ocamldoc
+  (Sergei Lebedev)
+
+- PR#4714: List.cons
+
+- PR#5418 (comments) : generate dependencies with $(CC) instead of gcc
+  (Damien Doligez, report by Michael Grünewald)
+
+- PR#6167: OCAMLPARAM support for disabling PIC generation ("pic=0")
+  (Gabor Pali)
+
+- PR#6367, GPR#25: introduce Asttypes.arg_label to encode labelled arguments
+  (Frédéric Bour and Jacques Garrigue)
+
+- PR#6452, GPR#140: add internal suport for custom printing formats
+  (Jérémie Dimino)
+
+- PR#6611: remove the option wrapper on optional arguments in the syntax tree
+  (Alain Frisch, review by Damien Doligez, request by whitequark)
+
+- PR#6635: support M.[], M.(), M.{< >} and M.[| |]
+  (Jeremy Yallop, review by Gabriel Radanne)
+
+- PR#6691: install .cmt[i] files for stdlib and compiler-libs
+  (David Sheets, request by Gabriel Radanne)
+
+- PR#6722: compatibility with x32 architecture (x86-64 in ILP32 mode).
+  ocamlopt is not supported, but bytecode compiles cleanly.
+  (Adam Borowski and Xavier Leroy)
+
+- PR#6742: remove duplicate virtual_flag information from Tstr_class
+  (Gabriel Radanne and Jacques Garrigue)
+
+- PR#6719: improve Buffer.add_channel when not enough input is available
+  (Simon Cruanes)
+
+* PR#6816: reject integer and float literals directly followed by an identifier.
+  This was prevously read as two separate tokens.
+  [let abc = 1 in (+) 123abc] was accepted and is now rejected.
+  (Hugo Heuzard)
+
+- PR#6876: improve warning 6 by listing the omitted labels.
+  (Warning 6: Label omitted in function application)
+  (Eyyüb Sari)
+
+- PR#6924: tiny optim to avoid some spilling of floats in x87
+  (Alain Frisch)
+
+- GPR#111: `(f [@taillcall]) x y` warns if `f x y` is not a tail-call
+  (Simon Cruanes)
+
+- GPR#118: ocamldep -allow-approx: fallback to a lexer-based approximation
+  (Frédéric Bour)
+
+- GPR#137: add untypeast.ml (in open recursion style) to compiler-libs
+  (Gabriel Radanne)
+
+- GPR#142: add a CAMLdrop macro for undoing CAMLparam*/CAMLlocal*
+  (Thomas Braibant and Damien Doligez)
+
+- GPR#145: speeedup bigarray access by optimizing Cmmgen.bigarray_indexing
+  (Vladimir Brankov, review by Gabriel Scherer)
+
+- GPR#147: [type 'a result = Ok of 'a | Error of 'b] in Pervasives
+  (Yaron Minsky)
+
+- GPR#156, GPR#279: optimize caml_frame_descriptors realloc (dynlink speedup)
+  (Pierre Chambart, Alain Frisch,
+   review by François Bobot, Xavier Leroy and Damien Doligez)
+
+- GPR#165, GPR#221: fix windows compilation warnings
+  (Bernhard Schommer, Gabriel Scherer, report by Alain Frisch)
+
+* GPR#170: Parse arbitrary precision integers.
+  Accept a single [A-Za-z] as modifier for integers (generalizing 'l','L','n')
+  and floats.
+  May cause breakage (ie. ppx preprocessor) because of changes in the parsetree.
+  This changes PR#6816 a little bit by reading the literal [123a] as a single
+  token that can later be rewritten by a ppx preprocessor.
+  (Hugo Heuzard)
+
+- GPR#189: Added .dylib and .so as extensions for ocamlmklib
+  (Edgar Aroutiounian, whitequark)
+
+- GPR#191: Making gc.h and some part of memory.h public
+  (Thomas Refis)
+
+- GPR#196: Make [Thread.id] and [Thread.self] [noalloc]
+  (Clark Gaebel)
+
+- GPR#237: a CONTRIBUTING document
+  (François Bobot, Gabriel Scherer, review by Xavier Leroy)
+
+- GPR#245: remove a few remaining French comments
+  (Florian Angeletti)
+
+- GPR#252: improve build instructions in MSVC Windows README
+  (Philip Daian)
+
+- GPR#308: add experimental support for NetBSD/arm (verified on RaspberryPi)
+  (Rich Neswold)
+
+- GPR#335: Type error messages specifies if a type is abstract
+  because no corresponding cmi could be found.
+  (Hugo Heuzard)
+
+- GPR#365: prevent printing just a single type variable on one side
+  of a type error clash.
+  (Hugo Heuzard)
+
+- GPR#383: configure: define _ALL_SOURCE for build on AIX7.1
+  (tkob)
+
+- GPR#401: automatically retry failed test directories in the testsuite
+  (David Allsopp)
+
+- GPR#451: an optional 'parallel' target in testsuite/Makefile using the
+  GNU parallel tool to run tests in parallel.
+  (Gabriel Scherer)
+
+- GPR#555: ensure that register typing constraints are respected at
+  join points in the control flow graph
+  (Mark Shinwell, debugging & test case by Arseniy Alekseyev and Leo White,
+    code review by Xavier Leroy)
+
+### Build system:
+
+- GPR#388: FlexDLL added as a Git submodule and bootstrappable with the compiler
+  (David Allsopp)
+
+OCaml 4.02.3 (27 Jul 2015):
+---------------------------
+
+Bug fixes:
+- PR#6908: Top-level custom printing for GADTs: interface change in 4.02.2
+  (Grégoire Henry, report by Jeremy Yallop)
+- PR#6919: corrupted final_table
+  (ygrek)
+- PR#6926: Regression: ocamldoc lost unattached comment
+  (Damien Doligez, report by François Bobot)
+- PR#6930: Aliased result type of GADT constructor results in assertion failure
+  (Jacques Garrigue)
+
+Feature wishes:
+- PR#6691: install .cmt[i] files for stdlib and compiler-libs
+  (David Sheets, request by Gabriel Radanne)
+- GPR#37: New primitive: caml_alloc_dummy_function
+  (Hugo Heuzard)
+
+OCaml 4.02.2 (17 Jun 2015):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+Language features:
+- PR#6583: add a new class of binary operators with the same syntactic
+  precedence as method calls; these operators start with # followed
+  by a non-empty sequence of operator symbols (for instance #+, #!?).
+  It is also possible to use '#' as part of these extra symbols
+  (for instance ##, or #+#); this is rejected by the type-checker,
+  but can be used e.g. by ppx rewriters.
+  (Alain Frisch, request by Gabriel Radanne)
+* PR#6016: add a "nonrec" keyword for type declarations
+  (Jérémie Dimino)
+* PR#6612, GPR#152: change the precedence of attributes in type declarations
+  (Jérémie Dimino)
+
+Compilers:
+- PR#6600: make -short-paths faster by building the printing map
+  incrementally
+  (Jacques Garrigue)
+- PR#6642: replace $CAMLORIGIN in -ccopt with the path to cma or cmxa
+  (whitequark, Gabriel Scherer, review by Damien Doligez)
+- PR#6797: new option -output-complete-obj
+  to output an object file with included runtime and autolink libraries
+  (whitequark)
+- PR#6845: -no-check-prims to tell ocamlc not to check primitives in runtime
+  (Alain Frisch)
+- GPR#149: Attach documentation comments to parse tree
+  (Leo White)
+- GPR#159: Better locations for structure/signature items
+  (Leo White)
+
+Toplevel and debugger:
+- PR#5958: generalized polymorphic #install_printer
+  (Pierre Chambart and Grégoire Henry)
+
+OCamlbuild:
+- PR#6237: explicit "infer" tag to control or disable menhir --infer
+  (Hugo Heuzard)
+- PR#6625: pass -linkpkg to files built with -output-obj.
+  (whitequark)
+- PR#6702: explicit "linkpkg" and "dontlink(foo)" flags
+  (whitequark, Gabriel Scherer)
+- PR#6712: Ignore common VCS directories
+  (whitequark)
+- PR#6720: pass -g to C compilers when tag 'debug' is set
+  (whitequark, Gabriel Scherer)
+- PR#6733: add .byte.so and .native.so targets to pass
+  -output-obj -cclib -shared.
+  (whitequark)
+- PR#6733: "runtime_variant(X)" to pass -runtime-variant X option.
+  (whitequark)
+- PR#6774: new menhir-specific flags "only_tokens" and "external_tokens(Foo)"
+  (François Pottier)
+
+Libraries:
+- PR#6285: Add support for nanosecond precision in Unix.stat()
+  (Jérémie Dimino, report by user 'gfxmonk')
+- PR#6781: Add higher baud rates to Unix termios
+  (Damien Doligez, report by Berke Durak)
+- PR#6834: Add Obj.{first,last}_non_constant_constructor_tag
+  (Mark Shinwell, request by Gabriel Scherer)
+
+Runtime:
+- PR#6078: Release the runtime system when calling caml_dlopen
+  (Jérémie Dimino)
+- PR#6675: GC hooks
+  (Damien Doligez and Roshan James)
+
+Build system:
+- PR#5418 (comments) : generate dependencies with $(CC) instead of gcc
+  (Damien Doligez and Michael Grünewald)
+- PR#6266: Cross compilation for iOs, Android etc
+  (whitequark, review by Damien Doligez and Mark Shinwell)
+
+Installation procedure:
+- Update instructions for x86-64 PIC mode and POWER architecture builds
+  (Mark Shinwell)
+
+Bug fixes:
+- PR#5271: Location.prerr_warning is hard-coded to use Format.err_formatter
+  (Damien Doligez, report by Rolf Rolles)
+- PR#5395: OCamlbuild mishandles relative symlinks and include paths
+  (Damien Doligez, report by Didier Le Botlan)
+- PR#5822: wrong value of Options.ext_dll on windows
+  (Damien Doligez and Daniel Weil)
+- PR#5836, PR#6684: printing lazy values in ocamldebug may segfault
+  (Gabriel Scherer, request by the Coq team)
+- PR#5887: move the byterun/*.h headers to byterun/caml/*.h to avoid
+  header name clashes
+  (Jérôme Vouillon and Adrien Nader and whitequark)
+- PR#6281: Graphics window does not acknowledge second click (double click)
+  (Kyle Headley)
+- PR#6490: incorrect backtraces in gdb on AArch64.  Also fixes incorrect
+  backtraces on 32-bit ARM.
+  (Mark Shinwell)
+- PR#6573: extern "C" for systhreads/threads.h
+  (Mickaël Delahaye)
+- PR#6575: Array.init evaluates callback although it should not do so
+  (Alain Frisch, report by Gerd Stolpmann)
+- PR#6607: The manual doesn't mention 0x200 flag for OCAMLRUNPARAM=v
+  (Alain Frisch)
+- PR#6616: allow meaningful use of -use-runtime without -custom.
+  (whitequark)
+- PR#6617: allow android build with pthreads support (since SDK r10c)
+  (whitequark)
+- PR#6626: ocamlbuild on cygwin cannot find ocamlfind
+  (Gergely Szilvasy)
+- PR#6628: Configure script rejects legitimate arguments
+  (Michael Grünewald, Damien Doligez)
+- PR#6630: Failure of tests/prim-bigstring/{big,}string.ml on big-endian
+  architectures
+  (Pierre Chambart, testing by Mark Shinwell)
+- PR#6640: ocamlbuild: wrong "unused tag" warning on "precious"
+  (report by user 'william')
+- PR#6652: ocamlbuild -clean does not print a newline after output
+  (Damien Doligez, report by Andi McClure)
+- PR#6658: cross-compiler: version check not working on OS X
+  (Gerd Stolpmann)
+- PR#6665: Failure of tests/asmcomp on sparc
+  (Stéphane Glondu)
+- PR#6667: wrong implementation of %bswap16 on ARM64
+  (Xavier Leroy)
+- PR#6669: fix 4.02 regression in toplevel printing of lazy values
+  (Leo White, review by Gabriel Scherer)
+- PR#6671: Windows: environment variable 'TZ' affects Unix.gettimeofday
+  (Mickaël Delahaye and Damien Doligez)
+- PR#6680: Missing parentheses in warning about polymorphic variant value
+  (Jacques Garrigue and Gabriel Scherer, report by Philippe Veber)
+- PR#6686: Bug in [subst_boxed_number]
+  (Jérémie Dimino, Mark Shinwell)
+- PR#6690: Uncaught exception (Not_found) with (wrong) wildcard or unification
+  type variable in place of a local abstract type
+  (Jacques Garrigue, report by Mikhail Mandrykin)
+- PR#6693 (part two): Incorrect relocation types in x86-64 runtime system
+  (whitequark, review by Jacques-Henri Jourdan, Xavier Leroy and Mark Shinwell)
+- PR#6717: Pprintast does not print let-pattern attributes
+  (Gabriel Scherer, report by whitequark)
+- PR#6727: Printf.sprintf "%F" misbehavior
+  (Benoît Vaugon, report by Vassili Karpov)
+- PR#6747: ocamlobjinfo: missing symbol caml_plugin_header due to underscore
+  (Damien Doligez, Maverick Woo)
+- PR#6749: ocamlopt returns n for (n mod 1) instead of 0
+  (Mark Shinwell and Jérémie Dimino)
+- PR#6753: Num.quo_num and Num.mod_num incorrect for some negative arguments
+  (Xavier Leroy)
+- PR#6758: Ocamldoc "analyse_module: parsetree and typedtree don't match"
+  (Damien Doligez, report by user 'maro')
+- PR#6759: big_int_of_string incorrectly parses some hexa literals
+  (Damien Doligez, report by Pierre-yves Strub)
+- PR#6763: #show with -short-paths doesn't select shortest type paths
+  (Jacques Garrigue, report by David Sheets)
+- PR#6768: Typechecker overflow the stack on cyclic type
+  (Jacques Garrigue, report by user 'darktenaibre')
+- PR#6770: (duplicate of PR#6686)
+- PR#6772: asmrun/signals_asm.c doesn't compile on NetBSD/i386
+  (Kenji Tokudome)
+- PR#6775: Digest.file leaks file descriptor on error
+  (Valentin Gatien-Baron)
+- PR#6779: Cross-compilers cannot link bytecode using custom primitives
+  (Damien Doligez, request by whitequark)
+- PR#6787: Soundness bug with polymorphic variants
+  (Jacques Garrigue, with help from Leo White and Grégoire Henry,
+   report by Michael O'Connor)
+- PR#6790: otherlibs should be built with -g
+  (Damien Doligez, report by whitequark)
+- PR#6791: "%s@[", "%s@{" regression in Scanf
+  (Benoît Vaugon)
+- PR#6793: ocamlbuild passes nonsensical "-ocamlc ..." commands to menhir
+  (Gabriel Scherer, report by Damien Doligez)
+- PR#6799: include guards missing for unixsupport.h and other files
+  (Andreas Hauptmann)
+- PR#6810: Improve documentation of Bigarray.Genarray.map_file
+  (Mark Shinwell and Daniel Bünzli)
+- PR#6812: -short-paths and -no-alias-deps can create inconsistent assumptions
+  (Jacques Garrigue, report by Valentin Gatien-Baron)
+- PR#6817: GADT exhaustiveness breakage with modules
+  (Leo White, report by Pierre Chambart)
+- PR#6824: fix buffer sharing on partial application of Format.asprintf
+  (Gabriel Scherer, report by Alain Frisch)
+- PR#6831: Build breaks for -aspp gcc on solaris-like OSs
+  (John Tibble)
+- PR#6836: Assertion failure using -short-paths
+  (Jacques Garrigue, report by David Sheets)
+- PR#6837: Build profiling libraries on FreeBSD and NetBSD x86-64
+  (Mark Shinwell, report by Michael Grünewald)
+- PR#6841: Changing compilation unit name with -o breaks ocamldebug
+  (Jacques Garrigue, report by Jordan Walke)
+- PR#6842: export Typemod.modtype_of_package
+- PR#6843: record weak dependencies even when the .cmi is missing
+  (Leo White, Gabriel Scherer)
+- PR#6849: Inverted pattern unification error
+  (Jacques Garrigue, report by Leo White)
+- PR#6857: __MODULE__ doesn't give the current module with -o
+  (Jacques Garrigue, report by Valentin Gatien-Baron)
+- PR#6862: Exhaustiveness check wrong for class constructor arguments
+  (Jacques Garrigue)
+- PR#6869: Improve comment on [Hashtbl.hash_param]
+  (Mark Shinwell, report by Jun Furuse)
+- PR#6870: Unsoundness when -rectypes fails to detect non-contractive type
+  (Jacques Garrigue, report by Stephen Dolan)
+- PR#6872: Type-directed propagation fails to disambiguate variants
+  that are also exception constructors
+  (Jacques Garrigue, report by Romain Beauxis)
+- PR#6878: AArch64 backend generates invalid asm: conditional branch
+  out of range (Mark Shinwell, report by Richard Jones, testing by Richard
+  Jones and Xavier Leroy, code review by Xavier Leroy and Thomas Refis)
+- PR#6879: Wrong optimization of 1 mod n
+  (Mark Shinwell, report by Jean-Christophe Filliâtre)
+- PR#6884: The __CYGWIN32__ #define should be replaced with __CYGWIN__
+  (Adrien Nader)
+- PR#6886: -no-alias-deps allows to build self-referential compilation units
+  (Jacques Garrigue, report by Valentin Gatien-Baron)
+- PR#6889: ast_mapper fails to rewrite class attributes
+  (Sébastien Briais)
+- PR#6893: ocamlbuild:  "tag not used" warning when using (p)dep
+  (Gabriel Scherer, report by Christiano Haesbaert)
+- GPR#143: fix getsockopt behaviour for boolean socket options
+  (Anil Madhavapeddy and Andrew Ray)
+- GPR#190: typo in pervasives
+  (Guillaume Bury)
+- Misplaced assertion in major_gc.c for no-naked-pointers mode
+  (Stephen Dolan, Mark Shinwell)
+
+Feature wishes:
+- PR#6452, GPR#140: add internal suport for custom printing formats
+  (Jérémie Dimino)
+- PR#6641: add -g, -ocamlcflags, -ocamloptflags options to ocamlmklib
+  (whitequark)
+- PR#6693: also build libasmrun_shared.so and lib{asm,caml}run_pic.a
+  (whitequark, review by Mark Shinwell)
+- PR#6842: export Typemod.modtype_of_package
+  (Jacques Garrigue, request by Jun Furuse)
+- GPR#139: more versatile specification of locations of .annot
+  (Christophe Troestler, review by Damien Doligez)
+- GPR#171: allow custom warning printers / catchers
+  (Benjamin Canou, review by Damien Doligez)
+- GPR#191: Making gc.h and some part of memory.h public
+  (Thomas Refis)
+
+OCaml 4.02.1 (14 Oct 2014):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+Standard library:
+* Add optional argument ?limit to Arg.align.
+
+Bug Fixes:
+- PR#4099: Bug in Makefile.nt: won't stop on error
+  (George Necula)
+- PR#6181: Improve MSVC build
+  (Chen Gang)
+- PR#6207: Configure doesn't detect features correctly on Haiku
+  (Jessica Hamilton)
+- PR#6466: Non-exhaustive matching warning message for open types is confusing
+  (whitequark)
+- PR#6529: fix quadratic-time algorithm in Consistbl.extract.
+  (Xavier Leroy, Alain Frisch, relase-worthy report by Jacques-Pascal Deplaix)
+- PR#6530: Add stack overflow handling for native code (OpenBSD i386 and amd64)
+  (Cristopher Zimmermann)
+- PR#6533: broken semantics of %(%) when substituted by a box
+  (Benoît Vaugon, report by Boris Yakobowski)
+- PR#6534: legacy support for %.10s
+  (Benoît Vaugon, Gabriel Scherer, report by Nick Chapman)
+- PR#6536: better documentation of flag # in format strings
+  (Damien Doligez, report by Nick Chapman)
+- PR#6544: Bytes and CamlinternalFormat missing from threads stdlib.cma
+  (Christopher Zimmermann)
+- PR#6546: -dsource omits parens for `List ((`String "A")::[]) in patterns
+  (Gabriel Scherer, report by whitequark)
+- PR#6547: __MODULE__ aborts the compiler if the module name cannot be inferred
+  (Jacques Garrigue, report by Kaustuv Chaudhuri)
+- PR#6549: Debug section is sometimes not readable when using -pack
+  (Hugo Heuzard, review by Gabriel Scherer)
+- PR#6553: Missing command line options for ocamldoc
+  (Maxence Guesdon)
+- PR#6554: fix race condition when retrieving backtraces
+  (Jérémie Dimino, Mark Shinwell).
+- PR#6557: String.sub throws Invalid_argument("Bytes.sub")
+  (Damien Doligez, report by Oliver Bandel)
+- PR#6562: Fix ocamldebug module source lookup
+  (Leo White)
+- PR#6563: Inclusion of packs failing to run module initializers
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6564: infinite loop in Mtype.remove_aliases
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6565: compilation fails with Env.Error(_)
+  (Jacques Garrigue and Mark Shinwell)
+- PR#6566: -short-paths and signature inclusion errors
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6572: Fatal error with recursive modules
+  (Jacques Garrigue, report by Quentin Stievenart)
+- PR#6575: Array.init evaluates callback although it should not do so
+  (Alain Frisch, report by Gerd Stolpmann)
+- PR#6578: Recursive module containing alias causes Segmentation fault
+  (Jacques Garrigue)
+- PR#6581: Some bugs in generative functors
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6584: ocamldep support for "-open M"
+  (Gabriel Scherer, review by Damien Doligez, report by Hezekiah M. Carty)
+- PR#6588: Code generation errors for ARM
+  (Mark Shinwell, Xavier Leroy)
+- PR#6590: Improve Windows (MSVC and mingw) build
+  (Chen Gang)
+- PR#6599: ocamlbuild: add -bin-annot when using -pack
+  (Christopher Zimmermann)
+- PR#6602: Fatal error when tracing a function with abstract type
+  (Jacques Garrigue, report by Hugo Herbelin)
+- ocamlbuild: add an -ocamlmklib option to change the ocamlmklib command
+  (Jérôme Vouillon)
+
+OCaml 4.02.0 (29 Aug 2014):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+Language features:
+- Attributes and extension nodes
+  (Alain Frisch)
+- Generative functors (PR#5905)
+  (Jacques Garrigue)
+* Module aliases
+  (Jacques Garrigue)
+* Alternative syntax for string literals {id|...|id} (can break comments)
+  (Alain Frisch)
+- Separation between read-only strings (type string) and read-write byte
+  sequences (type bytes). Activated by command-line option -safe-string.
+  (Damien Doligez)
+- PR#6318: Exception cases in pattern matching
+  (Jeremy Yallop, backend by Alain Frisch)
+- PR#5584: Extensible open datatypes
+  (Leo White)
+
+Build system for the OCaml distribution:
+- Use -bin-annot when building.
+- Use GNU make instead of portable makefiles.
+- Updated build instructions for 32-bit Mac OS X on Intel hardware.
+
+Shedding weight:
+* Removed Camlp4 from the distribution, now available as third-party software.
+* Removed Labltk from the distribution, now available as a third-party library.
+
+Type system:
+* PR#6235: Keep typing of pattern cases independent in principal mode
+  (i.e. information from previous cases is no longer used when typing
+  patterns; cf. 'PR#6235' in testsuite/test/typing-warnings/records.ml)
+  (Jacques Garrigue)
+- Allow opening a first-class module or applying a generative functor
+  in the body of a generative functor. Allow it also in the body of
+  an applicative functor if no types are created
+  (Jacques Garrigue, suggestion by Leo White)
+* Module aliases are now typed in a specific way, which remembers their
+  identity. Compiled interfaces become smaller, but may depend on the
+  original modules. This also changes the signature inferred by
+  "module type of".
+  (Jacques Garrigue, feedback from Leo White, Mark Shinwell and Nick Chapman)
+- PR#6331: Slight change in the criterion to distinguish private
+  abbreviations and private row types: create a private abbreviation for
+  closed objects and fixed polymorphic variants.
+  (Jacques Garrigue)
+* PR#6333: Compare first class module types structurally rather than
+  nominally. Value subtyping allows module subtyping as long as the internal
+  representation is unchanged.
+  (Jacques Garrigue)
+
+Compilers:
+- More aggressive constant propagation, including float and
+  int32/int64/nativeint arithmetic.  Constant propagation for floats
+  can be turned off with option -no-float-const-prop, for codes that
+  change FP rounding modes at run-time.
+  (Xavier Leroy)
+- New back-end optimization pass: common subexpression elimination (CSE).
+  (Reuses results of previous computations instead of recomputing them.)
+  (Xavier Leroy)
+- New back-end optimization pass: dead code elimination.
+  (Removes arithmetic and load instructions whose results are unused.)
+  (Xavier Leroy)
+- PR#6269: Optimization of sequences of string patterns
+  (Benoît Vaugon and Luc Maranget)
+- Experimental native code generator for AArch64 (ARM 64 bits)
+  (Xavier Leroy)
+- PR#6042: Optimization of integer division and modulus by constant divisors
+  (Xavier Leroy and Phil Denys)
+- Add "-open" command line flag for opening a single module before typing
+  (Leo White, Mark Shinwell and Nick Chapman)
+* "-o" now sets module name to the output file name up to the first "."
+  (it also applies when "-o" is not given, i.e. the module name is then
+   the input file name up to the first ".")
+  (Leo White, Mark Shinwell and Nick Chapman)
+* PR#5779: better sharing of structured constants
+  (Alain Frisch)
+- PR#5817: new flag to keep locations in cmi files
+  (Alain Frisch)
+- PR#5854: issue warning 3 when referring to a value marked with
+  the [@@ocaml.deprecated] attribute
+  (Alain Frisch, suggestion by Pierre-Marie Pédrot)
+- PR#6017: a new format implementation based on GADTs
+  (Benoît Vaugon and Gabriel Scherer)
+* PR#6203: Constant exception constructors no longer allocate
+  (Alain Frisch)
+- PR#6260: avoid unnecessary boxing in let
+  (Vladimir Brankov)
+- PR#6345: Better compilation of optional arguments with default values
+  (Alain Frisch, review by Jacques Garrigue)
+- PR#6389: ocamlopt -opaque option for incremental native compilation
+  (Pierre Chambart, Gabriel Scherer)
+
+Toplevel interactive system:
+- PR#5377: New "#show_*" directives
+  (ygrek, Jacques Garrigue and Alain Frisch)
+
+Runtime system:
+- New configure option "-no-naked-pointers" to improve performance by
+  avoiding page table tests during block darkening and the marking phase
+  of the major GC.  In this mode, all out-of-heap pointers must point at
+  things that look like OCaml values: in particular they must have a valid
+  header.  The colour of said headers should be black.
+  (Mark Shinwell, reviews by Damien Doligez and Xavier Leroy)
+- Fixed bug in native code version of [caml_raise_with_string] that could
+  potentially lead to heap corruption.
+  (Mark Shinwell)
+* Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with
+  [Val_unit] rather than zero.
+  (Mark Shinwell)
+- Fixed a major performance problem on large heaps (~1GB) by making heap
+  increments proportional to heap size by default
+  (Damien Doligez)
+- PR#4765: Structural equality treats exception specifically
+  (Alain Frisch)
+- PR#5009: efficient comparison/indexing of exceptions
+  (Alain Frisch, request by Markus Mottl)
+- PR#6075: avoid using unsafe C library functions (strcpy, strcat, sprintf)
+  (Xavier Leroy, reports from user 'jfc' and Anil Madhavapeddy)
+- An ISO C99-compliant C compiler and standard library is now assumed.
+  (Plus special exceptions for MSVC.)  In particular, emulation code for
+  64-bit integer arithmetic was removed, the C compiler must support a
+  64-bit integer type.
+  (Xavier Leroy)
+
+Standard library:
+* Add new modules Bytes and BytesLabels for mutable byte sequences.
+  (Damien Doligez)
+- PR#4986: add List.sort_uniq and Set.of_list
+  (Alain Frisch)
+- PR#5935: a faster version of "raise" which does not maintain the backtrace
+  (Alain Frisch)
+- PR#6146: support "Unix.kill pid Sys.sigkill" under Windows
+  (Romain Bardou and Alain Frisch)
+- PR#6148: speed improvement for Buffer
+  (John Whitington)
+- PR#6180: efficient creation of uninitialized float arrays
+  (Alain Frisch, request by Markus Mottl)
+- PR#6355: Improve documentation regarding finalisers and multithreading
+  (Daniel Bünzli, Mark Shinwell)
+- Trigger warning 3 for all values marked as deprecated in the documentation.
+  (Damien Doligez)
+
+OCamldoc:
+- PR#6257: handle full doc comments for variant constructors and
+  record fields
+  (Maxence Guesdon, request by ygrek)
+- PR#6274: allow doc comments on object types
+  (Thomas Refis)
+- PR#6310: fix ocamldoc's subscript/superscript CSS font size
+  (Anil Madhavapeddy)
+- PR#6425: fix generation of man pages
+  (Maxence Guesdon, report by Anil Madhavapeddy)
+
+Bug fixes:
+- PR#2719: wrong scheduling of bound checks within a
+  try...with Invalid_argument -> _ ...  (Xavier Leroy)
+- PR#4719: Sys.executable_name wrong if executable name contains dots (Windows)
+  (Alain Frisch, report by Bart Jacobs)
+- PR#5406 ocamlbuild: "tag 'package' does not expect a parameter"
+  (Gabriel Scherer)
+- PR#5598, PR#6165: Alterations to handling of \013 in source files
+  breaking other tools
+  (David Allsopp and Damien Doligez)
+- PR#5820: Fix camlp4 lexer roll back problem
+  (Hongbo Zhang)
+- PR#5946: CAMLprim taking (void) as argument
+  (Benoît Vaugon)
+- PR#6038: on x86-32, enforce 16-byte stack alignment for compatibility
+  with recent GCC and Clang.  Win32/MSVC keeps 4-byte stack alignment.
+  (Xavier Leroy)
+- PR#6062: Fix a 4.01 camlp4 DELETE_RULE regression caused by commit 13047
+  (Hongbo Zhang, report by Christophe Troestler)
+- PR#6173: Typing error message is worse than before
+  (Jacques Garrigue and John Whitington)
+- PR#6174: OCaml compiler loops on an example using GADTs (-rectypes case)
+  (Jacques Garrigue and Grégoire Henry, report by Chantal Keller)
+- PR#6175: open! was not suppored by camlp4
+  (Hongbo Zhang)
+- PR#6184: ocamlbuild: `ocamlfind ocamldep` does not support -predicate
+  (Jacques-Pascal Deplaix)
+- PR#6194: Incorrect unused warning with first-class modules in patterns
+  (Jacques Garrigue, report by Markus Mottl and Leo White)
+- PR#6211: in toplevel interactive use, bad interaction between uncaught
+  exceptions and multiple bindings of the form "let x = a let y = b;;".
+  (Xavier Leroy)
+- PR#6216: inlining of GADT matches generates invalid assembly
+  (Xavier Leroy and Alain Frisch, report by Mark Shinwell)
+- PR#6232: Don't use [mktemp] on platforms where [mkstemp] is available
+  (Stéphane Glondu, Mark Shinwell)
+- PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC
+  (Jacques-Henri Jourdan and Xavier Leroy,
+   report and testing by Stéphane Glondu)
+- PR#6235: Issue with type information flowing through a variant pattern
+  (Jacques Garrigue, report by Hongbo Zhang)
+- PR#6239: sometimes wrong stack alignment when raising exceptions
+           in -g mode with backtraces active
+  (Xavier Leroy, report by Yaron Minsky)
+- PR#6240: Fail to expand module type abbreviation during substyping
+  (Jacques Garrigue, report by Leo White)
+- PR#6241: Assumed inequality between paths involving functor arguments
+  (Jacques Garrigue, report by Jeremy Yallop)
+- PR#6243: Make "ocamlopt -g" more resistant to ill-formed locations
+  (Xavier Leroy, report by Pierre-Marie Pédrot)
+- PR#6262: equality of first-class modules take module aliases into account
+  (Alain Frisch and Leo White)
+- PR#6268: -DMODEL_$(MODEL) not passed when building asmrun/arm.p.o
+  (Peter Michael Green)
+- PR#6273: fix Sys.file_exists on large files (Win32)
+  (Christoph Bauer)
+- PR#6275: Soundness bug related to type constraints
+  (Jacques Garrigue, report by Leo White)
+- PR#6293: Assert_failure with invalid package type
+  (Jacques Garrigue, report by Elnatan Reisner)
+- PR#6300: ocamlbuild -use-ocamlfind conflicts with -ocamlc
+  (Gabriel Scherer)
+- PR#6302: bytecode debug information re-read from filesystem every time
+  (Jacques-Henri Jourdan)
+- PR#6307: Behavior of 'module type of' w.r.t. module aliases
+  (Jacques Garrigue, report by Alain Frisch)
+- PR#6332: Unix.open_process fails to pass empty arguments under Windows
+  (Damien Doligez, report Virgile Prevosto)
+- PR#6346: Build failure with latest version of xcode on OSX
+  (Jérémie Dimino)
+- PR#6348: Unification failure for GADT when original definition is hidden
+  (Leo White and Jacques Garrigue, report by Jeremy Yallop)
+- PR#6352: Automatic removal of optional arguments and sequencing
+  (Jacques Garrigue and Alain Frisch)
+- PR#6361: Hashtbl.hash not terminating on some lazy values w/ recursive types
+  (Xavier Leroy, report by Leo White)
+- PR#6383: Exception Not_found when using object type in absent module
+  (Jacques Garrigue, report by Sébastien Briais)
+- PR#6384: Uncaught Not_found exception with a hidden .cmi file
+  (Leo White)
+- PR#6385: wrong allocation of large closures by the bytecode interpreter
+  (Xavier Leroy, report by Stephen Dolan)
+- PR#6394: Assertion failed in Typecore.expand_path
+  (Alain Frisch and Jacques Garrigue)
+- PR#6405: unsound interaction of -rectypes and GADTs
+  (Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon)
+- PR#6408: Optional arguments given as ~?arg instead of ?arg in message
+  (Michael O'Connor)
+- PR#6411: missing libgcc_s_sjlj-1.dll in mingw (add -static-libgcc)
+  (Jun Furuse and Alain Frisch, Jonathan Protzenko and Adrien Nader)
+- PR#6436: Typos in @deprecated text in stdlib/arrayLabels.mli
+  (John Whitington)
+- PR#6439: Don't use the deprecated [getpagesize] function
+  (John Whitington, Mark Shinwell)
+- PR#6441: undetected tail-call in some mutually-recursive functions
+  (many arguments, and mutual block mixes functions and non-functions)
+  (Stefan Holdermans, review by Xavier Leroy)
+- PR#6443: ocaml segfault when List.fold_left is traced then executed
+  (Jacques Garrigue, report by user 'Reventlov')
+- PR#6451: some bugs in untypeast.ml
+  (Jun Furuse, review by Alain Frisch)
+- PR#6460: runtime assertion failure with large [| e1;...eN |]
+  float array expressions
+  (Leo White)
+- PR#6463: -dtypedtree fails on class fields
+  (Leo White)
+- PR#6469: invalid -dsource printing of "external _pipe = ...", "Pervasives.(!)"
+  (Gabriel Scherer and Damien Doligez, user 'ngunn')
+- PR#6482: ocamlbuild fails when _tags file in unhygienic directory
+  (Gabriel Scherer)
+- PR#6502: ocamlbuild spurious warning on "use_menhir" tag
+  (Xavier Leroy)
+- PR#6505: Missed Type-error leads to a segfault upon record access
+  (Jacques Garrigue, Jeremy Yallop, report by Christoph Höger)
+- PR#6507: crash on AArch64 resulting from incorrect setting of
+  [caml_bottom_of_stack].  (Richard Jones, Mark Shinwell)
+- PR#6509: add -linkall flag to ocamlcommon.cma
+  (Frédéric Bour)
+- PR#6513: Fatal error Ctype.Unify(_) in functor type
+- PR#6523: failure upon character bigarray access, and unnecessary change
+  in comparison ordering (Jeremy Yallop, Mark Shinwell)
+- bound-checking bug in caml_string_{get,set}{16,32,64}
+  (Pierre Chambart and Gabriel Scherer, report by Nicolas Trangez)
+- sometimes wrong stack alignment at out-of-bounds array access
+  (Gabriel Scherer and Xavier Leroy, report by Pierre Chambart)
+
+Features wishes:
+- PR#4243: make the Makefiles parallelizable
+  (Grégoire Henry and Damien Doligez)
+- PR#4323: have "of_string" in Num and Big_int work with binary and
+           hex representations
+  (Zoe Paraskevopoulou, review by Gabriel Scherer)
+- PR#4771: Clarify documentation of Dynlink.allow_only
+  (Damien Doligez, report by David Allsopp)
+- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where'
+  (Jun Furuse and Hongbo Zhang, report by Dmitry Grebeniuk)
+- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances
+  (Daniel Weil)
+- PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types
+  (Hongbo Zhang)
+- PR#5808: allow simple patterns, not just identifiers, in "let p : t = ..."
+  (Alain Frisch)
+- PR#5851: warn when -r is disabled because no _tags file is present
+  (Gabriel Scherer)
+- PR#5899: a programmer-friendly access to backtrace information
+  (Jacques-Henri Jourdan and Gabriel Scherer)
+- PR#6000 comment 9644: add a warning for non-principal coercions to format
+  (Jacques Garrigue, report by Damien Doligez)
+- PR#6054: add support for M.[ foo ], M.[| foo |] etc.
+  (Kaustuv Chaudhuri)
+- PR#6064: GADT representation for Bigarray.kind + CAML_BA_CHAR runtime kind
+  (Jeremy Yallop, review by Gabriel Scherer)
+- PR#6071: Add a -noinit option to the toplevel
+  (David Sheets)
+- PR#6087: ocamlbuild, improve _tags parsing of escaped newlines
+  (Gabriel Scherer, request by Daniel Bünzli)
+- PR#6109: Typos in ocamlbuild error messages
+  (Gabriel Kerneis)
+- PR#6116: more efficient implementation of Digest.to_hex
+  (ygrek)
+- PR#6142: add cmt file support to ocamlobjinfo
+  (Anil Madhavapeddy)
+- PR#6166: document -ocamldoc option of ocamlbuild
+  (Xavier Clerc)
+- PR#6182: better message for virtual objects and class types
+  (Leo White, Stephen Dolan)
+- PR#6183: enhanced documentation for 'Unix.shutdown_connection'
+  (Anil Madhavapeddy, report by Jun Furuse)
+- PR#6187: ocamlbuild: warn when using -plugin-tag(s) without myocamlbuild.ml
+  (Jacques-Pascal Deplaix)
+- PR#6246: allow wildcard _ as for-loop index
+  (Alain Frisch, request by ygrek)
+- PR#6267: more information printed by "bt" command of ocamldebug
+  (Josh Watzman)
+- PR#6270: remove need for -I directives to ocamldebug in common case
+  (Josh Watzman, review by Xavier Clerc and Alain Frisch)
+- PR#6311: Improve signature mismatch error messages
+  (Alain Frisch, suggestion by Daniel Bünzli)
+- PR#6358: obey DESTDIR in install targets
+  (Gabriel Scherer, request by François Berenger)
+- PR#6388, PR#6424: more parsetree correctness checks for -ppx users
+  (Alain Frisch, request by whitequark and Jun Furuse)
+- PR#6406: Expose OCaml version in C headers
+  (whitequark and Romain Calascibetta)
+- PR#6446: improve "unused declaration" warnings wrt. name shadowing
+  (Alain Frisch)
+- PR#6495: ocamlbuild tags 'safe_string', 'unsafe_string'
+  (Anil Madhavapeddy)
+- PR#6497: pass context information to -ppx preprocessors
+  (whitequark, Alain Frisch)
+- ocamllex: user-definable refill action
+  (Frédéric Bour, review by Gabriel Scherer and Luc Maranget)
+- shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .."
+  (Thomas Gazagnaire and Jeremy Yallop, review by Gabriel Scherer)
+- make ocamldebug -I auto-detection work with ocamlbuild
+  (Josh Watzman)
+
+OCaml 4.01.0 (12 Sep 2013):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+Other libraries:
+- Labltk: updated to Tcl/Tk 8.6.
+
+Type system:
+- PR#5759: use well-disciplined type information propagation to
+  disambiguate label and constructor names
+  (Jacques Garrigue, Alain Frisch and Leo White)
+* Propagate type information towards pattern-matching, even in the presence of
+  polymorphic variants (discarding only information about possibly-present
+  constructors). As a result, matching against absent constructors is no longer
+  allowed for exact and fixed polymorphic variant types.
+  (Jacques Garrigue)
+* PR#6035: Reject multiple declarations of the same method or instance variable
+  in an object
+  (Alain Frisch)
+
+Compilers:
+- PR#5861: raise an error when multiple private keywords are used in type
+  declarations
+  (Hongbo Zhang)
+- PR#5634: parsetree rewriter (-ppx flag)
+  (Alain Frisch)
+- ocamldep now supports -absname
+  (Alain Frisch)
+- PR#5768: On "unbound identifier" errors, use spell-checking to suggest names
+  present in the environment
+  (Gabriel Scherer)
+- ocamlc has a new option -dsource to visualize the parsetree
+  (Alain Frisch, Hongbo Zhang)
+- tools/eqparsetree compares two parsetree ignoring location
+  (Hongbo Zhang)
+- ocamlopt now uses clang as assembler on OS X if available, which enables
+  CFI support for OS X.
+  (Benedikt Meurer)
+- Added a new -short-paths option, which attempts to use the shortest
+  representation for type constructors inside types, taking open modules
+  into account. This can make types much more readable if your code
+  uses lots of functors.
+  (Jacques Garrigue)
+- PR#5986: added flag -compat-32 to ocamlc, ensuring that the generated
+  bytecode executable can be loaded on 32-bit hosts.
+  (Xavier Leroy)
+- PR#5980: warning on open statements which shadow an existing
+  identifier (if it is actually used in the scope of the open); new
+  open! syntax to silence it locally
+  (Alain Frisch, thanks to a report of Daniel Bünzli)
+* warning 3 is extended to warn about other deprecated features:
+  - ISO-latin1 characters in identifiers
+  - uses of the (&) and (or) operators instead of (&&) and (||)
+  (Damien Doligez)
+- Experimental OCAMLPARAM for ocamlc and ocamlopt
+  (Fabrice Le Fessant)
+- PR#5571: incorrect ordinal number in error message
+  (Alain Frisch, report by John Carr)
+- PR#6073: add signature to Tstr_include
+  (patch by Leo White)
+
+Standard library:
+- PR#5899: expose a way to inspect the current call stack,
+  Printexc.get_callstack
+  (Gabriel Scherer, Jacques-Henri Jourdan, Alain Frisch)
+- PR#5986: new flag Marshal.Compat_32 for the serialization functions
+  (Marshal.to_*), forcing the output to be readable on 32-bit hosts.
+  (Xavier Leroy)
+- infix application operators |> and @@ in Pervasives
+  (Fabrice Le Fessant)
+- PR#6176: new Format.asprintf function with a %a formatter
+  compatible with Format.fprintf (unlike Format.sprintf)
+  (Pierre Weis)
+
+Other libraries:
+- PR#5568: add O_CLOEXEC flag to Unix.openfile, so that the returned
+  file descriptor is created in close-on-exec mode
+  (Xavier Leroy)
+
+Runtime system:
+* PR#6019: more efficient implementation of caml_modify() and caml_initialize().
+  The new implementations are less lenient than the old ones: now,
+  the destination pointer of caml_modify() must point within the minor or
+  major heaps, and the destination pointer of caml_initialize() must
+  point within the major heap.
+  (Xavier Leroy, from an experiment by Brian Nigito, with feedback
+  from Yaron Minsky and Gerd Stolpmann)
+
+Internals:
+- Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary
+  as part of compilerlibs, to be used on bin-annot files.
+  (Fabrice Le Fessant)
+- The test suite can now be run without installing OCaml first.
+  (Damien Doligez)
+
+Bug fixes:
+- PR#3236: Document the fact that queues are not thread-safe
+  (Damien Doligez)
+- PR#3468: (part 1) Sys_error documentation
+  (Damien Doligez)
+- PR#3679: Warning display problems
+  (Fabrice Le Fessant)
+- PR#3963: Graphics.wait_next_event in Win32 hangs if window closed
+  (Damien Doligez)
+- PR#4079: Queue.copy is now tail-recursive
+  (patch by Christophe Papazian)
+- PR#4138: Documentation for Unix.mkdir
+  (Damien Doligez)
+- PR#4469: emacs mode: caml-set-compile-command is annoying with ocamlbuild
+  (Daniel Bünzli)
+- PR#4485: Graphics: Keyboard events incorrectly delivered in native code
+  (Damien Doligez, report by Sharvil Nanavati)
+- PR#4502: ocamlbuild now reliably excludes the build-dir from hygiene check
+  (Gabriel Scherer, report by Romain Bardou)
+- PR#4762: ?? is not used at all, but registered as a lexer token
+  (Alain Frisch)
+- PR#4788: wrong error message when executable file is not found for backtrace
+  (Damien Doligez, report by Claudio Sacerdoti Coen)
+- PR#4812: otherlibs/unix: add extern int code_of_unix_error (value error);
+  (Goswin von Berdelow)
+- PR#4887: input_char after close_in crashes ocaml (msvc runtime)
+  (Alain Frisch and Christoph Bauer, report by ygrek)
+- PR#4994: ocaml-mode doesn't work with xemacs21
+  (Damien Doligez, report by Stéphane Glondu)
+- PR#5098: creating module values may lead to memory leaks
+  (Alain Frisch, report by Milan Stanojević)
+- PR#5102: ocamlbuild fails when using an unbound variable in rule dependency
+  (Xavier Clerc, report by Daniel Bünzli)
+* PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails,
+  rather than raising 'Not_found'
+  (ygrek)
+- PR#5121: %( %) in Format module seems to be broken
+  (Pierre Weis, first patch by Valentin Gatien-Baron, report by Khoo Yit Phang)
+- PR#5178: document in INSTALL how to build a 32-bit version under Linux x86-64
+  (Benjamin Monate)
+- PR#5212: Improve ocamlbuild error messages of _tags parser
+  (ygrek)
+- PR#5240: register exception printers for Unix.Unix_error and Dynlink.Error
+  (Jérémie Dimino)
+- PR#5300: ocamlbuild: verbose parameter should implicitly set classic display
+  (Xavier Clerc, report by Robert Jakob)
+- PR#5327: (Windows) Unix.select blocks if same socket listed in first and
+  third arguments
+  (David Allsopp, displaying impressive MSDN skills)
+- PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound)
+  (Jacques Garrigue)
+- PR#5350: missing return code checks in the runtime system
+  (Xavier Leroy)
+- PR#5468: ocamlbuild should preserve order of parametric tags
+  (Wojciech Meyer, report by Dario Texeira)
+- PR#5551: Avoid repeated lookups for missing cmi files
+  (Alain Frisch)
+- PR#5552: unrecognized gcc option -no-cpp-precomp
+  (Damien Doligez, report by Markus Mottl)
+* PR#5580: missed opportunities for constant propagation
+  (Xavier Leroy and John Carr)
+- PR#5611: avoid clashes betwen .cmo files and output files during linking
+  (Wojciech Meyer)
+- PR#5662: typo in md5.c
+  (Olivier Andrieu)
+- PR#5673: type equality in a polymorphic field
+  (Jacques Garrigue, report by Jean-Louis Giavitto)
+- PR#5674: Methods call are 2 times slower with 4.00 than with 3.12
+  (Jacques Garrigue, Gabriel Scherer, report by Jean-Louis Giavitto)
+- PR#5694: Exception raised by type checker
+  (Jacques Garrigue, report by Markus Mottl)
+- PR#5695: remove warnings on sparc code emitter
+  (Fabrice Le Fessant)
+- PR#5697: better location for warnings on statement expressions
+  (Dan Bensen)
+- PR#5698: remove harcoded limit of 200000 labels in emitaux.ml
+  (Fabrice Le Fessant, report by Marcin Sawicki)
+- PR#5702: bytecomp/bytelibrarian lib_sharedobjs was defined but never used
+  (Hongbo Zhang, Fabrice Le Fessant)
+- PR#5708: catch Failure"int_of_string" in ocamldebug
+  (Fabrice Le Fessant, report by user 'schommer')
+- PR#5712: (9) new option -bin-annot is not documented
+  (Damien Doligez, report by Hendrik Tews)
+- PR#5731: instruction scheduling forgot to account for destroyed registers
+  (Xavier Leroy, Benedikt Meurer, reported by Jeffrey Scofield)
+- PR#5734: improved Win32 implementation of Unix.gettimeofday
+  (David Allsopp)
+- PR#5735: %apply and %revapply not first class citizens
+  (Fabrice Le Fessant, reported by Jun Furuse)
+- PR#5738: first class module patterns not handled by ocamldep
+  (Fabrice Le Fessant, Jacques Garrigue, reported by Hongbo Zhang)
+- PR#5739: Printf.printf "%F" (-.nan) returns -nan
+  (Xavier Leroy, David Allsopp, reported by Samuel Mimram)
+- PR#5741: make pprintast.ml in compiler_libs
+  (Alain Frisch, Hongbo Zhang)
+- PR#5747: 'unused open' warning not given when compiling with -annot
+  (Alain Frisch, reported by Valentin Gatien-Baron)
+- PR#5752: missing dependencies at byte-code link with mlpack
+  (Wojciech Meyer, Nicholas Lucaroni)
+- PR#5763: ocamlbuild does not give correct flags when running menhir
+  (Gabriel Scherer, reported by Philippe Veber)
+- PR#5765: ocamllex doesn't preserve line directives
+  (Damien Doligez, reported by Martin Jambon)
+- PR#5770: Syntax error messages involving unclosed parens are sometimes
+  incorrect
+  (Michel Mauny)
+- PR#5772: problem with marshaling of mutually-recursive functions
+  (Jacques-Henri Jourdan, reported by Cédric Pasteur)
+- PR#5775: several bug fixes for tools/pprintast.ml
+  (Hongbo Zhang)
+- PR#5784: -dclambda option is ignored
+  (Pierre Chambart)
+- PR#5785: misbehaviour with abstracted structural type used as GADT index
+  (Jacques Garrigue, report by Jeremy Yallop)
+- PR#5787: Bad behavior of 'Unused ...' warnings in the toplevel
+  (Alain Frisch)
+- PR#5793: integer marshalling is inconsistent between architectures
+  (Xavier Clerc, report by Pierre-Marie Pédrot)
+- PR#5798: add ARM VFPv2 support for Raspbian (ocamlopt)
+  (Jeffrey Scofield and Anil Madhavapeddy, patch review by Benedikt Meurer)
+- PR#5802: Avoiding "let" as a value name
+  (Jacques Garrigue, report by Tiphaine Turpin)
+- PR#5805: Assert failure with warning 34 on pre-processed file
+  (Alain Frisch, report by Tiphaine Turpin)
+- PR#5806: ensure that backtrace tests are always run (testsuite)
+  (Xavier Clerc, report by user 'michi')
+- PR#5809: Generating .cmt files takes a long time, in case of type error
+  (Alain Frisch)
+- PR#5810: error in switch printing when using -dclambda
+  (Pierre Chambart)
+- PR#5811: Untypeast produces singleton tuples for constructor patterns
+  with only one argument
+  (Tiphaine Turpin)
+- PR#5813: GC not called when unmarshaling repeatedly in a tight loop (ocamlopt)
+  (Xavier Leroy, report by David Waern)
+- PR#5814: read_cmt -annot does not report internal references
+  (Alain Frisch)
+- PR#5815: Multiple exceptions in signatures gives an error
+  (Leo White)
+- PR#5816: read_cmt -annot does not work for partial .cmt files
+  (Alain Frisch)
+- PR#5819: segfault when using [with] on large recursive record (ocamlopt)
+  (Xavier Leroy, Damien Doligez)
+- PR#5821: Wrong record field is reported as duplicate
+  (Alain Frisch, report by Martin Jambon)
+- PR#5824: Generate more efficient code for immediate right shifts.
+  (Pierre Chambart, review by Xavier Leroy)
+- PR#5825: Add a toplevel primitive to use source file wrapped with the
+  coresponding module
+  (Grégoire Henry, Wojciech Meyer, caml-list discussion)
+- PR#5833: README.win32 can leave the wrong flexlink in the path
+  (Damien Doligez, report by William Smith)
+- PR#5835: nonoptional labeled arguments can be passed with '?'
+  (Jacques Garrigue, report by Elnatan Reisner)
+- PR#5840: improved documentation for 'Unix.lseek'
+  (Xavier Clerc, report by Matej Košík)
+- PR#5848: Assertion failure in type checker
+  (Jacques Garrigue, Alain Frisch, report by David Waern)
+- PR#5858: Assert failure during typing of class
+  (Jacques Garrigue, report by Julien Signoles)
+- PR#5865: assert failure when reporting undefined field label
+  (Jacques Garrigue, report by Anil Madhavapeddy)
+- PR#5872: Performance: Buffer.add_char is not inlined
+  (Gerd Stolpmann, Damien Doligez)
+- PR#5876: Uncaught exception with a typing error
+  (Alain Frisch, Gabriel Scherer, report by Julien Moutinho)
+- PR#5877: multiple "open" can become expensive in memory
+  (Fabrice Le Fessant and Alain Frisch)
+- PR#5880: 'Genlex.make_lexer' documention mentions the wrong exception
+  (Xavier Clerc, report by Virgile Prevosto)
+- PR#5885: Incorrect rule for compiling C stubs when shared libraries are not
+  supported.
+  (Jérôme Vouillon)
+- PR#5891: ocamlbuild: support rectypes tag for mlpack
+  (Khoo Yit Phang)
+- PR#5892: GADT exhaustiveness check is broken
+  (Jacques Garrigue and Leo White)
+- PR#5906: GADT exhaustiveness check is still broken
+  (Jacques Garrigue, report by Sébastien Briais)
+- PR#5907: Undetected cycle during typecheck causes exceptions
+  (Jacques Garrigue, report by Pascal Zimmer)
+- PR#5910: Fix code generation bug for "mod 1" on ARM.
+  (Benedikt Meurer, report by user 'jteg68')
+- PR#5911: Signature substitutions fail in submodules
+  (Jacques Garrigue, report by Markus Mottl)
+- PR#5912: add configure option -no-cfi (for OSX 10.6.x with XCode 4.0.2)
+  (Damien Doligez against XCode versions, report by Thomas Gazagnaire)
+- PR#5914: Functor breaks with an equivalent argument signature
+  (Jacques Garrigue, report by Markus Mottl and Grégoire Henry)
+- PR#5920, PR#5957: linking failure for big bytecodes on 32bit architectures
+  (Benoît Vaugon and Chet Murthy, report by Jun Furuse and Sebastien Mondet)
+- PR#5928: Missing space between words in manual page for ocamlmktop
+  (Damien Doligez, report by Matej Košík)
+- PR#5930: ocamldep leaks temporary preprocessing files
+  (Gabriel Scherer, report by Valentin Gatien-Baron)
+- PR#5933: Linking is slow when there are functions with large arities
+  (Valentin Gatien-Baron, review by Gabriel Scherer)
+- PR#5934: integer shift by negative amount (in otherlibs/num)
+  (Xavier Leroy, report by John Regehr)
+- PR#5944: Bad typing performances of big variant type declaration
+  (Benoît Vaugon)
+- PR#5945: Mix-up of Minor_heap_min and Minor_heap_max units
+  (Benoît Vaugon)
+- PR#5948: GADT with polymorphic variants bug
+  (Jacques Garrigue, report by Leo White)
+- PR#5953: Unix.system does not handle EINTR
+  (Jérémie Dimino)
+- PR#5965: disallow auto-reference to a recursive module in its definition
+  (Alain Frisch, report by Arthur Windler via Gabriel Scherer)
+- PR#5973: Format module incorrectly parses format string
+  (Pierre Weis, report by Frédéric Bour)
+- PR#5974: better documentation for Str.regexp
+  (Damien Doligez, report by william)
+- PR#5976: crash after recovering from two stack overflows (ocamlopt on MacOS X)
+  (Xavier Leroy, report by Pierre Boutillier)
+- PR#5977: Build failure on raspberry pi: "input_value: integer too large"
+  (Alain Frisch, report by Sylvain Le Gall)
+- PR#5981: Incompatibility check assumes abstracted types are injective
+  (Jacques Garrigue, report by Jeremy Yallop)
+- PR#5982: caml_leave_blocking section and errno corruption
+  (Jérémie Dimino)
+- PR#5985: Unexpected interaction between variance and GADTs
+  (Jacques Garrigue, Jeremy Yallop and Leo White and Gabriel Scherer)
+- PR#5988: missing from the documentation: -impl is a valid flag for ocamlopt
+  (Damien Doligez, report by Vincent Bernardoff)
+- PR#5989: Assumed inequalities involving private rows
+  (Jacques Garrigue, report by Jeremy Yallop)
+- PR#5992: Crash when pattern-matching lazy values modifies the scrutinee
+  (Luc Maranget, Leo White)
+- PR#5993: Variance of private type abbreviations not checked for modules
+  (Jacques Garrigue)
+- PR#5997: Non-compatibility assumed for concrete types with same constructor
+  (Jacques Garrigue, report by Gabriel Scherer)
+- PR#6004: Type information does not flow to "inherit" parameters
+  (Jacques Garrigue, report by Alain Frisch)
+- PR#6005: Type unsoundness with recursive modules
+  (Jacques Garrigue, report by Jérémie Dimino and Josh Berdine)
+- PR#6010: Big_int.extract_big_int gives wrong results on negative arguments
+  (Xavier Leroy, report by Drake Wilson via Stéphane Glondu)
+- PR#6024: Format syntax for printing @ is incompatible with 3.12.1
+  (Damien Doligez, report by Boris Yakobowski)
+- PR#6001: Reduce the memory used by compiling Camlp4
+  (Hongbo Zhang and Gabriel Scherer, report by Henri Gouraud)
+- PR#6031: Camomile problem with -with-frame-pointers
+  (Fabrice Le Fessant, report by Anil Madhavapeddy)
+- PR#6032: better Random.self_init under Windows
+  (Alain Frisch, Xavier Leroy)
+- PR#6033: Matching.inline_lazy_force needs eta-expansion (command-line flags)
+  (Pierre Chambart, Xavier Leroy and Luc Maranget,
+   regression report by Gabriel Scherer)
+- PR#6046: testsuite picks up the wrong ocamlrun dlls
+  (Anil Madhavapeddy)
+- PR#6056: Using 'match' prevents generalization of values
+  (Jacques Garrigue, report by Elnatan Reisner)
+- PR#6058: 'ocamlbuild -use-ocamlfind -tag thread -package threads t.cma' fails
+  (Gabriel Scherer, report by Hezekiah M. Carty)
+- PR#6069: ocamldoc: lexing: empty token
+  (Maxence Guesdon, Grégoire Henry, report by ygrek)
+- PR#6072: configure does not handle FreeBSD current (i.e. 10) correctly
+  (Damien Doligez, report by Prashanth Mundkur)
+- PR#6074: Wrong error message for failing Condition.broadcast
+  (Markus Mottl)
+- PR#6084: Define caml_modify and caml_initialize as weak symbols to help
+  with Netmulticore
+  (Xavier Leroy, Gerd Stolpmann)
+- PR#6090: Module constraint + private type seems broken in ocaml 4.01.0
+  (Jacques Garrigue, report by Jacques-Pascal Deplaix)
+- PR#6109: Typos in ocamlbuild error messages
+  (Gabriel Kerneis)
+- PR#6123: Assert failure when self escapes its class
+  (Jacques Garrigue, report by whitequark)
+- PR#6158: Fatal error using GADTs
+  (Jacques Garrigue, report by Jeremy Yallop)
+- PR#6163: Assert_failure using polymorphic variants in GADTs
+  (Jacques Garrigue, report by Leo White)
+- PR#6164: segmentation fault on Num.power_num of 0/1
+  (Fabrice Le Fessant, report by Johannes Kanig)
+- PR#6210: Camlp4 location error
+  (Hongbo Zhang, report by Jun Furuse)
+
+Feature wishes:
+- PR#5181: Merge common floating point constants in ocamlopt
+  (Benedikt Meurer)
+- PR#5243: improve the ocamlbuild API documentation in signatures.mli
+  (Christophe Troestler)
+- PR#5546: moving a function into an internal module slows down its use
+  (Alain Frisch, report by Fabrice Le Fessant)
+- PR#5597: add instruction trace option 't' to OCAMLRUNPARAM
+  (Anil Madhavapeddy, Wojciech Meyer)
+- PR#5676: IPv6 support under Windows
+  (Jérôme Vouillon, review by Jonathan Protzenko)
+- PR#5721: configure -with-frame-pointers for Linux perf profiling
+  (Fabrice Le Fessant, test by Jérémie Dimino)
+- PR#5722: toplevel: print full module path only for first record field
+  (Jacques Garrigue, report by ygrek)
+- PR#5762: Add primitives for fast access to bigarray dimensions
+  (Pierre Chambart)
+- PR#5769: Allow propagation of Sys.big_endian in native code
+  (Pierre Chambart, stealth commit by Fabrice Le Fessant)
+- PR#5771: Add primitives for reading 2, 4, 8 bytes in strings and bigarrays
+  (Pierre Chambart)
+- PR#5774: Add bswap primitives for amd64 and arm
+  (Pierre Chambart, test by Alain Frisch)
+- PR#5795: Generate sqrtsd opcode instead of external call to sqrt on amd64
+  (Pierre Chambart)
+- PR#5827: provide a dynamic command line parsing mechanism
+  (Hongbo Zhang)
+- PR#5832: patch to improve "wrong file naming" error messages
+  (William Smith)
+- PR#5864: Add a find operation to Set
+  (François Berenger)
+- PR#5886: Small changes to compile for Android
+  (Jérôme Vouillon, review by Benedikt Meurer)
+- PR#5902: -ppx based pre-processor executables accept arguments
+  (Alain Frisch, report by Wojciech Meyer)
+- PR#5986: Protect against marshaling 64-bit integers in bytecode
+  (Xavier Leroy, report by Alain Frisch)
+- PR#6049: support for OpenBSD/macppc platform
+  (Anil Madhavapeddy, review by Benedikt Meurer)
+- PR#6059: add -output-obj rules for ocamlbuild
+  (Anil Madhavapeddy)
+- PR#6060: ocamlbuild tags 'principal', 'strict_sequence' and 'short_paths'
+  (Anil Madhavapeddy)
+- ocamlbuild tag 'no_alias_deps'
+  (Daniel Bünzli)
+
+Tools:
+- OCamlbuild now features a bin_annot tag to generate .cmt files.
+  (Jonathan Protzenko)
+- OCamlbuild now features a strict_sequence tag to trigger the
+  strict-sequence option.
+  (Jonathan Protzenko)
+- OCamlbuild now picks the non-core tools like ocamlfind and menhir from PATH
+  (Wojciech Meyer)
+- PR#5884: Misc minor fixes and cleanup for emacs mode
+  (Stefan Monnier)
+- PR#6030: Improve performance of -annot
+  (Guillaume Melquiond, Alain Frisch)
+
+
+OCaml 4.00.1 (5 Oct 2012):
+--------------------------
+
+Bug fixes:
+- PR#4019: better documentation of Str.matched_string
+- PR#5111: ocamldoc, heading tags inside spans tags is illegal in html
+- PR#5278: better error message when typing "make"
+- PR#5468: ocamlbuild should preserve order of parametric tags
+- PR#5563: harden Unix.select against file descriptors above FD_SETSIZE
+- PR#5690: "ocamldoc ... -text README" raises exception
+- PR#5700: crash with native-code stack backtraces under MacOS 10.8 x86-64
+- PR#5707: AMD64 code generator: do not use r10 and r11 for parameter passing,
+  as these registers can be destroyed by the dynamic loader
+- PR#5712: some documentation problems
+- PR#5715: configuring with -no-shared-libs breaks under cygwin
+- PR#5718: false positive on 'unused constructor' warning
+- PR#5719: ocamlyacc generates code that is not warning 33-compliant
+- PR#5725: ocamldoc output of preformatted code
+- PR#5727: emacs caml-mode indents shebang line in toplevel scripts
+- PR#5729: tools/untypeast.ml creates unary Pexp_tuple
+- PR#5731: instruction scheduling forgot to account for destroyed registers
+- PR#5735: %apply and %revapply not first class citizens
+- PR#5738: first class module patterns not handled by ocamldep
+- PR#5742: missing bound checks in Array.sub
+- PR#5744: ocamldoc error on "val virtual"
+- PR#5757: GC compaction bug (crash)
+- PR#5758: Compiler bug when matching on floats
+- PR#5761: Incorrect bigarray custom block size
+
+
+OCaml 4.00.0 (26 Jul 2012):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+- The official name of the language is now OCaml.
+
+Language features:
+- Added Generalized Algebraic Data Types (GADTs) to the language.
+  See chapter "Language extensions" of the reference manual for documentation.
+- It is now possible to omit type annotations when packing and unpacking
+  first-class modules. The type-checker attempts to infer it from the context.
+  Using the -principal option guarantees forward compatibility.
+- New (module M) and (module M : S) syntax in patterns, for immediate
+  unpacking of a first-class module.
+
+Compilers:
+- Revised simplification of let-alias (PR#5205, PR#5288)
+- Better reporting of compiler version mismatch in .cmi files
+* Warning 28 is now enabled by default.
+- New option -absname to use absolute paths in error messages
+- Optimize away compile-time beta-redexes, e.g. (fun x y -> e) a b.
+- Added option -bin-annot to dump the AST with type annotations.
+- Added lots of new warnings about unused variables, opens, fields,
+  constructors, etc.
+* New meaning for warning 7: it is now triggered when a method is overridden
+  with the "method" keyword.  Use "method!" to avoid the warning.
+
+Native-code compiler:
+- Optimized handling of partially-applied functions (PR#5287)
+- Small improvements in code generated for array bounds checks (PR#5345,
+  PR#5360).
+* New ARM backend (PR#5433):
+    . Supports both Linux/EABI (armel) and Linux/EABI+VFPv3 (armhf).
+    . Added support for the Thumb-2 instruction set with average code size
+      savings of 28%.
+    . Added support for position-independent code, natdynlink, profiling and
+      exception backtraces.
+- Generation of CFI information, and filename/line number debugging (with -g)
+  annotations, enabling in particular precise stack backtraces with
+  the gdb debugger. Currently supported for x86 32-bits and 64-bits only.
+  (PR#5487)
+- New tool: ocamloptp, the equivalent of ocamlcp for the native-code compiler.
+
+OCamldoc:
+- PR#5645: ocamldoc doesn't handle module/type substitution in signatures
+- PR#5544: improve HTML output (less formatting in html code)
+- PR#5522: allow refering to record fields and variant constructors
+- fix PR#5419 (error message in french)
+- fix PR#5535 (no cross ref to class after dump+load)
+* Use first class modules for custom generators, to be able to
+  load various plugins incrementally adding features to the current
+  generator
+* PR#5507: Use Location.t structures for locations.
+- fix: do not keep code when not told to keep code.
+
+Standard library:
+- Added float functions "hypot" and "copysign" (PR#3806, PR#4752, PR#5246)
+* Arg: options with empty doc strings are no longer included in the usage string
+  (PR#5437)
+- Array: faster implementations of "blit", "copy", "sub", "append" and "concat"
+  (PR#2395, PR#2787, PR#4591)
+* Hashtbl:
+    . Statistically-better generic hash function based on Murmur 3 (PR#5225)
+    . Fixed behavior of generic hash function w.r.t. -0.0 and NaN (PR#5222)
+    . Added optional "random" parameter to Hashtbl.create to randomize
+      collision patterns and improve security (PR#5572, CVE-2012-0839)
+    . Added "randomize" function and "R" parameter to OCAMLRUNPARAM
+      to turn randomization on by default (PR#5572, CVE-2012-0839)
+    . Added new functorial interface "MakeSeeded" to support randomization
+      with user-provided seeded hash functions.
+    . Install new header  for C code.
+- Filename: on-demand (lazy) initialization of the PRNG used by "temp_file".
+- Marshal: marshalling of function values (flag Marshal.Closures) now
+  also works for functions that come from dynamically-loaded modules (PR#5215)
+- Random:
+     . More random initialization (Random.self_init()), using /dev/urandom
+       when available (e.g. Linux, FreeBSD, MacOS X, Solaris)
+     * Faster implementation of Random.float (changes the generated sequences)
+- Format strings for formatted input/output revised to correct PR#5380
+    . Consistently treat %@ as a plain @ character
+    . Consistently treat %% as a plain % character
+- Scanf: width and precision for floating point numbers are now handled
+- Scanf: new function "unescaped" (PR#3888)
+- Set and Map: more efficient implementation of "filter" and "partition"
+- String: new function "map" (PR#3888)
+
+Installation procedure:
+- Compiler internals are now installed in `ocamlc -where`/compiler-libs.
+  The files available there include the .cmi interfaces for all compiler
+  modules, plus the following libraries:
+      ocamlcommon.cma/.cmxa     modules common to ocamlc, ocamlopt, ocaml
+      ocamlbytecomp.cma/.cmxa   modules for ocamlc and ocaml
+      ocamloptcomp.cma/.cmxa    modules specific to ocamlopt
+      ocamltoplevel.cma         modules specific to ocaml
+   (PR#1804, PR#4653, frequently-asked feature).
+* Some .cmi for toplevel internals that used to be installed in
+  `ocamlc -where` are now to be found in  `ocamlc -where`/compiler-libs.
+  Add "-I +compiler-libs" where needed.
+* toplevellib.cma is no longer installed because subsumed by
+  ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma
+- Added a configuration option (-with-debug-runtime) to compile and install
+  a debug version of the runtime system, and a compiler option
+  (-runtime-variant) to select the debug runtime.
+
+Bug Fixes:
+
+- PR#1643: functions of the Lazy module whose named started with 'lazy_' have
+  been deprecated, and new ones without the prefix added
+- PR#3571: in Bigarrays, call msync() before unmapping to commit changes
+- PR#4292: various documentation problems
+- PR#4511, PR#4838: local modules remove polymorphism
+* PR#4549: Filename.dirname is not handling multiple / on Unix
+- PR#4688: (Windows) special floating-point values aren't converted to strings
+  correctly
+- PR#4697: Unix.putenv leaks memory on failure
+- PR#4705: camlp4 does not allow to define types with `True or `False
+- PR#4746: wrong detection of stack overflows in native code under Linux
+- PR#4869: rare collisions between assembly labels for code and data
+- PR#4880: "assert" constructs now show up in the exception stack backtrace
+- PR#4892: Array.set could raise "out of bounds" before evaluating 3rd arg
+- PR#4937: camlp4 incorrectly handles optional arguments if 'option' is
+  redefined
+- PR#5024: camlp4r now handles underscores in irrefutable pattern matching of
+  records
+- PR#5064, PR#5485: try to ensure that 4K words of stack are available
+  before calling into C functions, raising a Stack_overflow exception
+  otherwise.  This reduces (but does not eliminate) the risk of
+  segmentation faults due to stack overflow in C code
+- PR#5073: wrong location for 'Unbound record field label' error
+- PR#5084: sub-sub-module building fails for native code compilation
+- PR#5120: fix the output function of Camlp4.Debug.formatter
+- PR#5131: compilation of custom runtime with g++ generates lots of warnings
+- PR#5137: caml-types-explore does not work
+- PR#5159: better documentation of type Lexing.position
+- PR#5171: Map.join does more comparisons than needed
+- PR#5176: emacs mode: stack overflow in regexp matcher
+- PR#5179: port OCaml to mingw-w64
+- PR#5211: updated Genlex documentation to state that camlp4 is mandatory for
+  'parser' keyword and associated notation
+- PR#5214: ocamlfind plugin invokes 'cut' utility
+- PR#5218: use $(MAKE) instead of "make" in Makefiles
+- PR#5224: confusing error message in non-regular type definition
+- PR#5231: camlp4: fix parsing of <:str_item< type t = $x$ >>
+- PR#5233: finaliser on weak array gives dangling pointers (crash)
+- PR#5238, PR#5277: Sys_error when getting error location
+- PR#5261, PR#5497: Ocaml source-code examples are not "copy-paste-able"
+* PR#5279: executable name is not initialized properly in caml_startup_code
+- PR#5290: added hash functions for channels, nats, mutexes, conditions
+- PR#5291: undetected loop in class initialization
+- PR#5295: OS threads: problem with caml_c_thread_unregister()
+- PR#5301: camlp4r and exception equal to another one with parameters
+- PR#5305: prevent ocamlbuild from complaining about links to _build/
+- PR#5306: comparing to Thread.self() raises exception at runtime
+- PR#5309: Queue.add is not thread/signal safe
+- PR#5310: Ratio.create_ratio/create_normalized_ratio have misleading names
+- PR#5311: better message for warning 23
+* PR#5312: command-line arguments @reponsefile auto-expansion feature
+  removed from the Windows OCaml runtime, to avoid conflicts with "-w @..."
+- PR#5313: ocamlopt -g misses optimizations
+- PR#5214: ocamlfind plugin invokes 'cut' utility
+- PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable
+- PR#5318: segfault on stack overflow when reading marshaled data
+- PR#5319: %r11 clobbered by Lswitch in Windows AMD64 native-code compilation
+- PR#5322: type abbreviations expanding to a universal type variable
+- PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode
+- PR#5330: thread tag with '.top' and '.inferred.mli' targets
+- PR#5331: ocamlmktop is not always a shell script
+- PR#5335: Unix.environment segfaults after a call to clearenv
+- PR#5338: sanitize.sh has windows style end-of-lines (mingw)
+- PR#5344: some predefined exceptions need special printing
+- PR#5349: Hashtbl.replace uses new key instead of reusing old key
+- PR#5356: ocamlbuild handling of 'predicates' for ocamlfind
+- PR#5364: wrong compilation of "((val m : SIG1) : SIG2)"
+- PR#5370: ocamldep omits filename in syntax error message
+- PR#5374: camlp4 creates wrong location for type definitions
+- PR#5380: strange sscanf input segfault
+- PR#5382: EOPNOTSUPP and ENOTSUPP different on exotic platforms
+- PR#5383: build failure in Win32/MSVC
+- PR#5387: camlp4: str_item and other syntactic elements with Nils are
+  not very usable
+- PR#5389: compaction sometimes leaves a very large heap
+- PR#5393: fails to build from source on GNU/kFreeBSD because of -R link option
+- PR#5394: documentation for -dtypes is missing in manpage
+- PR#5397: Filename.temp_dir_name should be mutable
+- PR#5410: fix printing of class application with Camlp4
+- PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode
+- PR#5435: ocamlbuild does not find .opt executables on Windows
+- PR#5436: update object ids on unmarshaling
+- PR#5442: camlp4: quotation issue with strings
+- PR#5453: configure doesn't find X11 under Ubuntu/MultiarchSpec
+- PR#5461: Double linking of bytecode modules
+- PR#5463: Bigarray.*.map_file fail if empty array is requested
+- PR#5465: increase stack size of ocamlopt.opt for windows
+- PR#5469: private record type generated by functor loses abbreviation
+- PR#5475: Wrapper script for interpreted LablTk wrongly handles command line
+  parameters
+- PR#5476: bug in native code compilation of let rec on float arrays
+- PR#5477: use pkg-config to configure graphics on linux
+- PR#5481: update camlp4 magic numbers
+- PR#5482: remove bashism in test suite scripts
+- PR#5495: camlp4o dies on infix definition (or)
+- PR#5498: Unification with an empty object only checks the absence of
+  the first method
+- PR#5503: error when ocamlbuild is passed an absolute path as build directory
+- PR#5509: misclassification of statically-allocated empty array that
+  falls exactly at beginning of an otherwise unused data page.
+- PR#5510: ocamldep has duplicate -ml{,i}-synonym options
+- PR#5511: in Bigarray.reshape, unwarranted limitation on new array dimensions.
+- PR#5513: Int64.div causes floating point exception (ocamlopt, x86)
+- PR#5516: in Bigarray C stubs, use C99 flexible array types if possible
+- PR#5518: segfault with lazy empty array
+- PR#5531: Allow ocamlbuild to add ocamldoc flags through -docflag
+  and -docflags switches
+- PR#5538: combining -i and -annot in ocamlc
+- PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file
+- PR#5648: (probably fixed) test failures in tests/lib-threads
+- PR#5551: repeated calls to find_in_path degrade performance
+- PR#5552: Mac OS X: unrecognized gcc option "-no-cpp-precomp"
+- PR#5555: add Hashtbl.reset to resize the bucket table to its initial size
+- PR#5560: incompatible type for tuple pattern with -principal
+- PR#5575: Random states are not marshallable across architectures
+- PR#5579: camlp4: when a plugin is loaded in the toplevel,
+  Token.Filter.define_filter has no effect before the first syntax error
+- PR#5585: typo: "explicitely"
+- PR#5587: documentation: "allows to" is not correct English
+- PR#5593: remove C file when -output-obj fails
+- PR#5597: register names for instrtrace primitives in embedded bytecode
+- PR#5598: add backslash-space support in strings in ocamllex
+- PR#5603: wrong .file debug info generated by ocamlopt -g
+- PR#5604: fix permissions of files created by ocamlbuild itself
+- PR#5610: new unmarshaler (from PR#5318) fails to freshen object identifiers
+- PR#5614: add missing -linkall flag when compiling ocamldoc.opt
+- PR#5616: move ocamlbuild documentation to the reference manual
+- PR#5619: Uncaught CType.Unify exception in the compiler
+- PR#5620: invalid printing of type manifest (camlp4 revised syntax)
+- PR#5637: invalid printing of anonymous type parameters (camlp4 revised syntax)
+- PR#5643: issues with .cfi and .loc directives generated by ocamlopt -g
+- PR#5644: Stream.count broken when used with Sapp or Slazy nodes
+- PR#5647: Cannot use install_printer in debugger
+- PR#5651: printer for abstract data type (camlp4 revised syntax)
+- PR#5654: self pattern variable location tweak
+- PR#5655: ocamlbuild doesn't pass cflags when building C stubs
+- PR#5657: wrong error location for abbreviated record fields
+- PR#5659: ocamlmklib -L option breaks with MSVC
+- PR#5661: fixes for the test suite
+- PR#5668: Camlp4 produces invalid syntax for "let _ = ..."
+- PR#5671: initialization of compare_ext field in caml_final_custom_operations()
+- PR#5677: do not use "value" as identifier (genprintval.ml)
+- PR#5687: dynlink broken when used from "output-obj" main program (bytecode)
+- problem with printing of string literals in camlp4 (reported on caml-list)
+- emacs mode: colorization of comments and strings now works correctly
+- problem with forall and method (reported on caml-list on 2011-07-26)
+- crash when using OCAMLRUNPARAM=a=X with invalid X (reported in private)
+
+Feature wishes:
+- PR#352: new option "-stdin" to make ocaml read stdin as a script
+- PR#1164: better error message when mixing -a and .cmxa
+- PR#1284: documentation: remove restriction on mixed streams
+- PR#1496: allow configuring LIBDIR, BINDIR, and MANDIR relative to $(PREFIX)
+- PR#1835: add Digest.from_hex
+- PR#1898: toplevel: add option to suppress continuation prompts
+- PR#4278: configure: option to disable "graph" library
+- PR#4444: new String.trim function, removing leading and trailing whistespace
+- PR#4549: make Filename.dirname/basename POSIX compliant
+- PR#4830: add option -v to expunge.ml
+- PR#4898: new Sys.big_endian boolean for machine endianness
+- PR#4963, PR#5467: no extern "C" into ocaml C-stub headers
+- PR#5199: tests are run only for bytecode if either native support is missing,
+  or a non-empty value is set to "BYTECODE_ONLY" Makefile variable
+- PR#5215: marshalling of dynlinked closure
+- PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x',
+    and '%apply' with semantics 'apply f x = f x'.
+- PR#5255: natdynlink detection on powerpc, hurd, sparc
+- PR#5295: OS threads: problem with caml_c_thread_unregister()
+- PR#5297: compiler now checks existence of builtin primitives
+- PR#5329: (Windows) more efficient Unix.select if all fd's are sockets
+- PR#5357: warning for useless open statements
+- PR#5358: first class modules don't allow "with type" declarations for types
+  in sub-modules
+- PR#5385: configure: emit a warning when MACOSX_DEPLOYMENT_TARGET is set
+- PR#5396: ocamldep: add options -sort, -all, and -one-line
+- PR#5397: Filename.temp_dir_name should be mutable
+- PR#5403: give better error message when emacs is not found in PATH
+- PR#5411: new directive for the toplevel: #load_rec
+- PR#5420: Unix.openfile share mode (Windows)
+- PR#5421: Unix: do not leak fds in various open_proc* functions
+- PR#5434: implement Unix.times in win32unix (partially)
+- PR#5438: new warnings for unused declarations
+- PR#5439: upgrade config.guess and config.sub
+- PR#5445 and others: better printing of types with user-provided names
+- PR#5454: Digest.compare is missing and md5 doc update
+- PR#5455: .emacs instructions, add lines to recognize ocaml scripts
+- PR#5456: pa_macro: replace __LOCATION__ after macro expansion; add LOCATION_OF
+- PR#5461: bytecode: emit warning when linking two modules with the same name
+- PR#5478: ocamlopt assumes ar command exists
+- PR#5479: Num.num_of_string may raise an exception, not reflected in the
+  documentation.
+- PR#5501: increase IO_BUFFER_SIZE to 64KiB
+- PR#5532: improve error message when bytecode file is wrong
+- PR#5555: add function Hashtbl.reset to resize the bucket table to
+  its initial size.
+- PR#5586: increase UNIX_BUFFER_SIZE to 64KiB
+- PR#5597: register names for instrtrace primitives in embedded bytecode
+- PR#5599: Add warn() tag in ocamlbuild to control -w compiler switch
+- PR#5628: add #remove_directory and Topdirs.remove_directory to remove
+  a directory from the load path
+- PR#5636: in system threads library, issue with linking of pthread_atfork
+- PR#5666: C includes don't provide a revision number
+- ocamldebug: ability to inspect values that contain code pointers
+- ocamldebug: new 'environment' directive to set environment variables
+  for debuggee
+- configure: add -no-camlp4 option
+
+Shedding weight:
+* Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS.
+* The "DBM" library (interface with Unix DBM key-value stores) is no
+  longer part of this distribution.  It now lives its own life at
+  https://forge.ocamlcore.org/projects/camldbm/
+* The "OCamlWin" toplevel user interface for MS Windows is no longer
+  part of this distribution.  It now lives its own life at
+  https://forge.ocamlcore.org/projects/ocamltopwin/
+
+Other changes:
+- Copy VERSION file to library directory when installing.
+
+
+OCaml 3.12.1 (4 Jul 2011):
+--------------------------
+
+Bug fixes:
+- PR#4345, PR#4767: problems with camlp4 printing of float values
+- PR#4380: ocamlbuild should not use tput on windows
+- PR#4487, PR#5164: multiple 'module type of' are incompatible
+- PR#4552: ocamlbuild does not create symlinks when using '.itarget' file
+- PR#4673, PR#5144: camlp4 fails on object copy syntax
+- PR#4702: system threads: cleanup tick thread at exit
+- PR#4732: camlp4 rejects polymorphic variants using keywords from macros
+- PR#4778: Win32/MSVC port: rare syntax error in generated MASM assembly file
+- PR#4794, PR#4959: call annotations not generated by ocamlopt
+- PR#4820: revised syntax pretty printer crashes with 'Stack_overflow'
+- PR#4928: wrong printing of classes and class types by camlp4
+- PR#4939: camlp4 rejects patterns of the '?x:_' form
+- PR#4967: ocamlbuild passes wrong switches to ocamldep through menhir
+- PR#4972: mkcamlp4 does not include 'dynlink.cma'
+- PR#5039: ocamlbuild should use '-linkpkg' only when linking programs
+- PR#5066: ocamldoc: add -charset option used in html generator
+- PR#5069: fcntl() in caml_sys_open may block, do it within blocking section
+- PR#5071, PR#5129, PR#5134: inconsistencies between camlp4 and camlp4* binaries
+- PR#5080, PR#5104: regression in type constructor handling by camlp4
+- PR#5090: bad interaction between toplevel and camlp4
+- PR#5095: ocamlbuild ignores some tags when building bytecode objects
+- PR#5100: ocamlbuild always rebuilds a 'cmxs' file
+- PR#5103: build and install objinfo when building with ocamlbuild
+- PR#5109: crash when a parser calls a lexer that calls another parser
+- PR#5110: invalid module name when using optional argument
+- PR#5115: bytecode executables produced by msvc64 port crash on 32-bit versions
+- PR#5117: bigarray: wrong function name without HAS_MMAP; missing include
+- PR#5118: Camlp4o and integer literals
+- PR#5122: camlp4 rejects lowercase identifiers for module types
+- PR#5123: shift_right_big_int returns a wrong zero
+- PR#5124: substitution inside a signature leads to odd printing
+- PR#5128: typo in 'Camlp4ListComprehension' syntax extension
+- PR#5136: obsolete function used in emacs mode
+- PR#5145: ocamldoc: missing html escapes
+- PR#5146: problem with spaces in multi-line string constants
+- PR#5149: (partial) various documentation problems
+- PR#5156: rare compiler crash with objects
+- PR#5165: ocamlbuild does not pass '-thread' option to ocamlfind
+- PR#5167: camlp4r loops when printing package type
+- PR#5172: camlp4 support for 'module type of' construct
+- PR#5175: in bigarray accesses, make sure bigarray expr is evaluated only once
+- PR#5177: Gc.compact implies Gc.full_major
+- PR#5182: use bytecode version of ocamldoc to generate man pages
+- PR#5184: under Windows, alignment issue with bigarrays mapped from files
+- PR#5188: double-free corruption in bytecode system threads
+- PR#5192: mismatch between words and bytes in interpreting max_young_wosize
+- PR#5202: error in documentation of atan2
+- PR#5209: natdynlink incorrectly detected on BSD systems
+- PR#5213: ocamlbuild should pass '-rectypes' to ocamldoc when needed
+- PR#5217: ocamlfind plugin should add '-linkpkg' for toplevel
+- PR#5228: document the exceptions raised by functions in 'Filename'
+- PR#5229: typo in build script ('TAG_LINE' vs 'TAGLINE')
+- PR#5230: error in documentation of Scanf.Scanning.open_in
+- PR#5234: option -shared reverses order of -cclib options
+- PR#5237: incorrect .size directives generated for x86-32 and x86-64
+- PR#5244: String.compare uses polymorphic compare_val (regression of PR#4194)
+- PR#5248: regression introduced while fixing PR#5118
+- PR#5252: typo in docs
+- PR#5258: win32unix: unix fd leak under windows
+- PR#5269: (tentative fix) Wrong ext_ref entries in .annot files
+- PR#5272: caml.el doesn't recognize downto as a keyword
+- PR#5276: issue with ocamlc -pack and recursively-packed modules
+- PR#5280: alignment constraints incorrectly autodetected on MIPS 32
+- PR#5281: typo in error message
+- PR#5308: unused variables not detected in "include (struct .. end)"
+- camlp4 revised syntax printing bug in the toplevel (reported on caml-list)
+- configure: do not define _WIN32 under cygwin
+- Hardened generic comparison in the case where two custom blocks
+  are compared and have different sets of custom operations.
+- Hardened comparison between bigarrays in the case where the two
+  bigarrays have different kinds.
+- Fixed wrong autodetection of expm1() and log1p().
+- don't add .exe suffix when installing the ocamlmktop shell script
+- ocamldoc: minor fixes related to the display of ocamldoc options
+- fixed bug with huge values in OCAMLRUNPARAM
+- mismatch between declaration and definition of caml_major_collection_slice
+
+Feature wishes:
+- PR#4992: added '-ml-synonym' and '-mli-synonym' options to ocamldep
+- PR#5065: added '-ocamldoc' option to ocamlbuild
+- PR#5139: added possibility to add options to ocamlbuild
+- PR#5158: added access to current camlp4 parsers and printers
+- PR#5180: improved instruction selection for float operations on amd64
+- stdlib: added a 'usage_string' function to Arg
+- allow with constraints to add a type equation to a datatype definition
+- ocamldoc: allow to merge '@before' tags like other ones
+- ocamlbuild: allow dependency on file "_oasis"
+
+Other changes:
+- Changed default minor heap size from 32k to 256k words.
+- Added new operation 'compare_ext' to custom blocks, called when
+  comparing a custom block value with an unboxed integer.
+
+
+Objective Caml 3.12.0 (2 Aug 2010):
+-----------------------------------
+
+(Changes that can break existing programs are marked with a "*"  )
+
+Language features:
+- Shorthand notation for records: in expressions and patterns,
+    { lbl } stands for { lbl = lbl } and { M.lbl } for { M.lbl = lbl }
+- Record patterns of the form { lbl = pat; _ } to mark that not all
+  labels are listed, purposefully.  (See new warning below.)
+- Explicit naming of a generic type; in an expression
+  "fun ... (type t) ... -> e", the type t is considered abstract in its
+  scope (the arguments that follow it and the body of the function),
+  and then replaced by a fresh type variable. In particular, the type
+  t can be used in contexts where a type variable is not allowed
+  (e.g. for defining an exception in a local module).
+- Explicit polymorphic types and polymorphic recursion. In let
+  definitions, one can write an explicit polymorphic type just
+  immediately the function name; the polymorphism will be enforced,
+  and recursive calls may use the polymorphism.
+  The syntax is the same as for polymorphic methods:
+    "let [rec]  : 'a1 ... 'an.  = ..."
+- First-class packages modules.
+  New kind of type expression, for packaged modules: (module PT).
+  New kind of expression, to pack a module as a first-class value:
+    (module MODEXPR : PT).
+  New kind of module expression, to unpack a first-class value as a module:
+    (val EXPR : PT).
+  PT is a package type of the form "S" or
+  "S with type t1 = ... and ... and type tn = ..." (S refers to a module type).
+- Local opening of modules in a subexpression.
+  Syntax: "let open M in e", or "M.(e)"
+- In class definitions, method and instance variable override can now
+  be made explicit, by writing "method!", "val!" or "inherit!" in place of
+  "method", "val" and "inherit". It is an error to override an
+  undefined member (or to use overriding inheritance when nothing get
+  overridden). Additionally, these constructs disactivate respectively
+  warnings 7 (method override, code 'M') and 13 (instance variable
+  override, code 'V'). Note that, by default, warning 7 is inactive
+  and warning 13 is active.
+- "Destructive" substitution in signatures.
+  By writing " with type t := " and
+  " with module M := " one replaces "t" and "M"
+  inside the signature, removing their respective fields. Among other
+  uses, this allows to merge two signatures containing identically
+  named fields.
+* While fixing PR#4824, also corrected a gaping hole in the type checker,
+  which allowed instantiating separately object parameters and instance
+  variables in an interface. This hole was here since the beginning of
+  ocaml, and as a result many programs using object inheritance in a non
+  trivial way will need to be corrected. You can look at lablgtk2 for an
+  example.
+
+Compilers and toplevel:
+- Warnings are now numbered and can be switched on and off individually.
+  The old system with letters referring to sets of warnings is still
+  supported.
+- New warnings:
+  + 9 (code 'R') to signal record patterns without "; _" where
+    some labels of the record type are not listed in the pattern.
+  + 28 when giving a wildcard argument to a constant constructor in
+    a pattern-matching.
+  + 29 when an end-of-line appears unescaped in a string constant.
+  + 30 when the same constructor or record field is defined twice in
+    mutually-recursive type definitions.
+* The semantics of warning 7 (code 'M', method override) have changed
+  (it now detects all overrides, not just repeated definitions inside
+  the same class body), and it is now inactive by default.
+- Better error report in case of unbound qualified identifier: if the module
+  is unbound this error is reported in the first place.
+- Added option '-strict-sequence' to force left hand part of sequence to have
+  type unit.
+- Added option '-no-app-funct' to turn applicative functors off.
+  This option can help working around mysterious type incompatibilities
+  caused by the incomplete comparison of applicative paths F(X).t.
+
+Native-code compiler:
+- AMD64: shorter and slightly more efficient code generated for
+  float comparisons.
+
+Standard library:
+- Format: new function ikfprintf analoguous to ifprintf with a continuation
+  argument.
+* PR#4210, #4245: stricter range checking in string->integer conversion
+  functions (int_of_string, Int32.of_string, Int64.of_string,
+  Nativeint.of_string).  The decimal string corresponding to
+  max_int + 1 is no longer accepted.
+- Scanf: to prevent confusion when mixing Scanf scanning functions and direct
+  low level input, value Scanf.stdin has been added.
+* Random: changed the algorithm to produce better randomness.  Now passes the
+  DieHard tests.
+- Map: implement functions from Set that make sense for Map.
+
+Other libraries:
+* Str: letters that constitute a word now include digits 0-9 and
+  underscore _.  This changes the interpretation of '\b' (word boundary)
+  in regexps, but is more consistent with other regexp libraries. (PR#4874).
+
+Ocamlbuild:
+- Add support for native dynlink.
+
+New tool:
+- ocamlobjinfo: displays various information, esp. dependencies, for
+  compiled OCaml files (.cmi, .cmo, .cma, .cmx, .cmxa, .cmxs, and bytecode
+  executables).  Extends and makes more official the old objinfo tool
+  that was installed by some OCaml packages.
+
+All tools:
+- PR#4857: add a -vnum option to display the version number and nothing else
+
+Bug Fixes:
+- PR#4012: Map.map and Map.mapi do not conform to specification
+- PR#4478: better error messages for type definition mismatches
+- PR#4683: labltk script uses fixed path on windows
+- PR#4742: finalisation function raising an exception blocks other finalisations
+- PR#4775: compiler crash on crazy types (temporary fix)
+- PR#4824: narrowing the type of class parameters with a module specification
+- PR#4862: relaxed value restriction and records
+- PR#4884: optional arguments do not work when Some is redefined
+- PR#4964: parenthesized names for infix functions in annot files
+- PR#4970: better error message for instance variables
+- PR#4975: spelling mistakes
+- PR#4988: contravariance lost with ocamlc -i
+- PR#5004: problem in Buffer.add_channel with very large lengths.
+- PR#5008: on AMD64/MSVC port, rare float corruption during GC.
+- PR#5018: wrong exception raised by Dynlink.loadfile.
+- PR#5057: fatal typing error with local module + functor + polymorphic variant
+- Wrong type for Obj.add_offset.
+- Small problem with representation of Int32, Int64, and Nativeint constants.
+- Use RTLD_LOCAL for native dynlink in private mode.
+
+Objective Caml 3.11.2 (20 Jan 2010):
+------------------------------------
+
+Bug fixes:
+- PR#4151: better documentation for min and max w.r.t. NaN
+- PR#4421: ocamlbuild uses wrong compiler for C files
+- PR#4710, PR#4720: ocamlbuild does not use properly configuration information
+- PR#4750: under some Windows installations, high start-up times for Unix lib
+- PR#4777: problem with scanf and CRLF
+- PR#4783: ocamlmklib problem under Windows
+- PR#4810: BSD problem with socket addresses, e.g. in Unix.getnameinfo
+- PR#4813: issue with parsing of float literals by the GNU assembler
+- PR#4816: problem with modules and private types
+- PR#4818: missed opportunity for type-based optimization of bigarray accesses
+- PR#4821: check for duplicate method names in classes
+- PR#4823: build problem on Mac OS X
+- PR#4836: spurious errors raised by Unix.single_write under Windows
+- PR#4841, PR#4860, PR#4930: problem with ocamlopt -output-obj under Mac OS X
+- PR#4847: C compiler error with ocamlc -output-obj under Win64
+- PR#4856: ocamlbuild uses ocamlrun to execute a native plugin
+- PR#4867, PR#4760: ocamlopt -shared fails on Mac OS X 64bit
+- PR#4873: ocamlbuild ignores "thread" tag when building a custom toplevel
+- PR#4890: ocamlbuild tries to use native plugin on bytecode-only arch
+- PR#4896: ocamlbuild should always pass -I to tools for external libraries
+- PR#4900: small bug triggering automatic compaction even if max_overhead = 1M
+- PR#4902: bug in %.0F printf format
+- PR#4910: problem with format concatenation
+- PR#4922: ocamlbuild recompiles too many files
+- PR#4923: missing \xff for scanf %S
+- PR#4933: functors not handling private types correctly
+- PR#4940: problem with end-of-line in DOS text mode, tentative fix
+- PR#4953: problem compiling bytecode interpreter on ARM in Thumb mode.
+- PR#4955: compiler crash when typing recursive type expression with constraint
+- Module Printf: the simple conversion %F (without width indication) was not
+           treated properly.
+- Makefile: problem with cygwin, flexdll, and symbolic links
+- Various build problems with ocamlbuild under Windows with msvc
+
+Feature wishes:
+- PR#9: (tentative implementation) make ocamldebug use #linenum annotations
+- PR#123, PR#4477: custom exception printers
+- PR#3456: Obj.double_field and Obj.set_double_field functions
+- PR#4003: destination directory can be given to Filename.[open_]temp_file
+- PR#4647: Buffer.blit function
+- PR#4685: access to Filename.dir_sep
+- PR#4703: support for debugging embedded applications
+- PR#4723: "clear_rules" function to empty the set of ocamlbuild rules
+- PR#4921: configure option to help cross-compilers
+
+Objective Caml 3.11.1 (12 Jun 2009):
+------------------------------------
+
+Bug fixes:
+- PR#4095: ocamldebug: strange behaviour of control-C
+- PR#4403: ocamldebug: improved handling of packed modules
+- PR#4650: Str.regexp_case_fold mis-handling complemented character sets [^a]
+- PR#4660: Scanf.format_from_string: handling of double quote
+- PR#4666: Unix.exec* failure in multithread programs under MacOS X and FreeBSD
+- PR#4667: debugger out of sync with dynlink changes
+- PR#4678: random "out of memory" error with systhreads
+- PR#4690: issue with dynamic loading under MacOS 10.5
+- PR#4692: wrong error message with options -i and -pack passed to ocamlc
+- PR#4699: in otherlibs/dbm, fixed construction of dlldbm.so.
+- PR#4704: error in caml_modify_generational_global_root()
+- PR#4708: (ocamldoc) improved printing of infix identifiers such as "lor".
+- PR#4722: typo in configure script
+- PR#4729: documented the fact that PF_INET6 is not available on all platforms
+- PR#4730: incorrect typing involving abbreviation "type 'a t = 'a"
+- PR#4731: incorrect quoting of arguments passed to the assembler on x86-64
+- PR#4735: Unix.LargeFile.fstat cannot report size over 32bits on Win32
+- PR#4740: guard against possible processor error in
+           {Int32,Int64,Nativeint}.{div,rem}
+- PR#4745: type inference wrongly produced non-generalizable type variables.
+- PR#4749: better pipe size for win32unix
+- PR#4756: printf: no error reported for wrong format '%_s'
+- PR#4758: scanf: handling of \ by format '%S'
+- PR#4766: incorrect simplification of some type abbreviations.
+- PR#4768: printf: %F does not respect width and precision specifications
+- PR#4769: Format.bprintf fails to flush
+- PR#4775: fatal error Ctype.Unify during module type-checking (temporary fix)
+- PR#4776: bad interaction between exceptions and classes
+- PR#4780: labltk build problem under Windows.
+- PR#4790: under Windows, map ERROR_NO_DATA Win32 error to EPIPE Unix error.
+- PR#4792: bug in Big_int.big_int_of_int64 on 32-bit platforms.
+- PR#4796: ocamlyacc: missing NUL termination of string
+- PR#4804: bug in Big_int.int64_of_big_int on 32-bit platforms.
+- PR#4805: improving compatibility with the clang C compiler
+- PR#4809: issue with Unix.create_process under Win32
+- PR#4814: ocamlbrowser: crash when editing comments
+- PR#4816: module abbreviations remove 'private' type restrictions
+- PR#4817: Object type gives error "Unbound type parameter .."
+- Module Parsing: improved computation of locations when an ocamlyacc rule
+                  starts with an empty nonterminal
+- Type-checker: fixed wrong variance computation for private types
+- x86-32 code generator, MSVC port: wrong "fld" instruction generated.
+- ocamlbuild: incorrectly using the compile-time value of $OCAMLLIB
+- Makefile problem when configured with -no-shared-libs
+- ocamldoc: use dynamic loading in native code
+
+Other changes:
+- Improved wording of various error messages
+  (contributed by Jonathan Davies, Citrix).
+- Support for 64-bit mode in Solaris/x86 (PR#4670).
+
+
+Objective Caml 3.11.0 (03 Dec 2008):
+------------------------------------
+
+(Changes that can break existing programs are marked with a "*"  )
+
+Language features:
+- Addition of lazy patterns: "lazy " matches suspensions whose values,
+  after forcing, match the pattern .
+- Introduction of private abbreviation types "type t = private ",
+  for abstracting the actual manifest type in type abbreviations.
+- Subtyping is now allowed between a private abbreviation and its definition,
+  and between a polymorphic method and its monomorphic instance.
+
+Compilers:
+- The file name for a compilation unit should correspond to a valid
+  identifier (Otherwise dynamic linking and other things can fail, and
+  a warning is emitted.)
+* Revised -output-obj: the output name must now be provided; its
+  extension must be one of .o/.obj, .so/.dll, or .c for the
+  bytecode compiler. The compilers can now produce a shared library
+  (with all the needed -ccopts/-ccobjs options) directly.
+- -dtypes renamed to -annot, records (in .annot files) which function calls
+  are tail calls.
+- All compiler error messages now include a file name and location, for
+  better interaction with Emacs' compilation mode.
+- Optimized compilation of "lazy e" when the argument "e" is
+  already evaluated.
+- Optimized compilation of equality tests with a variant constant constructor.
+- The -dllib options recorded in libraries are no longer ignored when
+  -use_runtime or -use_prims is used (unless -no_auto_link is
+  explicitly used).
+- Check that at most one of -pack, -a, -shared, -c, -output-obj is
+  given on the command line.
+- Optimized compilation of private types as regular manifest types
+  (e.g. abbreviation to float, float array or record types with only
+   float fields).
+
+Native-code compiler:
+- New port: Mac OS X / Intel in 64-bit mode (configure with -cc "gcc -m64").
+- A new option "-shared" to produce a plugin that can be dynamically
+  loaded with the native version of Dynlink.
+- A new option "-nodynlink" to enable optimizations valid only for code
+  that is never dynlinked (no-op except for AMD64).
+- More aggressive unboxing of floats and boxed integers.
+- Can select which assembler and asm options to use at configuration time.
+
+Run-time system:
+- New implementation of the page table describing the heap (two-level
+  array in 32 bits, sparse hashtable in 64 bits), fixes issues with address
+  space randomization on 64-bit OS (PR#4448).
+- New "generational" API for registering global memory roots with the GC,
+  enables faster scanning of global roots.
+  (The functions are caml_*_generational_global_root in .)
+- New function "caml_raise_with_args" to raise an exception with several
+  arguments from C.
+- Changes in implementation of dynamic linking of C code:
+  under Win32, use Alain Frisch's flexdll implementation of the dlopen
+  API; under MacOSX, use dlopen API instead of MacOSX bundle API.
+- Programs may now choose a first-fit allocation policy instead of
+  the default next-fit.  First-fit reduces fragmentation but is
+  slightly slower in some cases.
+
+Standard library:
+- Parsing library: new function "set_trace" to programmatically turn
+  on or off the printing of a trace during parsing.
+- Printexc library: new functions "print_backtrace" and "get_backtrace"
+  to obtain a stack backtrace of the most recently raised exception.
+  New function "record_backtrace" to turn the exception backtrace mechanism
+  on or off from within a program.
+- Scanf library: fine-tuning of meta format implementation;
+  fscanf behaviour revisited: only one input buffer is allocated for any
+  given input channel;
+  the %n conversion does not count a lookahead character as read.
+
+Other libraries:
+- Dynlink: on some platforms, the Dynlink library is now available in
+  native code. The boolean Dynlink.is_native allows the program to
+  know whether it has been compiled in bytecode or in native code.
+- Bigarrays: added "unsafe_get" and "unsafe_set"
+  (non-bound-checking versions of "get" and "set").
+- Bigarrays: removed limitation "array dimension < 2^31".
+- Labltk: added support for TK 8.5.
+- Num: added conversions between big_int and int32, nativeint, int64.
+  More efficient implementation of Num.quo_num and Num.mod_num.
+- Threads: improved efficiency of mutex and condition variable operations;
+  improved interaction with Unix.fork (PR#4577).
+- Unix: added getsockopt_error returning type Unix.error.
+  Added support for TCP_NODELAY and IPV6_ONLY socket options.
+- Win32 Unix: "select" now supports all kinds of file descriptors.
+  Improved emulation of "lockf" (PR#4609).
+
+Tools:
+- ocamldebug now supported under Windows (MSVC and Mingw ports),
+  but without the replay feature.  (Contributed by Dmitry Bely
+  and Sylvain Le Gall at OCamlCore with support from Lexifi.)
+- ocamldoc: new option -no-module-constraint-filter to include functions
+  hidden by signature constraint in documentation.
+- ocamlmklib and ocamldep.opt now available under Windows ports.
+- ocamlmklib no longer supports the -implib option.
+- ocamlnat: an experimental native toplevel (not built by default).
+
+Camlp4:
+* programs linked with camlp4lib.cma now also need dynlink.cma.
+
+Bug fixes:
+- Major GC and heap compaction: fixed bug involving lazy values and
+  out-of-heap pointers.
+- PR#3915: updated most man pages.
+- PR#4261: type-checking of recursive modules
+- PR#4308: better stack backtraces for "spontaneous" exceptions such as
+  Stack_overflow, Out_of_memory, etc.
+- PR#4338: Str.global_substitute, Str.global_replace and the Str.*split*
+  functions are now tail-recursive.
+- PR#4503: fixed bug in classify_float on ARM.
+- PR#4512: type-checking of recursive modules
+- PR#4517: crash in ocamllex-generated lexers.
+- PR#4542: problem with return value of Unix.nice.
+- PR#4557: type-checking of recursive modules.
+- PR#4562: strange %n semantics in scanf.
+- PR#4564: add note "stack is not executable" to object files generated by
+  ocamlopt (Linux/x86, Linux/AMD64).
+- PR#4566: bug in Ratio.approx_ratio_fix and Num.approx_num_fix.
+- PR#4582: clarified the documentation of functions in the String module.
+- PR#4583: stack overflow in "ocamlopt -g" during closure conversion pass.
+- PR#4585: ocamldoc and "val virtual" declarations.
+- PR#4587: ocamldoc and escaped @ characters.
+- PR#4605: Buffer.add_substitute was sometime wrong when target string had
+           backslashes.
+- PR#4614: Inconsistent declaration of CamlCBCmd in LablTk library.
+
+
+Objective Caml 3.10.2 (29 Feb 2008):
+------------------------------------
+
+Bug fixes:
+- PR#1217 (partial) Typo in ocamldep man page
+- PR#3952 (partial) ocamlopt: allocation problems on ARM
+- PR#4339 (continued) ocamlopt: problems on HPPA
+- PR#4455 str.mli not installed under Windows
+- PR#4473 crash when accessing float array with polymorphic method
+- PR#4480 runtime would not compile without gcc extensions
+- PR#4481 wrong typing of exceptions with object arguments
+- PR#4490 typo in error message
+- Random crash on 32-bit when major_heap_increment >= 2^22
+- Big performance bug in Weak hashtables
+- Small bugs in the make-package-macosx script
+- Bug in typing of polymorphic variants (reported on caml-list)
+
+
+Objective Caml 3.10.1 (11 Jan 2008):
+------------------------------------
+
+Bug fixes:
+- PR#3830 small bugs in docs
+- PR#4053 compilers: improved compilation time for large variant types
+- PR#4174 ocamlopt: fixed ocamlopt -nopervasives
+- PR#4199 otherlibs: documented a small problem in Unix.utimes
+- PR#4280 camlp4: parsing of identifier (^)
+- PR#4281 camlp4: parsing of type constraint
+- PR#4285 runtime: cannot compile under AIX
+- PR#4286 ocamlbuild: cannot compile under AIX and SunOS
+- PR#4288 compilers: including a functor application with side effects
+- PR#4295 camlp4 toplevel: synchronization after an error
+- PR#4300 ocamlopt: crash with backtrace and illegal array access
+- PR#4302 camlp4: list comprehension parsing problem
+- PR#4304 ocamlbuild: handle -I correctly
+- PR#4305 stdlib: alignment of Arg.Symbol
+- PR#4307 camlp4: assertion failure
+- PR#4312 camlp4: accept "let _ : int = 1"
+- PR#4313 ocamlbuild: -log and missing directories
+- PR#4315 camlp4: constraints in classes
+- PR#4316 compilers: crash with recursive modules and Lazy
+- PR#4318 ocamldoc: installation problem with Cygwin (tentative fix)
+- PR#4322 ocamlopt: stack overflow under Windows
+- PR#4325 compilers: wrong error message for unused var
+- PR#4326 otherlibs: marshal Big_int on win64
+- PR#4327 ocamlbuild: make emacs look for .annot in _build directory
+- PR#4328 camlp4: stack overflow with nil nodes
+- PR#4331 camlp4: guards on fun expressions
+- PR#4332 camlp4: parsing of negative 32/64 bit numbers
+- PR#4336 compilers: unsafe recursive modules
+- PR#4337 (note) camlp4: invalid character escapes
+- PR#4339 ocamlopt: problems on HP-UX (tentative fix)
+- PR#4340 camlp4: wrong pretty-printing of optional arguments
+- PR#4348 ocamlopt: crash on Mac Intel
+- PR#4349 camlp4: bug in private type definitions
+- PR#4350 compilers: type errors with records and polymorphic variants
+- PR#4352 compilers: terminal recursion under Windows (tentative fix)
+- PR#4354 ocamlcp: mismatch with ocaml on polymorphic let
+- PR#4358 ocamlopt: float constants wrong on ARM
+- PR#4360 ocamldoc: string inside comment
+- PR#4365 toplevel: wrong pretty-printing of polymorphic variants
+- PR#4373 otherlibs: leaks in win32unix
+- PR#4374 otherlibs: threads module not initialized
+- PR#4375 configure: fails to build on bytecode-only architectures
+- PR#4377 runtime: finalisation of infix pointers
+- PR#4378 ocamlbuild: typo in plugin.ml
+- PR#4379 ocamlbuild: problem with plugins under Windows
+- PR#4382 compilers: typing of polymorphic record fields
+- PR#4383 compilers: including module with private type
+- PR#4385 stdlib: Int32/Int64.format are unsafe
+- PR#4386 otherlibs: wrong signal numbers with Unix.sigprocmask etc.
+- PR#4387 ocamlbuild: build directory not used properly
+- PR#4392 ocamldep: optional argument of class
+- PR#4394 otherlibs: infinite loops in Str
+- PR#4397 otherlibs: wrong size for flag arrays in win32unix
+- PR#4402 ocamldebug: doesn't work with -rectypes
+- PR#4410 ocamlbuild: problem with plugin and -build
+- PR#4411 otherlibs: crash with Unix.access under Windows
+- PR#4412 stdlib: marshalling broken on 64 bit architectures
+- PR#4413 ocamlopt: crash on AMD64 with out-of-bound access and reraise
+- PR#4417 camlp4: pretty-printing of unary minus
+- PR#4419 camlp4: problem with constraint in type class
+- PR#4426 compilers: problem with optional labels
+- PR#4427 camlp4: wrong pretty-printing of lists of functions
+- PR#4433 ocamlopt: fails to build on MacOSX 10.5
+- PR#4435 compilers: crash with objects
+- PR#4439 fails to build on MacOSX 10.5
+- PR#4441 crash when build on sparc64 linux
+- PR#4442 stdlib: crash with weak pointers
+- PR#4446 configure: fails to detect X11 on MacOSX 10.5
+- PR#4448 runtime: huge page table on 64-bit architectures
+- PR#4450 compilers: stack overflow with recursive modules
+- PR#4470 compilers: type-checking of recursive modules too restrictive
+- PR#4472 configure: autodetection of libX11.so on Fedora x86_64
+- printf: removed (partially implemented) positional specifications
+- polymorphic < and <= comparisons: some C compiler optimizations
+  were causing incorrect results when arguments are incomparable
+
+New features:
+- made configure script work on PlayStation 3
+- ARM port: brought up-to-date for Debian 4.0 (Etch)
+- many other small changes and bugfixes in camlp4, ocamlbuild, labltk,
+  emacs files
+
+
+Objective Caml 3.10.0 (18 May 2007):
+------------------------------------
+
+(Changes that can break existing programs are marked with a "*"  )
+
+Language features:
+- Added virtual instance variables in classes "val virtual v : t"
+* Changed the behaviour of instance variable overriding; the new
+  definition replaces the old one, rather than creating a new
+  variable.
+
+New tools:
+- ocamlbuild: compilation manager for OCaml applications and libraries.
+  See draft documentation at http://gallium.inria.fr/~pouillar/
+* Camlp4: heavily revised implementation, new API.
+
+New ports:
+- MacOS X PowerPC 64 bits.
+- MS Windows 64 bits (x64) using the Microsoft PSDK toolchain.
+- MS Windows 32 bits using the Visual Studio 2005 toolchain.
+
+Compilers:
+- Faster type-checking of functor applications.
+- Referencing an interface compiled with -rectypes from a module
+    not compiled with -rectypes is now an error.
+- Revised the "fragile matching" warning.
+
+Native-code compiler:
+- Print a stack backtrace on an uncaught exception.
+  (Compile and link with ocamlopt -g; execute with OCAMLRUNPARAM=b.)
+  Supported on Intel/AMD in 32 and 64 bits, PPC in 32 and 64 bits.
+- Stack overflow detection on MS Windows 32 bits (courtesy O. Andrieu).
+- Stack overflow detection on MacOS X PPC and Intel.
+- Intel/AMD 64 bits: generate position-independent code by default.
+- Fixed bug involving -for-pack and missing .cmx files (PR#4124).
+- Fixed bug causing duplication of literals  (PR#4152).
+
+Run-time system:
+- C/Caml interface functions take "char const *" arguments
+  instead of "char *" when appropriate.
+- Faster string comparisons (fast case if strings are ==).
+
+Standard library:
+- Refined typing of format strings (type format6).
+- Printf, Format: new function ifprintf that consumes its arguments
+    and prints nothing (useful to print conditionally).
+- Scanf:
+    new function format_from_string to convert a string to a format string;
+    new %r conversion to accomodate user defined scanners.
+- Filename: improved Win32 implementation of Filename.quote.
+- List: List.nth now tail-recursive.
+- Sys: added Sys.is_directory.  Some functions (e.g. Sys.command) that
+    could incorrectly raise Sys_io_blocked now raise Sys_error as intended.
+- String and Char: the function ``escaped'' now escapes all the characters
+    especially handled by the compiler's lexer (PR#4220).
+
+Other libraries:
+- Bigarray: mmap_file takes an optional argument specifying
+    the start position of the data in the mapped file.
+- Dynlink: now defines only two modules, Dynlink and Dynlinkaux (internal),
+    reducing risks of name conflicts with user modules.
+- Labltk under Win32: now uses Tcl/Tk 8.4 instead of 8.3 by default.
+- VM threads: improved performance of I/O operations (less polling).
+- Unix: new function Unix.isatty.
+- Unix emulation under Win32:
+    fixed incorrect error reporting in several functions (PR#4097);
+    better handling of channels opened on sockets (PR#4098);
+    fixed GC bug in Unix.system (PR#4112).
+
+Documentation generator (OCamldoc):
+- correctly handle '?' in value names (PR#4215)
+- new option -hide-warnings not to print ocamldoc warnings
+
+Lexer generator (ocamllex): improved error reporting.
+
+License: fixed a typo in the "special exception" to the LGPL.
+
+
+Objective Caml 3.09.3 (15 Sep 2006):
+------------------------------------
+
+Bug fixes:
+- ocamldoc: -using modtype constraint to filter module elements displayed
+    in doc PR#4016
+- ocamldoc: error in merging of top dependencies of modules PR#4007
+- ocamldoc: -dot-colors has no effect PR#3981
+- ocamdloc: missing crossref in text from intro files PR#4066
+- compilers: segfault with recursive modules PR#4008
+- compilers: infinite loop when compiling objects PR#4018
+- compilers: bad error message when signature mismatch PR#4001
+- compilers: infinite loop with -rectypes PR#3999
+- compilers: contravariance bug in private rows
+- compilers: unsafe cast with polymorphic exception PR#4002
+- native compiler: bad assembly code generated for AMD64 PR#4067
+- native compiler: stack alignment problems on MacOSX/i386 PR#4036
+- stdlib: crash in marshalling PR#4030
+- stdlib: crash when closing a channel twice PR#4039
+- stdlib: memory leak in Sys.readdir PR#4093
+- C interface: better definition of CAMLreturn PR#4068
+- otherlibs/unix: crash in gethostbyname PR#3043
+- tools: subtle problem with unset in makefile PR#4048
+- camlp4: install pa_o_fast.o PR#3812
+- camlp4: install more modules PR#3689
+
+New features:
+- ocamldoc: name resolution in cross-referencing {!name}: if name is not
+    found, then it is searched in the parent module/class, and in the parent
+    of the parent, and so on until it is found.
+- ocamldoc: new option -short-functors to use a short form to display
+    functors in html generator PR#4017
+- ocamlprof: added "-version" option
+
+
+
+Objective Caml 3.09.2 (14 Apr 2006):
+------------------------------------
+
+Bug fixes:
+- Makefile: problem with "make world.opt" PR#3954
+- compilers: problem compiling several modules with one command line PR#3979
+- compilers,ocamldoc: error message that Emacs cannot parse
+- compilers: crash when printing type error PR#3968
+- compilers: -dtypes wrong for monomorphic type variables PR#3894
+- compilers: wrong warning on optional arguments PR#3980
+- compilers: crash when wrong use of type constructor in let rec PR#3976
+- compilers: better wording of "statement never returns" warning PR#3889
+- runtime: inefficiency of signal handling PR#3990
+- runtime: crashes with I/O in multithread programs PR#3906
+- camlp4: empty file name in error messages PR#3886
+- camlp4: stack overflow PR#3948
+- otherlibs/labltk: ocamlbrowser ignores its command line options PR#3961
+- otherlibs/unix: Unix.times wrong under Mac OS X PR#3960
+- otherlibs/unix: wrong doc for execvp and execvpe PR#3973
+- otherlibs/win32unix: random crash in Unix.stat PR#3998
+- stdlib: update_mod not found under Windows PR#3847
+- stdlib: Filename.dirname/basename wrong on Win32 PR#3933
+- stdlib: incomplete documentation of Pervasives.abs PR#3967
+- stdlib: Printf bugs PR#3902, PR#3955
+- tools/checkstack.c: missing include
+- yacc: crash when given argument "-" PR#3956
+
+New features:
+- ported to MacOS X on Intel PR#3985
+- configure: added support for GNU Hurd PR#3991
+
+Objective Caml 3.09.1 (4 Jan 2006):
+-----------------------------------
+
+Bug fixes:
+- compilers: raise not_found with -principal PR#3855
+- compilers: assert failure in typeclass.cml PR#3856
+- compilers: assert failure in typing/ctype.ml PR#3909
+- compilers: fatal error exception Ctype.Unify PR#3918
+- compilers: spurious warning Y in objects PR#3868
+- compilers: spurious warning Z on loop index PR#3907
+- compilers: error message that emacs cannot parse
+- ocamlopt: problems with -for-pack/-pack PR#3825, PR#3826, PR#3919
+- ocamlopt: can't produce shared libraries on x86_64 PR#3869, PR#3924
+- ocamlopt: float alignment problem on SPARC PR#3944
+- ocamlopt: can't compile on MIPS PR#3936
+- runtime: missing dependence for ld.conf
+- runtime: missing dependence for .depend.nt PR#3880
+- runtime: memory leak in caml_register_named_value PR#3940
+- runtime: crash in Marshal.to_buffer PR#3879
+- stdlib: Sys.time giving wrong results on Mac OS X PR#3850
+- stdlib: Weak.get_copy causing random crashes in rare cases
+- stdlib, debugger, labltk: use TMPDIR if set PR#3895
+- stdlib: scanf bug on int32 and nativeint PR#3932
+- camlp4: mkcamlp4 option parsing problem PR#3941
+- camlp4: bug in pretty-printing of lazy/assert/new
+- camlp4: update the unmaintained makefile for _loc name
+- ocamldoc: several fixes see ocamldoc/Changes.txt
+- otherlibs/str: bug in long sequences of alternatives PR#3783
+- otherlibs/systhreads: deadlock in Windows PR#3910
+- tools: update dumpobj to handle new event format PR#3873
+- toplevel: activate warning Y in toplevel PR#3832
+
+New features:
+- otherlibs/labltk: browser uses menu bars instead of menu buttons
+
+Objective Caml 3.09.0 (27 Oct 2006):
+------------------------------------
+
+(Changes that can break existing programs are marked with a "*"  )
+
+Language features:
+- Introduction of private row types, for abstracting the row in object
+  and variant types.
+
+Type checking:
+- Polymorphic variants with at most one constructor [< `A of t] are no
+  longer systematically promoted to the exact type [`A of t]. This was
+  more confusing than useful, and created problems with private row
+  types.
+
+Both compilers:
+- Added warnings 'Y' and 'Z' for local variables that are bound but
+  never used.
+- Added warning for some uses non-returning functions (e.g. raise), when they
+  are passed extra arguments, or followed by extra statements.
+- Pattern matching: more prudent compilation in case of guards; fixed PR#3780.
+- Compilation of classes: reduction in size of generated code.
+- Compilation of "module rec" definitions: fixed a bad interaction with
+  structure coercion (to a more restrictive signature).
+
+Native-code compiler (ocamlopt):
+* Revised implementation of the -pack option (packing of several compilation
+  units into one).  The .cmx files that are to be packed with
+  "ocamlopt -pack -o P.cmx" must be compiled with "ocamlopt -for-pack P".
+  In exchange for this additional constraint, ocamlopt -pack is now
+  available on all platforms (no need for binutils).
+* Fixed wrong evaluation order for arguments to certain inlined functions.
+- Modified code generation for "let rec ... and ..." to reduce compilation
+  time (which was quadratic in the number of mutually-recursive functions).
+- x86 port: support tail-calls for functions with up to 21 arguments.
+- AMD64 port, Linux: recover from system stack overflow.
+- Sparc port: more portable handling of out-of-bound conditions
+  on systems other than Solaris.
+
+Standard library:
+- Pervasives: faster implementation of close_in, close_out.
+  set_binary_mode_{out,in} now working correctly under Cygwin.
+- Printf: better handling of partial applications of the printf functions.
+- Scanf: new function sscanf_format to read a format from a
+  string. The type of the resulting format is dynamically checked and
+  should be the type of the template format which is the second argument.
+- Scanf: no more spurious lookahead attempt when the end of file condition
+  is set and a correct token has already been read and could be returned.
+
+Other libraries:
+- System threads library: added Thread.sigmask; fixed race condition
+  in signal handling.
+- Bigarray library: fixed bug in Array3.of_array.
+- Unix library: use canonical signal numbers in results of Unix.wait*;
+  hardened Unix.establish_server against EINTR errors.
+
+Run-time system:
+- Support platforms where sizeof(void *) = 8 and sizeof(long) = 4.
+- Improved and cleaned up implementation of signal handling.
+
+Replay debugger:
+- Improved handling of locations in source code.
+
+OCamldoc:
+- extensible {foo } syntax
+- user can give .txt files on the command line, containing ocamldoc formatted
+  text, to be able to include bigger texts out of source files
+- -o option is now used by the html generator to indicate the prefix
+  of generated index files (to avoid conflict when a Index module exists
+  on case-insensitive file systems).
+
+Miscellaneous:
+- Configuration information is installed in `ocamlc -where`/Makefile.config
+  and can be used by client Makefiles or shell scripts.
+
+Objective Caml 3.08.4 (11 Aug 2005):
+------------------------------------
+
+New features:
+- configure: find X11 config in some 64-bit Linux distribs
+- ocamldoc: (**/**) can be canceled with another (**/**) PR#3665
+- graphics: added resize_window
+- graphics: check for invalid arguments to drawing primitives PR#3595
+- ocamlbrowser: use windows subsystem on mingw
+
+Bug fixes:
+- ocamlopt: code generation problem on AMD64 PR#3640
+- wrong code generated for some classes PR#3576
+- fatal error when compiling some OO code PR#3745
+- problem with comparison on constant constructors PR#3608
+- camlp4: cryptic error message PR#3592
+- camlp4: line numbers in multi-line antiquotations PR#3549
+- camlp4: problem with make depend
+- camlp4: parse error with :> PR#3561
+- camlp4: ident conversion problem with val/contents/contents__
+- camlp4: several small parsing problems PR#3688
+- ocamldebug: handling of spaces in executable file name PR#3736
+- emacs-mode: problem when caml-types-buffer is deleted by user PR#3704
+- ocamldoc: extra backslash in ocamldoc man page PR#3687
+- ocamldoc: improvements to HTML display PR#3698
+- ocamldoc: escaping of @ in info files
+- ocamldoc: escaping of . and \ in man pages PR#3686
+- ocamldoc: better error reporting of misplaced comments
+- graphics: fixed .depend file PR#3558
+- graphics: segfault with threads and graphics PR#3651
+- nums: several bugs: PR#3718, PR#3719, others
+- nums: inline asm problems with gcc 4.0 PR#3604, PR#3637
+- threads: problem with backtrace
+- unix: problem with getaddrinfo PR#3565
+- stdlib: documentation of Int32.rem and Int64.rem PR#3573
+- stdlib: documentation of List.rev_map2 PR#3685
+- stdlib: wrong order in Map.fold PR#3607
+- stdlib: documentation of maximum float array length PR#3714
+- better detection of cycles when using -rectypes
+- missing case of module equality PR#3738
+- better error messages for unbound type variables
+- stack overflow while printing type error message PR#3705
+- assert failure when typing some classes PR#3638
+- bug in type_approx
+- better error messages related to type variance checking
+- yacc: avoid name capture for idents of the Parsing module
+
+
+Objective Caml 3.08.3 (24 Mar 2005):
+------------------------------------
+
+New features:
+- support for ocamlopt -pack under Mac OS X (PR#2634, PR#3320)
+- ignore unknown warning options for forward and backward compatibility
+- runtime: export caml_compare_unordered (PR#3479)
+- camlp4: install argl.* files (PR#3439)
+- ocamldoc: add -man-section option
+- labltk: add the "solid" relief option (PR#3343)
+
+Bug fixes:
+- typing: fix unsoundness in type declaration variance inference.
+    Type parameters which are constrained must now have an explicit variant
+    annotation, otherwise they are invariant. This is not backward
+    compatible, so this might break code which either uses subtyping or
+    uses the relaxed value restriction (i.e. was not typable before 3.07)
+- typing: erroneous partial match warning for polymorphic variants (PR#3424)
+- runtime: handle the case of an empty command line (PR#3409, PR#3444)
+- stdlib: make Sys.executable_name an absolute path in native code (PR#3303)
+- runtime: fix memory leak in finalise.c
+- runtime: auto-trigger compaction even if gc is called manually (PR#3392)
+- stdlib: fix segfault in Obj.dup on zero-sized values (PR#3406)
+- camlp4: correct parsing of the $ identifier (PR#3310, PR#3469)
+- windows (MS tools): use link /lib instead of lib (PR#3333)
+- windows (MS tools): change default install destination
+- autoconf: better checking of SSE2 instructions (PR#3329, PR#3330)
+- graphics: make close_graph close the X display as well as the window (PR#3312)
+- num: fix big_int_of_string (empty string) (PR#3483)
+- num: fix big bug on 64-bit architecture (PR#3299)
+- str: better documentation of string_match and string_partial_match (PR#3395)
+- unix: fix file descriptor leak in Unix.accept (PR#3423)
+- unix: miscellaneous clean-ups
+- unix: fix documentation of Unix.tm (PR#3341)
+- graphics: fix problem when allocating lots of images under Windows (PR#3433)
+- compiler: fix error message with -pack when .cmi is missing (PR#3028)
+- cygwin: fix problem with compilation of camlheader (PR#3485)
+- stdlib: Filename.basename doesn't return an empty string any more (PR#3451)
+- stdlib: better documentation of Open_excl flag (PR#3450)
+- ocamlcp: accept -thread option (PR#3511)
+- ocamldep: handle spaces in file names (PR#3370)
+- compiler: remove spurious warning in pattern-matching on variants (PR#3424)
+- windows: better handling of InterpreterPath registry entry (PR#3334, PR#3432)
+
+
+Objective Caml 3.08.2 (22 Nov 2004):
+------------------------------------
+
+Bug fixes:
+- runtime: memory leak when unmarshalling big data structures (PR#3247)
+- camlp4: incorrect line numbers in errors (PR#3188)
+- emacs: xemacs-specific code, wrong call to "sit-for"
+- ocamldoc: "Lexing: empty token" (PR#3173)
+- unix: problem with close_process_* (PR#3191)
+- unix: possible coredumps (PR#3252)
+- stdlib: wrong order in Set.fold (PR#3161)
+- ocamlcp: array out of bounds in profiled programs (PR#3267)
+- yacc: problem with polymorphic variant types for grammar entries (PR#3033)
+
+Misc:
+- export  for caml_format_exception (PR#3080)
+- clean up caml_search_exe_in_path (maybe PR#3079)
+- camlp4: new function "make_lexer" for new-style locations
+- unix: added missing #includes (PR#3088)
+
+
+Objective Caml 3.08.1 (19 Aug 2004):
+------------------------------------
+
+Licence:
+- The emacs files are now under GPL
+- Slightly relaxed some conditions of the QPL
+
+Bug fixes:
+- ld.conf now generated at compile-time instead of install-time
+- fixed -pack on Windows XP (PR#2935)
+- fixed Obj.tag (PR#2946)
+- added support for multiple dlopen in Darwin
+- run ranlib when installing camlp4 libraries (PR#2944)
+- link camlp4opt with -linkall (PR#2949)
+- camlp4 parsing of patterns now conforms to normal parsing (PR#3015)
+- install camlp4 *.cmx files (PR#2955)
+- fixed handling of linefeed in string constants in camlp4 (PR#3074)
+- ocamldoc: fixed display of class parameters in HTML and LaTeX (PR#2994)
+- ocamldoc: fixed display of link to class page in html (PR#2994)
+- Windows toplevel GUI: assorted fixes (including PR#2932)
+
+Misc:
+- added -v option to ocamllex
+- ocamldoc: new -intf and -impl options supported (PR#3036)
+
+Objective Caml 3.08.0 (13 Jul 2004):
+------------------------------------
+
+(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 (29 Sep 2003):
+----------------------------------
+
+Language features:
+- Experimental support for recursive module definitions
+      module rec A : SIGA = StructA and B : SIGB = StructB and ...
+- Support for "private types", or more exactly concrete data types
+  with private constructors or labels.  These data types can be
+  de-structured normally in pattern matchings, but values of these
+  types cannot be constructed directly outside of their defining module.
+- Added integer literals of types int32, nativeint, int64
+  (written with an 'l', 'n' or 'L' suffix respectively).
+
+Type-checking:
+- Allow polymorphic generalization of covariant parts of expansive
+  expressions.  For instance, if f: unit -> 'a list, "let x = f ()"
+  gives "x" the generalized type forall 'a. 'a list, instead of '_a list
+  as before.
+- The typing of polymorphic variants in pattern matching has changed.
+  It is intended to be more regular, sticking to the principle of "closing
+  only the variants which would be otherwise incomplete". Two potential
+  consequences: (1) some types may be left open which were closed before,
+  and the resulting type might not match the interface anymore (expected to
+  be rare); (2) in some cases an incomplete match may be generated.
+- Lots of bug fixes in the handling of polymorphism and recursion inside
+  types.
+- Added a new "-dtypes" option to ocamlc/ocamlopt, and an emacs extension
+  "emacs/caml-types.el".  The compiler option saves inferred type information
+  to file *.annot, and the emacs extension allows the user to look at the
+  type of any subexpression in the source file.  Works even in the case
+  of a type error (all the types computed up to the error are available).
+  This new feature is also supported by ocamlbrowser.
+- Disable "method is overridden" warning when the method was explicitly
+  redefined as virtual beforehand (i.e. not through inheritance). Typing
+  and semantics are unchanged.
+
+Both compilers:
+- Added option "-dtypes" to dump detailed type information to a file.
+- The "-i" option no longer generates compiled files, it only prints
+  the inferred types.
+- The sources for the module named "Mod" can be placed either in Mod.ml or
+  in mod.ml.
+- Compilation of "let rec" on non-functional values: tightened some checks,
+  relaxed some other checks.
+- Fixed wrong code that was generated for "for i = a to max_int"
+  or "for i = a downto min_int".
+- An explicit interface Mod.mli can now be provided for the module obtained
+  by ocamlc -pack -o Mod.cmo ... or ocamlopt -pack -o Mod.cmx ...
+- Revised internal handling of source code locations, now handles
+  preprocessed code better.
+- Pattern-matching bug on float literals fixed.
+- Minor improvements on pattern-matching over variants.
+- More efficient compilation of string comparisons and the "compare" function.
+- More compact code generated for arrays of constants.
+- Fixed GC bug with mutable record fields of type "exn".
+- Added warning "E" for "fragile patterns": pattern matchings that would
+  not be flagged as partial if new constructors were added to the data type.
+
+Bytecode compiler:
+- Added option -vmthread to select the threads library with VM-level
+  scheduling.  The -thread option now selects the system threads library.
+
+Native-code compiler:
+- New port: AMD64 (Opteron).
+- Fixed instruction selection bug on expressions of the kind (raise Exn)(arg).
+- Several bug fixes in ocamlopt -pack (tracking of imported modules,
+  command line too long).
+- Signal handling bug fixed.
+- x86 port:
+    Added -ffast-math option to use inline trigo and log functions.
+    Small performance tweaks for the Pentium 4.
+    Fixed illegal "imul" instruction generated by reloading phase.
+- Sparc port:
+    Enhanced code generation for Sparc V8 (option -march=v8) and
+    Sparc V9 (option -march=v9).
+    Profiling support added for Solaris.
+- PowerPC port:
+    Keep stack 16-aligned for compatibility with C calling conventions.
+
+Toplevel interactive system:
+- Tightened interface consistency checks between .cmi files, .cm[oa] files
+  loaded by #load, and the running toplevel.
+- #trace on mutually-recursive functions was broken, works again.
+- Look for .ocamlinit file in home directory in addition to the current dir.
+
+Standard library:
+- Match_failure and Assert_failure exceptions now report
+  (file, line, column), instead of (file, starting char, ending char).
+- float_of_string, int_of_string: some ill-formed input strings were not
+    rejected.
+- Added format concatenation, string_of_format, format_of_string.
+- Module Arg: added new option handlers Set_string, Set_int, Set_float,
+    Symbol, Tuple.
+- Module Format: tag handling is now turned off by default,
+    use [Format.set_tags true] to activate.
+- Modules Lexing and Parsing: added better handling of positions
+    in source file.  Added function Lexing.flush_input.
+- Module Scanf: %n and %N formats to count characters / items read so far;
+    assorted bug fixes, %! to match end of input. New ``_'' special
+    flag to skip reresulting value.
+- Module Format: tags are not activated by default.
+- Modules Set and Map: fixed bugs causing trees to become unbalanced.
+- Module Printf: less restrictive typing of kprintf.
+- Module Random: better seeding; functions to generate random int32, int64,
+    nativeint; added support for explicit state management.
+- Module Sys: added Sys.readdir for reading the contents of a directory.
+
+Runtime system:
+- output_value/input_value: fixed bug with large blocks (>= 4 Mwords)
+  produced on a 64-bit platform and incorrectly read back on a 32-bit
+  platform.
+- Fixed memory compaction bug involving input_value.
+- Added MacOS X support for dynamic linking of C libraries.
+- Improved stack backtraces on uncaught exceptions.
+- Fixed float alignment problem on Sparc V9 with gcc 3.2.
+
+Other libraries:
+- Dynlink:
+    By default, dynamically-loaded code now has access to all
+      modules defined by the program; new functions Dynlink.allow_only
+      and Dynlink.prohibit implement access control.
+    Fixed Dynlink problem with files generated with ocamlc -pack.
+    Protect against references to modules not yet fully initialized.
+- LablTK/CamlTK: added support for TCL/TK 8.4.
+- Str: reimplemented regexp matching engine, now less buggy, faster,
+    and LGPL instead of GPL.
+- Graphics: fixed draw_rect and fill_rect bug under X11.
+- System threads and bytecode threads libraries can be both installed.
+- System threads: better implementation of Thread.exit.
+- Bytecode threads: fixed two library initialization bugs.
+- Unix: make Unix.openfile blocking to account for named pipes;
+  GC bug in Unix.*stat fixed; fixed problem with Unix.dup2 on Windows.
+
+Ocamllex:
+- Can name parts of the matched input text, e.g.
+    "0" (['0'-'7']+ as s) { ... s ... }
+
+Ocamldebug:
+- Handle programs that run for more than 2^30 steps.
+
+Emacs mode:
+- Added file caml-types.el to interactively display the type information
+  saved by option -dtypes.
+
+Win32 ports:
+- Cygwin port: recognize \ as directory separator in addition to /
+- MSVC port: ocamlopt -pack works provided GNU binutils are installed.
+- Graphics library: fixed bug in Graphics.blit_image; improved event handling.
+
+OCamldoc:
+- new ty_code field for types, to keep code of a type (with option -keep-code)
+- new ex_code field for types, to keep code of an exception
+    (with option -keep-code)
+- some fixes in html generation
+- don't overwrite existing style.css file when generating HTML
+- create the ocamldoc.sty file when generating LaTeX (if nonexistent)
+- man pages are now installed in man/man3 rather than man/mano
+- fix: empty [] in generated HTML indexes
+
+
+Objective Caml 3.06 (20 Aug 2002):
+----------------------------------
+
+Type-checking:
+- Apply value restriction to polymorphic record fields.
+
+Run-time system:
+- Fixed GC bug affecting lazy values.
+
+Both compilers:
+- Added option "-version" to print just the version number.
+- Fixed wrong dependencies in .cmi generated with the -pack option.
+
+Native-code compiler:
+- Fixed wrong return value for inline bigarray assignments.
+
+Libraries:
+- Unix.getsockopt: make sure result is a valid boolean.
+
+Tools:
+- ocamlbrowser: improved error reporting; small Win32 fixes.
+
+Windows ports:
+- Fixed two problems with the Mingw port under Cygwin 1.3.
+
+
+Objective Caml 3.05 (29 Jul 2002):
+----------------------------------
+
+Language features:
+- Support for polymorphic methods and record fields.
+- Allows _ separators in integer and float literals, e.g. 1_000_000.
+
+Type-checker:
+- New flag -principal to enforce principality of type inference.
+- Fixed subtle typing bug with higher-order functors.
+- Fixed several complexity problems; changed (again) the  behaviour of
+  simple coercions.
+- Fixed various bugs with objects and polymorphic variants.
+- Improved some error messages.
+
+Both compilers:
+- Added option "-pack" to assemble several compilation units as one unit
+  having the given units as sub-modules.
+- More precise detection of unused sub-patterns in "or" patterns.
+- Warnings for ill-formed \ escapes in string and character literals.
+- Protect against spaces and other special characters in directory names.
+- Added interface consistency check when building a .cma or .cmxa library.
+- Minor reduction in code size for class initialization code.
+- Added option "-nostdlib" to ignore standard library entirely.
+
+Bytecode compiler:
+- Fixed issue with ocamlc.opt and dynamic linking.
+
+Native-code compiler:
+- Added link-time check for multiply-defined module names.
+- Fixed GC bug related to constant constructors of polymorphic variant types.
+- Fixed compilation bug for top-level "include" statements.
+- PowerPC port: work around limited range for relative branches,
+  thus removing assembler failures on large functions.
+- IA64 port: fixed code generation bug for 3-way constructor matching.
+
+Toplevel interactive system:
+- Can load object files given on command line before starting up.
+- ocamlmktop: minimized possibility of name clashes with user-provided modules.
+
+Run-time system:
+- Minor garbage collector no longer recursive.
+- Better support for lazy data in the garbage collector.
+- Fixed issues with the heap compactor.
+- Fixed issues with finalized Caml values.
+- The type "int64" is now supported on all platforms: we use software
+  emulation if the C compiler doesn't support 64-bit integers.
+- Support for float formats that are neither big-endian nor little-endian
+  (one known example: the ARM).
+- Fixed bug in callback*_exn functions in the exception-catching case.
+- Work around gcc 2.96 bug on RedHat 7.2 and Mandrake 8.0, 8.1 among others.
+- Stub DLLs now installed in subdir stublibs/ of standard library dir.
+
+Standard library:
+- Protect against integer overflow in sub-string and sub-array bound checks.
+- New module Complex implementing arithmetic over complex numbers.
+- New module Scanf implementing format-based scanning a la scanf() in C.
+- Module Arg: added alternate entry point Arg.parse_argv.
+- Modules Char, Int32, Int64, Nativeint, String: added type "t" and function
+  "compare" so that these modules can be used directly with e.g. Set.Make.
+- Module Digest: fixed issue with Digest.file on large files (>= 1Gb);
+    added Digest.to_hex.
+- Module Filename: added Filename.open_temp_file to atomically create and
+    open the temp file; improved security of Filename.temp_file.
+- Module Genlex: allow _ as first character of an identifier.
+- Module Lazy: more efficient implementation.
+- Module Lexing: improved performances for very large tokens.
+- Module List: faster implementation of sorting functions.
+- Module Printf:
+    added %S and %C formats (quoted, escaped strings and characters);
+    added kprintf (calls user-specified continuation on formatted string).
+- Module Queue: faster implementation (courtesy of François Pottier).
+- Module Random: added Random.bool.
+- Module Stack: added Stack.is_empty.
+- Module Pervasives:
+    added sub-module LargeFile to support files larger than 1Gb
+      (file offsets are int64 rather than int);
+    opening in "append" mode automatically sets "write" mode;
+    files are now opened in close-on-exec mode;
+    string_of_float distinguishes its output from a plain integer;
+    faster implementation of input_line for long lines.
+- Module Sys:
+     added Sys.ocaml_version containing the OCaml version number;
+     added Sys.executable_name containing the (exact) path of the
+       file being executable;
+     Sys.argv.(0) is now unchanged w.r.t. what was provided as 0-th argument
+       by the shell.
+- Module Weak: added weak hash tables.
+
+Other libraries:
+- Bigarray:
+    support for bigarrays of complex numbers;
+    added functions Genarray.dims,
+      {Genarray,Array1,Array2,Array3}.{kind,layout}.
+- Dynlink: fixed bug with loading of mixed-mode Caml/C libraries.
+- LablTK:
+    now supports also the CamlTK API (no labels);
+    support for Activate and Deactivate events;
+    support for virtual events;
+    added UTF conversion;
+    export the tcl interpreter as caml value, to avoid DLL dependencies.
+- Unix:
+    added sub-module LargeFile to support files larger than 1Gb
+      (file offsets are int64 rather than int);
+    added POSIX opening flags (O_NOCTTY, O_*SYNC);
+    use reentrant functions for gethostbyname and gethostbyaddr when available;
+    fixed bug in Unix.close_process and Unix.close_process_full;
+    removed some overhead in Unix.select.
+
+Tools:
+- ocamldoc (the documentation generator) is now part of the distribution.
+- Debugger: now supports the option -I +dir.
+- ocamllex: supports the same identifiers as ocamlc; warns for
+  bad \ escapes in strings and characters.
+- ocamlbrowser:
+    recenter the module boxes when showing a cross-reference;
+    include the current directory in the ocaml path.
+
+Windows port:
+- Can now compile with Mingw (the GNU compilers without the Cygwin
+  runtime library) in addition to MSVC.
+- Toplevel GUI: wrong filenames were given to #use and #load commands;
+  read_line() was buggy for short lines (2 characters or less).
+- OCamlBrowser: now fully functional.
+- Graphics library: fixed several bugs in event handling.
+- Threads library: fixed preemption bug.
+- Unix library: better handling of the underlying differences between
+  sockets and regular file descriptors;
+  added Unix.lockf and a better Unix.rename (thanks to Tracy Camp).
+- LablTk library: fixed a bug in Fileinput
+
+
+Objective Caml 3.04 (13 Dec 2001):
+----------------------------------
+
+Type-checker:
+- Allowed coercing self to the type of the current class, avoiding
+  an obscure error message about "Self type cannot be unified..."
+
+Both compilers:
+- Use OCAMLLIB environment variable to find standard library, falls
+  back on CAMLLIB if not defined.
+- Report out-of-range ASCII escapes in character or string literals
+  such as "\256".
+
+Byte-code compiler:
+- The -use-runtime and -make-runtime flags are back by popular demand
+  (same behavior as in 3.02).
+- Dynamic loading (of the C part of mixed Caml/C libraries): arrange that
+  linking in -custom mode uses the static libraries for the C parts,
+  not the shared libraries, for maximal robustness and compatibility with
+  3.02.
+
+Native-code compiler:
+- Fixed bug in link-time consistency checking.
+
+Tools:
+- ocamlyacc: added parser debugging support (set OCAMLRUNPARAM=p to get
+  a trace of the pushdown automaton actions).
+- ocamlcp: was broken in 3.03 (Sys_error), fixed.
+
+Run-time system:
+- More work on dynamic loading of the C part of mixed Caml/C libraries.
+- On uncaught exception, flush output channels before printing exception
+  message and backtrace.
+- Corrected several errors in exception backtraces.
+
+Standard library:
+- Pervasives: integer division and modulus are now fully specified
+  on negative arguments (with round-towards-zero semantics).
+- Pervasives.float_of_string: now raises Failure on ill-formed input.
+- Pervasives: added useful float constants max_float, min_float, epsilon_float.
+- printf functions in Printf and Format: added % formats for int32, nativeint,
+  int64; "*" in width and precision specifications now supported
+  (contributed by Thorsten Ohl).
+- Added Hashtbl.copy, Stack.copy.
+- Hashtbl: revised resizing strategy to avoid quadratic behavior
+  on Hashtbl.add.
+- New module MoreLabels providing labelized versions of modules
+  Hashtbl, Map and Set.
+- Pervasives.output_value and Marshal.to_* : improved hashing strategy
+  for internal data structures, avoid excessive slowness on
+  quasi-linearly-allocated inputs.
+
+Other libraries:
+- Num: fixed bug in big integer exponentiation (Big_int.power_*).
+
+Windows port:
+- New GUI for interactive toplevel (Jacob Navia).
+- The Graphics library is now available for stand-alone executables
+  (Jacob Navia).
+- Unix library: improved reporting of system error codes.
+- Fixed error in "globbing" of * and ? patterns on command line.
+
+Emacs mode: small fixes; special color highlighting for ocamldoc comments.
+
+License: added special exception to the LGPL'ed code (libraries and
+  runtime system) allowing unrestricted linking, whether static or dynamic.
+
+
+Objective Caml 3.03 ALPHA (12 Oct 2001):
+----------------------------------------
+
+Language:
+- Removed built-in syntactic sugar for streams and stream patterns
+  [< ... >], now supported via CamlP4, which is now included in the
+  distribution.
+- Switched the default behaviour to labels mode (labels are compulsory),
+  but allows omitting labels when a function application is complete.
+  -nolabels mode is available but deprecated for programming.
+  (See also scrapelabels and addlabels tools below.)
+- Removed all labels in the standard libraries, except labltk.
+  Labelized versions are kept for ArrayLabels, ListLabels, StringLabels
+  and UnixLabels. "open StdLabels" gives access to the first three.
+- Extended polymorphic variant type syntax, allowing union types and
+  row abbreviations for both sub- and super-types. #t deprecated in types.
+- See the Upgrading file for how to adapt to all the changes above.
+
+Type-checker:
+- Fixed obscure bug in module typing causing the type-checker to loop
+  on signatures of the form
+        module type M
+        module A: sig module type T = sig module T: M end end
+        module B: A.T
+- Improved efficiency of module type-checking via lazy computation of
+  certain signature summary information.
+- An empty polymorphic variant type is now an error.
+
+Both compilers:
+- Fixed wrong code generated for "struct include M ... end" when M
+  contains one or several "external" declarations.
+
+Byte-code compiler:
+- Protect against VM stack overflow caused by module initialization code
+  with many local variables.
+- Support for dynamic loading of the C part of mixed Caml/C libraries.
+- Removed the -use-runtime and -make-runtime flags, obsoleted by dynamic
+  loading of C libraries.
+
+Native-code compiler:
+- Attempt to recover gracefully from system stack overflow.  Currently
+  works on x86 under Linux and BSD.
+- Alpha: work around "as" bug in Tru64 5.1.
+
+Toplevel environment:
+- Revised printing of inferred types and evaluation results
+  so that an external printer (e.g. Camlp4's) can be hooked in.
+
+Tools:
+- The CamlP4 pre-processor-pretty-printer is now included in the standard
+  distribution.
+- New tool ocamlmklib to help build mixed Caml/C libraries.
+- New tool scrapelabels and addlabels, to either remove (non-optional)
+  labels in interfaces, or automatically add them in the definitions.
+  They provide easy transition from classic mode ocaml 3.02 sources,
+  depending on whether you want to keep labels or not.
+- ocamldep: added -pp option to handle preprocessed source files.
+
+Run-time system:
+- Support for dynamic loading of the C part of mixed Caml/C libraries.
+  Currently works under Linux, FreeBSD, Windows, Tru64, Solaris and Irix.
+- Implemented registration of global C roots with a skip list,
+  runs much faster when there are many global C roots.
+- Autoconfiguration script: fixed wrong detection of Mac OS X; problem
+  with the Sparc, gcc 3.0, and float alignment fixed.
+
+Standard library:
+- Added Pervasives.flush_all to flush all opened output channels.
+
+Other libraries:
+- All libraries revised to allow dynamic loading of the C part.
+- Graphics under X Windows: revised event handling, should no longer lose
+    mouse events between two calls to wait_next_event(); wait_next_event()
+    now interruptible by signals.
+- Bigarrays: fixed bug in marshaling of big arrays.
+
+Windows port:
+- Fixed broken Unix.{get,set}sockopt*
+
+
+
+Objective Caml 3.02 (30 Jul 2001):
+----------------------------------
+
+Both compilers:
+- Fixed embarrassing bug in pattern-matching compilation
+  (affected or-patterns containing variable bindings).
+- More optimizations in pattern-matching compilation.
+
+Byte-code compiler:
+- Protect against VM stack overflow caused by functions with many local
+  variables.
+
+Native-code compiler:
+- Removed re-sharing of string literals, causes too many surprises with
+  in-place string modifications.
+- Corrected wrong compilation of toplevel "include" statements.
+- Fixed bug in runtime function "callbackN_exn".
+- Signal handlers receive the conventional signal number as argument
+  instead of the system signal number (same behavior as with the
+  bytecode compiler).
+- ARM port: fixed issue with immediate operand overflow in large functions.
+
+Toplevel environment:
+- User-definer printers (for #install_printer) now receive as first argument
+  the pretty-printer formatter where to print their second argument.
+  Old printers (with only one argument) still supported for backward
+  compatibility.
+
+Standard library:
+- Module Hashtbl: added Hashtbl.fold.
+
+Other libraries:
+- Dynlink: better error reporting in add_interfaces for missing .cmi files.
+- Graphics: added more drawing functions (multiple points, polygons,
+    multiple lines, splines).
+- Bytecode threads: the module Unix is now thread-safe, ThreadUnix is
+    deprecated.  Unix.exec* now resets standard descriptors to blocking mode.
+- Native threads: fixed a context-switch-during-GC problem causing
+    certain C runtime functions to fail, most notably input_value.
+- Unix.inet_addr_of_string: call inet_aton() when available so as to
+    handle correctly the address 255.255.255.255.
+- Unix: added more getsockopt and setsockopt functions to get/set
+    options that have values other than booleans.
+- Num: added documentation for the Big_int module.
+
+Tools:
+- ocamldep: fixed wrong dependency issue with nested modules.
+
+Run-time system:
+- Removed floating-point error at start-up on some non-IEEE platforms
+  (e.g. FreeBSD prior to 4.0R).
+- Stack backtrace mechanism now works for threads that terminate on
+  an uncaught exception.
+
+Auto-configuration:
+- Updated config.guess and config.sub scripts, should recognize a greater
+  number of recent platform.
+
+Windows port:
+- Fixed broken Unix.waitpid.  Unix.file_descr can now be compared or hashed.
+- Toplevel application: issue with spaces in name of stdlib directory fixed.
+
+MacOS 9 port:
+- Removed the last traces of support for 68k
+
+
+Objective Caml 3.01 (09 Mar 2001):
+----------------------------------
+
+New language features:
+- Variables are allowed in "or" patterns, e.g.
+     match l with [t] | [_;t] -> ... t ...
+- "include " to re-export all components of a
+  structure inside another structure.
+- Variance annotation on parameters of type declarations, e.g.
+    type (+'a,-'b,'c) t (covariant in 'a, contravariant in 'b, invariant in 'c)
+
+New ports:
+- Intel IA64/Itanium under Linux (including the native-code compiler).
+- Cygwin under MS Windows.  This port is an alternative to the earlier
+  Windows port of OCaml, which relied on MS compilers; the Cygwin
+  Windows port does not need MS Visual C++ nor MASM, runs faster
+  in bytecode, and has a better implementation of the Unix library,
+  but currently lacks threads and COM component support.
+
+Type-checking:
+- Relaxed "monomorphic restriction" on type constructors in a
+  mutually-recursive type definition, e.g. the following is again allowed
+    type u = C of int t | D of string t and 'a t = ...
+- Fixed name-capture bug in "include SIG" and "SIG with ..." constructs.
+- Improved implicit subtypes built by (... :> ty), closer to intuition.
+- Several bug fixes in type-checking of variants.
+- Typing of polymorphic variants is more restrictive:
+   do not allow conjunctive types inside the same pattern matching.
+   a type has either an upper bound, or all its tags are in the lower bound.
+  This may break some programs (this breaks lablgl-0.94).
+
+Both compilers:
+- Revised compilation of pattern matching.
+- Option -I + to search a subdirectory  of the standard
+  library directory (i.e. write "ocamlc -I +labltk" instead of
+  "ocamlc -I /usr/local/lib/ocaml/labltk").
+- Option -warn-error to turn warnings into errors.
+- Option -where to print the location of the standard library directory.
+- Assertions are now type-checked even if the -noassert option is given,
+  thus -noassert can no longe change the types of modules.
+
+Bytecode compiler and bytecode interpreter:
+- Print stack backtrace when a program aborts due to an uncaught exception
+  (requires compilation with -g and running with ocamlrun -b or
+   OCAMLRUNPARAM="b=1").
+
+Native-code compiler:
+- Better unboxing optimizations on the int32, int64, and nativeint types.
+- Tail recursion preserved for functions having more parameters than
+  available registers (but tail calls to other functions are still
+  turned off if parameters do not fit entirely in registers).
+- Fixed name-capture bug in function inlining.
+- Improved spilling/reloading strategy for conditionals.
+- IA32, Alpha: better alignment of branch targets.
+- Removed spurious dependency on the -lcurses library.
+
+Toplevel environment:
+- Revised handling of top-level value definitions, allows reclaimation
+  of definitions that are shadowed by later definitions with the same names.
+  (E.g. "let x = ;; let x = 1;;" allows  to be reclaimed.)
+- Revised the tracing facility so that for standard library functions,
+  only calls from user code are traced, not calls from the system.
+- Added a "*" prompt when within a comment.
+
+Runtime system:
+- Fixed portability issue on bcopy() vs memmove(), affecting Linux RedHat 7.0
+  in particular.
+- Structural comparisons (=, <>, <, <=, >, >=, compare) reimplemented
+  so as to avoid overflowing the C stack.
+- Input/output functions: arrange so that reads and writes on closed
+  in_channel or out_channel raise Sys_error immediately.
+
+Standard library:
+- Module Gc: changed some counters to float in order to avoid overflow;
+    added alarms
+- Module Hashtbl: added Hashtbl.replace.
+- Module Int64: added bits_of_float, float_of_bits (access to IEEE 754
+    representation of floats).
+- Module List:  List.partition now tail-rec;
+    improved memory behavior of List.stable_sort.
+- Module Nativeint: added Nativeint.size (number of bits in a nativeint).
+- Module Obj: fixed incorrect resizing of float arrays in Obj.resize.
+- Module Pervasives: added float constants "infinity", "neg_infinity", "nan";
+    added a "classify_float" function to test a float for NaN, infinity, etc.
+- Pervasives.input_value: fixed bug affecting shared custom objects.
+- Pervasives.output_value: fixed size bug affecting "int64" values.
+- Pervasives.int_of_string, {Int32,Int64,Nativeint}.of_string:
+  fixed bug causing bad digits to be accepted without error.
+- Module Random: added get_state and set_state to checkpoint the generator.
+- Module Sys: signal handling functions are passed the system-independent
+  signal number rather than the raw system signal number whenever possible.
+- Module Weak: added Weak.get_copy.
+
+Other libraries:
+- Bigarray: added Bigarray.reshape to take a view of the elements of a
+  bigarray with different dimensions or number of dimensions;
+  fixed bug causing "get" operations to be unavailable in custom
+  toplevels including Bigarray.
+- Dynlink: raise an error instead of crashing when the loaded module
+  refers to the not-yet-initialized module performing a dynlink operation.
+- Bytecode threads: added a thread-safe version of the Marshal module;
+    fixed a rare GC bug in the thread scheduler.
+- POSIX threads: fixed compilation problem with threads.cmxa.
+- Both thread libraries: better tail-recursion in Event.sync.
+- Num library: fixed bug in square roots (Nat.sqrt_nat, Big_int.sqrt_big_int).
+
+Tools:
+- ocamldep: fixed missing dependencies on labels of record patterns and
+    record construction operations
+
+Win32 port:
+- Unix.waitpid now implements the WNOHANG option.
+
+Mac OS ports:
+- Mac OS X public beta is supported.
+- Int64.format works on Mac OS 8/9.
+
+
+Objective Caml 3.00 (25 Apr 2000):
+----------------------------------
+
+Language:
+- OCaml/OLabl merger:
+  * Support for labeled and optional arguments for functions and classes.
+  * Support for variant types (sum types compared by structure).
+  See tutorial (chapter 2 of the OCaml manual) for more information.
+- Syntactic change: "?" in stream error handlers changed to "??".
+- Added exception renaming in structures (exception E = F).
+- (OCaml 2.99/OLabl users only) Label syntax changed to preserve
+  backward compatibility with 2.0x (labeled function application
+  is f ~lbl:arg instead of f lbl:arg).  A tool is provided to help
+  convert labelized programs to OCaml 3.00.
+
+Both compilers:
+- Option -labels to select commuting label mode (labels are mandatory,
+  but labeled arguments can be passed in a different order than in
+  the definition of the function; in default mode, labels may be omitted,
+  but argument reordering is only allowed for optional arguments).
+- Libraries (.cma and .cmxa files) now "remember" C libraries given
+  at library construction time, and add them back at link time.
+  Allows linking with e.g. just unix.cma instead of
+  unix.cma -custom -cclib -lunix
+- Revised printing of error messages, now use Format.fprintf; no visible
+  difference for users, but could facilitate internationalization later.
+- Fixed bug in unboxing of records containing only floats.
+- Fixed typing bug involving applicative functors as components of modules.
+- Better error message for inconsistencies between compiled interfaces.
+
+Bytecode compiler:
+- New "modular" format for bytecode executables; no visible differences
+  for users, but will facilitate further extensions later.
+- Fixed problems in signal handling.
+
+Native-code compiler:
+- Profiling support on x86 under FreeBSD
+- Open-coding and unboxing optimizations for the new integer types
+  int32, int64, nativeint, and for bigarrays.
+- Fixed instruction selection bug with "raise" appearing in arguments
+  of strict operators, e.g. "1 + raise E".
+- Better error message when linking incomplete/incorrectly ordered set
+  of .cmx files.
+- Optimized scanning of global roots during GC, can reduce total running
+  time by up to 8% on GC-intensive programs.
+
+Interactive toplevel:
+- Better printing of exceptions, including arguments, when possible.
+- Fixed rare GC bug occurring during interpretation of scripts.
+- Added consistency checks between interfaces and implementations
+  during #load.
+
+Run-time system:
+- Added support for "custom" heap blocks (heap blocks carrying
+  C functions for finalization, comparison, hashing, serialization
+  and deserialization).
+- Support for finalisation functions written in Caml.
+
+Standard library:
+- New modules Int32, Int64, Nativeint for 32-bit, 64-bit and
+  platform-native integers
+- Module Array: added Array.sort, Array.stable_sort.
+- Module Gc: added Gc.finalise to attach Caml finalisation functions to
+  arbitrary heap-allocated data.
+- Module Hashtbl: do not bomb when resizing very large table.
+- Module Lazy: raise Lazy.Undefined when a lazy evaluation needs itself.
+- Module List: added List.sort, List.stable_sort; fixed bug in List.rev_map2.
+- Module Map: added mapi (iteration with key and data).
+- Module Set: added iterators for_all, exists, filter, partition.
+- Module Sort: still here but deprecated in favor of new sorting functions
+  in Array and List.
+- Module Stack: added Stack.top
+- Module String: fixed boundary condition on String.rindex_from
+- Added labels on function arguments where appropriate.
+
+New libraries and tools:
+- ocamlbrowser: graphical browser for OCaml sources and compiled interfaces,
+  supports cross-referencing, editing, running the toplevel.
+- LablTK: GUI toolkit based on TK, using labeled and optional arguments,
+  easier to use than CamlTK.
+- Bigarray: large, multi-dimensional numerical arrays, facilitate
+  interfacing with C/Fortran numerical code, efficient support for
+  advanced array operations such as slicing and memory-mapping of files.
+
+Other libraries:
+- Bytecode threads: timer-based preemption was broken, works back again;
+  fixed bug in Pervasives.input_line; exported Thread.yield.
+- System threads: several GC / reentrancy bugs fixed in buffered I/O
+  and Unix I/O; revised Thread.join implementation for strict POSIX
+  conformance; exported Thread.yield.
+- Graphics: added support for double buffering; added, current_x, current_y,
+  rmoveto, rlineto, and draw_rect.
+- Num: fixed bug in Num.float_of_num.
+- Str: worked around potential symbol conflicts with C standard library.
+- Dbm: fixed bug with Dbm.iter on empty database.
+
+New or updated ports:
+- Alpha/Digital Unix: lifted 256M limitation on total memory space
+  induced by -taso
+- Port to AIX 4.3 on PowerPC
+- Port to HPUX 10 on HPPA
+- Deprecated 680x0 / SunOS port
+
+Macintosh port:
+- Implemented the Unix and Thread libraries.
+- The toplevel application does not work on 68k Macintoshes; maybe
+  later if there's a demand.
+- Added a new tool, ocamlmkappli, to build an application from a
+  program written in O'Caml.
+
+
+Objective Caml 2.04 (26 Nov 1999):
+----------------------------------
+
+- C interface: corrected inconsistent change in the CAMLparam* macros.
+- Fixed internal error in ocamlc -g.
+- Fixed type-checking of "S with ...", where S is a module type name
+  abbreviating another module type name.
+- ocamldep: fixed stdout/stderr mismatch after failing on one file.
+- Random.self_init more random.
+- Windows port:
+  - Toplevel application: fixed spurious crash on exit.
+  - Native-code compiler: fixed bug in assembling certain
+    floating-point constants (masm doesn't grok 2e5, wants 2.0e5).
+
+Objective Caml 2.03 (19 Nov 1999):
+----------------------------------
+
+New ports:
+- Ported to BeOS / Intel x86 (bytecode and native-code).
+- BSD / Intel x86 port now supports both a.out and ELF binary formats.
+- Added support for {Net,Open}BSD / Alpha.
+- Revamped Rhapsody port, now works on MacOS X server.
+
+Syntax:
+- Warning for "(*)" and "*)" outside comment.
+- Removed "#line LINENO", too ambiguous with a method invocation;
+  the equivalent "# LINENO" is still supported.
+
+Typing:
+- When an incomplete pattern-matching is detected, report also a
+  value or value template that is not covered by the cases of
+  the pattern-matching.
+- Several bugs in class type matching and in type error reporting fixed.
+- Added an option -rectypes to support general recursive types,
+  not just those involving object types.
+
+Bytecode compiler:
+- Minor cleanups in the bytecode emitter.
+- Do not remove "let x = y" bindings in -g mode; makes it easier to
+  debug the code.
+
+Native-code compiler:
+- Fixed bug in grouping of allocations performed in the same basic block.
+- Fixed bug in constant propagation involving expressions containing
+  side-effects.
+- Fixed incorrect code generation for "for" loops whose upper bound is
+  a reference assigned inside the loop.
+- MIPS code generator: work around a bug in the IRIX 6 assembler.
+
+Toplevel:
+- Fixed incorrect redirection of standard formatter to stderr
+  while executing toplevel scripts.
+
+Standard library:
+- Added List.rev_map, List.rev_map2.
+- Documentation of List functions now says which functions are
+  tail-rec, and how much stack space is needed for non-tailrec functions.
+- Wrong type for Printf.bprintf fixed.
+- Fixed weird behavior of Printf.sprintf and Printf.bprintf in case of
+  partial applications.
+- Added Random.self_init, which initializes the PRNG from the system date.
+- Sort.array: serious bugs fixed.
+- Stream.count: fixed incorrect behavior with ocamlopt.
+
+Run-time system and external interface:
+- Fixed weird behavior of signal handlers w.r.t. signal masks and exceptions
+  raised from the signal handler.
+- Fixed bug in the callback*_exn() functions.
+
+Debugger:
+- Fixed wrong printing of float record fields and elements of float arrays.
+- Supports identifiers starting with '_'.
+
+Profiler:
+- Handles .mli files, so ocamlcp can be used to replace ocamlc (e.g. in a
+  makefile).
+- Now works on programs that use stream expressions and stream parsers.
+
+Other libraries:
+- Graphics: under X11, treat all mouse buttons equally; fixed problem
+  with current font reverting to the default font when the graphics
+  window is resized.
+- Str: fixed reentrancy bugs in Str.replace and Str.full_split.
+- Bytecode threads: set standard I/O descriptors to non-blocking mode.
+- OS threads: revised implementation of Thread.wait_signal.
+- All threads: added Event.wrap_abort, Event.choose [].
+- Unix.localtime, Unix.gmtime: check for errors.
+- Unix.create_process: now supports arbitrary redirections of std descriptors.
+- Added Unix.open_process_full.
+- Implemented Unix.chmod under Windows.
+- Big_int.square_big_int now gives the proper sign to its result.
+
+Others:
+- ocamldep: don't stop at first error, skip to next file.
+- Emacs mode: updated with Garrigue and Zimmerman's snapshot of 1999/10/18.
+- configure script: added -prefix option.
+- Windows toplevel application: fixed problem with graphics library
+  not loading properly.
+
+
+Objective Caml 2.02 (04 Mar 1999):
+----------------------------------
+
+* Type system:
+  - Check that all components of a signature have unique names.
+  - Fixed bug in signature matching involving a type component and
+    a module component, both sharing an abstract type.
+  - Bug involving recursive classes constrained by a class type fixed.
+  - Fixed bugs in printing class types and in printing unification errors.
+
+* Compilation:
+  - Changed compilation scheme for "{r with lbl = e}" when r has many fields
+    so as to avoid code size explosion.
+
+* Native-code compiler:
+  - Better constant propagation in boolean expressions and in conditionals.
+  - Removal of unused arguments during function inlining.
+  - Eliminated redundant tagging/untagging in bit shifts.
+  - Static allocation of closures for functions without free variables,
+    reduces the size of initialization code.
+  - Revised compilation scheme for definitions at top level of compilation
+    units, so that top level functions have no free variables.
+  - Coalesced multiple allocations of heap blocks inside one expression
+    (e.g. x :: y :: z allocates the two conses in one step).
+  - Ix86: better handling of large integer constants in instruction selection.
+  - MIPS: fixed wrong asm generated for String.length "literal".
+
+* Standard library:
+  - Added the "ignore" primitive function, which just throws away its
+    argument and returns "()".  It allows to write
+    "ignore(f x); y" if "f x" doesn't have type unit and you don't
+    want the warning caused by "f x; y".
+  - Added the "Buffer" module (extensible string buffers).
+  - Module Format: added formatting to buffers and to strings.
+  - Added "mem" functions (membership test) to Hashtbl and Map.
+  - Module List: added find, filter, partition.
+    Renamed remove and removeq to remove_assoc and remove_assq.
+  - Module Marshal: fixed bug in marshaling functions when passed functional
+    values defined by mutual recursion with other functions.
+  - Module Printf: added Printf.bprintf (print to extensible buffer);
+    added %i format as synonymous for %d (as per the docs).
+  - Module Sort: added Sort.array (Quicksort).
+
+* Runtime system:
+  - New callback functions for callbacks with arbitrary many arguments
+    and for catching Caml exceptions escaping from a callback.
+
+* The ocamldep dependency generator: now performs full parsing of the
+    sources, taking into account the scope of module bindings.
+
+* The ocamlyacc parser generator: fixed sentinel error causing wrong
+    tables to be generated in some cases.
+
+* The str library:
+  - Added split_delim, full_split as variants of split that control
+    more precisely what happens to delimiters.
+  - Added replace_matched for separate matching and replacement operations.
+
+* The graphics library:
+  - Bypass color lookup for 16 bpp and 32 bpp direct-color displays.
+  - Larger color cache.
+
+* The thread library:
+  - Bytecode threads: more clever use of non-blocking I/O, makes I/O
+    operations faster.
+  - POSIX threads: gcc-ism removed, should now compile on any ANSI C compiler.
+  - Both: avoid memory leak in the Event module when a communication
+    offer is never selected.
+
+* The Unix library:
+  - Fixed inversion of ctime and mtime in Unix.stat, Unix.fstat, Unix.lstat.
+  - Unix.establish_connection: properly reclaim socket if connect fails.
+
+* The DBM library: no longer crashes when calling Dbm.close twice.
+
+* Emacs mode:
+  - Updated with Garrigue and Zimmerman's latest version.
+  - Now include an "ocamltags" script for using etags on OCaml sources.
+
+* Win32 port:
+  - Fixed end-of-line bug in ocamlcp causing problems with generated sources.
+
+
+Objective Caml 2.01 (09 Dec 1998):
+----------------------------------
+
+* Typing:
+  - Added warning for expressions of the form "a; b" where a does not have
+    type "unit"; catches silly mistake such as
+    "record.lbl = newval; ..." instead of "record.lbl <- newval; ...".
+  - Typing bug in "let module" fixed.
+
+* Compilation:
+  - Fixed bug in compilation of recursive and mutually recursive classes.
+  - Option -w to turn specific warnings on/off.
+  - Option -cc to choose the C compiler used with ocamlc -custom and ocamlopt.
+
+* Bytecode compiler and bytecode interpreter:
+  - Intel x86: removed asm declaration causing "fixed or forbidden register
+    spilled" error with egcs and gcc 2.8 (but not with gcc 2.7, go figure).
+  - Revised handling of debugging information, allows faster linking with -g.
+
+* Native-code compiler:
+  - Fixed bugs in integer constant propagation.
+  - Out-of-bound accesses in array and strings now raise an Invalid_argument
+    exception (like the bytecode system) instead of stopping the program.
+  - Corrected scheduling of bound checks.
+  - Port to the StrongARM under Linux (e.g. Corel Netwinder).
+  - I386: fixed bug in profiled code (ocamlopt -p).
+  - Mips: switched to -n32 model under IRIX; dropped the Ultrix port.
+  - Sparc: simplified the addressing modes, allows for better scheduling.
+  - Fixed calling convention bug for Pervasives.modf.
+
+* Toplevel:
+  - #trace works again.
+  - ocamlmktop: use matching ocamlc, not any ocamlc from the search path.
+
+* Memory management:
+  - Fixed bug in heap expansion that could cause the GC to loop.
+
+* C interface:
+  - New macros CAMLparam... and CAMLlocal... to simplify the handling
+    of local roots in C code.
+  - Simplified procedure for allocating and filling Caml blocks from C.
+  - Declaration of string_length in .
+
+* Standard library:
+  - Module Format: added {get,set}_all_formatter_output_functions,
+    formatter_of_out_channel, and the control sequence @ in printf.
+  - Module List: added mem_assoc, mem_assq, remove, removeq.
+  - Module Pervasives: added float_of_int (synonymous for float),
+    int_of_float (truncate), int_of_char (Char.code), char_of_int (Char.chr),
+    bool_of_string.
+  - Module String: added contains, contains_from, rcontains_from.
+
+* Unix library:
+  - Unix.lockf: added F_RLOCK, F_TRLOCK; use POSIX locks whenever available.
+  - Unix.tc{get,set}attr: added non-standard speeds 57600, 115200, 230400.
+  - Unix.chroot: added.
+
+* Threads:
+  - Bytecode threads: improved speed of I/O scheduling.
+  - Native threads: fixed a bug involving signals and exceptions
+    generated from C.
+
+* The "str" library:
+  - Added Str.string_partial_match.
+  - Bumped size of internal stack.
+
+* ocamlyacc: emit correct '# lineno' directive for prelude part of .mly file.
+
+* Emacs editing mode: updated with Jacques Garrigue's newest code.
+
+* Windows port:
+  - Added support for the "-cclib -lfoo" option (instead of
+     -cclib /full/path/libfoo.lib as before).
+  - Threads: fixed a bug at initialization time.
+
+* Macintosh port: source code for Macintosh application merged in.
+
+
+Objective Caml 2.00 (19 Aug 1998):
+----------------------------------
+
+* Language:
+  - New class language.  See http://caml.inria.fr/ocaml/refman/
+    for a tutorial (chapter 2) and for the reference manual (section 4.9).
+  - Local module definitions "let module X =  in ".
+  - Record copying with update "{r with lbl1 = expr1; ...}".
+  - Array patterns "[|pat1; ...;patN|]" in pattern-matchings.
+  - New reserved keywords: "object", "initializer".
+  - No longer reserved: "closed", "protected".
+
+* Bytecode compiler:
+  - Use the same compact memory representations for float arrays, float
+    records and recursive closures as the native-code compiler.
+  - More type-dependent optimizations.
+  - Added the -use_runtime and -make_runtime flags to build separately
+    and reuse afterwards custom runtime systems
+    (inspired by Fabrice Le Fessant's patch).
+
+* Native-code compiler:
+  - Cross-module constant propagation of integer constants.
+  - More type-dependent optimizations.
+  - More compact code generated for "let rec" over data structures.
+  - Better code generated for "for" loops (test at bottom of code).
+  - More aggressive scheduling of stores.
+  - Added -p option for time profiling with gprof
+    (fully supported on Intel x86/Linux and Alpha/Digital Unix only)
+    (inspired by Aleksey Nogin's patch).
+  - A case of bad spilling with high register pressure fixed.
+  - Fixed GC bug when GC called from C without active Caml code.
+  - Alpha: $gp handling revised to follow Alpha's standard conventions,
+    allow running "atom" and "pixie" on ocamlopt-generated binaries.
+  - Intel x86: use movzbl and movsbl systematically to load 8-bit and 16-bit
+    quantities, no more hacks with partial registers (better for the
+    Pentium Pro, worse for the Pentium).
+  - PowerPC: more aggressive scheduling of return address reloading.
+  - Sparc: scheduling bug related to register pairs fixed.
+
+* Runtime system:
+  - Better printing of uncaught exceptions (print a fully qualified
+    name whenever possible).
+
+* New ports:
+  - Cray T3E (bytecode only) (in collaboration with CEA).
+  - PowerMac under Rhapsody.
+  - SparcStations under Linux.
+
+* Standard library:
+  - Added set_binary_mode_in and set_binary_mode_out in Pervasives
+    to toggle open channels between text and binary modes.
+  - output_value and input_value check that the given channel is in
+    binary mode.
+  - input_value no longer fails on very large marshalled data (> 16 Mbytes).
+  - Module Arg: added option Rest.
+  - Module Filename: temp_file no longer loops if temp dir doesn't exist.
+  - Module List: added rev_append (tail-rec alternative to @).
+  - Module Set: tell the truth about "elements" returning a sorted list;
+    added min_elt, max_elt, singleton.
+  - Module Sys: added Sys.time for simple measuring of CPU time.
+
+* ocamllex:
+  - Check for overflow when generating the tables for the automaton.
+  - Error messages in generated .ml file now point to .mll source.
+  - Added "let  = " to name regular expressions
+    (inspired by Christian Lindig's patch).
+
+* ocamlyacc:
+  - Better error recovery in presence of EOF tokens.
+  - Error messages in generated .ml file now point to .mly source.
+  - Generated .ml file now type-safe even without the generated .mli file.
+
+* The Unix library:
+  - Use float instead of int to represent Unix times (number of seconds
+    from the epoch).  This fixes a year 2005 problem on 32-bit platforms.
+    Functions affected: stat, lstat, fstat, time, gmtime, localtime,
+    mktime, utimes.
+  - Added putenv.
+  - Better handling of "unknown" error codes (EUNKNOWNERR).
+  - Fixed endianness bug in getservbyport.
+  - win32unix (the Win32 implementation of the Unix library) now has
+    the same interface as the unix implementation, this allows exchange
+    of compiled .cmo and .cmi files between Unix and Win32.
+
+* The thread libraries:
+  - Bytecode threads: bug with escaping exceptions fixed.
+  - System threads (POSIX, Win32): malloc/free bug fixed; signal bug fixed.
+  - Both: added Thread.wait_signal to wait synchronously for signals.
+
+* The graph library: bigger color cache.
+
+* The str library: added Str.quote, Str.regexp_string,
+  Str.regexp_string_case_fold.
+
+* Emacs mode:
+  - Fixed bug with paragraph fill.
+  - Fixed bug with next-error under Emacs 20.
+
+
+Objective Caml 1.07 (11 Dec 1997):
+----------------------------------
+
+* Native-code compiler:
+  - Revised interface between generated code and GC, fixes serious GC
+    problems with signals and native threads.
+  - Added "-thread" option for compatibility with ocamlc.
+
+* Debugger: correctly print instance variables of objects.
+
+* Run-time system: ported to OpenBSD.
+
+* Standard library: fixed wrong interface for Marshal.to_buffer and
+  Obj.unmarshal.
+
+* Num library: added Intel x86 optimized asm code (courtesy of
+  Bernard Serpette).
+
+* Thread libraries:
+  - Native threads: fixed GC bugs and installation procedure.
+  - Bytecode threads: fixed problem with "Marshal" module.
+  - Both: added Event.always.
+
+* MS Windows port: better handling of long command lines in Sys.command
+
+Objective Caml 1.06 (18 Nov 1997):
+----------------------------------
+
+* Language:
+  - Added two new keywords: "assert" (check assertion) and "lazy"
+    (delay evaluation).
+  - Allow identifiers to start with "_" (such identifiers are treated
+    as lowercase idents).
+
+* Objects:
+  - Added "protected" methods (visible only from subclasses, can be hidden
+    in class type declared in module signature).
+  - Objects can be compared using generic comparison functions.
+  - Fixed compilation of partial application of object constructors.
+
+* Type system:
+  - Occur-check now more strict (all recursions must traverse an object).
+  - A few bugs fixed.
+
+* Run-time system:
+  - A heap compactor was implemented, so long-running programs can now
+    fight fragmentation.
+  - The meaning of the "space_overhead" parameter has changed.
+  - The macros Push_roots and Pop_roots are superseded by Begin_roots* and
+    End_roots.
+  - Bytecode executable includes list of primitives used, avoids crashes
+    on version mismatch.
+  - Reduced startup overhead for marshalling, much faster marshalling of
+    small objects.
+  - New exception Stack_overflow distinct from Out_of_memory.
+  - Maximum stack size configurable.
+  - I/O revised for compatibility with compactor and with native threads.
+  - All C code ANSIfied (new-style function declarations, etc).
+  - Threaded code work on all 64-bit processors, not just Alpha/Digital Unix.
+  - Better printing of uncaught exceptions.
+
+* Both compilers:
+  - Parsing: more detailed reporting of syntax errors (e.g. shows
+    unmatched opening parenthesis on missing closing parenthesis).
+  - Check consistency between interfaces (.cmi).
+  - Revised rules for determining dependencies between modules.
+  - Options "-verbose" for printing calls to C compiler, "-noassert"
+    for turning assertion checks off.
+
+* Native-code compiler:
+  - Machine-dependent parts rewritten using inheritance instead of
+    parameterized modules.
+  - GC bug in value let rec fixed.
+  - Port to Linux/Alpha.
+  - Sparc: cleaned up use of %g registers, now compatible with Solaris threads.
+
+* Top-level interactive system:
+  - Can execute Caml script files given on command line.
+  - Reads commands from ./.ocamlinit on startup.
+  - Now thread-compatible.
+
+* Standard library:
+  - New library module: Lazy (delayed computations).
+  - New library module: Marshal.  Allows marshalling to strings and
+    transmission of closures between identical programs (SPMD parallelism).
+  - Filename: "is_absolute" is superseded by "is_implicit" and "is_relative".
+    To adapt old programs, change "is_absolute x" to "not (is_implicit x)"
+    (but the new "is_relative" is NOT the opposite of the old "is_absolute").
+  - Array, Hashtbl, List, Map, Queue, Set, Stack, Stream:
+    the "iter" functions now take as argument a unit-returning function.
+  - Format: added "printf" interface to the formatter (see the documentation).
+    Revised behaviour of simple boxes: no more than one new line is output
+    when consecutive break hints should lead to multiple line breaks.
+  - Stream: revised implementation, renamed Parse_failure to Failure and
+    Parse_error to Error (don't you love gratuitous changes?).
+  - String: added index, rindex, index_from, rindex_from.
+  - Array: added mapi, iteri, fold_left, fold_right, init.
+  - Added Map.map, Set.subset, Printexc.to_string.
+
+* ocamllex: lexers generated by ocamllex can now handle all characters,
+  including '\000'.
+
+* ocamlyacc: fixed bug with function closures returned by parser rules.
+
+* Debugger:
+  - Revised generation of events.
+  - Break on function entrance.
+  - New commands start/previous.
+  - The command loadprinter now try to recursively load required
+    modules.
+  - Numerous small fixes.
+
+* External libraries:
+  - systhreads: can now use POSIX threads; POSIX and Win32 threads are
+    now supported by the native-code compiler.
+  - dbm and graph: work in native code.
+  - num: fixed bug in Nat.nat_of_string.
+  - str: fixed deallocation bug with case folding.
+  - win32unix: use Win32 handles instead of (buggy) VC++ emulation of Unix
+    file handles; added gettimeofday.
+
+* Emacs editing mode and debugger interface updated to July '97 version.
+
+Objective Caml 1.05 (21 Mar 1997):
+----------------------------------
+
+* Typing: fixed several bugs causing spurious type errors.
+
+* Native-code compiler: fixed instruction selection bug causing GC to
+see ill-formed pointers; fixed callbacks to support invocation from a
+main program in C.
+
+* Standard library: fixed String.lowercase; Weak now resists integers.
+
+* Toplevel: multiple phrases without intermediate ";;" now really supported;
+fixed value printing problems where the wrong printer was selected.
+
+* Debugger: fixed printing problem with local references; revised
+handling of checkpoints; various other small fixes.
+
+* Macintosh port: fixed signed division problem in bytecomp/emitcode.ml
+
+Objective Caml 1.04 (11 Mar 1997):
+----------------------------------
+
+* Replay debugger ported from Caml Light; added debugger support in
+  compiler (option -g) and runtime system. Debugger is alpha-quality
+  and needs testing.
+
+* Parsing:
+  - Support for "# linenum" directives.
+  - At toplevel, allow several phrases without intermediate ";;".
+
+* Typing:
+  - Allow constraints on datatype parameters, e.g.
+    type 'a foo = ... constraint 'a = 'b * 'c.
+  - Fixed bug in signature matching in presence of free type variables '_a.
+  - Extensive cleanup of internals of type inference.
+
+* Native-code compilation:
+  - Inlining of small functions at point of call (fairly conservative).
+  - MIPS code generator ported to SGI IRIX 6.
+  - Better code generated for large integer constants.
+  - Check for urgent GC when allocating large objects in major heap.
+  - PowerPC port: better scheduling, reduced TOC consumption.
+  - HPPA port: handle long conditional branches gracefully,
+    several span-dependent bugs fixed.
+
+* Standard library:
+  - More floating-point functions (all ANSI C float functions now available).
+  - Hashtbl: added functorial interface (allow providing own equality
+    and hash functions); rehash when resizing, avoid memory leak on
+    Hashtbl.remove.
+  - Added Char.uppercase, Char.lowercase, String.uppercase, String.lowercase,
+    String.capitalize, String.uncapitalize.
+  - New module Weak for manipulating weak pointers.
+  - New module Callback for registering closures and exceptions to be
+    used from C.
+
+* Foreign interface:
+  - Better support for callbacks (C calling Caml), exception raising
+    from C, and main() in C. Added function to remove a global root.
+  - Option -output-obj to package Caml code as a C library.
+
+* Thread library: fixed bug in timed_read and timed_write operations;
+  Lexing.from_function and Lexing.from_channel now reentrant.
+
+* Unix interface: renamed EACCESS to EACCES (the POSIX name); added setsid;
+  fixed bug in inet_addr_of_string for 64-bit platforms.
+
+* Ocamlyacc: default error function no longer prevents error recovery.
+
+* Ocamllex: fixed reentrancy problem w.r.t. exceptions during refill;
+  fixed output problem (\r\r\n) under Win32.
+
+* Macintosh port:
+  - The makefiles are provided for compiling and installing O'Caml on
+    a Macintosh with MPW 3.4.1.
+  - An application with the toplevel in a window is forthcoming.
+
+* Windows NT/95 port: updated toplevel GUI to that of Caml Light 0.73.
+
+* Emacs editing mode and debugger interface included in distribution.
+
+
+Objective Caml 1.03 (29 Oct 1996):
+----------------------------------
+
+* Typing:
+  - bug with type names escaping their scope via unification with
+    non-generalized type variables '_a completely fixed;
+  - fixed bug in occur check : it was too restrictive;
+  - fixed bug of coercion operators;
+  - check that no two types of the same name are generated in a module
+    (there was no check for classes);
+  - "#install_printer" works again;
+  - fixed bug in printing of subtyping errors;
+  - in class interfaces, construct "method m" (without type) change
+    the status of method m from abstract to concrete;
+  - in a recursive definition of class interfaces, a class can now
+    inherit from a previous class;
+  - typing of a method make use of an eventual previously given type
+    of this method, yielding clearer type errors.
+
+* Compilation (ocamlc and ocamlopt):
+  - fixed bug in compilation of classes.
+
+* Native-code compilation:
+  - optimization of functions taking tuples of arguments;
+  - code emitter for the Motorola 680x0 processors (retrocomputing week);
+  - Alpha/OSF1: generate frame descriptors, avoids crashes when e.g.
+    exp() or log() cause a domain error; fixed bug with
+    String.length "literal";
+  - Sparc, Mips, HPPA: removed marking of scanned stack frames
+    (benefits do not outweight cost).
+
+* Standard library:
+  - Arg.parse now prints documentation for command-line options;
+  - I/O buffers (types in_channel and out_channel) now heap-allocated,
+    avoids crashing when closing a channel several times;
+  - Overflow bug in compare() fixed;
+  - GC bug in raising Sys_error from I/O functions fixed;
+  - Parsing.symbol_start works even for epsilon productions.
+
+* Foreign interface: main() in C now working, fixed bug in library
+  order at link time.
+
+* Thread library: guard against calling thread functions before Thread.create.
+
+* Unix library: fixed getsockopt, setsockopt, open_process_{in,out}.
+
+* Perl-free, cpp-free, cholesterol-free installation procedure.
+
+
+Objective Caml 1.02 (27 Sep 1996):
+----------------------------------
+
+* Typing:
+  - fixed bug with type names escaping their scope via unification
+    with non-generalized type variables '_a;
+  - keep #class abbreviations longer;
+  - faster checking of well-formed abbreviation definitions;
+  - stricter checking of "with" constraints over signatures (arity
+    mismatch, overriding of an already manifest type).
+
+* Compilation (ocamlc and ocamlopt):
+  - fixed bug in compilation of recursive classes;
+  - [|...|] and let...rec... allowed inside definitions of recursive
+    data structures;
+
+* Bytecode compilation: fixed overflow in linker for programs with
+  more than 65535 globals and constants.
+
+* Native-code compilation:
+  - ocamlopt ported to HPPA under HP/UX, Intel x86 under Solaris 2,
+    PowerMacintosh under MkLinux;
+  - fixed two bugs related to floating-point arrays (one with "t array"
+    where t is an abstract type implemented as float, one with
+    comparison between two float arrays on 32 bit platforms);
+  - fixed reloading/spilling problem causing non-termination of
+    register allocation;
+  - fixed bugs in handling of () causing loss of tail recursion;
+  - fixed reloading bug in indirect calls.
+
+* Windows NT/95 port:
+  - complete port of the threads library (Pascal Cuoq);
+  - partial port of the Unix library (Pascal Cuoq);
+  - expansion of *, ? and @ on the command line.
+
+* Standard library:
+  - bug in in List.exists2 fixed;
+  - bug in "Random.int n" for very large n on 64-bit machines fixed;
+  - module Format: added a "general purpose" type of box (open_box);
+    can output on several formatters at the same time.
+
+* The "threads" library:
+  - implementation on top of native threads available for Win32 and
+    POSIX 1003.1c;
+  - added -thread option to select a thread-safe version of the
+    standard library, the ThreadIO module is no longer needed.
+
+* The "graph" library: avoid invalid pixmaps when doing
+  open_graph/close_graph several times.
+
+* The "dynlink" library: support for "private" (no re-export) dynamic loading.
+
+* ocamlyacc: skip '...' character literals correctly.
+
+* C interface: C code linked with O'Caml code can provide its own main()
+  and call caml_main() later.
+
+
+Objective Caml 1.01 (12 Jun 1996):
+----------------------------------
+
+* Typing: better report of type incompatibilities;
+  non-generalizable type variables in a struct...end no longer flagged
+  immediately as an error;
+  name clashes during "open" avoided.
+
+* Fixed bug in output_value where identical data structures
+  could have different external representations; this bug caused wrong
+  "inconsistent assumptions" errors when checking compatibility of
+  interfaces at link-time.
+
+* Standard library: fixed bug in Array.blit on overlapping array sections
+
+* Unmarshaling from strings now working.
+
+* ocamlc, ocamlopt: new flags -intf and -impl to force compilation as
+  an implementation/an interface, regardless of file extension;
+  overflow bug on wide-range integer pattern-matchings fixed.
+
+* ocamlc: fixed bytecode generation bug causing problems with compilation
+  units defining more than 256 values
+
+* ocamlopt, all platforms:
+  fixed GC bug in "let rec" over data structures;
+  link startup file first, fixes "undefined symbol" errors with some
+  libraries.
+
+* ocamlopt, Intel x86:
+  more efficient calling sequence for calling C functions;
+  floating-point wars, chapter 5: don't use float stack for holding
+  float pseudo-registers, stack-allocating them is just as efficient.
+
+* ocamlopt, Alpha and Intel x86: more compact calling sequence for garbage
+  collection.
+
+* ocamllex: generated automata no longer use callbacks for refilling
+  the input buffer (works better with threads); character literals
+  correctly skipped inside actions.
+
+* ocamldep: "-I" directories now searched in the right order
+
+* Thread library: incompatibilities with callbacks, signals, and
+  dynamic linking removed; scheduling bug with Thread.wait fixed.
+
+* New "dbm" library, interfaces with NDBM.
+
+* Object-oriented extensions:
+    instance variables can now be omitted in class types;
+    some error messages have been made clearer;
+    several bugs fixes.
+
+Objective Caml 1.00 (9 May 1996):
+---------------------------------
+
+* Merge of Jérôme Vouillon and Didier Rémy's object-oriented
+extensions.
+
+* All libraries: all "new" functions renamed to "create" because "new"
+is now a reserved keyword.
+
+* Compilation of "or" patterns (pat1 | pat2) completely revised to
+avoid code size explosion.
+
+* Compiler support for preprocessing source files (-pp flag).
+
+* Library construction: flag -linkall to force linking of all units in
+a library.
+
+* Native-code compiler: port to the Sparc under NetBSD.
+
+* Toplevel: fixed bug when tracing several times the same function
+under different names.
+
+* New format for marshaling arbitrary data structures, allows
+marshaling to/from strings.
+
+* Standard library: new module Genlex (configurable lexer for streams)
+
+* Thread library: much better support for I/O and blocking system calls.
+
+* Graphics library: faster reclaimation of unused pixmaps.
+
+* Unix library: new functions {set,clear}_nonblock, {set,clear}_close_on_exec,
+{set,get}itimer, inet_addr_any, {get,set}sockopt.
+
+* Dynlink library: added support for linking libraries (.cma files).
+
+Caml Special Light 1.15 (15 Mar 1996):
+--------------------------------------
+
+* Caml Special Light now runs under Windows NT and 95. Many thanks to
+Kevin Gallo (Microsoft Research) who contributed his initial port.
+
+* csllex now generates tables for a table-driven automaton.
+The resulting lexers are smaller and run faster.
+
+* Completely automatic configuration script.
+
+* Typing: more stringent checking of module type definitions against
+manifest module type specifications.
+
+* Toplevel: recursive definitions of values now working.
+
+* Native-code compiler, all platforms:
+        toplevel "let"s with refutable patterns now working;
+        fixed bug in assignment to float record fields;
+        direct support for floating-point negation and absolute value.
+
+* Native-code compiler, x86: fixed bug with tail calls (with more than
+4 arguments) from a function with a one-word stack frame.
+
+* Native-code compiler, Sparc: problem with -compact fixed.
+
+* Thread library: support for non-blocking writes; scheduler revised.
+
+* Unix library: bug in gethostbyaddr fixed; bounds checking for read,
+write, etc.
+
+Caml Special Light 1.14 (8 Feb 1996):
+-------------------------------------
+
+* cslopt ported to the PowerPC/RS6000 architecture. Better support for
+AIX in the bytecode system as well.
+
+* cslopt, all platforms: fixed bug in live range splitting around catch/exit.
+
+* cslopt for the Intel (floating-point wars, chapter 4):
+implemented Ershov's algorithm to minimize floating-point stack usage;
+out-of-order pops fixed.
+
+* Several bug fixes in callbacks and signals.
+
+Caml Special Light 1.13 (4 Jan 1996):
+-------------------------------------
+
+* Pattern-matching compilation revised to factor out accesses inside
+matched structures.
+
+* Callbacks and signals now supported in cslopt.
+Signals are only detected at allocation points, though.
+Added callback functions with 2 and 3 arguments.
+
+* More explicit error messages when a native-code program aborts due
+to array or string bound violations.
+
+* In patterns, "C _" allowed even if the constructor C has several arguments.
+
+* && and || allowed as alternate syntax for & and or.
+
+* cslopt for the Intel: code generation for floating-point
+operations entirely redone for the third time (a pox on whomever at
+Intel decided to organize the floating-point registers as a stack).
+
+* cslopt for the Sparc: don't use Sparc V8 smul and sdiv instructions,
+emulation on V7 processors is abysmal.
+
+Caml Special Light 1.12 (30 Nov 1995):
+--------------------------------------
+
+* Fixed an embarrassing bug with references to floats.
+
+Caml Special Light 1.11 (29 Nov 1995):
+--------------------------------------
+
+* Streams and stream parsers a la Caml Light are back (thanks to
+Daniel de Rauglaudre).
+
+* User-level concurrent threads, with low-level shared memory primitives
+(locks and conditions) as well as channel-based communication primitives
+with first-class synchronous events, in the style of Reppy's CML.
+
+* The native-code compiler has been ported to the HP PA-RISC processor
+running under NextStep (sorry, no HPUX, its linker keeps dumping
+core on me).
+
+* References not captured in a function are optimized into variables.
+
+* Fixed several bugs related to exceptions.
+
+* Floats behave a little more as specified in the IEEE standard
+(believe it or not, but x < y is not the negation of x >= y).
+
+* Lower memory consumption for the native-code compiler.
+
+Caml Special Light 1.10 (07 Nov 1995):
+--------------------------------------
+
+* Many bug fixes (too many to list here).
+
+* Module language: introduction of a "with module" notation over
+signatures for concise sharing of all type components of a signature;
+better support for concrete types in signatures.
+
+* Native-code compiler: the Intel 386 version has been ported to
+NextStep and FreeBSD, and generates better code (especially for
+floats)
+
+* Tools and libraries: the Caml Light profiler and library for
+arbitrary-precision arithmetic have been ported (thanks to John
+Malecki and Victor Manuel Gulias Fernandez); better docs for the Unix
+and regexp libraries.
+
+Caml Special Light 1.07 (20 Sep 1995):
+--------------------------------------
+
+* Syntax: optional ;; allowed in compilation units and structures
+(back by popular demand)
+
+* cslopt:
+generic handling of float arrays fixed
+direct function application when the function expr is not a path fixed
+compilation of "let rec" over values fixed
+multiple definitions of a value name in a module correctly handled
+no calls to ranlib in Solaris
+
+* csltop: #trace now working
+
+* Standard library: added List.memq; documentation of Array fixed.
+
+Caml Special Light 1.06 (12 Sep 1995):
+--------------------------------------
+
+* First public release.
diff --git a/HACKING.adoc b/HACKING.adoc
new file mode 100644
index 00000000..44557b02
--- /dev/null
+++ b/HACKING.adoc
@@ -0,0 +1,260 @@
+= Hacking the compiler 🐫
+
+This document is a work-in-progress attempt to provide useful
+information for people willing to inspect or modify the compiler
+distribution's codebase. Feel free to improve it by sending change
+proposals for it.
+
+If you already have a patch that you would like to contribute to the
+official distribution, please see link:CONTRIBUTING.md[].
+
+=== Your first compiler modification
+
+1. Create a new git branch to store your changes.
++
+----
+git checkout -b my-modification
+----
+
+2. Consult link:INSTALL.adoc[] for build instructions. Here is the gist of it:
++
+----
+./configure
+make world.opt
+----
+
+3. Try the newly built compiler binaries `ocamlc`, `ocamlopt` or their
+`.opt` version. To try the toplevel, use:
++
+----
+make runtop
+----
+
+4. Hack frenetically and keep rebuilding.
+
+5. Run the testsuite from time to time.
++
+----
+make tests
+----
+
+5. Install in a new opam switch to try things out:
++
+----
+opam compiler-conf install
+----
+
+6. You did it, Well done! Consult link:CONTRIBUTING.md[] to send your contribution upstream.
+
+See our <> for various helpful details,
+for example on how to automatically <> from a compiler branch.
+
+=== What to do
+
+There is always a lot of potential tasks, both for old and
+newcomers. Here are various potential projects:
+
+* http://caml.inria.fr/mantis/view_all_bug_page.php[The OCaml
+  bugtracker] contains reported bugs and feature requests. Some
+  changes that should be accessible to newcomers are marked with the
+  tag
+  http://caml.inria.fr/mantis/search.php?project_id=1&sticky_issues=1&sortby=last_updated&dir=DESC&highlight_changed=24&hide_status_id=90&tag_string=junior_job[junior_job].
+
+* The
+  https://github.com/ocamllabs/compiler-hacking/wiki/Things-to-work-on[OCaml
+  Labs compiler-hacking wiki] contains various ideas of changes to
+  propose, some easy, some requiring a fair amount of work.
+
+* Documentation improvements are always much appreciated, either in
+  the various `.mli` files or in the official manual
+  (See link:manual/README.md[]). If you invest effort in understanding
+  a part of the codebase, submitting a pull request that adds
+  clarifying comments can be an excellent contribution to help you,
+  next time, and other code readers.
+
+* The https://github.com/ocaml/ocaml[github project] contains a lot of
+  pull requests, many of them being in dire need of a review -- we
+  have more people willing to contribute changes than to review
+  someone else's change. Picking one of them, trying to understand the
+  code (looking at the code around it) and asking questions about what
+  you don't understand or what feels odd is super-useful. It helps the
+  contribution process, and it is also an excellent way to get to know
+  various parts of the compiler from the angle of a specific aspect or
+  feature.
++
+Again, reviewing small or medium-sized pull requests is accessible to
+anyone with OCaml programming experience, and helps maintainers and
+other contributors. If you also submit pull requests yourself, a good
+discipline is to review at least as many pull requests as you submit.
+
+== Structure of the compiler
+
+The compiler codebase can be intimidating at first sight. Here are
+a few pointers to get started.
+
+=== Compilation pipeline
+
+==== The driver -- link:driver/[]
+
+The driver contains the "main" function of the compilers that drive
+compilation. It parses the command-line arguments and composes the
+required compiler passes by calling functions from the various parts
+of the compiler described below.
+
+==== Parsing -- link:parsing/[]
+
+Parses source files and produces an Abstract Syntax Tree (AST)
+(link:parsing/parsetree.mli[] has lot of helpful comments). See
+link:parsing/HACKING.adoc[].
+
+The logic for Camlp4 and Ppx preprocessing is not in link:parsing/[],
+but in link:driver/[], see link:driver/pparse.mli[],
+link:driver/pparse.mli[].
+
+==== Typing -- link:typing/[]
+
+Type-checks the AST and produces a typed representation of the program
+(link:parsing/typedtree.mli[] has some helpful comments). See
+link:typing/HACKING.adoc[].
+
+==== The bytecode compiler -- link:bytecomp/[]
+
+==== The native compiler -- link:middle_end/[] and link:asmcomp/[]
+
+=== Runtime system
+
+=== Libraries
+
+link:stdlib/[]:: The standard library. Each file is largely
+independent and should not need further knowledge.
+
+link:otherlibs/[]:: External libraries such as `unix`, `threads`,
+`dynlink`, `str` and `bigarray`.
+
+=== Tools
+
+link:lex/[]:: The `ocamllex` lexer generator.
+
+link:yacc/[]:: The `ocamlyacc` parser generator. We do not recommend
+using it for user projects in need of a parser generator. Please
+consider using and contributing to
+link:http://gallium.inria.fr/~fpottier/menhir/[menhir] instead, which
+has tons of extra features, lets you write more readable grammars, and
+has excellent documentation.
+
+=== Complete file listing
+
+  Changes::               what's new with each release
+  configure::             configure script
+  CONTRIBUTING.md::       how to contribute to OCaml
+  HACKING.adoc::          this file
+  INSTALL.adoc::          instructions for installation
+  LICENSE::               license and copyright notice
+  Makefile::              main Makefile
+  Makefile.nt::           Windows Makefile (deprecated)
+  Makefile.shared::       common Makefile
+  Makefile.tools::        used by manual/ and testsuite/ Makefiles
+  README.adoc::           general information on the compiler distribution
+  README.win32.adoc::     general information on the Windows ports of OCaml
+  VERSION::               version string
+  asmcomp/::              native-code compiler and linker
+  asmrun/::               native-code runtime library
+  boot/::                 bootstrap compiler
+  bytecomp/::             bytecode compiler and linker
+  byterun/::              bytecode interpreter and runtime system
+  compilerlibs/::         the OCaml compiler as a library
+  config/::               configuration files
+  debugger/::             source-level replay debugger
+  driver/::               driver code for the compilers
+  emacs/::                editing mode and debugger interface for GNU Emacs
+  experimental/::         experiments not built by default
+  flexdll/::              git submodule -- see link:README.win32.adoc[]
+  lex/::                  lexer generator
+  man/::                  man pages
+  manual/::               system to generate the manual
+  middle_end/::           the flambda optimisation phase
+  ocamldoc/::             documentation generator
+  otherlibs/::            several additional libraries
+  parsing/::              syntax analysis -- see link:parsing/HACKING.adoc[]
+  stdlib/::               standard library
+  testsuite/::            tests -- see link:testsuite/HACKING.adoc[]
+  tools/::                various utilities
+  toplevel/::             interactive system
+  typing/::               typechecking -- see link:typing/HACKING.adoc[]
+  utils/::                utility libraries
+  yacc/::                 parser generator
+
+== Development tips and tricks
+
+=== opam compiler script
+
+The separately-distributed script
+https://github.com/gasche/opam-compiler-conf[`opam-compiler-conf`] can
+be used to easily build opam switches out of a git branch of the
+compiler distribution. This lets you easily install and test opam
+packages from an under-modification compiler version.
+
+=== Useful Makefile targets
+
+Besides the targets listed in link:INSTALL.adoc[] for build and
+installation, the following targets may be of use:
+
+`make runtop` :: builds and runs the ocaml toplevel of the distribution
+                          (optionally uses `rlwrap` for readline+history support)
+`make natruntop`:: builds and runs the native ocaml toplevel (experimental)
+
+`make partialclean`:: Clean the OCaml files but keep the compiled C files.
+
+`make depend`:: Regenerate the `.depend` file. Should be used each time new dependencies are added between files.
+
+`make -C testsuite parallel`:: see link:testsuite/HACKING.adoc[]
+
+=== Bootstrapping
+
+The OCaml compiler is bootstrapped. This means that
+previously-compiled bytecode versions of the compiler, dependency
+generator and lexer are included in the repository under the
+link:boot/[] directory. These bytecode images are used once the
+bytecode runtime (which is written in C) has been built to compile the
+standard library and then to build a fresh compiler. Details can be
+found in link:INSTALL.adoc#bootstrap[INSTALL.adoc].
+
+=== Continuous integration
+
+==== Github's CI: Travis and AppVeyor
+
+==== INRIA's Continuous Integration (CI)
+
+INRIA provides a Jenkins continuous integration service that OCaml
+uses, see link:https://ci.inria.fr/ocaml/[]. It provides a wider
+architecture support (MSVC and MinGW, a zsystems s390x machine, and
+various MacOS versions) than the Travis/AppVeyor testing on github,
+but only runs on commits to the trunk or release branches, not on every
+PR.
+
+You do not need to be an INRIA employee to open an account on this
+jenkins service; anyone can create an account there to access build
+logs, enable email notifications, and manually restart builds. If you
+would like to do this but have trouble doing it, please contact Damien
+Doligez or Gabriel Scherer.
+
+==== Running INRIA's CI on a github Pull Request (PR)
+
+If you have suspicions that a PR may fail on exotic architectures
+(it touches the build system or the backend code generator,
+for example) and would like to get wider testing than github's CI
+provides, it is possible to manually start INRIA's CI on arbitrary git
+branches by pushing to a `precheck` branch of the main repository.
+
+This is done by pushing to a specific github repository that the CI
+watches, namely
+link:https://github.com/ocaml/precheck[ocaml/precheck]. You thus need
+to have write/push/commit access to this repository to perform this operation.
+
+Just checkout the commit/branch you want to test, then run
+
+ git push --force git@github.com:ocaml/precheck.git HEAD:trunk
+
+(This is the syntax to push the current `HEAD` state into the `trunk`
+reference on the specified remote.)
\ No newline at end of file
diff --git a/INSTALL.adoc b/INSTALL.adoc
new file mode 100644
index 00000000..835d21b9
--- /dev/null
+++ b/INSTALL.adoc
@@ -0,0 +1,369 @@
+= Installing OCaml from sources on a Unix(-like) machine =
+
+== PREREQUISITES
+
+* The GNU C Compiler (gcc) is recommended, as the bytecode interpreter takes
+  advantage of GCC-specific features to enhance performance. gcc is the standard
+  compiler under Linux, OS X, and many other systems.
+
+* If you do not have write access to `/tmp`, you should set the environment
+  variable `TMPDIR` to the name of some other temporary directory.
+
+* Under HP/UX, the GNU C Compiler (gcc), the GNU Assembler (gas), and GNU Make
+  are all *required*.  The vendor-provided compiler, assembler and make tools
+  have major problems.
+
+* Under Cygwin, the `gcc-core` and `make` packages are required.  `flexdll` is
+  necessary for shared library support.  `libX11-devel` is necessary for graph
+  library support and `libintl-devel` is necessary for the `ocamlobjinfo` tool
+  to be able to process `.cmxs` files.  `diffutils` is necessary to run the test
+  suite.
+
+== INSTALLATION INSTRUCTIONS
+
+1. Configure the system. From the top directory, do:
+
+        ./configure
++
+This generates the three configuration files `Makefile`, `m.h` and `s.h`
+in the `config/` subdirectory.
++
+The `configure` script accepts the following options:
++
+`-prefix `::                   (default: `/usr/local`)
+        Set the `PREFIX` variable used to define the defaults of the following
+        three options.  Must be an absolute path name.
+
+`-bindir `::                   (default: `$(PREFIX)/bin`)
+        Directory where the binaries will be installed.  Must be an absolute
+        path name, or start with `$(PREFIX)`.
+
+`-libdir `::                   (default: `$(PREFIX)/lib/ocaml`)
+        Directory where the OCaml library will be installed.  Must be an
+        absolute path name, or start with `$(PREFIX)`.
+
+`-mandir `::                   (default: `$(PREFIX)/man/man1`)
+        Directory where the manual pages will be installed.  Must be an absolute
+        path name, or start with `$(PREFIX)`.
+
+`-cc `::    (default: `gcc` if found, otherwise `cc`)
+        C compiler to use for building the system.
+
+`-libs `::         (default: none)
+        Extra libraries to link with the system.
+
+`-no-curses`::
+        Do not use the curses library.
+        The only use for this is to highlight errors in the toplevel using
+        'standout' mode, e.g. underline, rather than with '^' on a newline.
+
+`-host `::                (default: determined automatically)
+        The type of the host machine, in GNU's "configuration name" format
+        (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM).  This info is
+        generally determined automatically by the `configure` script, and rarely
+        ever needs to be provided by hand.  The installation instructions for
+        GCC or GNU Emacs contain a complete list of configuration names.
+
+`-target `::            (default: same as `-host`)
+        The type of the target machine, in GNU's "configuration name" format
+        (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM). Setting this will
+        setup OCaml as a cross-compiler which runs on `$host` and produces code
+        for `$target`. This requires a C toolchain which also produces code for
+        `$target` and a native OCaml compiler of the exact same version (if you
+        want a cross 4.00.1, you need a native 4.00.1).
+
+`-x11include `::       (default: determined automatically)
+`-x11lib `::               (default: determined automatically)
+        Location of the X11 include directory (e.g. `/usr/X11R6/include`) and
+        the X11 library directory (e.g. `/usr/X11R6/lib`).
+
+`-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.
+
+`-as `::     (default: determined automatically)
+        The assembler to use for assembling ocamlopt-generated code.
+
+`-aspp `::   (default: determined automatically)
+        The assembler to use for assembling the parts of the run-time system
+        manually written in assembly language. This assembler must pre-process
+        its input with the C preprocessor.
+
+`-with-debug-runtime`::
+        Compile and install the debug version of the runtimes, useful for
+        debugging C stubs and other low-level code.
+
+`-with-instrumented-runtime`::
+        Compile and install the instrumented version of the runtimes, useful
+        mainly for fine-tuning the GC.  Works only on Linux.
+
+`-verbose`::
+        Verbose output of the configuration tests.  Use it if the outcome of
+        `configure` is not what you were expecting.
+
+`-no-debugger`::
+        Do not build `ocamldebug`.
+
+`-no-native-compiler`::
+        Do not build the native compiler -- bytecode compilation only.
+
+`-no-ocamldoc`::
+        Do not build `ocamldoc`.
+
+`-no-ocamlbuild`::
+        Deprecated since 4.03.0, as `ocamlbuild` is now distributed separately
+        from the compiler distribution.
+
+`-no-graph`::
+        Do not compile the Graphics library.
+
+`-partialld `:: (default: determined automatically)
+        The linker and options to use for producing an object file (rather than
+        an executable) from several other object files.
+
+`-no-cfi`::
+        Do not compile support for CFI directives.
++
+Examples:
+
+* Standard installation in `/usr/{bin,lib,man}` instead of `/usr/local`:
+    ./configure -prefix /usr
+
+
+* Installation in `/usr`, man pages in section "l":
+
+    ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl
++
+or:
+
+    ./configure -prefix /usr -mandir '$(PREFIX)/man/manl'
+
+* On a Linux x86-64 host, to build a 32-bit version of OCaml:
+
+    ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" \
+                -host i386-linux -partialld "ld -r -melf_i386"
+
+* On a Linux x86-64 host, to build the run-time system in PIC mode, no special
+  options should be required -- the libraries should be built automatically.
+  The old instructions were:
+
+    ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC"
++
+On a 64-bit POWER architecture host running Linux, OCaml only operates in a
+  32-bit environment.  If your system compiler is configured as 32-bit, e.g.
+  Red Hat 5.9, you don't need to do anything special.  If that is not the case
+  (e.g. Red Hat 6.4), then IBM's "Advance Toolchain" can be used.  For example:
+
+    export PATH=/opt/at7.0/bin:$PATH
+    ./configure -cc "gcc -m32" -as "as -a32" -aspp "gcc -m32 -c" \
+      -partialld "ld -r -m elf32ppc"
+
+* On a OS X 10.5/Intel Core 2 or OS X 10.5/PowerPC host, to build a 64-bit
+  version of OCaml:
+
+    ./configure -cc "gcc -m64"
+
+* On OS X Intel, to build a 32-bit version of OCaml:
+
+    ./configure -host "i386-apple-darwin13.2.0" -cc "gcc -arch i386 -m32" \
+      -as "as -arch i386" -aspp "gcc -arch i386 -m32 -c"
+
+* For Sun Solaris with the `acc` compiler:
+
+    ./configure -cc "acc -fast" -libs "-lucb"
+
+* For Sun Solaris on Sparc 64bit, to compile natively (32bit only)
+
+    ./configure -cc "gcc -m32" -as "as -32" -aspp "gcc -m32 -c"
+
+* For AIX 4.3 with the IBM compiler `xlc`:
+
+    ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192"
++
+If something goes wrong during the automatic configuration, or if the generated
+files cause errors later on, then look at the template files:
+
+        config/Makefile-templ
+        config/m-templ.h
+        config/s-templ.h
++
+for guidance on how to edit the generated files by hand.
+
+2. From the top directory, do:
+
+        make world
++
+This builds the OCaml bytecode compiler for the first time.  This phase is
+fairly verbose; consider redirecting the output to a file:
+
+        make world > log.world 2>&1     # in sh
+        make world >& log.world         # in csh
+
+[[bootstrap]]
+3. (Optional) To be sure everything works well, you can try to bootstrap the
+   system -- that is, to recompile all OCaml sources with the newly created
+   compiler. From the top directory, do:
+
+        make bootstrap
++
+or, better:
+
+        make bootstrap > log.bootstrap 2>&1     # in sh
+        make bootstrap >& log.bootstrap         # in csh
++
+The `make bootstrap` checks that the bytecode programs compiled with the new
+compiler are identical to the bytecode programs compiled with the old compiler.
+If this is the case, you can be pretty sure the system has been correctly
+compiled. Otherwise, this does not necessarily mean something went wrong.  The
+best thing to do is to try a second bootstrapping phase: just do
+`make bootstrap` again.  It will either crash almost immediately, or
+re-re-compile everything correctly and reach the fix-point.
+
+4. If your platform is supported by the native-code compiler (as reported during
+   the auto-configuration), you can now build the native-code compiler.  From
+   the top directory, do:
+
+        make opt
++
+or:
+
+        make opt > log.opt 2>&1     # in sh
+        make opt >& log.opt         # in csh
+
+5. anchor:step-5[] Compile fast versions of the OCaml compilers, by compiling
+   them with the native-code compiler (you will have only compiled them to
+   bytecode in steps 2-4).  Just do:
+
+        make opt.opt
++
+Later, you can compile your programs to bytecode using ocamlc.opt instead of
+ocamlc, and to native-code using ocamlopt.opt instead of ocamlopt.  The ".opt"
+compilers should run faster than the normal compilers, especially on large input
+files, but they may take longer to start due to increased code size.  If
+compilation times are an issue on your programs, try the ".opt" compilers to see
+if they make a significant difference.
++
+An alternative, and faster approach to steps 2 to 5 is
+
+        make world.opt          # to build using native-code compilers
++
+The result is equivalent to `make world opt opt.opt`, but this may fail if
+anything goes wrong in native-code generation.
+
+6. You can now install the OCaml system. This will create the following commands
+   (in the binary directory selected during autoconfiguration):
++
+[width="70%",frame="topbot",cols="25%,75%"]
+|===============================================================================
+| `ocamlc`     | the batch bytecode compiler
+| `ocamlopt`   | the batch native-code compiler (if supported)
+| `ocamlrun`   | the runtime system for the bytecode compiler
+| `ocamlyacc`  | the parser generator
+| `ocamllex`   | the lexer generator
+| `ocaml`      | the interactive, toplevel-based system
+| `ocamlmktop` | a tool to make toplevel systems that integrate user-defined C
+                 primitives and OCaml code
+| `ocamldebug` | the source-level replay debugger
+| `ocamldep`   | generator of "make" dependencies for OCaml sources
+| `ocamldoc`   | the documentation generator
+| `ocamlprof`  | the execution count profiler
+| `ocamlcp`    | the bytecode compiler in profiling mode
+|===============================================================================
++
+and also, if you built them during <>: `ocamlc.opt`,
+`ocamlopt.opt`, `ocamllex.opt`, `ocamldep.opt` and `ocamldoc.opt`
++
+From the top directory, become superuser and do:
+
+        umask 022       # make sure to give read & execute permission to all
+        make install
+
+7. Installation is complete. Time to clean up. From the toplevel directory,
+   do:
+
+        make clean
+
+8. (Optional) The `emacs/` subdirectory contains Emacs-Lisp files for an OCaml
+   editing mode and an interface for the debugger.  To install these files,
+   change to the `emacs/` subdirectory and do:
+
+        make EMACSDIR= install
++
+or
+
+        make install
++
+In the latter case, the destination directory defaults to the
+`site-lisp` directory of your Emacs installation.
+
+9. After installation, do *not* strip the `ocamldebug` and `ocamlbrowser`
+   executables. These are mixed-mode executables (containing both compiled C
+   code and OCaml bytecode) and stripping erases the bytecode!  Other
+   executables such as `ocamlrun` can safely be stripped.
+
+== IF SOMETHING GOES WRONG
+
+Read the "common problems" and "machine-specific hints" section at the end of
+this file.
+
+Check the files `m.h` and `s.h` in `config/`. Wrong endian-ness or alignment
+constraints in `m.h` will immediately crash the bytecode interpreter.
+
+If you get a "segmentation violation" signal, check the limits on the stack size
+and data segment size (type `limit` under csh or `ulimit -a` under bash). Make
+sure the limit on the stack size is at least 4M.
+
+Try recompiling the runtime system with optimizations turned off (change
+`CFLAGS` in `byterun/Makefile` and `asmrun/Makefile`). The runtime system
+contains some complex, atypical pieces of C code which can uncover bugs in
+optimizing compilers.  Alternatively, try another C compiler (e.g. `gcc` instead
+of the vendor-supplied `cc`).
+
+You can also build a debug version of the runtime system. Go to the `byterun/`
+directory and do `make ocamlrund`.  Then, copy `ocamlrund` to
+`../boot/ocamlrun`, and try again.  This version of the runtime system contains
+lots of assertions and sanity checks that could help you pinpoint the problem.
+
+
+== COMMON PROBLEMS
+
+* The Makefiles use the `include` directive, which is not supported by all
+  versions of make. Use GNU Make if this is a problem.
+
+* Solaris make mishandles a space in our Makefiles, so you have to use GNU make
+  to build on Solaris.
+
+* 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.
+
+* Some versions of GCC 2.96 for the Intel x86 (as found in RedHat 7.2,
+  Mandrake 8.0 and Mandrake 8.1) generate incorrect code for the runtime system.
+  The `configure` script tries to work around this problem.
+
+* On HP 9000/700 machines under HP/UX 9, some versions of `cc` are unable to
+  compile correctly the runtime system (wrong code is generated for `(x - y)`
+  where `x` is a pointer and `y` an integer). Fix: use `gcc`.
+
+* Under OS X 10.6, with XCode 4.0.2, the `configure` script mistakenly detects
+  support for CFI directives in the assembler. Fix: give the `-no-cfi` option to
+  `configure`.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 00000000..3666ebe1
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,203 @@
+In the following, "the OCaml Core System" refers to all files marked
+"Copyright INRIA" in this distribution.
+
+The OCaml Core System is distributed under the terms of the
+GNU Lesser General Public License (LGPL) version 2.1 (included below).
+
+As a special exception to the GNU Lesser General Public License, you
+may link, statically or dynamically, a "work that uses the OCaml Core
+System" with a publicly distributed version of the OCaml Core System
+to produce an executable file containing portions of the OCaml Core
+System, and distribute that executable file under terms of your
+choice, without any of the additional requirements listed in clause 6
+of the GNU Lesser General Public License.  By "a publicly distributed
+version of the OCaml Core System", we mean either the unmodified OCaml
+Core System as distributed by INRIA, or a modified version of the
+OCaml Core System that is distributed under the conditions defined in
+clause 2 of the GNU Lesser General Public License.  This exception
+does not however invalidate any other reasons why the executable file
+might be covered by the GNU Lesser General Public License.
+
+----------------------------------------------------------------------
+
+GNU LESSER GENERAL PUBLIC LICENSE
+
+Version 2.1, February 1999
+
+Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+Preamble
+
+The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users.
+
+This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below.
+
+When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things.
+
+To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it.
+
+For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights.
+
+We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library.
+
+To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others.
+
+Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license.
+
+Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs.
+
+When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library.
+
+We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances.
+
+For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License.
+
+In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system.
+
+Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library.
+
+The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run.
+
+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you".
+
+A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables.
+
+The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".)
+
+"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library.
+
+Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does.
+
+1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library.
+
+You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.
+
+2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+    b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change.
+    c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License.
+    d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License.
+
+3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices.
+
+Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy.
+
+This option is useful when you wish to copy part of the code of the Library into a program that is not a library.
+
+4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange.
+
+If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code.
+
+5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License.
+
+However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables.
+
+When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law.
+
+If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.)
+
+Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself.
+
+6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications.
+
+You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things:
+
+    a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.)
+    b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with.
+    c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution.
+    d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place.
+    e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy.
+
+For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable.
+
+It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute.
+
+7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above.
+    b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work.
+
+8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance.
+
+9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it.
+
+10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License.
+
+11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice.
+
+This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License.
+
+12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License.
+
+13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation.
+
+14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally.
+
+NO WARRANTY
+
+15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+END OF TERMS AND CONDITIONS
+
+How to Apply These Terms to Your New Libraries
+
+If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License).
+
+To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found.
+
+one line to give the library's name and an idea of what it does.
+Copyright (C) year  name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names:
+
+Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
+
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
+
+That's all there is to it!
+
+--------------------------------------------------
diff --git a/Makefile b/Makefile
new file mode 100644
index 00000000..92556ef4
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,1305 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# The main Makefile
+
+# Hard bootstrap how-to:
+# (only necessary in some cases, for example if you remove some primitive)
+#
+# make coreboot     [old system -- you were in a stable state]
+# 
+# make clean runtime coreall
+# 
+# make clean runtime coreall
+# make coreboot [new system -- now in a stable state]
+
+include config/Makefile
+
+# For users who don't read the INSTALL file
+.PHONY: defaultentry
+defaultentry:
+ifeq "$(UNIX_OR_WIN32)" "unix"
+	@echo "Please refer to the installation instructions in file INSTALL."
+	@echo "If you've just unpacked the distribution, something like"
+	@echo "	./configure"
+	@echo "	make world.opt"
+	@echo "	make install"
+	@echo "should work.  But see the file INSTALL for more details."
+else
+	@echo "Please refer to the instructions in file README.win32.adoc."
+endif
+
+MKDIR=mkdir -p
+ifeq "$(UNIX_OR_WIN32)" "win32"
+LN = cp
+else
+LN = ln -sf
+endif
+
+CAMLRUN ?= boot/ocamlrun
+CAMLYACC ?= boot/ocamlyacc
+include stdlib/StdlibModules
+
+CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives
+CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
+ARCHES=amd64 i386 arm arm64 power sparc s390x
+INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \
+        -I middle_end/base_types -I asmcomp -I driver -I toplevel
+
+COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 \
+	  -warn-error A \
+          -bin-annot -safe-string -strict-formats $(INCLUDES)
+LINKFLAGS=
+
+ifeq "$(strip $(NATDYNLINKOPTS))" ""
+OCAML_NATDYNLINKOPTS=
+else
+OCAML_NATDYNLINKOPTS = -ccopt "$(NATDYNLINKOPTS)"
+endif
+
+ifeq "$(strip $(BYTECCLINKOPTS))" ""
+OCAML_BYTECCLINKOPTS=
+else
+OCAML_BYTECCLINKOPTS = -ccopt "$(BYTECCLINKOPTS)"
+endif
+
+YACCFLAGS=-v --strict
+CAMLLEX=$(CAMLRUN) boot/ocamllex
+CAMLDEP=$(CAMLRUN) tools/ocamldep
+DEPFLAGS=$(INCLUDES)
+
+OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
+
+UTILS=utils/config.cmo utils/misc.cmo \
+  utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
+  utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \
+  utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
+  utils/consistbl.cmo \
+  utils/strongly_connected_components.cmo \
+  utils/targetint.cmo
+
+PARSING=parsing/location.cmo parsing/longident.cmo \
+  parsing/docstrings.cmo parsing/syntaxerr.cmo \
+  parsing/ast_helper.cmo parsing/parser.cmo \
+  parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
+  parsing/pprintast.cmo \
+  parsing/ast_mapper.cmo parsing/ast_iterator.cmo parsing/attr_helper.cmo \
+  parsing/builtin_attributes.cmo parsing/ast_invariants.cmo parsing/depend.cmo
+
+TYPING=typing/ident.cmo typing/path.cmo \
+  typing/primitive.cmo typing/types.cmo \
+  typing/btype.cmo typing/oprint.cmo \
+  typing/subst.cmo typing/predef.cmo \
+  typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
+  typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
+  typing/printtyp.cmo typing/includeclass.cmo \
+  typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
+  typing/typedtreeIter.cmo typing/typedtreeMap.cmo \
+  typing/tast_mapper.cmo \
+  typing/cmt_format.cmo typing/untypeast.cmo \
+  typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
+  typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \
+  typing/typeclass.cmo \
+  typing/typemod.cmo
+
+COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
+  bytecomp/semantics_of_primitives.cmo \
+  bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
+  bytecomp/translobj.cmo bytecomp/translattribute.cmo \
+  bytecomp/translcore.cmo \
+  bytecomp/translclass.cmo bytecomp/translmod.cmo \
+  bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
+  driver/pparse.cmo driver/main_args.cmo \
+  driver/compenv.cmo driver/compmisc.cmo
+
+COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
+
+BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
+  bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \
+  bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \
+  bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \
+  driver/compdynlink.cmo driver/compplugin.cmo \
+  driver/errors.cmo driver/compile.cmo
+
+ARCH_SPECIFIC =\
+  asmcomp/arch.ml asmcomp/proc.ml asmcomp/CSE.ml asmcomp/selection.ml \
+  asmcomp/scheduling.ml asmcomp/reload.ml
+
+INTEL_ASM=\
+  asmcomp/x86_proc.cmo \
+  asmcomp/x86_dsl.cmo \
+  asmcomp/x86_gas.cmo \
+  asmcomp/x86_masm.cmo
+
+ARCH_SPECIFIC_ASMCOMP=
+ifeq ($(ARCH),i386)
+ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM)
+endif
+ifeq ($(ARCH),amd64)
+ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM)
+endif
+
+ASMCOMP=\
+  $(ARCH_SPECIFIC_ASMCOMP) \
+  asmcomp/arch.cmo \
+  asmcomp/cmm.cmo asmcomp/printcmm.cmo \
+  asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
+  asmcomp/clambda.cmo asmcomp/printclambda.cmo \
+  asmcomp/export_info.cmo \
+  asmcomp/export_info_for_pack.cmo \
+  asmcomp/compilenv.cmo \
+  asmcomp/closure.cmo \
+  asmcomp/build_export_info.cmo \
+  asmcomp/closure_offsets.cmo \
+  asmcomp/flambda_to_clambda.cmo \
+  asmcomp/import_approx.cmo \
+  asmcomp/un_anf.cmo \
+  asmcomp/afl_instrument.cmo \
+  asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
+  asmcomp/printmach.cmo asmcomp/selectgen.cmo \
+  asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \
+  asmcomp/comballoc.cmo \
+  asmcomp/CSEgen.cmo asmcomp/CSE.cmo \
+  asmcomp/liveness.cmo \
+  asmcomp/spill.cmo asmcomp/split.cmo \
+  asmcomp/interf.cmo asmcomp/coloring.cmo \
+  asmcomp/reloadgen.cmo asmcomp/reload.cmo \
+  asmcomp/deadcode.cmo \
+  asmcomp/printlinear.cmo asmcomp/linearize.cmo \
+  asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
+  asmcomp/branch_relaxation_intf.cmo \
+  asmcomp/branch_relaxation.cmo \
+  asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
+  asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
+  driver/opterrors.cmo driver/optcompile.cmo
+
+MIDDLE_END=\
+  middle_end/debuginfo.cmo \
+  middle_end/base_types/tag.cmo \
+  middle_end/base_types/linkage_name.cmo \
+  middle_end/base_types/compilation_unit.cmo \
+  middle_end/base_types/variable.cmo \
+  middle_end/base_types/mutable_variable.cmo \
+  middle_end/base_types/id_types.cmo \
+  middle_end/base_types/set_of_closures_id.cmo \
+  middle_end/base_types/set_of_closures_origin.cmo \
+  middle_end/base_types/closure_element.cmo \
+  middle_end/base_types/closure_id.cmo \
+  middle_end/base_types/var_within_closure.cmo \
+  middle_end/base_types/static_exception.cmo \
+  middle_end/base_types/export_id.cmo \
+  middle_end/base_types/symbol.cmo \
+  middle_end/pass_wrapper.cmo \
+  middle_end/allocated_const.cmo \
+  middle_end/projection.cmo \
+  middle_end/flambda.cmo \
+  middle_end/flambda_iterators.cmo \
+  middle_end/flambda_utils.cmo \
+  middle_end/inlining_cost.cmo \
+  middle_end/effect_analysis.cmo \
+  middle_end/freshening.cmo \
+  middle_end/simple_value_approx.cmo \
+  middle_end/lift_code.cmo \
+  middle_end/closure_conversion_aux.cmo \
+  middle_end/closure_conversion.cmo \
+  middle_end/initialize_symbol_to_let_symbol.cmo \
+  middle_end/lift_let_to_initialize_symbol.cmo \
+  middle_end/find_recursive_functions.cmo \
+  middle_end/invariant_params.cmo \
+  middle_end/inconstant_idents.cmo \
+  middle_end/alias_analysis.cmo \
+  middle_end/lift_constants.cmo \
+  middle_end/share_constants.cmo \
+  middle_end/simplify_common.cmo \
+  middle_end/remove_unused_arguments.cmo \
+  middle_end/remove_unused_closure_vars.cmo \
+  middle_end/remove_unused_program_constructs.cmo \
+  middle_end/simplify_boxed_integer_ops.cmo \
+  middle_end/simplify_primitives.cmo \
+  middle_end/inlining_stats_types.cmo \
+  middle_end/inlining_stats.cmo \
+  middle_end/inline_and_simplify_aux.cmo \
+  middle_end/remove_free_vars_equal_to_args.cmo \
+  middle_end/extract_projections.cmo \
+  middle_end/augment_specialised_args.cmo \
+  middle_end/unbox_free_vars_of_closures.cmo \
+  middle_end/unbox_specialised_args.cmo \
+  middle_end/unbox_closures.cmo \
+  middle_end/inlining_transforms.cmo \
+  middle_end/inlining_decision.cmo \
+  middle_end/inline_and_simplify.cmo \
+  middle_end/ref_to_variables.cmo \
+  middle_end/flambda_invariants.cmo \
+  middle_end/middle_end.cmo
+
+TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \
+  toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo
+
+OPTTOPLEVEL=toplevel/genprintval.cmo toplevel/opttoploop.cmo \
+  toplevel/opttopdirs.cmo toplevel/opttopmain.cmo
+BYTESTART=driver/main.cmo
+
+OPTSTART=driver/optmain.cmo
+
+TOPLEVELSTART=toplevel/topstart.cmo
+
+OPTTOPLEVELSTART=toplevel/opttopstart.cmo
+
+PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
+
+LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
+
+MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
+
+COMPLIBDIR=$(LIBDIR)/compiler-libs
+
+INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+INSTALL_MANDIR=$(DESTDIR)$(MANDIR)
+INSTALL_FLEXDLL=$(INSTALL_LIBDIR)/flexdll
+
+RUNTOP=./byterun/ocamlrun ./ocaml \
+  -nostdlib -I stdlib \
+  -noinit $(TOPFLAGS) \
+  -I otherlibs/$(UNIXLIB)
+NATRUNTOP=./ocamlnat$(EXE) -nostdlib -I stdlib -noinit $(TOPFLAGS)
+ifeq "UNIX_OR_WIN32" "unix"
+EXTRAPATH=
+else
+EXTRAPATH = PATH="otherlibs/win32unix:$(PATH)"
+endif
+
+BOOT_FLEXLINK_CMD=
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+FLEXDLL_SUBMODULE_PRESENT := $(wildcard flexdll/Makefile)
+ifeq "$(FLEXDLL_SUBMODULE_PRESENT)" ""
+  BOOT_FLEXLINK_CMD=
+  FLEXDLL_DIR=
+else
+  BOOT_FLEXLINK_CMD = FLEXLINK_CMD="../boot/ocamlrun ../flexdll/flexlink.exe"
+  CAMLOPT := OCAML_FLEXLINK="boot/ocamlrun flexdll/flexlink.exe" $(CAMLOPT)
+  FLEXDLL_DIR=$(if $(wildcard flexdll/flexdll_*.$(O)),"+flexdll")
+endif
+else
+  FLEXDLL_DIR=
+endif
+
+# The configuration file
+
+utils/config.ml: utils/config.mlp config/Makefile
+	sed -e 's|%%AFL_INSTRUMENT%%|$(AFL_INSTRUMENT)|' \
+	    -e 's|%%ARCH%%|$(ARCH)|' \
+	    -e 's|%%ARCMD%%|$(ARCMD)|' \
+	    -e 's|%%ASM%%|$(ASM)|' \
+	    -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
+	    -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
+	    -e 's|%%BYTECODE_C_COMPILER%%|$(BYTECODE_C_COMPILER)|' \
+	    -e 's|%%BYTERUN%%|$(BYTERUN)|' \
+	    -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
+	    -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
+	    -e 's|%%EXT_ASM%%|$(EXT_ASM)|' \
+	    -e 's|%%EXT_DLL%%|$(EXT_DLL)|' \
+	    -e 's|%%EXT_EXE%%|$(EXE)|' \
+	    -e 's|%%EXT_LIB%%|$(EXT_LIB)|' \
+	    -e 's|%%EXT_OBJ%%|$(EXT_OBJ)|' \
+	    -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
+	    -e 's|%%FLEXLINK_FLAGS%%|$(subst \,\\,$(FLEXLINK_FLAGS))|' \
+	    -e 's|%%FLEXDLL_DIR%%|$(FLEXDLL_DIR)|' \
+	    -e 's|%%HOST%%|$(HOST)|' \
+	    -e 's|%%LIBDIR%%|$(LIBDIR)|' \
+	    -e 's|%%LIBUNWIND_AVAILABLE%%|$(LIBUNWIND_AVAILABLE)|' \
+	    -e 's|%%LIBUNWIND_LINK_FLAGS%%|$(LIBUNWIND_LINK_FLAGS)|' \
+	    -e 's|%%MKDLL%%|$(subst \,\\,$(MKDLL))|' \
+	    -e 's|%%MKEXE%%|$(subst \,\\,$(MKEXE))|' \
+	    -e 's|%%MKMAINDLL%%|$(subst \,\\,$(MKMAINDLL))|' \
+	    -e 's|%%MODEL%%|$(MODEL)|' \
+	    -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
+	    -e 's|%%NATIVE_C_COMPILER%%|$(NATIVE_C_COMPILER)|' \
+	    -e 's|%%PACKLD%%|$(PACKLD)|' \
+	    -e 's|%%PROFILING%%|$(PROFILING)|' \
+	    -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \
+	    -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
+	    -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \
+	    -e 's|%%SYSTEM%%|$(SYSTEM)|' \
+	    -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
+	    -e 's|%%TARGET%%|$(TARGET)|' \
+	    -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \
+	    -e 's|%%WITH_PROFINFO%%|$(WITH_PROFINFO)|' \
+	    -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \
+	    $< > $@
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+.PHONY: reconfigure
+reconfigure:
+	./configure $(CONFIGURE_ARGS)
+endif
+
+.PHONY: partialclean
+partialclean::
+	rm -f utils/config.ml
+
+.PHONY: beforedepend
+beforedepend:: utils/config.ml
+
+# Start up the system from the distribution compiler
+.PHONY: coldstart
+coldstart:
+	$(MAKE) -C byterun $(BOOT_FLEXLINK_CMD) all
+	cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
+	$(MAKE) -C yacc $(BOOT_FLEXLINK_CMD) all
+	cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
+	$(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) \
+	  COMPILER="../boot/ocamlc -use-prims ../byterun/primitives" all
+	cd stdlib; cp $(LIBFILES) ../boot
+	cd boot; $(LN) ../byterun/libcamlrun.$(A) .
+
+# Recompile the core system using the bootstrap compiler
+.PHONY: coreall
+coreall:
+	$(MAKE) ocamlc
+	$(MAKE) ocamllex ocamlyacc ocamltools library
+
+# Build the core system: the minimum needed to make depend and bootstrap
+.PHONY: core
+core:
+ifeq "$(UNIX_OR_WIN32)" "unix"
+	$(MAKE) coldstart
+else # Windows, to be fixed!
+	$(MAKE) runtime
+endif
+	$(MAKE) coreall
+
+# Save the current bootstrap compiler
+.PHONY: backup
+backup:
+	$(MKDIR) boot/Saved
+	if test -d $(MAXSAVED); then rm -r $(MAXSAVED); fi
+	mv boot/Saved boot/Saved.prev
+	mkdir boot/Saved
+	mv boot/Saved.prev boot/Saved/Saved.prev
+	cp boot/ocamlrun$(EXE) boot/Saved
+	cd boot; mv ocamlc ocamllex ocamlyacc$(EXE) ocamldep Saved
+	cd boot; cp $(LIBFILES) Saved
+
+# Restore the saved bootstrap compiler if a problem arises
+.PHONY: restore
+restore:
+	cd boot; mv Saved/* .; rmdir Saved; mv Saved.prev Saved
+
+# Check if fixpoint reached
+.PHONY: compare
+compare:
+	@if $(CAMLRUN) tools/cmpbyt boot/ocamlc ocamlc \
+         && $(CAMLRUN) tools/cmpbyt boot/ocamllex lex/ocamllex \
+         && $(CAMLRUN) tools/cmpbyt boot/ocamldep tools/ocamldep; \
+	then echo "Fixpoint reached, bootstrap succeeded."; \
+	else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
+	fi
+
+# Promote the newly compiled system to the rank of cross compiler
+# (Runs on the old runtime, produces code for the new runtime)
+.PHONY: promote-cross
+promote-cross:
+	$(CAMLRUN) tools/stripdebug ocamlc boot/ocamlc
+	$(CAMLRUN) tools/stripdebug lex/ocamllex boot/ocamllex
+	cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
+	$(CAMLRUN) tools/stripdebug tools/ocamldep boot/ocamldep
+	cd stdlib; cp $(LIBFILES) ../boot
+
+# Promote the newly compiled system to the rank of bootstrap compiler
+# (Runs on the new runtime, produces code for the new runtime)
+.PHONY: promote
+promote: promote-cross
+	cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
+
+# Remove old bootstrap compilers
+.PHONY: cleanboot
+cleanboot:
+	rm -rf boot/Saved/Saved.prev/*
+
+# Compile the native-code compiler
+.PHONY: opt-core
+opt-core: runtimeopt
+	$(MAKE) ocamlopt
+	$(MAKE) libraryopt
+
+.PHONY: opt
+opt:
+ifeq "$(UNIX_OR_WIN32)" "unix"
+	$(MAKE) runtimeopt
+	$(MAKE) ocamlopt
+	$(MAKE) libraryopt
+	$(MAKE) otherlibrariesopt ocamltoolsopt
+else
+	$(MAKE) opt-core
+	$(MAKE) otherlibrariesopt ocamltoolsopt
+endif
+
+# Native-code versions of the tools
+.PHONY: opt.opt
+ifeq "$(UNIX_OR_WIN32)" "unix"
+opt.opt:
+	$(MAKE) checkstack
+	$(MAKE) runtime
+	$(MAKE) core
+	$(MAKE) ocaml
+	$(MAKE) opt-core
+	$(MAKE) ocamlc.opt
+	$(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+	$(MAKE) ocamlopt.opt
+	$(MAKE) otherlibrariesopt
+	$(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT)
+else
+opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
+         ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLDOC_OPT)
+endif
+
+.PHONY: base.opt
+base.opt:
+	$(MAKE) checkstack
+	$(MAKE) runtime
+	$(MAKE) core
+	$(MAKE) ocaml
+	$(MAKE) opt-core
+	$(MAKE) ocamlc.opt
+	$(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+	$(MAKE) ocamlopt.opt
+	$(MAKE) otherlibrariesopt
+
+# Core bootstrapping cycle
+.PHONY: coreboot
+coreboot:
+# Save the original bootstrap compiler
+	$(MAKE) backup
+# Promote the new compiler but keep the old runtime
+# This compiler runs on boot/ocamlrun and produces bytecode for
+# byterun/ocamlrun
+	$(MAKE) promote-cross
+# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun)
+	$(MAKE) partialclean
+	$(MAKE) ocamlc ocamllex ocamltools
+# Rebuild the library (using byterun/ocamlrun ./ocamlc)
+	$(MAKE) library-cross
+# Promote the new compiler and the new runtime
+	$(MAKE) CAMLRUN=byterun/ocamlrun promote
+# Rebuild the core system
+	$(MAKE) partialclean
+	$(MAKE) core
+# Check if fixpoint reached
+	$(MAKE) compare
+
+# Recompile the system using the bootstrap compiler
+
+.PHONY: all
+all: runtime
+	$(MAKE) coreall
+	$(MAKE) ocaml
+	$(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+
+# Bootstrap and rebuild the whole system.
+# The compilation of ocaml will fail if the runtime has changed.
+# Never mind, just do make bootstrap to reach fixpoint again.
+.PHONY: bootstrap
+bootstrap: coreboot
+	$(MAKE) all
+	$(MAKE) compare
+
+# Compile everything the first time
+
+.PHONY: world
+world: coldstart
+	$(MAKE) all
+
+# Compile also native code compiler and libraries, fast
+.PHONY: world.opt
+world.opt: coldstart
+	$(MAKE) opt.opt
+
+# FlexDLL sources missing error messages
+# Different git mechanism displayed depending on whether this source tree came
+# from a git clone or a source tarball.
+
+flexdll/Makefile:
+	@echo In order to bootstrap FlexDLL, you need to place the sources in
+	@echo flexdll.
+	@echo This can either be done by downloading a source tarball from
+	@echo \  http://alain.frisch.fr/flexdll.html
+	@if [ -d .git ]; then \
+	  echo or by checking out the flexdll submodule with; \
+	  echo \  git submodule update --init; \
+	else \
+	  echo or by cloning the git repository; \
+	  echo \  git clone https://github.com/alainfrisch/flexdll.git; \
+	fi
+	@false
+
+.PHONY: flexdll
+flexdll: flexdll/Makefile flexlink
+	$(MAKE) -C flexdll \
+             MSVC_DETECT=0 CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false support
+
+# Bootstrapping flexlink - leaves a bytecode image of flexlink.exe in flexdll/
+.PHONY: flexlink
+flexlink: flexdll/Makefile
+	$(MAKE) -C byterun BOOTSTRAPPING_FLEXLINK=yes ocamlrun$(EXE)
+	cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
+	$(MAKE) -C stdlib COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo
+	cd stdlib && cp stdlib.cma std_exit.cmo *.cmi ../boot
+	$(MAKE) -C flexdll MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) \
+	  TOOLPREF=$(TOOLPREF) CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false \
+	  OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" \
+	  flexlink.exe
+	$(MAKE) -C byterun clean
+	$(MAKE) partialclean
+
+.PHONY: flexlink.opt
+flexlink.opt:
+	cd flexdll && \
+	mv flexlink.exe flexlink && \
+	$(MAKE) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 \
+	           TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) \
+	           OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe && \
+	mv flexlink.exe flexlink.opt && \
+	mv flexlink flexlink.exe
+
+.PHONY: install-flexdll
+install-flexdll:
+	cat stdlib/camlheader flexdll/flexlink.exe > \
+	  "$(INSTALL_BINDIR)/flexlink.exe"
+ifneq "$(filter-out mingw,$(TOOLCHAIN))" ""
+	cp flexdll/default$(filter-out _i386,_$(ARCH)).manifest \
+    "$(INSTALL_BINDIR)/"
+endif
+	if test -n "$(wildcard flexdll/flexdll_*.$(O))" ; then \
+	  $(MKDIR) "$(INSTALL_FLEXDLL)" ; \
+	  cp flexdll/flexdll_*.$(O) "$(INSTALL_FLEXDLL)" ; \
+	fi
+
+# Installation
+.PHONY: install
+install:
+	$(MKDIR) "$(INSTALL_BINDIR)"
+	$(MKDIR) "$(INSTALL_LIBDIR)"
+	$(MKDIR) "$(INSTALL_STUBLIBDIR)"
+	$(MKDIR) "$(INSTALL_COMPLIBDIR)"
+	cp VERSION "$(INSTALL_LIBDIR)"
+	$(MAKE) -C byterun install
+	cp ocaml "$(INSTALL_BINDIR)/ocaml$(EXE)"
+	cp ocamlc "$(INSTALL_BINDIR)/ocamlc.byte$(EXE)"
+	$(MAKE) -C stdlib install
+	cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.byte$(EXE)"
+	cp yacc/ocamlyacc$(EXE) "$(INSTALL_BINDIR)/ocamlyacc$(EXE)"
+	cp utils/*.cmi utils/*.cmt utils/*.cmti utils/*.mli \
+	   parsing/*.cmi parsing/*.cmt parsing/*.cmti parsing/*.mli \
+	   typing/*.cmi typing/*.cmt typing/*.cmti typing/*.mli \
+	   bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti bytecomp/*.mli \
+	   driver/*.cmi driver/*.cmt driver/*.cmti driver/*.mli \
+	   toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \
+	   "$(INSTALL_COMPLIBDIR)"
+	cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+	   compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \
+	   "$(INSTALL_COMPLIBDIR)"
+	cp expunge "$(INSTALL_LIBDIR)/expunge$(EXE)"
+	cp toplevel/topdirs.cmi toplevel/topdirs.cmt toplevel/topdirs.cmti \
+           toplevel/topdirs.mli "$(INSTALL_LIBDIR)"
+	$(MAKE) -C tools install
+ifeq "$(UNIX_OR_WIN32)" "unix" # Install manual pages only on Unix
+	$(MKDIR) "$(INSTALL_MANDIR)/man$(MANEXT)"
+	-$(MAKE) -C man install
+endif
+	for i in $(OTHERLIBRARIES); do \
+	  $(MAKE) -C otherlibs/$$i install || exit $$?; \
+	done
+	if test -n "$(WITH_OCAMLDOC)"; then \
+	  $(MAKE) -C ocamldoc install; \
+	fi
+	if test -n "$(WITH_DEBUGGER)"; then \
+	  $(MAKE) -C debugger install; \
+	fi
+ifeq "$(UNIX_OR_WIN32)" "win32"
+	if test -n "$(FLEXDLL_SUBMODULE_PRESENT)"; then \
+	  $(MAKE) install-flexdll; \
+	fi
+endif
+	cp config/Makefile "$(INSTALL_LIBDIR)/Makefile.config"
+	if test -f ocamlopt; then $(MAKE) installopt; else \
+	   cd "$(INSTALL_BINDIR)"; \
+	   $(LN) ocamlc.byte$(EXE) ocamlc$(EXE); \
+	   $(LN) ocamllex.byte$(EXE) ocamllex$(EXE); \
+	fi
+
+# Installation of the native-code compiler
+.PHONY: installopt
+installopt:
+	$(MAKE) -C asmrun install
+	cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte$(EXE)"
+	$(MAKE) -C stdlib installopt
+	cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
+	    middle_end/*.mli \
+		"$(INSTALL_COMPLIBDIR)"
+	cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \
+	    middle_end/base_types/*.cmti middle_end/base_types/*.mli \
+		"$(INSTALL_COMPLIBDIR)"
+	cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti asmcomp/*.mli \
+		"$(INSTALL_COMPLIBDIR)"
+	cp compilerlibs/ocamloptcomp.cma $(OPTSTART) "$(INSTALL_COMPLIBDIR)"
+	if test -n "$(WITH_OCAMLDOC)"; then \
+	  $(MAKE) -C ocamldoc installopt; \
+	fi
+	for i in $(OTHERLIBRARIES); do \
+	  $(MAKE) -C otherlibs/$$i installopt || exit $$?; \
+	done
+	if test -f ocamlopt.opt ; then $(MAKE) installoptopt; else \
+	   cd "$(INSTALL_BINDIR)"; \
+	   $(LN) ocamlc.byte$(EXE) ocamlc$(EXE); \
+	   $(LN) ocamlopt.byte$(EXE) ocamlopt$(EXE); \
+	   $(LN) ocamllex.byte$(EXE) ocamllex$(EXE); \
+	fi
+	$(MAKE) -C tools installopt
+	if test -f ocamlopt.opt -a -f flexdll/flexlink.opt ; then \
+	  cp -f flexdll/flexlink.opt "$(INSTALL_BINDIR)/flexlink$(EXE)" ; \
+	fi
+
+
+
+.PHONY: installoptopt
+installoptopt:
+	cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)"
+	cp ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt.opt$(EXE)"
+	cp lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex.opt$(EXE)"
+	cd "$(INSTALL_BINDIR)"; \
+	   $(LN) ocamlc.opt$(EXE) ocamlc$(EXE); \
+	   $(LN) ocamlopt.opt$(EXE) ocamlopt$(EXE); \
+	   $(LN) ocamllex.opt$(EXE) ocamllex$(EXE)
+	cp utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
+	   driver/*.cmx asmcomp/*.cmx "$(INSTALL_COMPLIBDIR)"
+	cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
+	   compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
+	   compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
+	   $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \
+	   $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \
+	   "$(INSTALL_COMPLIBDIR)"
+	if test -f ocamlnat$(EXE) ; then \
+	  cp ocamlnat$(EXE) "$(INSTALL_BINDIR)/ocamlnat$(EXE)"; \
+	  cp toplevel/opttopdirs.cmi "$(INSTALL_LIBDIR)"; \
+	  cp compilerlibs/ocamlopttoplevel.cmxa \
+	     compilerlibs/ocamlopttoplevel.$(A) \
+	     $(OPTTOPLEVELSTART:.cmo=.cmx) $(OPTTOPLEVELSTART:.cmo=.$(O)) \
+	     "$(INSTALL_COMPLIBDIR)"; \
+	fi
+	cd "$(INSTALL_COMPLIBDIR)" && \
+	   $(RANLIB) ocamlcommon.$(A) ocamlbytecomp.$(A) ocamloptcomp.$(A)
+
+# Installation of the *.ml sources of compiler-libs
+.PHONY: install-compiler-sources
+install-compiler-sources:
+	cp utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \
+	   toplevel/*.ml middle_end/*.ml middle_end/base_types/*.ml \
+	   asmcomp/*.ml $(INSTALL_COMPLIBDIR)
+
+# Run all tests
+
+.PHONY: tests
+tests: opt.opt
+	cd testsuite; $(MAKE) clean && $(MAKE) all
+
+# Make clean in the test suite
+
+.PHONY: clean
+clean::
+	$(MAKE) -C testsuite clean
+
+# Build the manual latex files from the etex source files
+# (see manual/README.md)
+.PHONY: manual-pregen
+manual-pregen: opt.opt
+	cd manual; $(MAKE) clean && $(MAKE) pregen-etex
+
+# The clean target
+clean:: partialclean
+
+# Shared parts of the system
+
+compilerlibs/ocamlcommon.cma: $(COMMON)
+	$(CAMLC) -a -linkall -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamlcommon.cma
+
+# The bytecode compiler
+
+compilerlibs/ocamlbytecomp.cma: $(BYTECOMP)
+	$(CAMLC) -a -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamlbytecomp.cma
+
+ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
+	$(CAMLC) $(LINKFLAGS) -compat-32 -o $@ $^
+
+partialclean::
+	rm -rf ocamlc
+
+# The native-code compiler
+
+compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
+	$(CAMLC) -a -o $@ $^
+
+partialclean::
+	rm -f compilerlibs/ocamloptcomp.cma
+
+ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
+          compilerlibs/ocamlbytecomp.cma $(OPTSTART)
+	$(CAMLC) $(LINKFLAGS) -o $@ $^
+
+partialclean::
+	rm -f ocamlopt
+
+# The toplevel
+
+compilerlibs/ocamltoplevel.cma: $(TOPLEVEL)
+	$(CAMLC) -a -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamltoplevel.cma
+
+ocaml_dependencies := \
+  compilerlibs/ocamlcommon.cma \
+  compilerlibs/ocamlbytecomp.cma \
+  compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
+
+.INTERMEDIATE: ocaml.tmp
+ocaml.tmp: $(ocaml_dependencies)
+	$(CAMLC) $(LINKFLAGS) -linkall -o $@ $^
+
+ocaml: expunge ocaml.tmp
+	- $(CAMLRUN) $^ $@ $(PERVASIVES)
+
+partialclean::
+	rm -f ocaml
+
+.PHONY: runtop
+runtop:
+ifeq "$(UNIX_OR_WIN32)" "unix"
+	$(MAKE) runtime
+	$(MAKE) coreall
+	$(MAKE) ocaml
+else
+	$(MAKE) core
+	$(MAKE) ocaml
+endif
+	@rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(RUNTOP) ||\
+	  $(EXTRAPATH) $(RUNTOP)
+
+.PHONY: natruntop
+natruntop:
+	$(MAKE) runtime
+	$(MAKE) coreall
+	$(MAKE) opt.opt
+	$(MAKE) ocamlnat
+	@rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(NATRUNTOP) ||\
+	  $(EXTRAPATH) $(NATRUNTOP)
+
+# Native dynlink
+
+otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml
+	$(MAKE) -C otherlibs/dynlink allopt
+
+# The parser
+
+parsing/parser.mli parsing/parser.ml: parsing/parser.mly
+	$(CAMLYACC) $(YACCFLAGS) $<
+
+partialclean::
+	rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output
+
+beforedepend:: parsing/parser.mli parsing/parser.ml
+
+# The lexer
+
+parsing/lexer.ml: parsing/lexer.mll
+	$(CAMLLEX) $<
+
+partialclean::
+	rm -f parsing/lexer.ml
+
+beforedepend:: parsing/lexer.ml
+
+# Shared parts of the system compiled with the native-code compiler
+
+compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx)
+	$(CAMLOPT) -a -linkall -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A)
+
+# The bytecode compiler compiled with the native-code compiler
+
+compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx)
+	$(CAMLOPT) -a $(OCAML_NATDYNLINKOPTS) -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A)
+
+ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
+            $(BYTESTART:.cmo=.cmx)
+	$(CAMLOPT) $(LINKFLAGS) $(OCAML_BYTECCLINKOPTS) -o $@ \
+	  $^ -cclib "$(BYTECCLIBS)"
+
+partialclean::
+	rm -f ocamlc.opt
+
+# The native-code compiler compiled with itself
+
+compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
+	$(CAMLOPT) -a -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A)
+
+ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+              compilerlibs/ocamlbytecomp.cmxa  \
+              $(OPTSTART:.cmo=.cmx)
+	$(CAMLOPT) $(LINKFLAGS) -o $@ $^
+
+partialclean::
+	rm -f ocamlopt.opt
+
+$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) \
+$(ASMCOMP:.cmo=.cmx): ocamlopt
+
+# The predefined exceptions and primitives
+
+byterun/primitives:
+	$(MAKE) -C byterun primitives
+
+bytecomp/runtimedef.ml: byterun/primitives byterun/caml/fail.h
+	(echo 'let builtin_exceptions = [|'; \
+	 cat byterun/caml/fail.h | tr -d '\r' | \
+	 sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$|  \1;|p'; \
+	 echo '|]'; \
+	 echo 'let builtin_primitives = [|'; \
+	 sed -e 's/.*/  "&";/' byterun/primitives; \
+	 echo '|]') > $@
+
+partialclean::
+	rm -f bytecomp/runtimedef.ml
+
+beforedepend:: bytecomp/runtimedef.ml
+
+# Choose the right machine-dependent files
+
+asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
+	cd asmcomp; $(LN) $(ARCH)/arch.ml .
+
+asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
+	cd asmcomp; $(LN) $(ARCH)/proc.ml .
+
+asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
+	cd asmcomp; $(LN) $(ARCH)/selection.ml .
+
+asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml
+	cd asmcomp; $(LN) $(ARCH)/CSE.ml .
+
+asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
+	cd asmcomp; $(LN) $(ARCH)/reload.ml .
+
+asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
+	cd asmcomp; $(LN) $(ARCH)/scheduling.ml .
+
+# Preprocess the code emitters
+
+asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
+	echo \# 1 \"$(ARCH)/emit.mlp\" > $@
+	$(CAMLRUN) tools/cvt_emit < $< >> $@ \
+	|| { rm -f $@; exit 2; }
+
+partialclean::
+	rm -f asmcomp/emit.ml
+
+beforedepend:: asmcomp/emit.ml
+
+tools/cvt_emit: tools/cvt_emit.mll
+	$(MAKE) -C tools cvt_emit
+
+# The "expunge" utility
+
+expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
+         toplevel/expunge.cmo
+	$(CAMLC) $(LINKFLAGS) -o $@ $^
+
+partialclean::
+	rm -f expunge
+
+# The runtime system for the bytecode compiler
+
+.PHONY: runtime
+runtime: stdlib/libcamlrun.$(A)
+
+.PHONY: makeruntime
+makeruntime:
+	$(MAKE) -C byterun $(BOOT_FLEXLINK_CMD) all
+byterun/libcamlrun.$(A): makeruntime ;
+stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A)
+	cd stdlib; $(LN) ../byterun/libcamlrun.$(A) .
+clean::
+	$(MAKE) -C byterun clean
+	rm -f stdlib/libcamlrun.$(A)
+
+.PHONY: alldepend
+alldepend::
+	$(MAKE) -C byterun depend
+
+# The runtime system for the native-code compiler
+
+.PHONY: runtimeopt
+runtimeopt: stdlib/libasmrun.$(A)
+
+.PHONY: makeruntimeopt
+makeruntimeopt:
+	$(MAKE) -C asmrun $(BOOT_FLEXLINK_CMD) all
+asmrun/libasmrun.$(A): makeruntimeopt ;
+stdlib/libasmrun.$(A): asmrun/libasmrun.$(A)
+	cp $< $@
+clean::
+	$(MAKE) -C asmrun clean
+	rm -f stdlib/libasmrun.$(A)
+alldepend::
+	$(MAKE) -C asmrun depend
+
+# The standard library
+
+.PHONY: library
+library: ocamlc
+	$(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) all
+
+.PHONY: library-cross
+library-cross:
+	$(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) CAMLRUN=../byterun/ocamlrun all
+
+.PHONY: libraryopt
+libraryopt:
+	$(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) allopt
+
+partialclean::
+	$(MAKE) -C stdlib clean
+
+alldepend::
+	$(MAKE) -C stdlib depend
+
+# The lexer and parser generators
+
+.PHONY: ocamllex
+ocamllex: ocamlyacc ocamlc
+	$(MAKE) -C lex all
+
+.PHONY: ocamllex.opt
+ocamllex.opt: ocamlopt
+	$(MAKE) -C lex allopt
+
+partialclean::
+	$(MAKE) -C lex clean
+
+alldepend::
+	$(MAKE) -C lex depend
+
+.PHONY: ocamlyacc
+ocamlyacc:
+	$(MAKE) -C yacc $(BOOT_FLEXLINK_CMD) all
+
+clean::
+	$(MAKE) -C yacc clean
+
+# OCamldoc
+
+.PHONY: ocamldoc
+ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries
+	$(MAKE) -C ocamldoc all
+
+.PHONY: ocamldoc.opt
+ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
+	$(MAKE) -C ocamldoc opt.opt
+
+# Documentation
+
+.PHONY: html_doc
+html_doc: ocamldoc
+	$(MAKE) -C ocamldoc $@
+	@echo "documentation is in ./ocamldoc/stdlib_html/"
+
+partialclean::
+	$(MAKE) -C ocamldoc clean
+
+alldepend::
+	$(MAKE) -C ocamldoc depend
+
+# The extra libraries
+
+.PHONY: otherlibraries
+otherlibraries: ocamltools
+	for i in $(OTHERLIBRARIES); do \
+	  ($(MAKE) -C otherlibs/$$i all) || exit $$?; \
+	done
+
+.PHONY: otherlibrariesopt
+otherlibrariesopt:
+	for i in $(OTHERLIBRARIES); do \
+	  ($(MAKE) -C otherlibs/$$i allopt) || exit $$?; \
+	done
+
+partialclean::
+	for i in $(OTHERLIBRARIES); do \
+	  ($(MAKE) -C otherlibs/$$i partialclean); \
+	done
+
+clean::
+	for i in $(OTHERLIBRARIES); do \
+	  ($(MAKE) -C otherlibs/$$i clean); \
+	done
+
+alldepend::
+	for i in $(OTHERLIBRARIES); do \
+	  ($(MAKE) -C otherlibs/$$i depend); \
+	done
+
+# The replay debugger
+
+.PHONY: ocamldebugger
+ocamldebugger: ocamlc ocamlyacc ocamllex otherlibraries
+	$(MAKE) -C debugger all
+
+partialclean::
+	$(MAKE) -C debugger clean
+
+alldepend::
+	$(MAKE) -C debugger depend
+
+# Check that the stack limit is reasonable.
+ifeq "$(UNIX_OR_WIN32)" "unix"
+.PHONY: checkstack
+checkstack:
+	if $(MKEXE) -o tools/checkstack$(EXE) tools/checkstack.c; \
+	  then tools/checkstack$(EXE); \
+	  else :; \
+	fi
+	rm -f tools/checkstack$(EXE)
+endif
+
+# Lint @since and @deprecated annotations
+
+.PHONY: lintapidiff
+lintapidiff:
+	$(MAKE) -C tools lintapidiff.opt
+	git ls-files -- 'otherlibs/*/*.mli' 'stdlib/*.mli' |\
+	    grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\
+	    tools/lintapidiff.opt $(shell git tag|grep '^[0-9]*.[0-9]*.[0-9]*$$'|grep -v '^[12].')
+
+# Make clean in the test suite
+
+clean::
+	cd testsuite; $(MAKE) clean
+
+# Make MacOS X package
+ifeq "$(UNIX_OR_WIN32)" "unix"
+.PHONY: package-macosx
+package-macosx:
+	sudo rm -rf package-macosx/root
+	$(MAKE) PREFIX="`pwd`"/package-macosx/root install
+	tools/make-package-macosx
+	sudo rm -rf package-macosx/root
+
+clean::
+	rm -rf package-macosx/*.pkg package-macosx/*.dmg
+endif
+
+# The middle end (whose .cma library is currently only used for linking
+# the "ocamlobjinfo" program, since we cannot depend on the whole native code
+# compiler for "make world" and the list of dependencies for
+# asmcomp/export_info.cmo is long).
+
+compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END)
+	$(CAMLC) -a -o $@ $^
+compilerlibs/ocamlmiddleend.cmxa: $(MIDDLE_END:%.cmo=%.cmx)
+	$(CAMLOPT) -a -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamlmiddleend.cma \
+	      compilerlibs/ocamlmiddleend.cmxa \
+	      compilerlibs/ocamlmiddleend.$(A)
+
+# Tools
+
+.PHONY: ocamltools
+ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \
+            asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \
+            asmcomp/export_info.cmo
+	$(MAKE) -C tools all
+
+.PHONY: ocamltoolsopt
+ocamltoolsopt: ocamlopt
+	$(MAKE) -C tools opt
+
+.PHONY: ocamltoolsopt.opt
+ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex.opt asmcomp/cmx_format.cmi \
+                   asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \
+                   asmcomp/export_info.cmx
+	$(MAKE) -C tools opt.opt
+
+partialclean::
+	$(MAKE) -C tools clean
+
+alldepend::
+	$(MAKE) -C tools depend
+
+## Test compilation of backend-specific parts
+
+partialclean::
+	rm -f $(ARCH_SPECIFIC)
+
+beforedepend:: $(ARCH_SPECIFIC)
+
+# This rule provides a quick way to check that machine-dependent
+# files compiles fine for a foreign architecture (passed as ARCH=xxx).
+
+.PHONY: check_arch
+check_arch:
+	@echo "========= CHECKING asmcomp/$(ARCH) =============="
+	@rm -f $(ARCH_SPECIFIC) asmcomp/emit.ml asmcomp/*.cm*
+	@$(MAKE) compilerlibs/ocamloptcomp.cma \
+	            >/dev/null
+	@rm -f $(ARCH_SPECIFIC) asmcomp/emit.ml asmcomp/*.cm*
+
+.PHONY: check_all_arches
+check_all_arches:
+	@STATUS=0; \
+	 for i in $(ARCHES); do \
+	   $(MAKE) --no-print-directory check_arch ARCH=$$i || STATUS=1; \
+	 done; \
+	 exit $$STATUS
+
+# Compiler Plugins
+
+DYNLINK_DIR=otherlibs/dynlink
+
+driver/compdynlink.mlbyte: $(DYNLINK_DIR)/dynlink.ml driver/compdynlink.mli
+	grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \
+	     $(DYNLINK_DIR)/dynlink.ml >driver/compdynlink.mlbyte
+
+ifeq ($(NATDYNLINK),true)
+driver/compdynlink.mlopt: $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mli
+	cp $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mlopt
+else
+driver/compdynlink.mlopt: driver/compdynlink.mlno driver/compdynlink.mli
+	cp driver/compdynlink.mlno driver/compdynlink.mlopt
+endif
+
+driver/compdynlink.mli: $(DYNLINK_DIR)/dynlink.mli
+	cp $(DYNLINK_DIR)/dynlink.mli driver/compdynlink.mli
+
+driver/compdynlink.cmo: driver/compdynlink.mlbyte driver/compdynlink.cmi
+	$(CAMLC) $(COMPFLAGS) -c -impl $<
+
+driver/compdynlink.cmx: driver/compdynlink.mlopt driver/compdynlink.cmi
+	$(CAMLOPT) $(COMPFLAGS) -c -impl $<
+
+beforedepend:: driver/compdynlink.mlbyte driver/compdynlink.mlopt \
+               driver/compdynlink.mli
+partialclean::
+	rm -f driver/compdynlink.mlbyte
+	rm -f driver/compdynlink.mli
+	rm -f driver/compdynlink.mlopt
+
+# The native toplevel
+
+compilerlibs/ocamlopttoplevel.cmxa: $(OPTTOPLEVEL:.cmo=.cmx)
+	$(CAMLOPT) -a -o $@ $^
+partialclean::
+	rm -f compilerlibs/ocamlopttoplevel.cmxa
+
+# When the native toplevel executable has an extension (e.g. ".exe"),
+# provide a phony 'ocamlnat' synonym
+
+ifneq ($(EXE),)
+.PHONY: ocamlnat
+ocamlnat: ocamlnat$(EXE)
+endif
+
+ocamlnat$(EXE): compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+    compilerlibs/ocamlbytecomp.cmxa \
+    compilerlibs/ocamlopttoplevel.cmxa \
+    $(OPTTOPLEVELSTART:.cmo=.cmx)
+	$(CAMLOPT) $(LINKFLAGS) -linkall -o $@ $^
+
+partialclean::
+	rm -f ocamlnat$(EXE)
+
+toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
+
+# The numeric opcodes
+
+bytecomp/opcodes.ml: byterun/caml/instruct.h tools/make_opcodes
+	$(CAMLRUN) tools/make_opcodes -opcodes < $< > $@
+
+tools/make_opcodes: tools/make_opcodes.mll
+	$(MAKE) -C tools make_opcodes
+
+partialclean::
+	rm -f bytecomp/opcodes.ml
+
+beforedepend:: bytecomp/opcodes.ml
+
+# Default rules
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(COMPFLAGS) -c $<
+
+partialclean::
+	for d in utils parsing typing bytecomp asmcomp middle_end \
+	         middle_end/base_types driver toplevel tools; do \
+	  rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.$(S) \
+	    $$d/*.$(O) $$d/*.$(SO) $d/*~; \
+	done
+	rm -f *~
+
+.PHONY: depend
+depend: beforedepend
+	(for d in utils parsing typing bytecomp asmcomp middle_end \
+	 middle_end/base_types driver toplevel; \
+	 do $(CAMLDEP) -slash $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
+	 done) > .depend
+	$(CAMLDEP) -slash $(DEPFLAGS) -native \
+		-impl driver/compdynlink.mlopt >> .depend
+	$(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
+		-impl driver/compdynlink.mlbyte >> .depend
+
+alldepend:: depend
+
+.PHONY: distclean
+distclean: clean
+	rm -f asmrun/.depend.nt byterun/.depend.nt \
+	            otherlibs/bigarray/.depend.nt  \
+		    otherlibs/str/.depend.nt
+	rm -f boot/ocamlrun boot/ocamlrun$(EXE) boot/camlheader \
+	      boot/ocamlyacc boot/*.cm* boot/libcamlrun.$(A)
+	rm -f config/Makefile config/m.h config/s.h
+	rm -f tools/*.bak
+	rm -f ocaml ocamlc
+	rm -f testsuite/_log
+
+include .depend
diff --git a/Makefile.nt b/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/Makefile.tools b/Makefile.tools
new file mode 100644
index 00000000..9ec9a98d
--- /dev/null
+++ b/Makefile.tools
@@ -0,0 +1,109 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# This makefile provides variables for using the in-tree compiler,
+# interpreter, lexer and other associated tools. It is intended to be
+# included within other makefiles.
+# See testsuite/makefiles/Makefile.common, manual/tools/Makefile and
+# manual/manual/tutorials/Makefile as examples.
+# Note that these makefile should define the $(TOPDIR) variable on their
+# own.
+
+WINTOPDIR=`cygpath -m "$(TOPDIR)"`
+
+# TOPDIR is the root directory of the OCaml sources, in Unix syntax.
+# WINTOPDIR is the same directory, in Windows syntax.
+
+OTOPDIR=$(TOPDIR)
+CTOPDIR=$(TOPDIR)
+CYGPATH=echo
+DIFF=diff -q
+SORT=sort
+SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)"
+
+# The variables above may be overridden by .../config/Makefile
+# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+#   arguments given to the OCaml compiler.
+# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+#   arguments given to the C and Fortran compilers.
+# CYGPATH is the command that translates unix-style file names into
+#   whichever syntax is appropriate for arguments of OCaml programs.
+# DIFF is a "diff -q" command that ignores trailing CRs under Windows.
+# SORT is the Unix "sort" command. Usually a simple command, but may be an
+#   absolute name if the Windows "sort" command is in the PATH.
+# SET_LD_PATH is a command prefix that sets the path for dynamic libraries
+#   (CAML_LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell
+#   variable. Note that for Windows we add Unix-syntax directory names in
+#   PATH, and Cygwin will translate it to Windows syntax.
+
+include $(TOPDIR)/config/Makefile
+
+ifneq ($(USE_RUNTIME),)
+#Check USE_RUNTIME value
+ifeq ($(findstring $(USE_RUNTIME),d i),)
+$(error If set, USE_RUNTIME must be equal to "d" (debug runtime) \
+        or "i" (instrumented runtime))
+endif
+
+RUNTIME_VARIANT=-I $(OTOPDIR)/asmrun -I $(OTOPDIR)/byterun \
+                -runtime-variant $(USE_RUNTIME)
+export OCAMLRUNPARAM?=v=0
+endif
+
+OCAMLRUN=$(TOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE)
+
+OCFLAGS=-nostdlib -I $(OTOPDIR)/stdlib $(COMPFLAGS)
+OCOPTFLAGS=
+
+ifeq ($(SUPPORTS_SHARED_LIBRARIES),false)
+  CUSTOM = -custom
+else
+  CUSTOM =
+endif
+
+OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) -noinit
+EXPECT_TEST=$(OCAMLRUN) $(OTOPDIR)/testsuite/tools/expect_test$(EXE)
+ifeq "$(FLEXLINK)" ""
+  FLEXLINK_PREFIX=
+else
+  ifeq "$(wildcard $(TOPDIR)/flexdll/Makefile)" ""
+    FLEXLINK_PREFIX=
+  else
+    EMPTY=
+    FLEXLINK_PREFIX=OCAML_FLEXLINK="$(WINTOPDIR)/boot/ocamlrun \
+	                            $(WINTOPDIR)/flexdll/flexlink.exe" $(EMPTY)
+  endif
+endif
+OCAMLC=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlc $(CUSTOM) $(OCFLAGS) \
+       $(RUNTIME_VARIANT)
+OCAMLOPT=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS) \
+         $(RUNTIME_VARIANT)
+OCAMLDOC=$(OCAMLRUN) $(OTOPDIR)/ocamldoc/ocamldoc
+OCAMLLEX=$(OCAMLRUN) $(OTOPDIR)/lex/ocamllex
+OCAMLMKLIB=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \
+           -ocamlc "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \
+                    $(OTOPDIR)/ocamlc $(OCFLAGS) $(RUNTIME_VARIANT)" \
+           -ocamlopt "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \
+                      $(OTOPDIR)/ocamlopt $(OCFLAGS) $(RUNTIME_VARIANT)"
+OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
+DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tools/dumpobj
+OBJINFO=$(OCAMLRUN) $(OTOPDIR)/tools/ocamlobjinfo
+BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]
+NATIVECODE_ONLY=false
+
+#FORTRAN_COMPILER=
+#FORTRAN_LIBRARY=
+
+UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac`
diff --git a/README.adoc b/README.adoc
new file mode 100644
index 00000000..fe07edbb
--- /dev/null
+++ b/README.adoc
@@ -0,0 +1,117 @@
+= README =
+
+== Overview
+
+OCaml is an implementation of the ML language, based on the Caml Light
+dialect extended with a complete class-based object system and a powerful
+module system in the style of Standard ML.
+
+OCaml comprises two compilers. One generates bytecode which is then
+interpreted by a C program. This compiler runs quickly, generates compact
+code with moderate memory requirements, and is portable to essentially any
+32 or 64 bit Unix platform. Performance of generated programs is quite good
+for a bytecoded implementation.  This compiler can be used either as a
+standalone, batch-oriented compiler that produces standalone programs, or as
+an interactive, toplevel-based system.
+
+The other compiler generates high-performance native code for a number of
+processors. Compilation takes longer and generates bigger code, but the
+generated programs deliver excellent performance, while retaining the
+moderate memory requirements of the bytecode compiler. The native-code
+compiler currently runs on the following platforms:
+
+Tier 1 (actively used and maintained by the core OCaml team):
+
+AMD64 (Opteron)::    Linux, OS X, MS Windows
+IA32 (Pentium)::     Linux, FreeBSD, OS X, MS Windows
+PowerPC::            Linux, OS X
+ARM::                Linux
+
+Tier 2 (maintained when possible, with help from users):
+
+AMD64::              FreeBSD, OpenBSD, NetBSD
+IA32 (Pentium)::     NetBSD, OpenBSD, Solaris 9
+PowerPC::            NetBSD
+ARM::                NetBSD
+SPARC::              Solaris, Linux, NetBSD
+
+Other operating systems for the processors above have not been tested, but
+the compiler may work under other operating systems with little work.
+
+Before the introduction of objects, OCaml was known as Caml Special Light.
+OCaml is almost upwards compatible with Caml Special Light, except for a few
+additional reserved keywords that have forced some renaming of standard
+library functions.
+
+== Copyright
+
+All files marked "Copyright INRIA" in this distribution are copyright 1996,
+1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Institut National de
+Recherche en Informatique et en Automatique (INRIA) and distributed under
+the conditions stated in file LICENSE.
+
+== Installation
+
+See the file link:INSTALL.adoc[] for installation instructions on
+machines running Unix, Linux, OS X and Cygwin.  For native Microsoft
+Windows, see link:README.win32.adoc[].
+
+== Documentation
+
+The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs
+Info files.  It is available at
+
+http://caml.inria.fr/
+
+The community also maintains the Web site http://ocaml.org, with tutorials
+and other useful information for OCaml users.
+
+== Availability
+
+The complete OCaml distribution can be accessed at
+
+http://caml.inria.fr/
+
+== Keeping in Touch with the Caml Community
+
+There exists a mailing list of users of the OCaml implementations developed
+at INRIA. The purpose of this list is to share experience, exchange ideas
+(and even code), and report on applications of the OCaml language. Messages
+can be written in English or in French. The list has more than 1000
+subscribers.
+
+Messages to the list should be sent to:
+
+mailto:caml-list@inria.fr[]
+
+You can subscribe to this list via the Web interface at
+
+https://sympa.inria.fr/sympa/subscribe/caml-list
+
+Archives of the list are available on the Web site above.
+
+The Usenet news `groups comp.lang.ml` and `comp.lang.functional` also
+contains discussions about the ML family of programming languages, including
+OCaml.
+
+The IRC channel `#ocaml` on https://freenode.net/[Freenode] also has several
+hundred users and welcomes questions.
+
+The OCaml Community website is
+
+http://ocaml.org/
+
+== Bug Reports and User Feedback
+
+Please report bugs using the Web interface to the bug-tracking system at
+http://caml.inria.fr/bin/caml-bugs
+
+To be effective, bug reports should include a complete program (preferably
+small) that exhibits the unexpected behavior, and the configuration you are
+using (machine type, etc).
+
+You can also contact the implementors directly at mailto:caml@inria.fr[].
+
+For information on contributing to OCaml, see link:HACKING.adoc[] and
+link:CONTRIBUTING.md[].
diff --git a/README.win32.adoc b/README.win32.adoc
new file mode 100644
index 00000000..e34b3346
--- /dev/null
+++ b/README.win32.adoc
@@ -0,0 +1,345 @@
+= Release notes for the Microsoft Windows ports of OCaml =
+:toc: macro
+
+There are no fewer than three ports of OCaml for Microsoft Windows, each
+available in 32 and 64-bit versions:
+
+  - native Windows, built with the Microsoft C/C++ Optimizing Compiler
+  - native Windows, built using the Mingw-w64 version of GCC
+  - Cygwin (http://www.cygwin.com[www.cygwin.com])
+
+Here is a summary of the main differences between these ports:
+
+|=====
+|                                        | Native Microsoft       | Native Mingw-w64 | Cygwin
+4+^| Third-party software required
+| for base bytecode system               | none                   | none             | none
+| for `ocamlc -custom`                     | Microsoft Visual C++   | Cygwin           | Cygwin
+| for native-code generation             | Microsoft Visual C++   | Cygwin           | Cygwin
+4+^| Features
+| Speed of bytecode interpreter          | 70%                    | 100%             | 100%
+| Replay debugger                        | yes <>       | yes <> | yes
+| The Unix library                       | partial                | partial          | full
+| The Threads library                    | yes                    | yes              | yes
+| The Graphics library                   | yes                    | yes              | no
+| Restrictions on generated executables? | none                   | none             | yes <>
+|=====
+
+[[tb1]]
+(*):: Executables generated by the native GCC package in Cygwin are linked with
+the Cygwin DLL and require this to be distributed with your programs.
+Executables generated by Microsoft Visual C++ or the Mingw-w64 compilers (even
+when run in Cygwin as `i686-w64-mingw32-gcc` or `x86_64-w64-mingw32-gcc`) are
+not linked against this DLL. Prior to Cygwin 2.5.2 (the Cygwin version can be
+obtained with `uname -r`) the Cygwin DLL is distributed under the GPL, requiring
+any programs linked with it to be distributed under a compatible licence. Since
+version 2.5.2, the Cygwin DLL is distributed under the LGPLv3 with a static
+linking exception meaning that, like executables generated by Microsoft Visual
+C++ or the Mingw-w64 compilers, generated executables may be distributed under
+terms of your choosing.
+
+[[tb2]]
+(**):: The debugger is supported but the "replay" functions are not enabled.
+Other functions are available (step, goto, run...).
+
+Cygwin aims to provide a Unix-like environment on Windows, and the build
+procedure for it is the same as for other flavours of Unix.  See
+link:INSTALL.adoc[] for full instructions.
+
+The native ports require Windows XP or later and naturally the 64-bit versions
+need a 64-bit edition of Windows (note that this is both to run *and* build).
+
+The two native Windows ports have to be built differently, and the remainder of
+this document gives more information.
+
+toc::[]
+
+== PREREQUISITES
+
+All the Windows ports require a Unix-like build environment.  Although other
+methods are available, the officially supported environment for doing this is
+32-bit (x86) Cygwin.
+
+Only the `make` Cygwin package is required. `diffutils` is required if you wish
+to be able to run the test suite.
+
+Unless you are also compiling the Cygwin port of OCaml, you should not install
+the `gcc-core` or `flexdll` packages. If you do, care may be required to ensure
+that a particular build is using the correct installation of `flexlink`.
+
+[[bmflex]]
+In addition to Cygwin, FlexDLL must also be installed, which is available from
+https://github.com/alainfrisch/flexdll. A binary distribution is available;
+instructions on how to build FlexDLL from sources, including how to bootstrap
+FlexDLL and OCaml are given <>.  Unless you
+bootstrap FlexDLL, you will need to ensure that the directory to which you
+install FlexDLL is included in your `PATH` environment variable. Note: if you
+use Visual Studio 2015 or Visual Studio 2017, the binary distribution of
+FlexDLL will not work and you must build it from sources.
+
+The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) of all three
+ports runs without any additional tools.
+
+== Microsoft Visual C/C++ Ports
+
+=== REQUIREMENTS
+
+The native-code compiler (`ocamlopt`) and static linking of OCaml bytecode with
+C code (`ocamlc -custom`) require a Microsoft Visual C/C++ Compiler and the
+`flexlink` tool (see <>).
+
+Any edition (including Express/Community editions) of Microsoft Visual Studio
+2005 or later may be used to provide the required Windows headers and the C
+compiler. Additionally, some older Microsoft Windows SDKs include the
+Visual C/C++ Compiler.
+
+|=====
+|                    | `cl` Version | Express                 | SDK
+| Visual Studio 2005 | 14.00.x.x    | 32-bit only <> |
+| Visual Studio 2008 | 15.00.x.x    | 32-bit only             | Windows SDK 7.0 also provides 32/64-bit compilers
+| Visual Studio 2010 | 16.00.x.x    | 32-bit only             | Windows SDK 7.1 also provides 32/64-bit compilers
+| Visual Studio 2012 | 17.00.x.x    | 32/64-bit               |
+| Visual Studio 2013 | 18.00.x.x    | 32/64-bit               |
+| Visual Studio 2015 | 19.00.x.x    | 32/64-bit               |
+| Visual Studio 2017 | 19.10.x.x    | 32/64-bit               |
+|=====
+
+[[vs1]]
+(*):: Visual C++ 2005 Express Edition does not provide an assembler; this can be
+      downloaded separately from
+      https://www.microsoft.com/en-gb/download/details.aspx?id=12654
+
+=== COMPILATION FROM THE SOURCES
+
+The command-line tools must be compiled from the Unix source distribution
+(`ocaml-X.YY.Z.tar.gz`), which also contains the files modified for Windows.
+(Note: you should use cygwin's `tar` command to unpack this archive. If you
+use WinZip, you will need to deselect "TAR file smart CR/LF conversion" in
+the WinZip Options Window.)
+
+Microsoft Visual C/C++ is designed to be used from special developer mode
+Command Prompts which set the environment variables for the required compiler.
+There are multiple ways of setting up your environment ready for their use.  The
+simplest is to start the appropriate command prompt shortcut from the program
+group of the compiler you have installed.
+
+The details differ depending on whether you are using a Windows SDK to provide
+the compiler or Microsoft Visual Studio itself.
+
+For the Windows SDK, there is only one command prompt called "CMD Shell" in
+versions 6.1 and 7.0 and "Windows SDK 7.1 Command Prompt" in version 7.1. This
+launches a Command Prompt which will usually select a `DEBUG` build environment
+for the operating system that you are running. You should then run:
+
+  SetEnv /Release /x86
+
+for 32-bit or:
+
+  SetEnv /Release /x64
+
+for 64-bit. For Visual Studio 2005-2013, you need to use one of the shortcuts in
+the "Visual Studio Tools" program group under the main program group for the
+version of Visual Studio you installed. For Visual Studio 2015 and 2017, you
+need to use the shortcuts in the "Windows Desktop Command Prompts" (2015) or
+"VC" (2017) group under the "Visual Studio Tools" group.
+
+Unlike `SetEnv` for the Windows SDK, the architecture is selected by using a
+different shortcut, rather than by running a command.
+
+For Visual Studio 2005-2010, excluding version-specific prefixes, these are
+named "Command Prompt" for 32-bit and "x64 Cross Tools Command Prompt" or
+"x64 Win64 Command Prompt" for 64-bit. It does not matter whether you use a
+"Cross Tools" or "Win64" version for x64, this simply refers to whether the
+compiler itself is a 32-bit or 64-bit program; both produce 64-bit output and
+work with OCaml.
+
+For Visual Studio 2012 and 2013, both x86 and x64 Command Prompt shortcuts
+indicate if they are the "Native Tools" or "Cross Tools" versions. Visual Studio
+2015 and 2017 make the shortcuts even clearer by including the full name of the
+architecture.
+
+You cannot at present use a cross-compiler to compile 64-bit OCaml on 32-bit
+Windows.
+
+Once you have started a Command Prompt, you can verify that you have the
+compiler you are expecting simply by running:
+
+  cl
+  Microsoft (R) C/C++ Optimizing Compiler Version 19.00.23506 for x86
+  ...
+
+You then need to start Cygwin from this Command Prompt.  Assuming you have
+installed it to its default location of `C:\cygwin`, simply run:
+
+  C:\cygwin\bin\mintty -
+
+(note the space and hyphen at the end of the command).
+
+This should open a terminal window and start bash.  You should be able to run
+`cl` from this.  You can now change to the top-level directory of the directory
+of the OCaml distribution.
+
+The Microsoft Linker is provided by a command called `link` which unfortunately
+conflicts with a Cygwin command of the same name.  It is therefore necessary to
+ensure that the directory containing the Microsoft C/C++ Compiler appears at
+the beginning of `PATH`, before Cygwin's `/usr/bin`.  You can automate this from
+the top-level of the OCaml distribution by running:
+
+  eval $(tools/msvs-promote-path)
+
+If you forget to do this, `make world` will fail relatively
+quickly as it will be unable to link `ocamlrun`.
+
+Now run:
+
+        cp config/m-nt.h config/m.h
+        cp config/s-nt.h config/s.h
+
+followed by:
+
+        cp config/Makefile.msvc config/Makefile
+
+for 32-bit, or:
+
+        cp config/Makefile.msvc64 config/Makefile
+
+for 64-bit. Then, edit `config/Makefile` as needed, following the comments in
+this file. Normally, the only variable that needs to be changed is `PREFIX`,
+which indicates where to install everything.
+
+Finally, use `make` to build the system, e.g.
+
+        make world bootstrap opt opt.opt install
+
+After installing, it is not necessary to keep the Cygwin installation (although
+you may require it to build additional third party libraries and tools).  You
+will need to use `ocamlopt` (or `ocamlc -custom`) from the same Visual Studio or
+Windows SDK Command Prompt as you compiled OCaml from, or `ocamlopt` will not
+be able to find `cl`.
+
+If you wish to use `ocamlopt` from Cygwin's bash on a regular basis, you may
+like to copy the `tools/msvs-promote-path` script and add the `eval` line to
+your `~/.bashrc` file.
+
+* The Microsoft Visual C/C++ compiler does not implement "computed gotos", and
+  therefore generates inefficient code for `byterun/interp.c`.  Consequently,
+  the performance of bytecode programs is about 2/3 of that obtained under
+  Unix/GCC,  Cygwin or Mingw-w64 on similar hardware.
+
+* Libraries available in this port: `bigarray`, `dynlink`, `graphics`, `num`,
+  `str`, `threads`, and large parts of `unix`.
+
+* The replay debugger is partially supported (no reverse execution).
+
+=== CREDITS
+
+The initial port of Caml Special Light (the ancestor of OCaml) to Windows NT
+was done by Kevin Gallo at Microsoft Research, who kindly contributed his
+changes to the OCaml project.
+
+== Mingw-w64 Ports
+
+=== REQUIREMENTS
+
+The native-code compiler (`ocamlopt`) and static linking of OCaml bytecode with
+C code (`ocamlc -custom`) require the appropriate Mingw-w64 gcc and the
+`flexlink` tool (see <>). Mingw-w64 gcc is provided by the
+`mingw64-i686-gcc-core` package for 32-bit and the `mingw64-x86_64-gcc-core`
+package for 64-bit.
+
+  - Do not try to use the Cygwin version of flexdll for this port.
+
+  - The standalone mingw toolchain from the Mingw-w64 project
+    (http://mingw-w64.org/) is not supported. Please use the version packaged in
+    Cygwin instead.
+
+=== COMPILATION FROM THE SOURCES
+
+The command-line tools must be compiled from the Unix source distribution
+(`ocaml-X.YY.Z.tar.gz`), which also contains the files modified for Windows.
+(Note: you should use cygwin's `tar` command to unpack this archive. If you
+use WinZip, you will need to deselect "TAR file smart CR/LF conversion" in
+the WinZip Options Window.)
+
+Now run:
+
+        cp config/m-nt.h config/m.h
+        cp config/s-nt.h config/s.h
+
+followed by:
+
+        cp config/Makefile.mingw config/Makefile
+
+for 32-bit, or:
+
+        cp config/Makefile.mingw64 config/Makefile
+
+for 64-bit. Then, edit `config/Makefile` as needed, following the comments in
+this file. Normally, the only variable that needs to be changed is `PREFIX`,
+which indicates where to install everything.
+
+Finally, use `make` to build the system, e.g.
+
+        make world bootstrap opt opt.opt install
+
+After installing, you will need to ensure that `ocamlopt` (or `ocamlc -custom`)
+can access the C compiler.  You can do this either by using OCaml from Cygwin's
+bash or by adding Cygwin's bin directory (e.g. `C:\cygwin\bin`) to your `PATH`.
+
+* Libraries available in this port: `bigarray`, `dynlink`, `graphics`, `num`,
+  `str`, `threads`, and large parts of `unix`.
+
+* The replay debugger is partially supported (no reverse execution).
+
+* The default `config/Makefile.mingw` and `config/Makefile.mingw64` pass
+  `-static-libgcc` to the linker. For more information on this topic:
+
+  - http://gcc.gnu.org/onlinedocs/gcc-4.9.1/gcc/Link-Options.html#Link-Options
+  - http://caml.inria.fr/mantis/view.php?id=6411
+
+[[seflexdll]]
+== FlexDLL
+Although the core of FlexDLL is necessarily written in C, the `flexlink` program
+is, naturally, written in OCaml.  This creates a circular dependency if you wish
+to build entirely from sources.  Since OCaml 4.03 and FlexDLL 0.35, it is now
+possible to bootstrap the two programs simultaneously.  The process is identical
+for both ports.  If you choose to compile this way, it is not necessary to
+install FlexDLL separately -- indeed, if you do install FlexDLL separately, you
+may need to be careful to ensure that `ocamlopt` picks up the correct `flexlink`
+in your `PATH`.
+
+You must place the FlexDLL sources for Version 0.35 or later in the directory
+`flexdll/` at the top-level directory of the OCaml distribution.  This can be
+done in one of three ways:
+
+ * Extracting the sources from a tarball from
+   https://github.com/alainfrisch/flexdll/releases
+ * Cloning the git repository by running:
++
+  git clone https://github.com/alainfrisch/flexdll.git
+
+ * If you are compiling from a git clone of the OCaml repository, instead of
+   using a sources tarball, you can run:
++
+  git submodule update --init
+
+OCaml is then compiled as normal for the port you require, except that before
+compiling `world`, you must compile `flexdll`, i.e.:
+
+  make flexdll world [bootstrap] opt opt.opt install
+
+ * `make install` will install FlexDLL by placing `flexlink.exe`
+   (and the default manifest file for the Microsoft port) in `bin/` and the
+   FlexDLL object files in `lib/`.
+ * If you don't include `make opt.opt`, `flexlink.exe` will be a
+   bytecode program.  `make install` always installs the "best"
+   `flexlink.exe` (i.e. there is never a `flexlink.opt.exe` installed).
+ * If you have populated `flexdll/`, you *must* run
+   `make flexdll`.  If you wish to revert to using an externally
+   installed FlexDLL, you must erase the contents of `flexdll/` before
+   compiling.
+
+== Trademarks
+
+Microsoft, Visual C++, Visual Studio and Windows are registered trademarks of
+Microsoft Corporation in the United States and/or other countries.
diff --git a/VERSION b/VERSION
new file mode 100644
index 00000000..6ca38253
--- /dev/null
+++ b/VERSION
@@ -0,0 +1,4 @@
+4.05.0
+
+# The version string is the first line of this file.
+# It must be in the format described in stdlib/sys.mli
diff --git a/appveyor.yml b/appveyor.yml
new file mode 100644
index 00000000..fbdb79ad
--- /dev/null
+++ b/appveyor.yml
@@ -0,0 +1,81 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                         Christophe Troestler                           *
+#*                                                                        *
+#*   Copyright 2015 Christophe Troestler                                  *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Compile the 64 bits version
+platform:
+  - x64
+
+image: Visual Studio 2015
+
+branches:
+  only:
+    - trunk
+    - 4.05
+
+# Do a shallow clone of the repo to speed up the build
+clone_depth: 1
+
+environment:
+  global:
+    CYG_ROOT: C:/cygwin64
+    CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/
+    CYG_CACHE: C:/cygwin64/var/cache/setup
+    OCAMLRUNPARAM: v=0,b
+    OCAMLROOT: "%PROGRAMFILES%/OCaml"
+    OCAMLROOT2: "%PROGRAMFILES%/OCaml-mingw32"
+
+cache:
+  - C:\cygwin64\var\cache\setup
+
+install:
+  - mkdir "%OCAMLROOT%/bin/flexdll"
+  - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.35.zip" -FileName "flexdll.zip"
+  - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-0.35.tar.gz" -FileName "flexdll.tar.gz"
+  - cinst 7zip.commandline
+  - mkdir flexdll-tmp
+  - cd flexdll-tmp
+  - 7za x -y ..\flexdll.zip
+  - for %%F in (flexdll.h flexlink.exe default_amd64.manifest) do copy %%F "%OCAMLROOT%\bin\flexdll"
+  - cd ..
+  # Make sure the Cygwin path comes before the Git one (otherwise
+  # cygpath behaves crazily), but after the MSVC one.
+  - set Path=C:\cygwin64\bin;%OCAMLROOT%\bin\flexdll;%Path%
+  - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"'
+  - '"%CYG_ROOT%\setup-x86_64.exe" -qgnNdO -R "%CYG_ROOT%" -s "%CYG_MIRROR%" -l "%CYG_CACHE%" -P diffutils -P make -P mingw64-i686-gcc-core >NUL'
+  - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"'
+  - set OCAML_PREV_PATH=%PATH%
+  - set OCAML_PREV_LIB=%LIB%
+  - set OCAML_PREV_INCLUDE=%INCLUDE%
+  - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+
+build_script:
+  - "%CYG_ROOT%/bin/bash -lc \"echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile\""
+  - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh"'
+  - set PATH=%OCAML_PREV_PATH%
+  - set LIB=%OCAML_PREV_LIB%
+  - set INCLUDE=%OCAML_PREV_INCLUDE%
+  - call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
+  - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh msvc32-only"'
+
+test_script:
+  - set PATH=%OCAML_PREV_PATH%
+  - set LIB=%OCAML_PREV_LIB%
+  - set INCLUDE=%OCAML_PREV_INCLUDE%
+  - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+  - '%APPVEYOR_BUILD_FOLDER%\ocamlc.opt -version'
+  - set CAML_LD_LIBRARY_PATH=%OCAMLROOT%/lib/stublibs
+  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make tests"'
+  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make tests"'
+  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make install"'
+  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make install"'
diff --git a/appveyor_build.sh b/appveyor_build.sh
new file mode 100644
index 00000000..e3c0454a
--- /dev/null
+++ b/appveyor_build.sh
@@ -0,0 +1,95 @@
+#!/bin/bash
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                         Christophe Troestler                           *
+#*                                                                        *
+#*   Copyright 2015 Christophe Troestler                                  *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+function run {
+    NAME=$1
+    shift
+    echo "-=-=- $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+    $@
+    CODE=$?
+    if [ $CODE -ne 0 ]; then
+        echo "-=-=- $NAME failed! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+        exit $CODE
+    else
+        echo "-=-=- End of $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+    fi
+}
+
+PREFIX="C:/Program Files/OCaml"
+
+wmic cpu get name
+
+if [[ $1 = "msvc32-only" ]] ; then
+  cd $APPVEYOR_BUILD_FOLDER/flexdll-0.35
+  make MSVC_DETECT=0 CHAINS=msvc MSVC_FLAGS="-nologo -MD -D_CRT_NO_DEPRECATE -GS- -WX" support
+  cp flexdll*_msvc.obj "$PREFIX/bin/flexdll"
+
+  cd $APPVEYOR_BUILD_FOLDER/../build-msvc32
+  cp config/m-nt.h config/m.h
+  cp config/s-nt.h config/s.h
+
+  eval $(tools/msvs-promote-path)
+
+  PREFIX="C:/Program Files/OCaml-msmvc32"
+  echo "Edit config/Makefile to set PREFIX=$PREFIX"
+  sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc > config/Makefile
+
+  run "make world" make world
+  run "make runtimeopt" make runtimeopt
+  run "make -C otherlibs/systhreads libthreadsnat.lib" make -C otherlibs/systhreads libthreadsnat.lib
+
+  exit 0
+fi
+
+cd $APPVEYOR_BUILD_FOLDER
+
+git worktree add ../build-mingw32 -b appveyor-build-mingw32
+git worktree add ../build-msvc32 -b appveyor-build-msvc32
+
+cd ../build-mingw32
+git submodule update --init flexdll
+
+cd $APPVEYOR_BUILD_FOLDER
+
+tar -xzf flexdll.tar.gz
+cd flexdll-0.35
+make MSVC_DETECT=0 CHAINS=msvc64 support
+cp flexdll*_msvc64.obj "$PREFIX/bin/flexdll"
+cd ..
+
+cp config/m-nt.h config/m.h
+cp config/s-nt.h config/s.h
+
+echo "Edit config/Makefile to set PREFIX=$PREFIX"
+sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc64 > config/Makefile
+#run "Content of config/Makefile" cat config/Makefile
+
+run "make world" make world
+run "make bootstrap" make bootstrap
+run "make opt" make opt
+run "make opt.opt" make opt.opt
+
+cd ../build-mingw32
+
+cp config/m-nt.h config/m.h
+cp config/s-nt.h config/s.h
+
+PREFIX="C:/Program Files/OCaml-mingw32"
+echo "Edit config/Makefile to set PREFIX=$PREFIX"
+sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -Werror\0/" config/Makefile.mingw > config/Makefile
+#run "Content of config/Makefile" cat config/Makefile
+
+run "make flexdll" make flexdll
+run "make world.opt" make world.opt
diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml
new file mode 100644
index 00000000..5ec6ebeb
--- /dev/null
+++ b/asmcomp/CSEgen.ml
@@ -0,0 +1,366 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Common subexpression elimination by value numbering over extended
+   basic blocks. *)
+
+open Mach
+
+type valnum = int
+
+(* Classification of operations *)
+
+type op_class =
+  | Op_pure           (* pure arithmetic, produce one or several result *)
+  | Op_checkbound     (* checkbound-style: no result, can raise an exn *)
+  | Op_load           (* memory load *)
+  | Op_store of bool  (* memory store, false = init, true = assign *)
+  | Op_other   (* anything else that does not allocate nor store in memory *)
+
+(* We maintain sets of equations of the form
+       valnums = operation(valnums)
+   plus a mapping from registers to valnums (value numbers). *)
+
+type rhs = operation * valnum array
+
+module Equations = struct
+  module Rhs_map =
+    Map.Make(struct type t = rhs let compare = Pervasives.compare end)
+
+  type 'a t =
+    { load_equations : 'a Rhs_map.t;
+      other_equations : 'a Rhs_map.t }
+
+  let empty =
+    { load_equations = Rhs_map.empty;
+      other_equations = Rhs_map.empty }
+
+  let add op_class op v m =
+    match op_class with
+    | Op_load ->
+      { m with load_equations = Rhs_map.add op v m.load_equations }
+    | _ ->
+      { m with other_equations = Rhs_map.add op v m.other_equations }
+
+  let find op_class op m =
+    match op_class with
+    | Op_load ->
+      Rhs_map.find op m.load_equations
+    | _ ->
+      Rhs_map.find op m.other_equations
+
+  let remove_loads m =
+    { load_equations = Rhs_map.empty;
+      other_equations = m.other_equations }
+end
+
+type numbering =
+  { num_next: int;                      (* next fresh value number *)
+    num_eqs: valnum array Equations.t;  (* mapping rhs -> valnums *)
+    num_reg: valnum Reg.Map.t }         (* mapping register -> valnum *)
+
+let empty_numbering =
+  { num_next = 0; num_eqs = Equations.empty; num_reg = Reg.Map.empty }
+
+(** Generate a fresh value number [v] and associate it to register [r].
+  Returns a pair [(n',v)] with the updated value numbering [n']. *)
+
+let fresh_valnum_reg n r =
+  let v = n.num_next in
+  ({n with num_next = v + 1; num_reg = Reg.Map.add r v n.num_reg}, v)
+
+(* Same, for a set of registers [rs]. *)
+
+let array_fold_transf (f: numbering -> 'a -> numbering * 'b) n (a: 'a array)
+                      : numbering * 'b array =
+  match Array.length a with
+  | 0 -> (n, [||])
+  | 1 -> let (n', b) = f n a.(0) in (n', [|b|])
+  | l -> let b = Array.make l 0 and n = ref n in
+         for i = 0 to l - 1 do
+           let (n', x) = f !n a.(i) in
+           b.(i) <- x; n := n'
+         done;
+         (!n, b)
+
+let fresh_valnum_regs n rs =
+  array_fold_transf fresh_valnum_reg n rs
+
+(** [valnum_reg n r] returns the value number for the contents of
+  register [r].  If none exists, a fresh value number is returned
+  and associated with register [r].  The possibly updated numbering
+  is also returned.  [valnum_regs] is similar, but for an array of
+  registers. *)
+
+let valnum_reg n r =
+  try
+    (n, Reg.Map.find r n.num_reg)
+  with Not_found ->
+    fresh_valnum_reg n r
+
+let valnum_regs n rs =
+  array_fold_transf valnum_reg n rs
+
+(* Look up the set of equations for an equation with the given rhs.
+   Return [Some res] if there is one, where [res] is the lhs. *)
+
+let find_equation op_class n rhs =
+  try
+    Some(Equations.find op_class rhs n.num_eqs)
+  with Not_found ->
+    None
+
+(* Find a register containing the given value number. *)
+
+let find_reg_containing n v =
+  Reg.Map.fold (fun r v' res -> if v' = v then Some r else res)
+               n.num_reg None
+
+(* Find a set of registers containing the given value numbers. *)
+
+let find_regs_containing n vs =
+  match Array.length vs with
+  | 0 -> Some [||]
+  | 1 -> begin match find_reg_containing n vs.(0) with
+         | None -> None
+         | Some r -> Some [|r|]
+         end
+  | l -> let rs = Array.make l Reg.dummy in
+         begin try
+           for i = 0 to l - 1 do
+             match find_reg_containing n vs.(i) with
+             | None -> raise Exit
+             | Some r -> rs.(i) <- r
+           done;
+           Some rs
+         with Exit ->
+           None
+         end
+
+(* Associate the given value number to the given result register,
+   without adding new equations. *)
+
+let set_known_reg n r v =
+  { n with num_reg = Reg.Map.add r v n.num_reg }
+
+(* Associate the given value numbers to the given result registers,
+   without adding new equations. *)
+
+let array_fold2 f n a1 a2 =
+  let l = Array.length a1 in
+  assert (l = Array.length a2);
+  let n = ref n in
+  for i = 0 to l - 1 do n := f !n a1.(i) a2.(i) done;
+  !n
+
+let set_known_regs n rs vs =
+  array_fold2 set_known_reg n rs vs
+
+(* Record the effect of a move: no new equations, but the result reg
+   maps to the same value number as the argument reg. *)
+
+let set_move n src dst =
+  let (n1, v) = valnum_reg n src in
+  { n1 with num_reg = Reg.Map.add dst v n1.num_reg }
+
+(* Record the equation [fresh valnums = rhs] and associate the given
+   result registers [rs] to [fresh valnums]. *)
+
+let set_fresh_regs n rs rhs op_class =
+  let (n1, vs) = fresh_valnum_regs n rs in
+  { n1 with num_eqs = Equations.add op_class rhs vs n.num_eqs }
+
+(* Forget everything we know about the given result registers,
+   which are receiving unpredictable values at run-time. *)
+
+let set_unknown_regs n rs =
+  { n with num_reg = Array.fold_right Reg.Map.remove rs n.num_reg }
+
+(* Keep only the equations satisfying the given predicate. *)
+
+let remove_load_numbering n =
+  { n with num_eqs = Equations.remove_loads n.num_eqs }
+
+(* Forget everything we know about registers of type [Addr]. *)
+
+let kill_addr_regs n =
+  { n with num_reg =
+              Reg.Map.filter (fun r _n -> r.Reg.typ <> Cmm.Addr) n.num_reg }
+
+(* Prepend a set of moves before [i] to assign [srcs] to [dsts].  *)
+
+let insert_single_move i src dst = instr_cons (Iop Imove) [|src|] [|dst|] i
+
+let insert_move srcs dsts i =
+  match Array.length srcs with
+  | 0 -> i
+  | 1 -> instr_cons (Iop Imove) srcs dsts i
+  | _ -> (* Parallel move: first copy srcs into tmps one by one,
+            then copy tmps into dsts one by one *)
+         let tmps = Reg.createv_like srcs in
+         let i1 = array_fold2 insert_single_move i tmps dsts in
+         array_fold2 insert_single_move i1 srcs tmps
+
+class cse_generic = object (self)
+
+(* Default classification of operations.  Can be overriden in
+   processor-specific files to classify specific operations better. *)
+
+method class_of_operation op =
+  match op with
+  | Imove | Ispill | Ireload -> assert false   (* treated specially *)
+  | Iconst_int _ | Iconst_float _ | Iconst_symbol _ -> Op_pure
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ -> assert false                 (* treated specially *)
+  | Istackoffset _ -> Op_other
+  | Iload(_,_) -> Op_load
+  | Istore(_,_,asg) -> Op_store asg
+  | Ialloc _ -> assert false                   (* treated specially *)
+  | Iintop(Icheckbound _) -> Op_checkbound
+  | Iintop _ -> Op_pure
+  | Iintop_imm(Icheckbound _, _) -> Op_checkbound
+  | Iintop_imm(_, _) -> Op_pure
+  | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+  | Ifloatofint | Iintoffloat -> Op_pure
+  | Ispecific _ -> Op_other
+
+(* Operations that are so cheap that it isn't worth factoring them. *)
+
+method is_cheap_operation op =
+  match op with
+  | Iconst_int _ -> true
+  | _ -> false
+
+(* Forget all equations involving memory loads.  Performed after a
+   non-initializing store *)
+
+method private kill_loads n =
+  remove_load_numbering n
+
+(* Perform CSE on the given instruction [i] and its successors.
+   [n] is the value numbering current at the beginning of [i]. *)
+
+method private cse n i =
+  match i.desc with
+  | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _)
+  | Iexit _ | Iraise _ ->
+      i
+  | Iop (Imove | Ispill | Ireload) ->
+      (* For moves, we associate the same value number to the result reg
+         as to the argument reg. *)
+      let n1 = set_move n i.arg.(0) i.res.(0) in
+      {i with next = self#cse n1 i.next}
+  | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) ->
+      (* For function calls, we should at least forget:
+         - equations involving memory loads, since the callee can
+           perform arbitrary memory stores;
+         - equations involving arithmetic operations that can
+           produce [Addr]-typed derived pointers into the heap
+           (see below for Ialloc);
+         - mappings from hardware registers to value numbers,
+           since the callee does not preserve these registers.
+         That doesn't leave much usable information: checkbounds
+         could be kept, but won't be usable for CSE as one of their
+         arguments is always a memory load.  For simplicity, we
+         just forget everything. *)
+      {i with next = self#cse empty_numbering i.next}
+  | Iop (Ialloc _) ->
+      (* For allocations, we must avoid extending the live range of a
+         pseudoregister across the allocation if this pseudoreg
+         is a derived heap pointer (a pointer into the heap that does
+         not point to the beginning of a Caml block).  PR#6484 is an
+         example of this situation.  Such pseudoregs have type [Addr].
+         Pseudoregs with types other than [Addr] can be kept.
+         Moreover, allocation can trigger the asynchronous execution
+         of arbitrary Caml code (finalizer, signal handler, context
+         switch), which can contain non-initializing stores.
+         Hence, all equations over loads must be removed. *)
+       let n1 = kill_addr_regs (self#kill_loads n) in
+       let n2 = set_unknown_regs n1 i.res in
+       {i with next = self#cse n2 i.next}
+  | Iop op ->
+      begin match self#class_of_operation op with
+      | (Op_pure | Op_checkbound | Op_load) as op_class ->
+          let (n1, varg) = valnum_regs n i.arg in
+          let n2 = set_unknown_regs n1 (Proc.destroyed_at_oper i.desc) in
+          begin match find_equation op_class n1 (op, varg) with
+          | Some vres ->
+              (* This operation was computed earlier. *)
+              (* Are there registers that hold the results computed earlier? *)
+              begin match find_regs_containing n1 vres with
+              | Some res when (not (self#is_cheap_operation op))
+                           && (not (Proc.regs_are_volatile res)) ->
+                  (* We can replace res <- op args with r <- move res,
+                     provided res are stable (non-volatile) registers.
+                     If the operation is very cheap to compute, e.g.
+                     an integer constant, don't bother. *)
+                  let n3 = set_known_regs n1 i.res vres in
+                  (* This is n1 above and not n2 because the move
+                     does not destroy any regs *)
+                  insert_move res i.res (self#cse n3 i.next)
+              | _ ->
+                  (* We already computed the operation but lost its
+                     results.  Associate the result registers to
+                     the result valnums of the previous operation. *)
+                  let n3 = set_known_regs n2 i.res vres in
+                  {i with next = self#cse n3 i.next}
+              end
+          | None ->
+              (* This operation produces a result we haven't seen earlier. *)
+              let n3 = set_fresh_regs n2 i.res (op, varg) op_class in
+              {i with next = self#cse n3 i.next}
+          end
+      | Op_store false | Op_other ->
+          (* An initializing store or an "other" operation do not invalidate
+             any equations, but we do not know anything about the results. *)
+         let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in
+         let n2 = set_unknown_regs n1 i.res in
+         {i with next = self#cse n2 i.next}
+      | Op_store true ->
+          (* A non-initializing store can invalidate
+             anything we know about prior loads. *)
+         let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in
+         let n2 = set_unknown_regs n1 i.res in
+         let n3 = self#kill_loads n2 in
+         {i with next = self#cse n3 i.next}
+      end
+  (* For control structures, we set the numbering to empty at every
+     join point, but propagate the current numbering across fork points. *)
+  | Iifthenelse(test, ifso, ifnot) ->
+     let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in
+      {i with desc = Iifthenelse(test, self#cse n1 ifso, self#cse n1 ifnot);
+              next = self#cse empty_numbering i.next}
+  | Iswitch(index, cases) ->
+     let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in
+      {i with desc = Iswitch(index, Array.map (self#cse n1) cases);
+              next = self#cse empty_numbering i.next}
+  | Iloop(body) ->
+      {i with desc = Iloop(self#cse empty_numbering body);
+              next = self#cse empty_numbering i.next}
+  | Icatch(rec_flag, handlers, body) ->
+      let aux (nfail, handler) =
+        nfail, self#cse empty_numbering handler
+      in
+      {i with desc = Icatch(rec_flag, List.map aux handlers, self#cse n body);
+              next = self#cse empty_numbering i.next}
+  | Itrywith(body, handler) ->
+      {i with desc = Itrywith(self#cse n body,
+                              self#cse empty_numbering handler);
+              next = self#cse empty_numbering i.next}
+
+method fundecl f =
+  {f with fun_body = self#cse empty_numbering f.fun_body}
+
+end
diff --git a/asmcomp/CSEgen.mli b/asmcomp/CSEgen.mli
new file mode 100644
index 00000000..98b5f5b0
--- /dev/null
+++ b/asmcomp/CSEgen.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Common subexpression elimination by value numbering over extended
+   basic blocks. *)
+
+type op_class =
+  | Op_pure     (* pure, produce one result *)
+  | Op_checkbound     (* checkbound-style: no result, can raise an exn *)
+  | Op_load           (* memory load *)
+  | Op_store of bool  (* memory store, false = init, true = assign *)
+  | Op_other   (* anything else that does not allocate nor store in memory *)
+
+class cse_generic : object
+  (* The following methods can be overriden to handle processor-specific
+     operations. *)
+
+  method class_of_operation: Mach.operation -> op_class
+
+  method is_cheap_operation: Mach.operation -> bool
+    (* Operations that are so cheap that it isn't worth factoring them. *)
+
+  (* The following method is the entry point and should not be overridden *)
+  method fundecl: Mach.fundecl -> Mach.fundecl
+
+end
diff --git a/asmcomp/afl_instrument.ml b/asmcomp/afl_instrument.ml
new file mode 100644
index 00000000..d3d371cf
--- /dev/null
+++ b/asmcomp/afl_instrument.ml
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Stephen Dolan, University of Cambridge                 *)
+(*                                                                        *)
+(*   Copyright 2016 Stephen Dolan.                                        *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Insert instrumentation for afl-fuzz *)
+
+open Lambda
+open Cmm
+
+let afl_area_ptr = Cconst_symbol "caml_afl_area_ptr"
+let afl_prev_loc = Cconst_symbol "caml_afl_prev_loc"
+let afl_map_size = 1 lsl 16
+
+let rec with_afl_logging b =
+  if !Clflags.afl_inst_ratio < 100 &&
+    Random.int 100 >= !Clflags.afl_inst_ratio then instrument b else
+  let instrumentation =
+    (* The instrumentation that afl-fuzz requires is:
+
+         cur_location = ;
+         shared_mem[cur_location ^ prev_location]++;
+         prev_location = cur_location >> 1;
+
+       See http://lcamtuf.coredump.cx/afl/technical_details.txt or
+       docs/technical_details.txt in afl-fuzz source for for a full
+       description of what's going on. *)
+    let cur_location = Random.int afl_map_size in
+    let cur_pos = Ident.create "pos" in
+    let afl_area = Ident.create "shared_mem" in
+    let op oper args = Cop (oper, args, Debuginfo.none) in
+    Clet(afl_area, op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr],
+    Clet(cur_pos,  op Cxor [op (Cload (Word_int, Asttypes.Mutable))
+      [afl_prev_loc]; Cconst_int cur_location],
+    Csequence(
+      op (Cstore(Byte_unsigned, Assignment))
+         [op Cadda [Cvar afl_area; Cvar cur_pos];
+          op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable))
+                       [op Cadda [Cvar afl_area; Cvar cur_pos]];
+                    Cconst_int 1]],
+      op (Cstore(Word_int, Assignment))
+         [afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in
+  Csequence(instrumentation, instrument b)
+
+and instrument = function
+  (* these cases add logging, as they may be targets of conditional branches *)
+  | Cifthenelse (cond, t, f) ->
+     Cifthenelse (instrument cond, with_afl_logging t, with_afl_logging f)
+  | Cloop e ->
+     Cloop (with_afl_logging e)
+  | Ctrywith (e, ex, handler) ->
+     Ctrywith (instrument e, ex, with_afl_logging handler)
+  | Cswitch (e, cases, handlers, dbg) ->
+     Cswitch (instrument e, cases, Array.map with_afl_logging handlers, dbg)
+
+  (* these cases add no logging, but instrument subexpressions *)
+  | Clet (v, e, body) -> Clet (v, instrument e, instrument body)
+  | Cassign (v, e) -> Cassign (v, instrument e)
+  | Ctuple es -> Ctuple (List.map instrument es)
+  | Cop (op, es, dbg) -> Cop (op, List.map instrument es, dbg)
+  | Csequence (e1, e2) -> Csequence (instrument e1, instrument e2)
+  | Ccatch (isrec, cases, body) ->
+     Ccatch (isrec,
+             List.map (fun (nfail, ids, e) -> nfail, ids, instrument e) cases,
+             instrument body)
+  | Cexit (ex, args) -> Cexit (ex, List.map instrument args)
+
+  (* these are base cases and have no logging *)
+  | Cconst_int _ | Cconst_natint _ | Cconst_float _
+  | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _
+  | Cblockheader _ | Cvar _ as c -> c
+
+let instrument_function c =
+  with_afl_logging c
+
+let instrument_initialiser c =
+  (* Each instrumented module calls caml_setup_afl at
+     initialisation, which is a no-op on the second and subsequent
+     calls *)
+  with_afl_logging
+    (Csequence
+       (Cop (Cextcall ("caml_setup_afl", typ_int, false, None),
+             [Cconst_int 0],
+             Debuginfo.none),
+        c))
diff --git a/asmcomp/afl_instrument.mli b/asmcomp/afl_instrument.mli
new file mode 100644
index 00000000..1eb439b2
--- /dev/null
+++ b/asmcomp/afl_instrument.mli
@@ -0,0 +1,4 @@
+(* Instrumentation for afl-fuzz *)
+
+val instrument_function : Cmm.expression -> Cmm.expression
+val instrument_initialiser : Cmm.expression -> Cmm.expression
diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml
new file mode 100644
index 00000000..7e4193d7
--- /dev/null
+++ b/asmcomp/amd64/CSE.ml
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for the AMD64 *)
+
+open Arch
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+  match op with
+  | Ispecific spec ->
+    begin match spec with
+    | Ilea _ -> Op_pure
+    | Istore_int(_, _, is_asg) -> Op_store is_asg
+    | Ioffset_loc(_, _) -> Op_store true
+    | Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load
+    | Ibswap _ | Isqrtf -> super#class_of_operation op
+    end
+  | _ -> super#class_of_operation op
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/amd64/NOTES.md b/asmcomp/amd64/NOTES.md
new file mode 100644
index 00000000..b0adc698
--- /dev/null
+++ b/asmcomp/amd64/NOTES.md
@@ -0,0 +1,21 @@
+# Supported platforms
+
+Intel and AMD x86 processors in 64-bit mode, a.k.a `x86_64`.
+
+Floating-point architecture: SSE2, supported by all x86_64 processors.
+
+Operating systems: Linux, BSD, MacOS X, MS Windows.
+
+Debian architecture name: `amd64`
+
+# Reference documents
+
+* Instruction set architecture:
+  any Intel or AMD manual less than 10 years old.
+* ELF application binary interface:
+  _System V Application Binary Interface,
+   AMD64 Architecture Processor Supplement_
+* MacOS X application binary interface:
+  _OS X ABI Function Call Guide: x86-64 Function Calling Conventions_
+* Windows 64 application binary interface:
+  _x64 Software Conventions_ from MSDN
diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml
new file mode 100644
index 00000000..38fc2fb2
--- /dev/null
+++ b/asmcomp/amd64/arch.ml
@@ -0,0 +1,133 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Machine-specific command-line options *)
+
+let command_line_options =
+  [ "-fPIC", Arg.Set Clflags.pic_code,
+      " Generate position-independent machine code (default)";
+    "-fno-PIC", Arg.Clear Clflags.pic_code,
+      " Generate position-dependent machine code" ]
+
+(* Specific operations for the AMD64 processor *)
+
+open Format
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+  | Iindexed2 of int                    (* reg + reg + displ *)
+  | Iscaled of int * int                (* reg * scale + displ *)
+  | Iindexed2scaled of int * int        (* reg + reg * scale + displ *)
+
+type specific_operation =
+    Ilea of addressing_mode             (* "lea" gives scaled adds *)
+  | Istore_int of nativeint * addressing_mode * bool
+                                        (* Store an integer constant *)
+  | Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
+  | Ifloatarithmem of float_operation * addressing_mode
+                                       (* Float arith operation with memory *)
+  | Ibswap of int                      (* endiannes conversion *)
+  | Isqrtf                             (* Float square root *)
+  | Ifloatsqrtf of addressing_mode     (* Float square root from memory *)
+and float_operation =
+    Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv
+
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let size_addr = 8
+let size_int = 8
+let size_float = 8
+
+let allow_unaligned_access = true
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = true
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+  | Iindexed2 n -> Iindexed2(n + delta)
+  | Iscaled(scale, n) -> Iscaled(scale, n + delta)
+  | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
+
+let num_args_addressing = function
+    Ibased _ -> 0
+  | Iindexed _ -> 1
+  | Iindexed2 _ -> 2
+  | Iscaled _ -> 1
+  | Iindexed2scaled _ -> 2
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Ibased(s, 0) ->
+      fprintf ppf "\"%s\"" s
+  | Ibased(s, n) ->
+      fprintf ppf "\"%s\" + %i" s n
+  | Iindexed n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a%s" printreg arg.(0) idx
+  | Iindexed2 n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx
+  | Iscaled(scale, n) ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a  * %i%s" printreg arg.(0) scale idx
+  | Iindexed2scaled(scale, n) ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx
+
+let print_specific_operation printreg op ppf arg =
+  match op with
+  | Ilea addr -> print_addressing printreg addr ppf arg
+  | Istore_int(n, addr, is_assign) ->
+      fprintf ppf "[%a] := %nd %s"
+         (print_addressing printreg addr) arg n
+         (if is_assign then "(assign)" else "(init)")
+  | Ioffset_loc(n, addr) ->
+      fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n
+  | Isqrtf ->
+      fprintf ppf "sqrtf %a" printreg arg.(0)
+  | Ifloatsqrtf addr ->
+     fprintf ppf "sqrtf float64[%a]"
+             (print_addressing printreg addr) [|arg.(0)|]
+  | Ifloatarithmem(op, addr) ->
+      let op_name = function
+      | Ifloatadd -> "+f"
+      | Ifloatsub -> "-f"
+      | Ifloatmul -> "*f"
+      | Ifloatdiv -> "/f" in
+      fprintf ppf "%a %s float64[%a]" printreg arg.(0) (op_name op)
+                   (print_addressing printreg addr)
+                   (Array.sub arg 1 (Array.length arg - 1))
+  | Ibswap i ->
+      fprintf ppf "bswap_%i %a" i printreg arg.(0)
+
+let win64 =
+  match Config.system with
+  | "win64" | "mingw64" | "cygwin" -> true
+  | _                   -> false
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
new file mode 100644
index 00000000..c3f8692a
--- /dev/null
+++ b/asmcomp/amd64/emit.mlp
@@ -0,0 +1,1128 @@
+# 2 "asmcomp/amd64/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of Intel x86_64 assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+open X86_ast
+open X86_proc
+open X86_dsl
+
+(* [Branch_relaxation] is not used in this file, but is required by
+   emit.mlp files for certain other targets; the reference here ensures
+   that when releases are being prepared the .depend files are correct
+   for all targets. *)
+open! Branch_relaxation
+
+let _label s = D.label ~typ:QWORD s
+
+(* Override proc.ml *)
+
+let int_reg_name =
+  [| RAX; RBX; RDI; RSI; RDX; RCX; R8; R9;
+     R12; R13; R10; R11; RBP; |]
+
+let float_reg_name = Array.init 16 (fun i -> XMM i)
+
+let register_name r =
+  if r < 100 then Reg64 (int_reg_name.(r))
+  else Regf (float_reg_name.(r - 100))
+
+(* CFI directives *)
+
+let cfi_startproc () =
+  if Config.asm_cfi_supported then D.cfi_startproc ()
+
+let cfi_endproc () =
+  if Config.asm_cfi_supported then D.cfi_endproc ()
+
+let cfi_adjust_cfa_offset n =
+  if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n
+
+let emit_debug_info dbg =
+  emit_debug_info_gen dbg D.file D.loc
+
+let fp = Config.with_frame_pointers
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+let stack_offset = ref 0
+
+(* Layout of the stack frame *)
+
+let frame_required () =
+  fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0
+
+let frame_size () =                     (* includes return address *)
+  if frame_required() then begin
+    let sz =
+      (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8
+       + (if fp then 8 else 0))
+    in Misc.align sz 16
+  end else
+    !stack_offset + 8
+
+let slot_offset loc cl =
+  match loc with
+  | Incoming n -> frame_size() + n
+  | Local n ->
+      if cl = 0
+      then !stack_offset + n * 8
+      else !stack_offset + (num_stack_slots.(0) + n) * 8
+  | Outgoing n -> n
+
+(* Symbols *)
+
+let symbol_prefix = if system = S_macosx then "_" else ""
+
+let emit_symbol s = string_of_symbol symbol_prefix s
+
+(* Record symbols used and defined - at the end generate extern for those
+   used but not defined *)
+
+let symbols_defined = ref StringSet.empty
+let symbols_used = ref StringSet.empty
+
+let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined
+let add_used_symbol s = symbols_used := StringSet.add s !symbols_used
+
+let imp_table = Hashtbl.create 16
+
+let reset_imp_table () = Hashtbl.clear imp_table
+
+let get_imp_symbol s =
+  match Hashtbl.find imp_table s with
+  | exception Not_found ->
+      let imps = "__caml_imp_" ^ s in
+      Hashtbl.add imp_table s imps;
+      imps
+  | imps -> imps
+
+let emit_imp_table () =
+  let f s imps =
+    _label (emit_symbol imps);
+    D.qword (ConstLabel (emit_symbol s))
+  in
+  D.data();
+  D.comment "relocation table start";
+  D.align 8;
+  Hashtbl.iter f imp_table;
+  D.comment "relocation table end"
+
+let mem__imp s =
+  let imp_s = get_imp_symbol s in
+  mem64_rip QWORD (emit_symbol imp_s)
+
+let rel_plt s =
+  if windows && !Clflags.dlcode then mem__imp s
+  else
+    let use_plt =
+      match system with
+      | S_macosx | S_mingw64 | S_cygwin | S_win64 -> false
+      | _ -> !Clflags.dlcode
+    in
+    sym (if use_plt then emit_symbol s ^ "@PLT" else emit_symbol s)
+
+let emit_call s = I.call (rel_plt s)
+
+let emit_jump s = I.jmp (rel_plt s)
+
+let load_symbol_addr s arg =
+  if !Clflags.dlcode then
+    if windows then begin
+      (* I.mov (mem__imp s) arg (\* mov __caml_imp_foo(%rip), ... *\) *)
+      I.mov (sym (emit_symbol s)) arg (* movabsq $foo, ... *)
+    end else I.mov (mem64_rip QWORD (emit_symbol s ^ "@GOTPCREL")) arg
+  else if !Clflags.pic_code then
+    I.lea (mem64_rip NONE (emit_symbol s)) arg
+  else
+    I.mov (sym (emit_symbol s)) arg
+
+(* Output a label *)
+
+let emit_label lbl =
+  match system with
+  | S_macosx | S_win64 -> "L" ^ string_of_int lbl
+  | _ -> ".L" ^ string_of_int lbl
+
+let label s = sym (emit_label s)
+
+let def_label s = D.label (emit_label s)
+
+let emit_Llabel fallthrough lbl =
+  if not fallthrough && !fastcode_flag then D.align 4;
+  def_label lbl
+
+(* Output a pseudo-register *)
+
+let reg = function
+  | { loc = Reg.Reg r } -> register_name r
+  | { loc = Stack s; typ = Float } as r ->
+      let ofs = slot_offset s (register_class r) in
+      mem64 REAL8 ofs RSP
+  | { loc = Stack s } as r ->
+      let ofs = slot_offset s (register_class r) in
+      mem64 QWORD ofs RSP
+  | { loc = Unknown } ->
+      assert false
+
+let reg64 = function
+  | { loc = Reg.Reg r } -> int_reg_name.(r)
+  | _ -> assert false
+
+
+let res i n = reg i.res.(n)
+
+let arg i n = reg i.arg.(n)
+
+(* Output a reference to the lower 8, 16 or 32 bits of a register *)
+
+let reg_low_8_name  = Array.map (fun r -> Reg8L r) int_reg_name
+let reg_low_16_name = Array.map (fun r -> Reg16 r) int_reg_name
+let reg_low_32_name = Array.map (fun r -> Reg32 r) int_reg_name
+
+let emit_subreg tbl typ r =
+  match r.loc with
+  | Reg.Reg r when r < 13 -> tbl.(r)
+  | Stack s -> mem64 typ (slot_offset s (register_class r)) RSP
+  | _ -> assert false
+
+let arg8 i n = emit_subreg reg_low_8_name BYTE i.arg.(n)
+let arg16 i n = emit_subreg reg_low_16_name WORD i.arg.(n)
+let arg32 i n = emit_subreg reg_low_32_name DWORD i.arg.(n)
+let arg64 i n = reg64 i.arg.(n)
+
+let res16 i n = emit_subreg reg_low_16_name WORD i.res.(n)
+let res32 i n = emit_subreg reg_low_32_name DWORD i.res.(n)
+
+(* Output an addressing mode *)
+
+let addressing addr typ i n =
+  match addr with
+  | Ibased(s, ofs) ->
+      add_used_symbol s;
+      mem64_rip typ (emit_symbol s) ~ofs
+  | Iindexed d ->
+      mem64 typ d (arg64 i n)
+  | Iindexed2 d ->
+      mem64 typ ~base:(arg64 i n) d (arg64 i (n+1))
+  | Iscaled(2, d) ->
+      mem64 typ ~base:(arg64 i n) d (arg64 i n)
+  | Iscaled(scale, d) ->
+      mem64 typ ~scale d (arg64 i n)
+  | Iindexed2scaled(scale, d) ->
+      mem64 typ ~scale ~base:(arg64 i n) d (arg64 i (n+1))
+
+(* Record live pointers at call points -- see Emitaux *)
+
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := ((r lsl 1) + 1) :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ()
+    )
+    live;
+  record_frame_descr ~label:lbl ~frame_size:(frame_size())
+    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+  lbl
+
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in
+  def_label lbl
+
+(* Spacetime instrumentation *)
+
+let spacetime_before_uninstrumented_call ~node_ptr ~index =
+  (* At the moment, [node_ptr] is pointing at the node for the current
+     OCaml function.  Get hold of the node itself and move the pointer
+     forwards, saving it into the distinguished register.  This is used
+     for instrumentation of function calls (e.g. caml_call_gc and bounds
+     check failures) not inserted until this stage of the compiler
+     pipeline. *)
+  I.mov node_ptr (reg Proc.loc_spacetime_node_hole);
+  assert (index >= 2);
+  I.add (int (index * 8)) (reg Proc.loc_spacetime_node_hole)
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_frame: label;                    (* Label of frame descriptor *)
+    gc_spacetime : (X86_ast.arg * int) option;
+    (* Spacetime node hole pointer and index *)
+  }
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  def_label gc.gc_lbl;
+  begin match gc.gc_spacetime with
+  | None -> assert (not Config.spacetime)
+  | Some (node_ptr, index) ->
+    assert Config.spacetime;
+    spacetime_before_uninstrumented_call ~node_ptr ~index
+  end;
+  emit_call "caml_call_gc";
+  def_label gc.gc_frame;
+  I.jmp (label gc.gc_return_lbl)
+
+(* Record calls to caml_ml_array_bound_error.
+   In -g mode, or when using Spacetime profiling, we maintain one call to
+   caml_ml_array_bound_error per bound check site.  Without -g, we can share
+   a single call. *)
+
+type bound_error_call =
+  { bd_lbl: label;                      (* Entry label *)
+    bd_frame: label;                    (* Label of frame descriptor *)
+    bd_spacetime : (X86_ast.arg * int) option;
+    (* As for [gc_call]. *)
+  }
+
+let bound_error_sites = ref ([] : bound_error_call list)
+let bound_error_call = ref 0
+
+let bound_error_label ?label dbg ~spacetime =
+  if !Clflags.debug || Config.spacetime then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    bound_error_sites :=
+      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame;
+        bd_spacetime = spacetime; } :: !bound_error_sites;
+    lbl_bound_error
+  end else begin
+    if !bound_error_call = 0 then bound_error_call := new_label();
+    !bound_error_call
+  end
+
+let emit_call_bound_error bd =
+  def_label bd.bd_lbl;
+  begin match bd.bd_spacetime with
+  | None -> ()
+  | Some (node_ptr, index) ->
+    spacetime_before_uninstrumented_call ~node_ptr ~index
+  end;
+  emit_call "caml_ml_array_bound_error";
+  def_label bd.bd_frame
+
+let emit_call_bound_errors () =
+  List.iter emit_call_bound_error !bound_error_sites;
+  if !bound_error_call > 0 then begin
+    def_label !bound_error_call;
+    emit_call "caml_ml_array_bound_error"
+  end
+
+(* Names for instructions *)
+
+let instr_for_intop = function
+  | Iadd -> I.add
+  | Isub -> I.sub
+  | Imul -> (fun arg1 arg2 -> I.imul arg1 (Some arg2))
+  | Iand -> I.and_
+  | Ior -> I.or_
+  | Ixor -> I.xor
+  | Ilsl -> I.sal
+  | Ilsr -> I.shr
+  | Iasr -> I.sar
+  | _ -> assert false
+
+let instr_for_floatop = function
+  | Iaddf -> I.addsd
+  | Isubf -> I.subsd
+  | Imulf -> I.mulsd
+  | Idivf -> I.divsd
+  | _ -> assert false
+
+let instr_for_floatarithmem = function
+  | Ifloatadd -> I.addsd
+  | Ifloatsub -> I.subsd
+  | Ifloatmul -> I.mulsd
+  | Ifloatdiv -> I.divsd
+
+let cond = function
+  | Isigned Ceq   -> E   | Isigned Cne   -> NE
+  | Isigned Cle   -> LE  | Isigned Cgt   -> G
+  | Isigned Clt   -> L   | Isigned Cge   -> GE
+  | Iunsigned Ceq -> E   | Iunsigned Cne -> NE
+  | Iunsigned Cle -> BE  | Iunsigned Cgt -> A
+  | Iunsigned Clt -> B   | Iunsigned Cge -> AE
+
+(* Output an = 0 or <> 0 test. *)
+
+let output_test_zero arg =
+  match arg.loc with
+  | Reg.Reg _ -> I.test (reg arg) (reg arg)
+  | _  -> I.cmp (int 0) (reg arg)
+
+(* Output a floating-point compare and branch *)
+
+let emit_float_test cmp neg i lbl =
+  (* Effect of comisd on flags and conditional branches:
+                     ZF PF CF  cond. branches taken
+        unordered     1  1  1  je, jb, jbe, jp
+        >             0  0  0  jne, jae, ja
+        <             0  0  1  jne, jbe, jb
+        =             1  0  0  je, jae, jbe.
+     If FP traps are on (they are off by default),
+     comisd traps on QNaN and SNaN but ucomisd traps on SNaN only.
+  *)
+  match (cmp, neg) with
+  | (Ceq, false) | (Cne, true) ->
+      let next = new_label() in
+      I.ucomisd (arg i 1) (arg i 0);
+      I.jp (label next);          (* skip if unordered *)
+      I.je lbl;                   (* branch taken if x=y *)
+      def_label next
+  | (Cne, false) | (Ceq, true) ->
+      I.ucomisd (arg i 1) (arg i 0);
+      I.jp lbl;                   (* branch taken if unordered *)
+      I.jne lbl                   (* branch taken if xy *)
+  | (Clt, _) ->
+      I.comisd (arg i 0) (arg i 1);
+      if not neg then I.ja lbl    (* branch taken if y>x i.e. x
+      I.comisd (arg i 0) (arg i 1);(* swap compare *)
+      if not neg then I.jae lbl   (* branch taken if y>=x i.e. x<=y *)
+      else            I.jb lbl    (* taken if unordered or y
+      I.comisd (arg i 1) (arg i 0);
+      if not neg then I.ja lbl    (* branch taken if x>y *)
+      else            I.jbe lbl   (* taken if unordered or x<=y i.e. !(x>y) *)
+  | (Cge, _) ->
+      I.comisd (arg i 1) (arg i 0);(* swap compare *)
+      if not neg then I.jae lbl   (* branch taken if x>=y *)
+      else            I.jb lbl    (* taken if unordered or x=y) *)
+
+(* Deallocate the stack frame before a return or tail call *)
+
+let output_epilogue f =
+  if frame_required() then begin
+    let n = frame_size() - 8 - (if fp then 8 else 0) in
+    if n <> 0
+    then begin
+      I.add (int n) rsp;
+      cfi_adjust_cfa_offset (-n);
+    end;
+    if fp then I.pop rbp;
+    f ();
+    (* reset CFA back cause function body may continue *)
+    if n <> 0
+    then cfi_adjust_cfa_offset n
+  end
+  else
+    f ()
+
+(* Floating-point constants *)
+
+let float_constants = ref ([] : (int64 * int) list)
+
+let add_float_constant cst =
+  try
+    List.assoc cst !float_constants
+  with Not_found ->
+    let lbl = new_label() in
+    float_constants := (cst, lbl) :: !float_constants;
+    lbl
+
+let emit_float_constant f lbl =
+  _label (emit_label lbl);
+  D.qword (Const f)
+
+let emit_global_label s =
+  let lbl = Compilenv.make_symbol (Some s) in
+  add_def_symbol lbl;
+  let lbl = emit_symbol lbl in
+  D.global lbl;
+  _label lbl
+
+
+(* Output the assembly code for an instruction *)
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+
+(* Emit an instruction *)
+let emit_instr fallthrough i =
+  emit_debug_info i.dbg;
+  match i.desc with
+  | Lend -> ()
+  | Lop(Imove | Ispill | Ireload) ->
+      let src = i.arg.(0) and dst = i.res.(0) in
+      if src.loc <> dst.loc then
+        begin match src.typ, src.loc, dst.loc with
+        | Float, Reg.Reg _, Reg.Reg _ -> I.movapd (reg src) (reg dst)
+        | Float, _, _ -> I.movsd (reg src) (reg dst)
+        | _ -> I.mov (reg src) (reg dst)
+        end
+  | Lop(Iconst_int n) ->
+      if n = 0n then begin
+        match i.res.(0).loc with
+        | Reg _ -> I.xor (res i 0) (res i 0)
+        | _     -> I.mov (int 0) (res i 0)
+      end
+      else
+        I.mov (nat n) (res i 0)
+  | Lop(Iconst_float f) ->
+      begin match f with
+      | 0x0000_0000_0000_0000L ->       (* +0.0 *)
+          I.xorpd (res i 0) (res i 0)
+      | _ ->
+          let lbl = add_float_constant f in
+          I.movsd (mem64_rip NONE (emit_label lbl)) (res i 0)
+      end
+  | Lop(Iconst_symbol s) ->
+      add_used_symbol s;
+      load_symbol_addr s (res i 0)
+  | Lop(Icall_ind { label_after; }) ->
+      I.call (arg i 0);
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Icall_imm { func; label_after; }) ->
+      add_used_symbol func;
+      emit_call func;
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Itailcall_ind { label_after; }) ->
+      output_epilogue begin fun () ->
+        I.jmp (arg i 0);
+        if Config.spacetime then begin
+          record_frame Reg.Set.empty false i.dbg ~label:label_after
+        end
+      end
+  | Lop(Itailcall_imm { func; label_after; }) ->
+      begin
+        if func = !function_name then
+          I.jmp (label !tailrec_entry_point)
+        else begin
+          output_epilogue begin fun () ->
+            add_used_symbol func;
+            emit_jump func
+          end
+        end
+      end;
+      if Config.spacetime then begin
+        record_frame Reg.Set.empty false i.dbg ~label:label_after
+      end
+  | Lop(Iextcall { func; alloc; label_after; }) ->
+      add_used_symbol func;
+      if alloc then begin
+        load_symbol_addr func rax;
+        emit_call "caml_c_call";
+        record_frame i.live false i.dbg ~label:label_after;
+        if system <> S_win64 then begin
+          (* TODO: investigate why such a diff.
+             This comes from:
+            http://caml.inria.fr/cgi-bin/viewvc.cgi?view=revision&revision=12664
+
+             If we do the same for Win64, we probably need to change
+             amd64nt.asm accordingly.
+          *)
+          load_symbol_addr "caml_young_ptr" r11;
+          I.mov (mem64 QWORD 0 R11) r15
+        end
+      end else begin
+        emit_call func;
+        if Config.spacetime then begin
+          record_frame Reg.Set.empty false i.dbg ~label:label_after
+        end
+      end
+  | Lop(Istackoffset n) ->
+      if n < 0
+      then I.add (int (-n)) rsp
+      else if n > 0
+      then I.sub (int n) rsp;
+      if n <> 0
+      then cfi_adjust_cfa_offset n;
+      stack_offset := !stack_offset + n
+  | Lop(Iload(chunk, addr)) ->
+      let dest = res i 0 in
+      begin match chunk with
+      | Word_int | Word_val ->
+          I.mov (addressing addr QWORD i 0) dest
+      | Byte_unsigned ->
+          I.movzx (addressing addr BYTE i 0) dest
+      | Byte_signed ->
+          I.movsx (addressing addr BYTE i 0) dest
+      | Sixteen_unsigned ->
+          I.movzx (addressing addr WORD i 0) dest
+      | Sixteen_signed ->
+          I.movsx (addressing addr WORD i 0) dest;
+      | Thirtytwo_unsigned ->
+          I.mov (addressing addr DWORD i 0) (res32 i 0)
+      | Thirtytwo_signed ->
+          I.movsxd (addressing addr DWORD i 0) dest
+      | Single ->
+          I.cvtss2sd (addressing addr REAL4 i 0) dest
+      | Double | Double_u ->
+          I.movsd (addressing addr REAL8 i 0) dest
+      end
+  | Lop(Istore(chunk, addr, _)) ->
+      begin match chunk with
+      | Word_int | Word_val ->
+          I.mov (arg i 0) (addressing addr QWORD i 1)
+      | Byte_unsigned | Byte_signed ->
+          I.mov (arg8 i 0) (addressing addr BYTE i 1)
+      | Sixteen_unsigned | Sixteen_signed ->
+          I.mov (arg16 i 0) (addressing addr WORD i 1)
+      | Thirtytwo_signed | Thirtytwo_unsigned ->
+          I.mov (arg32 i 0) (addressing addr DWORD i 1)
+      | Single ->
+          I.cvtsd2ss (arg i 0) xmm15;
+          I.movss xmm15 (addressing addr REAL4 i 1)
+      | Double | Double_u ->
+          I.movsd (arg i 0) (addressing addr REAL8 i 1)
+      end
+  | Lop(Ialloc { words = n; label_after_call_gc; spacetime_index; }) ->
+      if !fastcode_flag then begin
+        let lbl_redo = new_label() in
+        def_label lbl_redo;
+        I.sub (int n) r15;
+        let spacetime_node_hole_ptr_is_in_rax =
+          Config.spacetime && (i.arg.(0).loc = Reg 0)
+        in
+        if !Clflags.dlcode then begin
+          (* When using Spacetime, %rax might be the node pointer, so we
+             must take care not to clobber it.  (Whilst we can tell the
+             register allocator that %rax is destroyed by Ialloc, we can't
+             force that the argument (the node pointer) is not in %rax.) *)
+          if spacetime_node_hole_ptr_is_in_rax then begin
+            I.push rax
+          end;
+          load_symbol_addr "caml_young_limit" rax;
+          I.cmp (mem64 QWORD 0 RAX) r15;
+          if spacetime_node_hole_ptr_is_in_rax then begin
+            I.pop rax  (* this does not affect the flags *)
+          end
+        end else
+          I.cmp (mem64_rip QWORD (emit_symbol "caml_young_limit")) r15;
+        let lbl_call_gc = new_label() in
+        let dbg =
+          if not Config.spacetime then Debuginfo.none
+          else i.dbg
+        in
+        let lbl_frame =
+          record_frame_label ?label:label_after_call_gc i.live false dbg
+        in
+        I.jb (label lbl_call_gc);
+        I.lea (mem64 NONE 8 R15) (res i 0);
+        let gc_spacetime =
+          if not Config.spacetime then None
+          else Some (arg i 0, spacetime_index)
+        in
+        call_gc_sites :=
+          { gc_lbl = lbl_call_gc;
+            gc_return_lbl = lbl_redo;
+            gc_frame = lbl_frame;
+            gc_spacetime; } :: !call_gc_sites
+      end else begin
+        if Config.spacetime then begin
+          spacetime_before_uninstrumented_call ~node_ptr:(arg i 0)
+            ~index:spacetime_index;
+        end;
+        begin match n with
+        | 16 -> emit_call "caml_alloc1"
+        | 24 -> emit_call "caml_alloc2"
+        | 32 -> emit_call "caml_alloc3"
+        | _  ->
+            I.mov (int n) rax;
+            emit_call "caml_allocN"
+        end;
+        let label =
+          record_frame_label ?label:label_after_call_gc i.live false
+            Debuginfo.none
+        in
+        def_label label;
+        I.lea (mem64 NONE 8 R15) (res i 0)
+      end
+  | Lop(Iintop(Icomp cmp)) ->
+      I.cmp (arg i 1) (arg i 0);
+      I.set (cond cmp) al;
+      I.movzx al (res i 0)
+  | Lop(Iintop_imm(Icomp cmp, n)) ->
+      I.cmp (int n) (arg i 0);
+      I.set (cond cmp) al;
+      I.movzx al (res i 0)
+  | Lop(Iintop (Icheckbound { label_after_error; spacetime_index; } )) ->
+      let spacetime =
+        if not Config.spacetime then None
+        else Some (arg i 2, spacetime_index)
+      in
+      let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in
+      I.cmp (arg i 1) (arg i 0);
+      I.jbe (label lbl)
+  | Lop(Iintop_imm(Icheckbound { label_after_error; spacetime_index; }, n)) ->
+      let spacetime =
+        if not Config.spacetime then None
+        else Some (arg i 1, spacetime_index)
+      in
+      let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in
+      I.cmp (int n) (arg i 0);
+      I.jbe (label lbl)
+  | Lop(Iintop(Idiv | Imod)) ->
+      I.cqo ();
+      I.idiv (arg i 1)
+  | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
+      (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *)
+      instr_for_intop op cl (res i 0)
+  | Lop(Iintop Imulh) ->
+      I.imul (arg i 1) None
+  | Lop(Iintop op) ->
+      (* We have i.arg.(0) = i.res.(0) *)
+      instr_for_intop op (arg i 1) (res i 0)
+  | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc ->
+      I.lea (mem64 NONE n (arg64 i 0)) (res i 0)
+  | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) ->
+      I.inc (res i 0)
+  | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) ->
+      I.dec (res i 0)
+  | Lop(Iintop_imm(op, n)) ->
+      (* We have i.arg.(0) = i.res.(0) *)
+      instr_for_intop op (int n) (res i 0)
+  | Lop(Inegf) ->
+      I.xorpd (mem64_rip OWORD (emit_symbol "caml_negf_mask")) (res i 0)
+  | Lop(Iabsf) ->
+      I.andpd (mem64_rip OWORD (emit_symbol "caml_absf_mask")) (res i 0)
+  | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) ->
+      instr_for_floatop floatop (arg i 1) (res i 0)
+  | Lop(Ifloatofint) ->
+      I.cvtsi2sd  (arg i 0)  (res i 0)
+  | Lop(Iintoffloat) ->
+      I.cvttsd2si (arg i 0) (res i 0)
+  | Lop(Ispecific(Ilea addr)) ->
+      I.lea (addressing addr NONE i 0) (res i 0)
+  | Lop(Ispecific(Istore_int(n, addr, _))) ->
+      I.mov (nat n) (addressing addr QWORD i 0)
+  | Lop(Ispecific(Ioffset_loc(n, addr))) ->
+      I.add (int n) (addressing addr QWORD i 0)
+  | Lop(Ispecific(Ifloatarithmem(op, addr))) ->
+      instr_for_floatarithmem op (addressing addr REAL8 i 1) (res i 0)
+  | Lop(Ispecific(Ibswap 16)) ->
+      I.xchg ah al;
+      I.movzx (res16 i 0) (res i 0)
+  | Lop(Ispecific(Ibswap 32)) ->
+      I.bswap (res32 i 0);
+      I.movsxd (res32 i 0) (res i 0)
+  | Lop(Ispecific(Ibswap 64)) ->
+      I.bswap (res i 0)
+  | Lop(Ispecific(Ibswap _)) ->
+      assert false
+  | Lop(Ispecific Isqrtf) ->
+      I.sqrtsd (arg i 0) (res i 0)
+  | Lop(Ispecific(Ifloatsqrtf addr)) ->
+      I.sqrtsd (addressing addr REAL8 i 0) (res i 0)
+  | Lreloadretaddr ->
+      ()
+  | Lreturn ->
+      output_epilogue begin fun () ->
+        I.ret ()
+      end
+  | Llabel lbl ->
+      emit_Llabel fallthrough lbl
+  | Lbranch lbl ->
+      I.jmp (label lbl)
+  | Lcondbranch(tst, lbl) ->
+      let lbl = label lbl in
+      begin match tst with
+      | Itruetest ->
+          output_test_zero i.arg.(0);
+          I.jne lbl
+      | Ifalsetest ->
+          output_test_zero i.arg.(0);
+          I.je lbl
+      | Iinttest cmp ->
+          I.cmp (arg i 1) (arg i 0);
+          I.j (cond cmp) lbl
+      | Iinttest_imm((Isigned Ceq | Isigned Cne |
+                      Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
+          output_test_zero i.arg.(0);
+          I.j (cond cmp) lbl
+      | Iinttest_imm(cmp, n) ->
+          I.cmp (int n) (arg i 0);
+          I.j (cond cmp) lbl
+      | Ifloattest(cmp, neg) ->
+          emit_float_test cmp neg i lbl
+      | Ioddtest ->
+          I.test (int 1) (arg8 i 0);
+          I.jne lbl
+      | Ieventest ->
+          I.test (int 1) (arg8 i 0);
+          I.je lbl
+      end
+  | Lcondbranch3(lbl0, lbl1, lbl2) ->
+      I.cmp (int 1) (arg i 0);
+      begin match lbl0 with
+      | None -> ()
+      | Some lbl -> I.jb (label lbl)
+      end;
+      begin match lbl1 with
+      | None -> ()
+      | Some lbl -> I.je (label lbl)
+      end;
+      begin match lbl2 with
+      | None -> ()
+      | Some lbl -> I.jg (label lbl)
+      end
+  | Lswitch jumptbl ->
+      let lbl = emit_label (new_label()) in
+      (* rax and rdx are clobbered by the Lswitch,
+         meaning that no variable that is live across the Lswitch
+         is assigned to rax or rdx.  However, the argument to Lswitch
+         can still be assigned to one of these two registers, so
+         we must be careful not to clobber it before use. *)
+      let (tmp1, tmp2) =
+        if i.arg.(0).loc = Reg 0 (* rax *)
+        then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*))
+        else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in
+
+      I.lea (mem64_rip NONE lbl) (reg tmp1);
+      I.movsxd (mem64 DWORD 0 (arg64 i 0) ~scale:4 ~base:(reg64 tmp1))
+               (reg tmp2);
+      I.add (reg tmp2) (reg tmp1);
+      I.jmp (reg tmp1);
+
+      begin match system with
+      | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") []
+      | S_macosx | S_win64 -> () (* with LLVM/OS X and MASM, use the text segment *)
+      | _ -> D.section [".rodata"] None []
+      end;
+      D.align 4;
+      _label lbl;
+      for i = 0 to Array.length jumptbl - 1 do
+        D.long (ConstSub (ConstLabel(emit_label jumptbl.(i)),
+                         ConstLabel lbl))
+      done;
+      D.text ()
+  | Lsetuptrap lbl ->
+      I.call (label lbl)
+  | Lpushtrap ->
+      cfi_adjust_cfa_offset 8;
+      I.push r14;
+      cfi_adjust_cfa_offset 8;
+      I.mov rsp r14;
+      stack_offset := !stack_offset + 16
+  | Lpoptrap ->
+      I.pop r14;
+      cfi_adjust_cfa_offset (-8);
+      I.add (int 8) rsp;
+      cfi_adjust_cfa_offset (-8);
+      stack_offset := !stack_offset - 16
+  | Lraise k ->
+      (* No Spacetime instrumentation is required for [caml_raise_exn] and
+         [caml_reraise_exn].  The only function called that might affect the
+         trie is [caml_stash_backtrace], and it does not. *)
+      begin match k with
+      | Cmm.Raise_withtrace ->
+          emit_call "caml_raise_exn";
+          record_frame Reg.Set.empty true i.dbg
+      | Cmm.Raise_notrace ->
+          I.mov r14 rsp;
+          I.pop r14;
+          I.ret ()
+      end
+
+let rec emit_all fallthrough i =
+  match i.desc with
+  | Lend -> ()
+  | _ ->
+      emit_instr fallthrough i;
+      emit_all (Linearize.has_fallthrough i.desc) i.next
+
+(* Emission of the profiling prelude *)
+
+let emit_profile () =
+  if system = S_gnu || system = S_linux then begin
+    (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly
+       and rbx, rbp, r12-r15 like all C functions.  This includes
+       all the registers used for argument passing, so we don't
+       need to preserve other regs.  We do need to initialize rbp
+       like mcount expects it, though. *)
+    I.push r10;
+    if not fp then I.mov rsp rbp;
+    (* No Spacetime instrumentation needed: [mcount] cannot call anything
+       OCaml-related. *)
+    emit_call "mcount";
+    I.pop r10
+  end
+
+let all_functions = ref []
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  fastcode_flag := fundecl.fun_fast;
+  tailrec_entry_point := new_label();
+  stack_offset := 0;
+  call_gc_sites := [];
+  bound_error_sites := [];
+  bound_error_call := 0;
+  all_functions := fundecl :: !all_functions;
+  D.text ();
+  D.align 16;
+  add_def_symbol fundecl.fun_name;
+  if system = S_macosx
+  && not !Clflags.output_c_object
+  && is_generic_function fundecl.fun_name
+  then (* PR#4690 *)
+    D.private_extern (emit_symbol fundecl.fun_name)
+  else
+    D.global (emit_symbol fundecl.fun_name);
+  D.label (emit_symbol fundecl.fun_name);
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc ();
+  if fp then begin
+    I.push rbp;
+    cfi_adjust_cfa_offset 8;
+    I.mov rsp rbp;
+  end;
+  if !Clflags.gprofile then emit_profile();
+  if frame_required() then begin
+    let n = frame_size() - 8 - (if fp then 8 else 0) in
+    if n <> 0
+    then begin
+      I.sub (int n) rsp;
+      cfi_adjust_cfa_offset n;
+    end;
+  end;
+  def_label !tailrec_entry_point;
+  emit_all true fundecl.fun_body;
+  List.iter emit_call_gc !call_gc_sites;
+  emit_call_bound_errors ();
+  if frame_required() then begin
+    let n = frame_size() - 8 - (if fp then 8 else 0) in
+    if n <> 0
+    then begin
+      cfi_adjust_cfa_offset (-n);
+    end;
+  end;
+  cfi_endproc ();
+  begin match system with
+  | S_gnu | S_linux ->
+      D.type_ (emit_symbol fundecl.fun_name) "@function";
+      D.size (emit_symbol fundecl.fun_name)
+        (ConstSub (
+            ConstThis,
+            ConstLabel (emit_symbol fundecl.fun_name)))
+  | _ -> ()
+  end
+
+(* Emission of data *)
+
+let emit_item = function
+  | Cglobal_symbol s -> D.global (emit_symbol s)
+  | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s)
+  | Cint8 n -> D.byte (const n)
+  | Cint16 n -> D.word (const n)
+  | Cint32 n -> D.long (const_nat n)
+  | Cint n -> D.qword (const_nat n)
+  | Csingle f -> D.long  (Const (Int64.of_int32 (Int32.bits_of_float f)))
+  | Cdouble f -> D.qword (Const (Int64.bits_of_float f))
+  | Csymbol_address s -> add_used_symbol s; D.qword (ConstLabel (emit_symbol s))
+  | Cstring s -> D.bytes s
+  | Cskip n -> if n > 0 then D.space n
+  | Calign n -> D.align n
+
+let data l =
+  D.data ();
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  X86_proc.reset_asm_code ();
+  reset_debug_info();                   (* PR#5603 *)
+  reset_imp_table();
+  float_constants := [];
+  all_functions := [];
+  if system = S_win64 then begin
+    D.extrn "caml_young_ptr" QWORD;
+    D.extrn "caml_young_limit" QWORD;
+    D.extrn "caml_exception_pointer" QWORD;
+    D.extrn "caml_call_gc" NEAR;
+    D.extrn "caml_c_call" NEAR;
+    D.extrn "caml_allocN" NEAR;
+    D.extrn "caml_alloc1" NEAR;
+    D.extrn "caml_alloc2" NEAR;
+    D.extrn "caml_alloc3" NEAR;
+    D.extrn "caml_ml_array_bound_error" NEAR;
+    D.extrn "caml_raise_exn" NEAR;
+  end;
+
+
+  if !Clflags.dlcode || Arch.win64 then begin
+    (* from amd64.S; could emit these constants on demand *)
+    begin match system with
+    | S_macosx -> D.section ["__TEXT";"__literal16"] None ["16byte_literals"]
+    | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") []
+    | S_win64 -> D.data ()
+    | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"]
+    end;
+    D.align 16;
+    _label (emit_symbol "caml_negf_mask");
+    D.qword (Const 0x8000000000000000L);
+    D.qword (Const 0L);
+    D.align 16;
+    _label (emit_symbol "caml_absf_mask");
+    D.qword (Const 0x7FFFFFFFFFFFFFFFL);
+    D.qword (Const 0xFFFFFFFFFFFFFFFFL);
+  end;
+
+  D.data ();
+  emit_global_label "data_begin";
+
+  D.text ();
+  emit_global_label "code_begin";
+  if system = S_macosx then I.nop (); (* PR#4690 *)
+  ()
+
+let emit_spacetime_shapes () =
+  D.data ();
+  D.align 8;
+  emit_global_label "spacetime_shapes";
+  List.iter (fun fundecl ->
+      (* CR-someday mshinwell: some of this should be platform independent *)
+      begin match fundecl.fun_spacetime_shape with
+      | None -> ()
+      | Some shape ->
+        let funsym = emit_symbol fundecl.fun_name in
+        D.comment ("Shape for " ^ funsym ^ ":");
+        D.qword (ConstLabel funsym);
+        List.iter (fun (part_of_shape, label) ->
+            let tag =
+              match part_of_shape with
+              | Direct_call_point _ -> 1
+              | Indirect_call_point -> 2
+              | Allocation_point -> 3
+            in
+            D.qword (Const (Int64.of_int tag));
+            D.qword (ConstLabel (emit_label label));
+            begin match part_of_shape with
+            | Direct_call_point { callee; } ->
+              D.qword (ConstLabel (emit_symbol callee))
+            | Indirect_call_point -> ()
+            | Allocation_point -> ()
+            end)
+          shape;
+          D.qword (Const 0L)
+      end)
+    !all_functions;
+  D.qword (Const 0L);
+  D.comment "End of Spacetime shapes."
+
+let end_assembly() =
+  if !float_constants <> [] then begin
+    begin match system with
+    | S_macosx -> D.section ["__TEXT";"__literal8"] None ["8byte_literals"]
+    | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") []
+    | S_win64 -> D.data ()
+    | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"]
+    end;
+    List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants
+  end;
+
+  D.text ();
+  if system = S_macosx then I.nop ();
+  (* suppress "ld warning: atom sorting error" *)
+
+  emit_global_label "code_end";
+
+  emit_imp_table();
+
+  D.data ();
+  emit_global_label "data_end";
+  D.long (const 0);
+
+  emit_global_label "frametable";
+
+  let setcnt = ref 0 in
+  emit_frames
+    { efa_code_label = (fun l -> D.qword (ConstLabel (emit_label l)));
+      efa_data_label = (fun l -> D.qword (ConstLabel (emit_label l)));
+      efa_16 = (fun n -> D.word (const n));
+      efa_32 = (fun n -> D.long (const_32 n));
+      efa_word = (fun n -> D.qword (const n));
+      efa_align = D.align;
+      efa_label_rel =
+        (fun lbl ofs ->
+           let c =
+             ConstAdd (
+               ConstSub(ConstLabel(emit_label lbl), ConstThis),
+               const_32 ofs
+             ) in
+           if system = S_macosx then begin
+             incr setcnt;
+             let s = Printf.sprintf "L$set$%d" !setcnt in
+             D.setvar (s, c);
+             D.long (ConstLabel s)
+           end else
+             D.long c
+        );
+      efa_def_label = (fun l -> _label (emit_label l));
+      efa_string = (fun s -> D.bytes (s ^ "\000"))
+    };
+
+  if Config.spacetime then begin
+    emit_spacetime_shapes ()
+  end;
+
+  if system = S_linux then
+    (* Mark stack as non-executable, PR#4564 *)
+    D.section [".note.GNU-stack"] (Some "") [ "%progbits" ];
+
+  if system = S_win64 then begin
+    D.comment "External functions";
+    StringSet.iter
+      (fun s ->
+         if not (StringSet.mem s !symbols_defined) then
+           D.extrn (emit_symbol s) NEAR)
+      !symbols_used;
+    symbols_used := StringSet.empty;
+    symbols_defined := StringSet.empty;
+  end;
+
+  let asm =
+    if !Emitaux.create_asm_file then
+      Some
+        (
+         (if X86_proc.masm then X86_masm.generate_asm
+          else X86_gas.generate_asm) !Emitaux.output_channel
+        )
+    else
+      None
+  in
+  X86_proc.generate_code asm
diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
new file mode 100644
index 00000000..0b2cc119
--- /dev/null
+++ b/asmcomp/amd64/proc.ml
@@ -0,0 +1,343 @@
+# 2 "asmcomp/amd64/proc.ml"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the AMD64 processor *)
+
+open Misc
+open Arch
+open Cmm
+open Reg
+open Mach
+
+let fp = Config.with_frame_pointers
+
+(* Which ABI to use *)
+
+let win64 = Arch.win64
+
+(* Registers available for register allocation *)
+
+(* Register map:
+    rax         0
+    rbx         1
+    rdi         2
+    rsi         3
+    rdx         4
+    rcx         5
+    r8          6
+    r9          7
+    r12         8
+    r13         9
+    r10         10
+    r11         11
+    rbp         12
+    r14         trap pointer
+    r15         allocation pointer
+
+  xmm0 - xmm15  100 - 115  *)
+
+(* Conventions:
+     rax - r13: OCaml function arguments
+     rax: OCaml and C function results
+     xmm0 - xmm9: OCaml function arguments
+     xmm0: OCaml and C function results
+   Under Unix:
+     rdi, rsi, rdx, rcx, r8, r9: C function arguments
+     xmm0 - xmm7: C function arguments
+     rbx, rbp, r12-r15 are preserved by C
+     xmm registers are not preserved by C
+   Under Win64:
+     rcx, rdx, r8, r9: C function arguments
+     xmm0 - xmm3: C function arguments
+     rbx, rbp, rsi, rdi r12-r15 are preserved by C
+     xmm6-xmm15 are preserved by C
+   Note (PR#5707): r11 should not be used for parameter passing, as it
+     can be destroyed by the dynamic loader according to SVR4 ABI.
+     Linux's dynamic loader also destroys r10.
+*)
+
+let max_arguments_for_tailcalls = 10
+
+let int_reg_name =
+  match Config.ccomp_type with
+  | "msvc" ->
+      [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
+         "r12"; "r13"; "r10"; "r11"; "rbp" |]
+  | _ ->
+      [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
+         "%r12"; "%r13"; "%r10"; "%r11"; "%rbp" |]
+
+let float_reg_name =
+  match Config.ccomp_type with
+  | "msvc" ->
+      [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7";
+         "xmm8"; "xmm9"; "xmm10"; "xmm11";
+         "xmm12"; "xmm13"; "xmm14"; "xmm15" |]
+  | _ ->
+      [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7";
+         "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11";
+         "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |]
+
+let num_register_classes = 2
+
+let register_class r =
+  match r.typ with
+  | Val | Int | Addr -> 0
+  | Float -> 1
+
+let num_available_registers = [| 13; 16 |]
+
+let first_available_register = [| 0; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+(* Pack registers starting at %rax so as to reduce the number of REX
+   prefixes and thus improve code density *)
+let rotate_registers = false
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 13 Reg.dummy in
+  for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done;
+  v
+
+let hard_float_reg =
+  let v = Array.make 16 Reg.dummy in
+  for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done;
+  v
+
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let rax = phys_reg 0
+let rdx = phys_reg 4
+let r13 = phys_reg 9
+let rbp = phys_reg 12
+let rxmm15 = phys_reg 115
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Calling conventions *)
+
+let calling_conventions first_int last_int first_float last_float make_stack
+                        arg =
+  let loc = Array.make (Array.length arg) Reg.dummy in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref 0 in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+    | Val | Int | Addr as ty ->
+        if !int <= last_int then begin
+          loc.(i) <- phys_reg !int;
+          incr int
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !float <= last_float then begin
+          loc.(i) <- phys_reg !float;
+          incr float
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+let max_int_args_in_regs () =
+  if Config.spacetime then 9 else 10
+
+let loc_arguments arg =
+  calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 outgoing arg
+let loc_parameters arg =
+  let (loc, _ofs) =
+    calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 incoming arg
+  in
+  loc
+let loc_results res =
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+
+let loc_spacetime_node_hole = r13
+
+(* C calling conventions under Unix:
+     first integer args in rdi, rsi, rdx, rcx, r8, r9
+     first float args in xmm0 ... xmm7
+     remaining args on stack
+     return value in rax or xmm0.
+  C calling conventions under Win64:
+     first integer args in rcx, rdx, r8, r9
+     first float args in xmm0 ... xmm3
+     each integer arg consumes a float reg, and conversely
+     remaining args on stack
+     always 32 bytes reserved at bottom of stack.
+     Return value in rax or xmm0. *)
+
+let loc_external_results res =
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+
+let unix_loc_external_arguments arg =
+  calling_conventions 2 7 100 107 outgoing arg
+
+let win64_int_external_arguments =
+  [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |]
+let win64_float_external_arguments =
+  [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |]
+
+let win64_loc_external_arguments arg =
+  let loc = Array.make (Array.length arg) Reg.dummy in
+  let reg = ref 0
+  and ofs = ref 32 in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+    | Val | Int | Addr as ty ->
+        if !reg < 4 then begin
+          loc.(i) <- phys_reg win64_int_external_arguments.(!reg);
+          incr reg
+        end else begin
+          loc.(i) <- stack_slot (Outgoing !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !reg < 4 then begin
+          loc.(i) <- phys_reg win64_float_external_arguments.(!reg);
+          incr reg
+        end else begin
+          loc.(i) <- stack_slot (Outgoing !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
+
+let loc_external_arguments arg =
+  let arg =
+    Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg
+  in
+  let loc, alignment =
+    if win64 then win64_loc_external_arguments arg
+    else unix_loc_external_arguments arg
+  in
+  Array.map (fun reg -> [|reg|]) loc, alignment
+
+let loc_exn_bucket = rax
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _rs = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call =
+  if win64 then
+    (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
+    Array.of_list(List.map phys_reg
+      [0;4;5;6;7;10;11;
+       100;101;102;103;104;105])
+  else
+    (* Unix: rbp, rbx, r12-r15 preserved *)
+    Array.of_list(List.map phys_reg
+      [0;2;3;4;5;6;7;10;11;
+       100;101;102;103;104;105;106;107;
+       108;109;110;111;112;113;114;115])
+
+let destroyed_at_oper = function
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
+  | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _))
+        -> [| rax; rdx |]
+  | Iop(Istore(Single, _, _)) -> [| rxmm15 |]
+  | Iop(Ialloc _) when Config.spacetime
+        -> [| rax; loc_spacetime_node_hole |]
+  | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _))
+        -> [| rax |]
+  | Iop (Iintop (Icheckbound _)) when Config.spacetime ->
+      [| loc_spacetime_node_hole |]
+  | Iop (Iintop_imm(Icheckbound _, _)) when Config.spacetime ->
+      [| loc_spacetime_node_hole |]
+  | Iswitch(_, _) -> [| rax; rdx |]
+  | _ ->
+    if fp then
+(* prevent any use of the frame pointer ! *)
+      [| rbp |]
+    else
+      [||]
+
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+
+let safe_register_pressure = function
+    Iextcall _ -> if win64 then if fp then 7 else 8 else 0
+  | _ -> if fp then 10 else 11
+
+let max_register_pressure = function
+    Iextcall _ ->
+      if win64 then
+        if fp then [| 7; 10 |]  else [| 8; 10 |]
+        else
+        if fp then [| 3; 0 |] else  [| 4; 0 |]
+  | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) ->
+    if fp then [| 10; 16 |] else [| 11; 16 |]
+  | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) ->
+    if fp then [| 11; 16 |] else [| 12; 16 |]
+  | Istore(Single, _, _) ->
+    if fp then [| 12; 15 |] else [| 13; 15 |]
+  | _ -> if fp then [| 12; 16 |] else [| 13; 16 |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers). *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
+  | Ispecific(Ilea _) -> true
+  | Ispecific _ -> false
+  | _ -> true
+
+(* Layout of the stack frame *)
+
+let num_stack_slots = [| 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler *)
+
+let assemble_file infile outfile =
+  X86_proc.assemble_file infile outfile
+
+let init () =
+  if fp then begin
+    num_available_registers.(0) <- 12
+  end else
+    num_available_registers.(0) <- 13
diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml
new file mode 100644
index 00000000..690e0165
--- /dev/null
+++ b/asmcomp/amd64/reload.ml
@@ -0,0 +1,128 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmm
+open Reg
+open Mach
+
+(* Reloading for the AMD64 *)
+
+(* Summary of instruction set constraints:
+   "S" means either stack or register, "R" means register only.
+   Operation                    Res     Arg1    Arg2
+     Imove                      R       S
+                             or S       R
+     Iconst_int                 S if 32-bit signed, R otherwise
+     Iconst_float               R
+     Iconst_symbol (not PIC)    S
+     Iconst_symbol (PIC)        R
+     Icall_ind                          R
+     Itailcall_ind                      R
+     Iload                      R       R       R
+     Istore                             R       R
+     Iintop(Icomp)              R       R       S
+                            or  S       S       R
+     Iintop(Imul|Idiv|Imod)     R       R       S
+     Iintop(Imulh)              R       R       S
+     Iintop(shift)              S       S       R
+     Iintop(others)             R       R       S
+                            or  S       S       R
+     Iintop_imm(Iadd, n)/lea    R       R
+     Iintop_imm(others)         S       S
+     Inegf...Idivf              R       R       S
+     Ifloatofint                R       S
+     Iintoffloat                R       S
+     Ispecific(Ilea)            R       R       R
+     Ispecific(Ifloatarithmem)  R       R       R
+
+   Conditional branches:
+     Iinttest                           S       R
+                                    or  R       S
+     Ifloattest                         R       S    (or  S R if swapped test)
+     other tests                        S
+*)
+
+let stackp r =
+  match r.loc with
+    Stack _ -> true
+  | _ -> false
+
+class reload = object (self)
+
+inherit Reloadgen.reload_generic as super
+
+method! reload_operation op arg res =
+  match op with
+  | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) ->
+      (* One of the two arguments can reside in the stack, but not both *)
+      if stackp arg.(0) && stackp arg.(1)
+      then ([|arg.(0); self#makereg arg.(1)|], res)
+      else (arg, res)
+  | Iintop_imm(Iadd, _) when arg.(0).loc <> res.(0).loc ->
+      (* This add will be turned into a lea; args and results must be
+         in registers *)
+      super#reload_operation op arg res
+  | Iintop(Imulh | Idiv | Imod | Ilsl | Ilsr | Iasr)
+  | Iintop_imm(_, _) ->
+      (* The argument(s) and results can be either in register or on stack *)
+      (* Note: Imulh, Idiv, Imod: arg(0) and res(0) already forced in regs
+               Ilsl, Ilsr, Iasr: arg(1) already forced in regs *)
+      (arg, res)
+  | Iintop(Imul) | Iaddf | Isubf | Imulf | Idivf ->
+      (* First argument (= result) must be in register, second arg
+         can reside in the stack *)
+      if stackp arg.(0)
+      then (let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|]))
+      else (arg, res)
+  | Ifloatofint | Iintoffloat ->
+      (* Result must be in register, but argument can be on stack *)
+      (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res))
+  | Iconst_int n ->
+      if n <= 0x7FFFFFFFn && n >= -0x80000000n
+      then (arg, res)
+      else super#reload_operation op arg res
+  | Iconst_symbol _ ->
+      if !Clflags.pic_code || !Clflags.dlcode || Arch.win64
+      then super#reload_operation op arg res
+      else (arg, res)
+  | _ -> (* Other operations: all args and results in registers *)
+      super#reload_operation op arg res
+
+method! reload_test tst arg =
+  match tst with
+    Iinttest _ ->
+      (* One of the two arguments can reside on stack *)
+      if stackp arg.(0) && stackp arg.(1)
+      then [| self#makereg arg.(0); arg.(1) |]
+      else arg
+  | Ifloattest((Clt|Cle), _) ->
+      (* Cf. emit.mlp: we swap arguments in this case *)
+      (* First argument can be on stack, second must be in register *)
+      if stackp arg.(1)
+      then [| arg.(0); self#makereg arg.(1) |]
+      else arg
+  | Ifloattest((Ceq|Cne|Cgt|Cge), _) ->
+      (* Second argument can be on stack, first must be in register *)
+      if stackp arg.(0)
+      then [| self#makereg arg.(0); arg.(1) |]
+      else arg
+  | _ ->
+      (* The argument(s) can be either in register or on stack *)
+      arg
+
+end
+
+let fundecl f =
+  (new reload)#fundecl f
diff --git a/asmcomp/amd64/scheduling.ml b/asmcomp/amd64/scheduling.ml
new file mode 100644
index 00000000..ad146c50
--- /dev/null
+++ b/asmcomp/amd64/scheduling.ml
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let _ = let module M = Schedgen in () (* to create a dependency *)
+
+(* Scheduling is turned off because the processor schedules dynamically
+   much better than what we could do. *)
+
+let fundecl f = f
diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
new file mode 100644
index 00000000..336120f4
--- /dev/null
+++ b/asmcomp/amd64/selection.ml
@@ -0,0 +1,271 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the AMD64 *)
+
+open Arch
+open Proc
+open Cmm
+open Mach
+
+(* Auxiliary for recognizing addressing modes *)
+
+type addressing_expr =
+    Asymbol of string
+  | Alinear of expression
+  | Aadd of expression * expression
+  | Ascale of expression * int
+  | Ascaledadd of expression * expression * int
+
+let rec select_addr exp =
+  match exp with
+    Cconst_symbol s when not !Clflags.dlcode ->
+      (Asymbol s, 0)
+  | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) ->
+      let (a, n) = select_addr arg in (a, n + m)
+  | Cop(Csubi, [arg; Cconst_int m], _) ->
+      let (a, n) = select_addr arg in (a, n - m)
+  | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) ->
+      let (a, n) = select_addr arg in (a, n + m)
+  | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) ->
+      begin match select_addr arg with
+        (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
+      | _ -> (Alinear exp, 0)
+      end
+  | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) ->
+      begin match select_addr arg with
+        (Alinear e, n) -> (Ascale(e, mult), n * mult)
+      | _ -> (Alinear exp, 0)
+      end
+  | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) ->
+      begin match select_addr arg with
+        (Alinear e, n) -> (Ascale(e, mult), n * mult)
+      | _ -> (Alinear exp, 0)
+      end
+  | Cop((Caddi | Caddv | Cadda), [arg1; arg2], _) ->
+      begin match (select_addr arg1, select_addr arg2) with
+          ((Alinear e1, n1), (Alinear e2, n2)) ->
+              (Aadd(e1, e2), n1 + n2)
+        | ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
+              (Ascaledadd(e1, e2, scale), n1 + n2)
+        | ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
+              (Ascaledadd(e2, e1, scale), n1 + n2)
+        | (_, (Ascale(e2, scale), n2)) ->
+              (Ascaledadd(arg1, e2, scale), n2)
+        | ((Ascale(e1, scale), n1), _) ->
+              (Ascaledadd(arg2, e1, scale), n1)
+        | _ ->
+              (Aadd(arg1, arg2), 0)
+      end
+  | arg ->
+      (Alinear arg, 0)
+
+(* Special constraints on operand and result registers *)
+
+exception Use_default
+
+let rax = phys_reg 0
+let rcx = phys_reg 5
+let rdx = phys_reg 4
+
+let pseudoregs_for_operation op arg res =
+  match op with
+  (* Two-address binary operations: arg.(0) and res.(0) must be the same *)
+    Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf ->
+      ([|res.(0); arg.(1)|], res)
+  (* One-address unary operations: arg.(0) and res.(0) must be the same *)
+  | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _)
+  | Iabsf | Inegf
+  | Ispecific(Ibswap (32|64)) ->
+      (res, res)
+  (* For xchg, args must be a register allowing access to high 8 bit register
+     (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *)
+  | Ispecific(Ibswap 16) ->
+      ([| rax |], [| rax |])
+  (* For imulq, first arg must be in rax, rax is clobbered, and result is in
+     rdx. *)
+  | Iintop(Imulh) ->
+      ([| rax; arg.(1) |], [| rdx |])
+  | Ispecific(Ifloatarithmem(_,_)) ->
+      let arg' = Array.copy arg in
+      arg'.(0) <- res.(0);
+      (arg', res)
+  (* For shifts with variable shift count, second arg must be in rcx *)
+  | Iintop(Ilsl|Ilsr|Iasr) ->
+      ([|res.(0); rcx|], res)
+  (* For div and mod, first arg must be in rax, rdx is clobbered,
+     and result is in rax or rdx respectively.
+     Keep it simple, just force second argument in rcx. *)
+  | Iintop(Idiv) ->
+      ([| rax; rcx |], [| rax |])
+  | Iintop(Imod) ->
+      ([| rax; rcx |], [| rdx |])
+  (* Other instructions are regular *)
+  | _ -> raise Use_default
+
+(* If you update [inline_ops], you may need to update [is_simple_expr] and/or
+   [effects_of], below. *)
+let inline_ops =
+  [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
+    "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
+
+(* The selector class *)
+
+class selector = object (self)
+
+inherit Spacetime_profiling.instruction_selection as super
+
+method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF)
+  (* -1-.... : hack so that this can be compiled on 32-bit
+     (cf 'make check_all_arches') *)
+
+method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
+
+method! is_simple_expr e =
+  match e with
+  | Cop(Cextcall (fn, _, _, _), args, _)
+    when List.mem fn inline_ops ->
+      (* inlined ops are simple if their arguments are *)
+      List.for_all self#is_simple_expr args
+  | _ ->
+      super#is_simple_expr e
+
+method! effects_of e =
+  match e with
+  | Cop(Cextcall(fn, _, _, _), args, _)
+    when List.mem fn inline_ops ->
+      Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+  | _ ->
+      super#effects_of e
+
+method select_addressing _chunk exp =
+  let (a, d) = select_addr exp in
+  (* PR#4625: displacement must be a signed 32-bit immediate *)
+  if not (self # is_immediate d)
+  then (Iindexed 0, exp)
+  else match a with
+    | Asymbol s ->
+        (Ibased(s, d), Ctuple [])
+    | Alinear e ->
+        (Iindexed d, e)
+    | Aadd(e1, e2) ->
+        (Iindexed2 d, Ctuple[e1; e2])
+    | Ascale(e, scale) ->
+        (Iscaled(scale, d), e)
+    | Ascaledadd(e1, e2, scale) ->
+        (Iindexed2scaled(scale, d), Ctuple[e1; e2])
+
+method! select_store is_assign addr exp =
+  match exp with
+    Cconst_int n when self#is_immediate n ->
+      (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
+  | (Cconst_natint n) when self#is_immediate_natint n ->
+      (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
+  | (Cblockheader(n, _dbg))
+      when self#is_immediate_natint n && not Config.spacetime ->
+      (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
+  | Cconst_pointer n when self#is_immediate n ->
+      (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
+  | Cconst_natpointer n when self#is_immediate_natint n ->
+      (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
+  | _ ->
+      super#select_store is_assign addr exp
+
+method! select_operation op args dbg =
+  match op with
+  (* Recognize the LEA instruction *)
+    Caddi | Caddv | Cadda | Csubi ->
+      begin match self#select_addressing Word_int (Cop(op, args, dbg)) with
+        (Iindexed _, _)
+      | (Iindexed2 0, _) -> super#select_operation op args dbg
+      | (addr, arg) -> (Ispecific(Ilea addr), [arg])
+      end
+  (* Recognize float arithmetic with memory. *)
+  | Caddf ->
+      self#select_floatarith true Iaddf Ifloatadd args
+  | Csubf ->
+      self#select_floatarith false Isubf Ifloatsub args
+  | Cmulf ->
+      self#select_floatarith true Imulf Ifloatmul args
+  | Cdivf ->
+      self#select_floatarith false Idivf Ifloatdiv args
+  | Cextcall("sqrt", _, false, _) ->
+     begin match args with
+       [Cop(Cload ((Double|Double_u as chunk), _), [loc], _dbg)] ->
+         let (addr, arg) = self#select_addressing chunk loc in
+         (Ispecific(Ifloatsqrtf addr), [arg])
+     | [arg] ->
+         (Ispecific Isqrtf, [arg])
+     | _ ->
+         assert false
+     end
+  (* Recognize store instructions *)
+  | Cstore ((Word_int|Word_val as chunk), _init) ->
+      begin match args with
+        [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)]
+        when loc = loc' && self#is_immediate n ->
+          let (addr, arg) = self#select_addressing chunk loc in
+          (Ispecific(Ioffset_loc(n, addr)), [arg])
+      | _ ->
+          super#select_operation op args dbg
+      end
+  | Cextcall("caml_bswap16_direct", _, _, _) ->
+      (Ispecific (Ibswap 16), args)
+  | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+      (Ispecific (Ibswap 32), args)
+  | Cextcall("caml_int64_direct_bswap", _, _, _)
+  | Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
+      (Ispecific (Ibswap 64), args)
+  (* AMD64 does not support immediate operands for multiply high signed *)
+  | Cmulhi ->
+      (Iintop Imulh, args)
+  | _ -> super#select_operation op args dbg
+
+(* Recognize float arithmetic with mem *)
+
+method select_floatarith commutative regular_op mem_op args =
+  match args with
+    [arg1; Cop(Cload ((Double|Double_u as chunk), _), [loc2], _)] ->
+      let (addr, arg2) = self#select_addressing chunk loc2 in
+      (Ispecific(Ifloatarithmem(mem_op, addr)),
+                 [arg1; arg2])
+  | [Cop(Cload ((Double|Double_u as chunk), _), [loc1], _); arg2]
+        when commutative ->
+      let (addr, arg1) = self#select_addressing chunk loc1 in
+      (Ispecific(Ifloatarithmem(mem_op, addr)),
+                 [arg2; arg1])
+  | [arg1; arg2] ->
+      (regular_op, [arg1; arg2])
+  | _ ->
+      assert false
+
+method! mark_c_tailcall =
+  Proc.contains_calls := true
+
+(* Deal with register constraints *)
+
+method! insert_op_debug op dbg rs rd =
+  try
+    let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
+    self#insert_moves rs rsrc;
+    self#insert_debug (Iop op) dbg rsrc rdst;
+    self#insert_moves rdst rd;
+    rd
+  with Use_default ->
+    super#insert_op_debug op dbg rs rd
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml
new file mode 100644
index 00000000..2269cbec
--- /dev/null
+++ b/asmcomp/arm/CSE.ml
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for ARM *)
+
+open Arch
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+  match op with
+  | Ispecific(Ishiftcheckbound _) -> Op_checkbound
+  | Ispecific _ -> Op_pure
+  | _ -> super#class_of_operation op
+
+method! is_cheap_operation op =
+  match op with
+  | Iconst_int n -> n <= 255n && n >= 0n
+  | _ -> false
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/arm/NOTES.md b/asmcomp/arm/NOTES.md
new file mode 100644
index 00000000..7a8ae671
--- /dev/null
+++ b/asmcomp/arm/NOTES.md
@@ -0,0 +1,20 @@
+# Supported platforms
+
+A great many variants of the ARM 32-bit architecture:
+* Architecture versions: v4, v5, v5te, v6, v6t2, v7.
+  ARMv7 is the standard nowadays.
+* Instruction encoding: classic ARM or Thumb or Thumb-2.
+* Floating-point: software emulation, VFPv2, VFPv3-d16, VFP-v3.
+* ABI: the standard EABI (with floats passed in integer registers)
+  or the EABI-HF variant (with floats passed in VFP registers).
+
+Debian architecture names: `armel` and `armhf`.
+
+# Reference documents
+
+* Instruction set architecture:
+  _ARM Architecture Reference Manual, ARMv7-A and ARMv7-R edition_.
+  Alternatively:
+  _ARM Architecture Reference Manual, ARMv8_, restricted to the AArch32 subset.
+* Application binary interface:
+  _Procedure Call Standard for the ARM Architecture_
diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml
new file mode 100644
index 00000000..0bee7e1e
--- /dev/null
+++ b/asmcomp/arm/arch.ml
@@ -0,0 +1,262 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Specific operations for the ARM processor *)
+
+open Format
+
+type abi = EABI | EABI_HF
+type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7
+type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3
+
+let abi =
+  match Config.system with
+    "linux_eabi" | "freebsd" -> EABI
+  | "linux_eabihf" | "netbsd" -> EABI_HF
+  | _ -> assert false
+
+let string_of_arch = function
+    ARMv4   -> "armv4"
+  | ARMv5   -> "armv5"
+  | ARMv5TE -> "armv5te"
+  | ARMv6   -> "armv6"
+  | ARMv6T2 -> "armv6t2"
+  | ARMv7   -> "armv7"
+
+let string_of_fpu = function
+    Soft      -> "soft"
+  | VFPv2     -> "vfpv2"
+  | VFPv3_D16 -> "vfpv3-d16"
+  | VFPv3     -> "vfpv3"
+
+(* Machine-specific command-line options *)
+
+let (arch, fpu, thumb) =
+  let (def_arch, def_fpu, def_thumb) =
+    begin match abi, Config.model with
+    (* Defaults for architecture, FPU and Thumb *)
+      EABI, "armv5"    -> ARMv5,   Soft,      false
+    | EABI, "armv5te"  -> ARMv5TE, Soft,      false
+    | EABI, "armv6"    -> ARMv6,   Soft,      false
+    | EABI, "armv6t2"  -> ARMv6T2, Soft,      false
+    | EABI, "armv7"    -> ARMv7,   Soft,      false
+    | EABI, _          -> ARMv4,   Soft,      false
+    | EABI_HF, "armv6" -> ARMv6,   VFPv2,     false
+    | EABI_HF, _       -> ARMv7,   VFPv3_D16, true
+    end in
+  (ref def_arch, ref def_fpu, ref def_thumb)
+
+let farch spec =
+  arch := begin match spec with
+             "armv4" when abi <> EABI_HF   -> ARMv4
+           | "armv5" when abi <> EABI_HF   -> ARMv5
+           | "armv5te" when abi <> EABI_HF -> ARMv5TE
+           | "armv6"                       -> ARMv6
+           | "armv6t2"                     -> ARMv6T2
+           | "armv7"                       -> ARMv7
+           | spec -> raise (Arg.Bad ("wrong '-farch' option: " ^ spec))
+  end
+
+let ffpu spec =
+  fpu := begin match spec with
+            "soft" when abi <> EABI_HF     -> Soft
+          | "vfpv2" when abi = EABI_HF     -> VFPv2
+          | "vfpv3-d16" when abi = EABI_HF -> VFPv3_D16
+          | "vfpv3" when abi = EABI_HF     -> VFPv3
+          | spec -> raise (Arg.Bad ("wrong '-ffpu' option: " ^ spec))
+  end
+
+let command_line_options =
+  [ "-farch", Arg.String farch,
+      "  Select the ARM target architecture"
+      ^ " (default: " ^ (string_of_arch !arch) ^ ")";
+    "-ffpu", Arg.String ffpu,
+      "  Select the floating-point hardware"
+      ^ " (default: " ^ (string_of_fpu !fpu) ^ ")";
+    "-fPIC", Arg.Set Clflags.pic_code,
+      " Generate position-independent machine code";
+    "-fno-PIC", Arg.Clear Clflags.pic_code,
+      " Generate position-dependent machine code";
+    "-fthumb", Arg.Set thumb,
+      " Enable Thumb/Thumb-2 code generation"
+      ^ (if !thumb then " (default)" else "");
+    "-fno-thumb", Arg.Clear thumb,
+      " Disable Thumb/Thumb-2 code generation"
+      ^ (if not !thumb then " (default" else "")]
+
+(* Addressing modes *)
+
+type addressing_mode =
+    Iindexed of int                     (* reg + displ *)
+
+(* We do not support the reg + shifted reg addressing mode, because
+   what we really need is reg + shifted reg + displ,
+   and this is decomposed in two instructions (reg + shifted reg -> tmp,
+   then addressing tmp + displ). *)
+
+(* Specific operations *)
+
+type specific_operation =
+    Ishiftarith of arith_operation * shift_operation * int
+  | Ishiftcheckbound of shift_operation * int
+  | Irevsubimm of int
+  | Imulhadd      (* multiply high and add *)
+  | Imuladd       (* multiply and add *)
+  | Imulsub       (* multiply and subtract *)
+  | Inegmulf      (* floating-point negate and multiply *)
+  | Imuladdf      (* floating-point multiply and add *)
+  | Inegmuladdf   (* floating-point negate, multiply and add *)
+  | Imulsubf      (* floating-point multiply and subtract *)
+  | Inegmulsubf   (* floating-point negate, multiply and subtract *)
+  | Isqrtf        (* floating-point square root *)
+  | Ibswap of int (* endianess conversion *)
+
+and arith_operation =
+    Ishiftadd
+  | Ishiftsub
+  | Ishiftsubrev
+  | Ishiftand
+  | Ishiftor
+  | Ishiftxor
+
+and shift_operation =
+    Ishiftlogicalleft
+  | Ishiftlogicalright
+  | Ishiftarithmeticright
+
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let size_addr = 4
+let size_int = 4
+let size_float = 8
+
+let allow_unaligned_access = false
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing (Iindexed n) delta = Iindexed(n + delta)
+
+let num_args_addressing (Iindexed _) = 1
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Iindexed n ->
+      printreg ppf arg.(0);
+      if n <> 0 then fprintf ppf " + %i" n
+
+let shiftop_name = function
+  | Ishiftlogicalleft -> "<<"
+  | Ishiftlogicalright -> ">>u"
+  | Ishiftarithmeticright -> ">>s"
+
+let print_specific_operation printreg op ppf arg =
+  match op with
+    Ishiftarith(op, shiftop, amount) ->
+      let (op1_name, op2_name) = match op with
+          Ishiftadd -> ("", "+")
+        | Ishiftsub -> ("", "-")
+        | Ishiftsubrev -> ("-", "+")
+        | Ishiftand -> ("", "&")
+        | Ishiftor -> ("", "|")
+        | Ishiftxor -> ("", "^") in
+      fprintf ppf "%s%a %s (%a %s %i)"
+        op1_name
+        printreg arg.(0)
+        op2_name
+        printreg arg.(1)
+        (shiftop_name shiftop)
+        amount
+  | Ishiftcheckbound(shiftop, amount) ->
+      fprintf ppf "check (%a %s %i) > %a"
+        printreg arg.(0)
+        (shiftop_name shiftop)
+        amount
+        printreg arg.(1)
+  | Irevsubimm n ->
+      fprintf ppf "%i %s %a" n "-" printreg arg.(0)
+  | Imulhadd ->
+      fprintf ppf "%a *h %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imuladd ->
+      fprintf ppf "(%a * %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imulsub ->
+      fprintf ppf "-(%a * %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmulf ->
+      fprintf ppf "-f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+  | Imuladdf ->
+      fprintf ppf "%a +f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmuladdf ->
+      fprintf ppf "%a -f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imulsubf ->
+      fprintf ppf "(-f %a) +f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmulsubf ->
+      fprintf ppf "(-f %a) -f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Isqrtf ->
+      fprintf ppf "sqrtf %a"
+        printreg arg.(0)
+  | Ibswap n ->
+      fprintf ppf "bswap%i %a" n
+        printreg arg.(0)
+
+(* Recognize immediate operands *)
+
+(* Immediate operands are 8-bit immediate values, zero-extended,
+   and rotated right by 0 ... 30 bits.
+   In Thumb/Thumb-2 mode we utilize 26 ... 30. *)
+
+let is_immediate n =
+  let n = ref n in
+  let s = ref 0 in
+  let m = if !thumb then 24 else 30 in
+  while (!s <= m && Int32.logand !n 0xffl <> !n) do
+    n := Int32.logor (Int32.shift_right_logical !n 2) (Int32.shift_left !n 30);
+    s := !s + 2
+  done;
+  !s <= m
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
new file mode 100644
index 00000000..0563828e
--- /dev/null
+++ b/asmcomp/arm/emit.mlp
@@ -0,0 +1,960 @@
+#2 "asmcomp/arm/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of ARM assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+(* Output a label *)
+
+let emit_label lbl =
+  emit_string ".L"; emit_int lbl
+
+(* Symbols *)
+
+let emit_symbol s =
+  Emitaux.emit_symbol '$' s
+
+let emit_call s =
+  if !Clflags.dlcode || !Clflags.pic_code
+  then `bl	{emit_symbol s}(PLT)`
+  else `bl	{emit_symbol s}`
+
+let emit_jump s =
+  if !Clflags.dlcode || !Clflags.pic_code
+  then `b	{emit_symbol s}(PLT)`
+  else `b	{emit_symbol s}`
+
+(* Output a pseudo-register *)
+
+let emit_reg = function
+    {loc = Reg r} -> emit_string (register_name r)
+  | _ -> fatal_error "Emit_arm.emit_reg"
+
+(* Layout of the stack frame *)
+
+let stack_offset = ref 0
+
+let frame_size () =
+  let sz =
+    !stack_offset +
+    4 * num_stack_slots.(0) +
+    8 * num_stack_slots.(1) +
+    8 * num_stack_slots.(2) +
+    (if !contains_calls then 4 else 0)
+  in Misc.align sz 8
+
+let slot_offset loc cl =
+  match loc with
+    Incoming n ->
+      assert (n >= 0);
+      frame_size() + n
+  | Local n ->
+      if cl = 0
+      then !stack_offset + n * 4
+      else !stack_offset + num_stack_slots.(0) * 4 + n * 8
+  | Outgoing n ->
+      assert (n >= 0);
+      n
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+  | Stack s ->
+      let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]`
+  | _ -> fatal_error "Emit_arm.emit_stack"
+
+(* Output an addressing mode *)
+
+let emit_addressing addr r n =
+  match addr with
+    Iindexed ofs ->
+      `[{emit_reg r.(n)}, #{emit_int ofs}]`
+
+(* Record live pointers at call points *)
+
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := ((r lsl 1) + 1) :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ())
+    live;
+  record_frame_descr ~label:lbl ~frame_size:(frame_size())
+    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+  lbl
+
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_frame_lbl: label }               (* Label of frame descriptor *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  `{emit_label gc.gc_lbl}:	{emit_call "caml_call_gc"}\n`;
+  `{emit_label gc.gc_frame_lbl}:	b	{emit_label gc.gc_return_lbl}\n`
+
+(* Record calls to caml_ml_array_bound_error.
+   In debug mode, we maintain one call to caml_ml_array_bound_error
+   per bound check site. Otherwise, we can share a single call. *)
+
+type bound_error_call =
+  { bd_lbl: label;                    (* Entry label *)
+    bd_frame_lbl: label }             (* Label of frame descriptor *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+
+let bound_error_label ?label dbg =
+  if !Clflags.debug || !bound_error_sites = [] then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    bound_error_sites :=
+      { bd_lbl = lbl_bound_error;
+        bd_frame_lbl = lbl_frame } :: !bound_error_sites;
+    lbl_bound_error
+  end else begin
+    let bd = List.hd !bound_error_sites in bd.bd_lbl
+  end
+
+let emit_call_bound_error bd =
+  `{emit_label bd.bd_lbl}:	{emit_call "caml_ml_array_bound_error"}\n`;
+  `{emit_label bd.bd_frame_lbl}:\n`
+
+(* Negate a comparison *)
+
+let negate_integer_comparison = function
+    Isigned cmp   -> Isigned(negate_comparison cmp)
+  | Iunsigned cmp -> Iunsigned(negate_comparison cmp)
+
+(* Names of various instructions *)
+
+let name_for_comparison = function
+    Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
+  | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
+  | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
+  | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
+
+let name_for_int_operation = function
+  (* Use adds,subs,... to enable 16-bit T1 encoding *)
+    Iadd  -> "adds"
+  | Isub  -> "subs"
+  | Imul  -> "mul"
+  | Imulh -> "smmul"
+  | Iand  -> "ands"
+  | Ior   -> "orrs"
+  | Ixor  -> "eors"
+  | Ilsl  -> "lsls"
+  | Ilsr  -> "lsrs"
+  | Iasr  -> "asrs"
+  | _ -> assert false
+
+let name_for_shift_operation = function
+    Ishiftlogicalleft -> "lsl"
+  | Ishiftlogicalright -> "lsr"
+  | Ishiftarithmeticright -> "asr"
+
+(* General functional to decompose a non-immediate integer constant
+   into 8-bit chunks shifted left 0 ... 30 bits. *)
+
+let decompose_intconst n fn =
+  let i = ref n in
+  let shift = ref 0 in
+  let ninstr = ref 0 in
+  while !i <> 0l do
+    if Int32.logand (Int32.shift_right !i !shift) 3l = 0l then
+      shift := !shift + 2
+    else begin
+      let bits = Int32.logand !i (Int32.shift_left 0xffl !shift) in
+      i := Int32.sub !i bits;
+      shift := !shift + 8;
+      incr ninstr;
+      fn bits
+    end
+  done;
+  !ninstr
+
+(* Load an integer constant into a register *)
+
+let emit_intconst dst n =
+  let nr = Int32.lognot n in
+  if is_immediate n then begin
+    (* Use movs here to enable 16-bit T1 encoding *)
+    `	movs	{emit_reg dst}, #{emit_int32 n}\n`; 1
+  end else if is_immediate nr then begin
+    `	mvn	{emit_reg dst}, #{emit_int32 nr}\n`; 1
+  end else if !arch > ARMv6 then begin
+    let nl = Int32.logand 0xffffl n in
+    let nh = Int32.logand 0xffffl (Int32.shift_right_logical n 16) in
+    if nh = 0l then begin
+      `	movw	{emit_reg dst}, #{emit_int32 nl}\n`; 1
+    end else if Int32.logand nl 0xffl = nl then begin
+      `	movs	{emit_reg dst}, #{emit_int32 nl}\n`;
+      `	movt	{emit_reg dst}, #{emit_int32 nh}\n`; 2
+    end else begin
+      `	movw	{emit_reg dst}, #{emit_int32 nl}\n`;
+      `	movt	{emit_reg dst}, #{emit_int32 nh}\n`; 2
+    end
+  end else begin
+    let first = ref true in
+    decompose_intconst n
+      (fun bits ->
+        if !first
+        (* Use movs,adds here to enable 16-bit T1 encoding *)
+        then `	movs	{emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n`
+        else `	adds	{emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`;
+        first := false)
+  end
+
+(* Adjust sp (up or down) by the given byte amount *)
+
+let emit_stack_adjustment n =
+  if n = 0 then 0 else begin
+    let instr = if n < 0 then "sub" else "add" in
+    let ninstr = decompose_intconst (Int32.of_int (abs n))
+                   (fun bits ->
+                     `	{emit_string instr}	sp, sp, #{emit_int32 bits}\n`) in
+    cfi_adjust_cfa_offset (-n);
+    ninstr
+  end
+
+(* Deallocate the stack frame before a return or tail call *)
+
+let output_epilogue f =
+  let n = frame_size() in
+  if n > 0 then begin
+    let ninstr = emit_stack_adjustment n in
+    let ninstr = ninstr + f () in
+    (* reset CFA back cause function body may continue *)
+    cfi_adjust_cfa_offset n;
+    ninstr
+  end else
+    f ()
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+(* Pending floating-point literals *)
+let float_literals = ref ([] : (int64 * label) list)
+(* Pending relative references to the global offset table *)
+let gotrel_literals = ref ([] : (label * label) list)
+(* Pending symbol literals *)
+let symbol_literals = ref ([] : (string * label) list)
+(* Total space (in words) occupied by pending literals *)
+let num_literals = ref 0
+
+(* Label a floating-point literal *)
+let float_literal f =
+  try
+    List.assoc f !float_literals
+  with Not_found ->
+    let lbl = new_label() in
+    num_literals := !num_literals + 2;
+    float_literals := (f, lbl) :: !float_literals;
+    lbl
+
+(* Label a GOTREL literal *)
+let gotrel_literal l =
+  let lbl = new_label() in
+  num_literals := !num_literals + 1;
+  gotrel_literals := (l, lbl) :: !gotrel_literals;
+  lbl
+
+(* Label a symbol literal *)
+let symbol_literal s =
+  try
+    List.assoc s !symbol_literals
+  with Not_found ->
+    let lbl = new_label() in
+    num_literals := !num_literals + 1;
+    symbol_literals := (s, lbl) :: !symbol_literals;
+    lbl
+
+(* Emit all pending literals *)
+let emit_literals() =
+  if !float_literals <> [] then begin
+    `	.align	3\n`;
+    List.iter
+      (fun (f, lbl) ->
+        `{emit_label lbl}:`; emit_float64_split_directive ".long" f)
+      !float_literals;
+    float_literals := []
+  end;
+  if !symbol_literals <> [] then begin
+    let offset = if !thumb then 4 else 8 in
+    let suffix = if !Clflags.pic_code then "(GOT)" else "" in
+    `	.align	2\n`;
+    List.iter
+      (fun (l, lbl) ->
+        `{emit_label lbl}:	.word	_GLOBAL_OFFSET_TABLE_-({emit_label l}+{emit_int offset})\n`)
+      !gotrel_literals;
+    List.iter
+      (fun (s, lbl) ->
+        `{emit_label lbl}:	.word	{emit_symbol s}{emit_string suffix}\n`)
+      !symbol_literals;
+    gotrel_literals := [];
+    symbol_literals := []
+  end;
+  num_literals := 0
+
+(* Emit code to load the address of a symbol *)
+
+let emit_load_symbol_addr dst s =
+  if !Clflags.pic_code then begin
+    let lbl_pic = new_label() in
+    let lbl_got = gotrel_literal lbl_pic in
+    let lbl_sym = symbol_literal s in
+    (* Both r3 and r12 are marked as clobbered in PIC mode (cf. proc.ml),
+       so use r12 as temporary scratch register unless the destination is
+       r12, then we use r3 instead. *)
+    let tmp = if dst.loc = Reg 8 (*r12*)
+              then phys_reg 3 (*r3*)
+              else phys_reg 8 (*r12*) in
+    `	ldr	{emit_reg tmp}, {emit_label lbl_got}\n`;
+    `	ldr	{emit_reg dst}, {emit_label lbl_sym}\n`;
+    `{emit_label lbl_pic}:	add	{emit_reg tmp}, pc, {emit_reg tmp}\n`;
+    `	ldr	{emit_reg dst}, [{emit_reg tmp}, {emit_reg dst}] @ {emit_symbol s}\n`;
+    4
+  end else if !arch > ARMv6 && not !Clflags.dlcode && !fastcode_flag then begin
+    `	movw	{emit_reg dst}, #:lower16:{emit_symbol s}\n`;
+    `	movt	{emit_reg dst}, #:upper16:{emit_symbol s}\n`;
+    2
+  end else begin
+    let lbl = symbol_literal s in
+    `	ldr	{emit_reg dst}, {emit_label lbl} @ {emit_symbol s}\n`;
+    1
+  end
+
+(* Output the assembly code for an instruction *)
+
+let emit_instr i =
+    emit_debug_info i.dbg;
+    match i.desc with
+      Lend -> 0
+    | Lop(Imove | Ispill | Ireload) ->
+        let src = i.arg.(0) and dst = i.res.(0) in
+        if src.loc = dst.loc then 0 else begin
+          begin match (src, dst) with
+            {loc = Reg _; typ = Float}, {loc = Reg _} ->
+              `	fcpyd	{emit_reg dst}, {emit_reg src}\n`
+          | {loc = Reg _}, {loc = Reg _} ->
+              `	mov	{emit_reg dst}, {emit_reg src}\n`
+          | {loc = Reg _; typ = Float}, _ ->
+              `	fstd	{emit_reg src}, {emit_stack dst}\n`
+          | {loc = Reg _}, _ ->
+              `	str	{emit_reg src}, {emit_stack dst}\n`
+          | {typ = Float}, _ ->
+              `	fldd	{emit_reg dst}, {emit_stack src}\n`
+          | _ ->
+              `	ldr	{emit_reg dst}, {emit_stack src}\n`
+          end; 1
+        end
+    | Lop(Iconst_int n) ->
+        emit_intconst i.res.(0) (Nativeint.to_int32 n)
+    | Lop(Iconst_float f) when !fpu = Soft ->
+        let high_bits = Int64.to_int32 (Int64.shift_right_logical f 32)
+        and low_bits = Int64.to_int32 f in
+        if is_immediate low_bits || is_immediate high_bits then begin
+          let ninstr_low = emit_intconst i.res.(0) low_bits
+          and ninstr_high = emit_intconst i.res.(1) high_bits in
+          ninstr_low + ninstr_high
+        end else begin
+          let lbl = float_literal f in
+          `	ldr	{emit_reg i.res.(0)}, {emit_label lbl}\n`;
+          `	ldr	{emit_reg i.res.(1)}, {emit_label lbl} + 4\n`;
+          2
+        end
+    | Lop(Iconst_float f) when !fpu = VFPv2 ->
+        let lbl = float_literal f in
+        `	fldd	{emit_reg i.res.(0)}, {emit_label lbl}\n`;
+        1
+    | Lop(Iconst_float f) ->
+        let encode imm =
+          let sg = Int64.to_int (Int64.shift_right_logical imm 63) in
+          let ex = Int64.to_int (Int64.shift_right_logical imm 52) in
+          let ex = (ex land 0x7ff) - 1023 in
+          let mn = Int64.logand imm 0xfffffffffffffL in
+          if Int64.logand mn 0xffffffffffffL <> 0L || ex < -3 || ex > 4
+          then
+            None
+          else begin
+            let mn = Int64.to_int (Int64.shift_right_logical mn 48) in
+            if mn land 0x0f <> mn then
+              None
+            else
+              let ex = ((ex + 3) land 0x07) lxor 0x04 in
+              Some((sg lsl 7) lor (ex lsl 4) lor mn)
+          end in
+        begin match encode f with
+          None ->
+            let lbl = float_literal f in
+            `	fldd	{emit_reg i.res.(0)}, {emit_label lbl}\n`
+        | Some imm8 ->
+            `	fconstd	{emit_reg i.res.(0)}, #{emit_int imm8}\n`
+        end; 1
+    | Lop(Iconst_symbol s) ->
+        emit_load_symbol_addr i.res.(0) s
+    | Lop(Icall_ind { label_after; }) ->
+        if !arch >= ARMv5 then begin
+          `	blx	{emit_reg i.arg.(0)}\n`;
+          `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+        end else begin
+          `	mov	lr, pc\n`;
+          `	bx	{emit_reg i.arg.(0)}\n`;
+          `{record_frame i.live false i.dbg ~label:label_after}\n`; 2
+        end
+    | Lop(Icall_imm { func; label_after; }) ->
+        `	{emit_call func}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+    | Lop(Itailcall_ind { label_after = _; }) ->
+        output_epilogue begin fun () ->
+          if !contains_calls then
+            `	ldr	lr, [sp, #{emit_int (-4)}]\n`;
+          `	bx	{emit_reg i.arg.(0)}\n`; 2
+        end
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then begin
+          `	b	{emit_label !tailrec_entry_point}\n`; 1
+        end else begin
+          output_epilogue begin fun () ->
+            if !contains_calls then
+              `	ldr	lr, [sp, #{emit_int (-4)}]\n`;
+            `	{emit_jump func}\n`; 2
+          end
+        end
+    | Lop(Iextcall { func; alloc = false; }) ->
+        `	{emit_call func}\n`; 1
+    | Lop(Iextcall { func; alloc = true; label_after; }) ->
+        let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
+        `	{emit_call "caml_c_call"}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`;
+        1 + ninstr
+    | Lop(Istackoffset n) ->
+        assert (n mod 8 = 0);
+        let ninstr = emit_stack_adjustment (-n) in
+        stack_offset := !stack_offset + n;
+        ninstr
+    | Lop(Iload(Single, addr)) when !fpu >= VFPv2 ->
+        `	flds	s14, {emit_addressing addr i.arg 0}\n`;
+        `	fcvtds	{emit_reg i.res.(0)}, s14\n`; 2
+    | Lop(Iload((Double | Double_u), addr)) when !fpu = Soft ->
+        (* Use LDM or LDRD if possible *)
+        begin match i.res.(0), i.res.(1), addr with
+          {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0
+          when rt < rt2 ->
+            `	ldm	{emit_reg i.arg.(0)}, \{{emit_reg i.res.(0)}, {emit_reg i.res.(1)}}\n`; 1
+        | {loc = Reg rt}, {loc = Reg rt2}, addr
+          when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 ->
+            `	ldrd	{emit_reg i.res.(0)}, {emit_reg i.res.(1)}, {emit_addressing addr i.arg 0}\n`; 1
+        | _ ->
+            let addr' = offset_addressing addr 4 in
+            if i.res.(0).loc <> i.arg.(0).loc then begin
+              `	ldr	{emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`;
+              `	ldr	{emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`
+            end else begin
+              `	ldr	{emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`;
+              `	ldr	{emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
+            end; 2
+        end
+    | Lop(Iload(size, addr)) ->
+        let r = i.res.(0) in
+        let instr =
+          match size with
+            Byte_unsigned -> "ldrb"
+          | Byte_signed -> "ldrsb"
+          | Sixteen_unsigned -> "ldrh"
+          | Sixteen_signed -> "ldrsh"
+          | Double
+          | Double_u -> "fldd"
+          | _ (* 32-bit quantities *) -> "ldr" in
+        `	{emit_string instr}	{emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1
+    | Lop(Istore(Single, addr, _)) when !fpu >= VFPv2 ->
+        `	fcvtsd	s14, {emit_reg i.arg.(0)}\n`;
+        `	fsts	s14, {emit_addressing addr i.arg 1}\n`; 2
+    | Lop(Istore((Double | Double_u), addr, _)) when !fpu = Soft ->
+        (* Use STM or STRD if possible *)
+        begin match i.arg.(0), i.arg.(1), addr with
+          {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0
+          when rt < rt2 ->
+            `	stm	{emit_reg i.arg.(2)}, \{{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}}\n`; 1
+        | {loc = Reg rt}, {loc = Reg rt2}, addr
+          when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 ->
+            `	strd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_addressing addr i.arg 2}\n`; 1
+        | _ ->
+            let addr' = offset_addressing addr 4 in
+            `	str	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`;
+            `	str	{emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2
+        end
+    | Lop(Istore(size, addr, _)) ->
+        let r = i.arg.(0) in
+        let instr =
+          match size with
+            Byte_unsigned
+          | Byte_signed -> "strb"
+          | Sixteen_unsigned
+          | Sixteen_signed -> "strh"
+          | Double
+          | Double_u -> "fstd"
+          | _ (* 32-bit quantities *) -> "str" in
+        `	{emit_string instr}	{emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        let lbl_frame =
+          record_frame_label i.live false i.dbg ?label:label_after_call_gc
+        in
+        if !fastcode_flag then begin
+          let lbl_redo = new_label() in
+          `{emit_label lbl_redo}:`;
+          let ninstr = decompose_intconst
+                         (Int32.of_int n)
+                         (fun i ->
+                           `	sub	alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in
+          `	cmp	alloc_ptr, alloc_limit\n`;
+          `	add	{emit_reg i.res.(0)}, alloc_ptr, #4\n`;
+          let lbl_call_gc = new_label() in
+          `	bcc	{emit_label lbl_call_gc}\n`;
+          call_gc_sites :=
+            { gc_lbl = lbl_call_gc;
+              gc_return_lbl = lbl_redo;
+              gc_frame_lbl = lbl_frame } :: !call_gc_sites;
+          3 + ninstr
+        end else begin
+          let ninstr =
+            begin match n with
+               8 -> `	{emit_call "caml_alloc1"}\n`; 1
+            | 12 -> `	{emit_call "caml_alloc2"}\n`; 1
+            | 16 -> `	{emit_call "caml_alloc3"}\n`; 1
+            |  _ -> let ninstr = emit_intconst (phys_reg 7) (Int32.of_int n) in
+                    `	{emit_call "caml_allocN"}\n`; 1 + ninstr
+            end in
+          `{emit_label lbl_frame}:	add	{emit_reg i.res.(0)}, alloc_ptr, #4\n`;
+          1 + ninstr
+        end
+    | Lop(Iintop(Icomp cmp)) ->
+        let compthen = name_for_comparison cmp in
+        let compelse = name_for_comparison (negate_integer_comparison cmp) in
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	ite	{emit_string compthen}\n`;
+        `	mov{emit_string	compthen}	{emit_reg i.res.(0)}, #1\n`;
+        `	mov{emit_string compelse}	{emit_reg i.res.(0)}, #0\n`; 4
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        let compthen = name_for_comparison cmp in
+        let compelse = name_for_comparison (negate_integer_comparison cmp) in
+        `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
+        `	ite	{emit_string compthen}\n`;
+        `	mov{emit_string	compthen}	{emit_reg i.res.(0)}, #1\n`;
+        `	mov{emit_string compelse}	{emit_reg i.res.(0)}, #0\n`; 4
+    | Lop(Iintop (Icheckbound { label_after_error; } )) ->
+        let lbl = bound_error_label ?label:label_after_error i.dbg in
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	bls	{emit_label lbl}\n`; 2
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+        let lbl = bound_error_label ?label:label_after_error i.dbg in
+        `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
+        `	bls	{emit_label lbl}\n`; 2
+    | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) ->
+        let lbl = bound_error_label i.dbg in
+        let op = name_for_shift_operation shiftop in
+        `	cmp	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, {emit_string op} #{emit_int n}\n`;
+        `	bcs	{emit_label lbl}\n`; 2
+    | Lop(Iintop Imulh) when !arch < ARMv6 ->
+        `	smull	r12, {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
+    | Lop(Ispecific Imulhadd) ->
+        `	smmla	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1
+    | Lop(Iintop op) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
+    | Lop(Iintop_imm(op, n)) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
+    | Lop(Iabsf | Inegf as op) when !fpu = Soft ->
+        let instr = (match op with
+                       Iabsf -> "bic"
+                     | Inegf -> "eor"
+                     | _     -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(1)}, {emit_reg i.arg.(1)}, #0x80000000\n`; 1
+    | Lop(Iabsf | Inegf | Ispecific Isqrtf as op) ->
+        let instr = (match op with
+                       Iabsf            -> "fabsd"
+                     | Inegf            -> "fnegd"
+                     | Ispecific Isqrtf -> "fsqrtd"
+                     | _                -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
+    | Lop(Ifloatofint) ->
+        `	fmsr	s14, {emit_reg i.arg.(0)}\n`;
+        `	fsitod	{emit_reg i.res.(0)}, s14\n`; 2
+    | Lop(Iintoffloat) ->
+        `	ftosizd	s14, {emit_reg i.arg.(0)}\n`;
+        `	fmrs	{emit_reg i.res.(0)}, s14\n`; 2
+    | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) ->
+        let instr = (match op with
+                       Iaddf              -> "faddd"
+                     | Isubf              -> "fsubd"
+                     | Imulf              -> "fmuld"
+                     | Idivf              -> "fdivd"
+                     | Ispecific Inegmulf -> "fnmuld"
+                     | _                  -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        1
+    | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
+        let instr = (match op with
+                       Imuladdf    -> "fmacd"
+                     | Inegmuladdf -> "fnmacd"
+                     | Imulsubf    -> "fmscd"
+                     | Inegmulsubf -> "fnmscd"
+                     | _ -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`;
+        1
+    | Lop(Ispecific(Ishiftarith(op, shiftop, n))) ->
+        let instr = (match op with
+                       Ishiftadd    -> "add"
+                     | Ishiftsub    -> "sub"
+                     | Ishiftsubrev -> "rsb"
+                     | Ishiftand    -> "and"
+                     | Ishiftor     -> "orr"
+                     | Ishiftxor    -> "eor") in
+        let op = name_for_shift_operation shiftop in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, \
+                                        {emit_reg i.arg.(1)}, {emit_string op} #{emit_int n}\n`; 1
+    | Lop(Ispecific(Irevsubimm n)) ->
+        `	rsb	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
+    | Lop(Ispecific(Imuladd | Imulsub as op)) ->
+        let instr = (match op with
+                       Imuladd -> "mla"
+                     | Imulsub -> "mls"
+                     | _ -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1
+    | Lop(Ispecific(Ibswap size)) ->
+        begin match size with
+          16 ->
+            `	rev16	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`;
+            `	movt	{emit_reg i.res.(0)}, #0\n`; 2
+        | 32 ->
+            `	rev	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
+        | _ ->
+            assert false
+        end
+    | Lreloadretaddr ->
+        let n = frame_size() in
+        `	ldr	lr, [sp, #{emit_int(n-4)}]\n`; 1
+    | Lreturn ->
+        output_epilogue begin fun () ->
+          `	bx	lr\n`; 1
+        end
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`; 0
+    | Lbranch lbl ->
+        `	b	{emit_label lbl}\n`; 1
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+          Itruetest ->
+            `	cmp	{emit_reg i.arg.(0)}, #0\n`;
+            `	bne	{emit_label lbl}\n`; 2
+        | Ifalsetest ->
+            `	cmp	{emit_reg i.arg.(0)}, #0\n`;
+            `	beq	{emit_label lbl}\n`; 2
+        | Iinttest cmp ->
+            `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            let comp = name_for_comparison cmp in
+            `	b{emit_string comp}	{emit_label lbl}\n`; 2
+        | Iinttest_imm(cmp, n) ->
+            `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
+            let comp = name_for_comparison cmp in
+            `	b{emit_string comp}	{emit_label lbl}\n`; 2
+        | Ifloattest(cmp, neg) ->
+            let comp = (match (cmp, neg) with
+                          (Ceq, false) | (Cne, true) -> "eq"
+                        | (Cne, false) | (Ceq, true) -> "ne"
+                        | (Clt, false) -> "cc"
+                        | (Clt, true)  -> "cs"
+                        | (Cle, false) -> "ls"
+                        | (Cle, true)  -> "hi"
+                        | (Cgt, false) -> "gt"
+                        | (Cgt, true)  -> "le"
+                        | (Cge, false) -> "ge"
+                        | (Cge, true)  -> "lt") in
+            `	fcmpd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `	fmstat\n`;
+            `	b{emit_string comp}	{emit_label lbl}\n`; 3
+        | Ioddtest ->
+            `	tst	{emit_reg i.arg.(0)}, #1\n`;
+            `	bne	{emit_label lbl}\n`; 2
+        | Ieventest ->
+            `	tst	{emit_reg i.arg.(0)}, #1\n`;
+            `	beq	{emit_label lbl}\n`; 2
+        end
+    | Lcondbranch3(lbl0, lbl1, lbl2) ->
+        `	cmp	{emit_reg i.arg.(0)}, #1\n`;
+        begin match lbl0 with
+          None -> ()
+        | Some lbl -> `	blt	{emit_label lbl}\n`
+        end;
+        begin match lbl1 with
+          None -> ()
+        | Some lbl -> `	beq	{emit_label lbl}\n`
+        end;
+        begin match lbl2 with
+          None -> ()
+        | Some lbl -> `	bgt	{emit_label lbl}\n`
+        end;
+        4
+    | Lswitch jumptbl ->
+        if !arch > ARMv6 && !thumb then begin
+          (* The Thumb-2 TBH instruction supports only forward branches,
+             so we need to generate appropriate trampolines for all labels
+             that appear before this switch instruction (PR#5623) *)
+          let tramtbl = Array.copy jumptbl in
+          `	tbh	[pc, {emit_reg i.arg.(0)}, lsl #1]\n`;
+          for j = 0 to Array.length tramtbl - 1 do
+            let rec label i =
+              match i.desc with
+                Lend -> new_label()
+              | Llabel lbl when lbl = tramtbl.(j) -> lbl
+              | _ -> label i.next in
+            tramtbl.(j) <- label i.next;
+            `	.short	({emit_label tramtbl.(j)}-.)/2+{emit_int j}\n`
+          done;
+          (* Generate the necessary trampolines *)
+          for j = 0 to Array.length tramtbl - 1 do
+            if tramtbl.(j) <> jumptbl.(j) then
+              `{emit_label tramtbl.(j)}:	b	{emit_label jumptbl.(j)}\n`
+          done
+        end else if not !Clflags.pic_code then begin
+          `	ldr	pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
+          `	nop\n`;
+          for j = 0 to Array.length jumptbl - 1 do
+            `	.word	{emit_label jumptbl.(j)}\n`
+          done
+        end else begin
+          (* Slightly slower, but position-independent *)
+          `	add	pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`;
+          `	nop\n`;
+          for j = 0 to Array.length jumptbl - 1 do
+            `	b	{emit_label jumptbl.(j)}\n`
+          done
+        end;
+        2 + Array.length jumptbl
+    | Lsetuptrap lbl ->
+        `	bl	{emit_label lbl}\n`; 1
+    | Lpushtrap ->
+        stack_offset := !stack_offset + 8;
+        `	push	\{trap_ptr, lr}\n`;
+        cfi_adjust_cfa_offset 8;
+        `	mov	trap_ptr, sp\n`; 2
+    | Lpoptrap ->
+        `	pop	\{trap_ptr, lr}\n`;
+        cfi_adjust_cfa_offset (-8);
+        stack_offset := !stack_offset - 8; 1
+    | Lraise k ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
+          `	{emit_call "caml_raise_exn"}\n`;
+          `{record_frame Reg.Set.empty true i.dbg}\n`; 1
+        | Cmm.Raise_notrace ->
+          `	mov	sp, trap_ptr\n`;
+          `	pop	\{trap_ptr, pc}\n`; 2
+        end
+
+(* Emission of an instruction sequence *)
+
+let rec emit_all ninstr i =
+  if i.desc = Lend then () else begin
+    let n = emit_instr i in
+    let ninstr' = ninstr + n in
+    (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *)
+    let limit = (if !fpu >= VFPv2 && !float_literals <> []
+                 then 127
+                 else 511) in
+    let limit = limit - !num_literals in
+    if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin
+      emit_literals();
+      emit_all 0 i.next
+    end else if !num_literals != 0 && ninstr' >= limit then begin
+      let lbl = new_label() in
+      `	b	{emit_label lbl}\n`;
+      emit_literals();
+      `{emit_label lbl}:\n`;
+      emit_all 0 i.next
+    end else
+      emit_all ninstr' i.next
+  end
+
+(* Emission of the profiling prelude *)
+
+let emit_profile() =
+  match Config.system with
+    "linux_eabi" | "linux_eabihf" | "netbsd" ->
+      `	push	\{lr}\n`;
+      `	{emit_call "__gnu_mcount_nc"}\n`
+  | _ -> ()
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  fastcode_flag := fundecl.fun_fast;
+  tailrec_entry_point := new_label();
+  float_literals := [];
+  gotrel_literals := [];
+  symbol_literals := [];
+  stack_offset := 0;
+  call_gc_sites := [];
+  bound_error_sites := [];
+  `	.text\n`;
+  `	.align	2\n`;
+  `	.globl	{emit_symbol fundecl.fun_name}\n`;
+  if !arch > ARMv6 && !thumb then
+    `	.thumb\n`
+  else
+    `	.arm\n`;
+  `	.type	{emit_symbol fundecl.fun_name}, %function\n`;
+  `{emit_symbol fundecl.fun_name}:\n`;
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc();
+  if !Clflags.gprofile then emit_profile();
+  let n = frame_size() in
+  if n > 0 then begin
+    ignore(emit_stack_adjustment (-n));
+    if !contains_calls then begin
+      cfi_offset ~reg:14 (* lr *) ~offset:(-4);
+      `	str	lr, [sp, #{emit_int(n - 4)}]\n`
+    end
+  end;
+  `{emit_label !tailrec_entry_point}:\n`;
+  emit_all 0 fundecl.fun_body;
+  emit_literals();
+  List.iter emit_call_gc !call_gc_sites;
+  List.iter emit_call_bound_error !bound_error_sites;
+  cfi_endproc();
+  `	.type	{emit_symbol fundecl.fun_name}, %function\n`;
+  `	.size	{emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`
+
+(* Emission of data *)
+
+let emit_item = function
+    Cglobal_symbol s -> `	.globl	{emit_symbol s}\n`;
+  | Cdefine_symbol s -> `{emit_symbol s}:\n`
+  | Cint8 n -> `	.byte	{emit_int n}\n`
+  | Cint16 n -> `	.short	{emit_int n}\n`
+  | Cint32 n -> `	.long	{emit_int32 (Nativeint.to_int32 n)}\n`
+  | Cint n -> `	.long	{emit_int32 (Nativeint.to_int32 n)}\n`
+  | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
+  | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f)
+  | Csymbol_address s -> `	.word	{emit_symbol s}\n`
+  | Cstring s -> emit_string_directive "	.ascii  " s
+  | Cskip n -> if n > 0 then `	.space	{emit_int n}\n`
+  | Calign n -> `	.align	{emit_int(Misc.log2 n)}\n`
+
+let data l =
+  `	.data\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  reset_debug_info();
+  `	.file	\"\"\n`;  (* PR#7037 *)
+  `	.syntax	unified\n`;
+  begin match !arch with
+  | ARMv4   -> `	.arch	armv4t\n`
+  | ARMv5   -> `	.arch	armv5t\n`
+  | ARMv5TE -> `	.arch	armv5te\n`
+  | ARMv6   -> `	.arch	armv6\n`
+  | ARMv6T2 -> `	.arch	armv6t2\n`
+  | ARMv7   -> `	.arch	armv7-a\n`
+  end;
+  begin match !fpu with
+    Soft      -> `	.fpu	softvfp\n`
+  | VFPv2     -> `	.fpu	vfpv2\n`
+  | VFPv3_D16 -> `	.fpu	vfpv3-d16\n`
+  | VFPv3     -> `	.fpu	vfpv3\n`
+  end;
+  `trap_ptr	.req	r8\n`;
+  `alloc_ptr	.req	r10\n`;
+  `alloc_limit	.req	r11\n`;
+  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.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.make_symbol (Some "code_end") in
+  `	.text\n`;
+  `	.globl	{emit_symbol lbl_end}\n`;
+  `{emit_symbol lbl_end}:\n`;
+  let lbl_end = Compilenv.make_symbol (Some "data_end") in
+  `	.data\n`;
+  `	.globl	{emit_symbol lbl_end}\n`;
+  `{emit_symbol lbl_end}:\n`;
+  `	.long	0\n`;
+  let lbl = Compilenv.make_symbol (Some "frametable") in
+  `	.globl	{emit_symbol lbl}\n`;
+  `{emit_symbol lbl}:\n`;
+  emit_frames
+    { efa_code_label = (fun lbl ->
+                       `	.type	{emit_label lbl}, %function\n`;
+                       `	.word	{emit_label lbl}\n`);
+      efa_data_label = (fun lbl ->
+                       `	.type	{emit_label lbl}, %object\n`;
+                       `	.word	{emit_label lbl}\n`);
+      efa_16 = (fun n -> `	.short	{emit_int n}\n`);
+      efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
+      efa_word = (fun n -> `	.word	{emit_int n}\n`);
+      efa_align = (fun n -> `	.align	{emit_int(Misc.log2 n)}\n`);
+      efa_label_rel = (fun lbl ofs ->
+                           `	.word	{emit_label lbl} - . + {emit_int32 ofs}\n`);
+      efa_def_label = (fun lbl -> `{emit_label lbl}:\n`);
+      efa_string = (fun s -> emit_string_directive "	.asciz	" s) };
+  `	.type	{emit_symbol lbl}, %object\n`;
+  `	.size	{emit_symbol lbl}, .-{emit_symbol lbl}\n`;
+  begin match Config.system with
+    "linux_eabihf" | "linux_eabi" | "netbsd" ->
+      (* Mark stack as non-executable *)
+      `	.section	.note.GNU-stack,\"\",%progbits\n`
+  | _ -> ()
+  end
diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml
new file mode 100644
index 00000000..64d9013f
--- /dev/null
+++ b/asmcomp/arm/proc.ml
@@ -0,0 +1,314 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the ARM processor *)
+
+open Misc
+open Cmm
+open Reg
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Registers available for register allocation *)
+
+(* Integer register map:
+    r0 - r3               general purpose (not preserved)
+    r4 - r7               general purpose (preserved)
+    r8                    trap pointer (preserved)
+    r9                    platform register, usually reserved
+    r10                   allocation pointer (preserved)
+    r11                   allocation limit (preserved)
+    r12                   intra-procedural scratch register (not preserved)
+    r13                   stack pointer
+    r14                   return address
+    r15                   program counter
+   Floating-point register map (VFPv{2,3}):
+    d0 - d7               general purpose (not preserved)
+    d8 - d15              general purpose (preserved)
+    d16 - d31             generat purpose (not preserved), VFPv3 only
+*)
+
+let int_reg_name =
+  [| "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" |]
+
+let float_reg_name =
+  [| "d0";  "d1";  "d2";  "d3";  "d4";  "d5";  "d6";  "d7";
+     "d8";  "d9";  "d10"; "d11"; "d12"; "d13"; "d14"; "d15";
+     "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23";
+     "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |]
+
+(* We have three register classes:
+    0 for integer registers
+    1 for VFPv2 and VFPv3-D16
+    2 for VFPv3
+   This way we can choose between VFPv2/VFPv3-D16 and VFPv3
+   at (ocamlopt) runtime using command line switches.
+*)
+
+let num_register_classes = 3
+
+let register_class r =
+  match (r.typ, !fpu) with
+  | (Val | Int | Addr), _  -> 0
+  | Float, VFPv2         -> 1
+  | Float, VFPv3_D16     -> 1
+  | Float, _             -> 2
+
+let num_available_registers =
+  [| 9; 16; 32 |]
+
+let first_available_register =
+  [| 0; 100; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+let rotate_registers = true
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 9 Reg.dummy in
+  for i = 0 to 8 do
+    v.(i) <- Reg.at_location Int (Reg i)
+  done;
+  v
+
+let hard_float_reg =
+  let v = Array.make 32 Reg.dummy in
+  for i = 0 to 31 do
+    v.(i) <- Reg.at_location Float (Reg(100 + i))
+  done;
+  v
+
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
+(* Calling conventions *)
+
+let calling_conventions first_int last_int first_float last_float make_stack
+      arg =
+  let loc = Array.make (Array.length arg) [| Reg.dummy |] in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref 0 in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i) with
+    | [| arg |] ->
+      begin match arg.typ with
+      | Val | Int | Addr as ty ->
+          if !int <= last_int then begin
+            loc.(i) <- [| phys_reg !int |];
+            incr int
+          end else begin
+            loc.(i) <- [| stack_slot (make_stack !ofs) ty |];
+            ofs := !ofs + size_int
+          end
+      | Float ->
+          assert (abi = EABI_HF);
+          assert (!fpu >= VFPv2);
+          if !float <= last_float then begin
+            loc.(i) <- [| phys_reg !float |];
+            incr float
+          end else begin
+            ofs := Misc.align !ofs size_float;
+            loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
+            ofs := !ofs + size_float
+          end
+      end
+    | [| arg1; arg2 |] ->
+      (* Passing of 64-bit quantities to external functions. *)
+      begin match arg1.typ, arg2.typ with
+      | Int, Int ->
+          (* 64-bit quantities split across two registers must either be in a
+             consecutive pair of registers where the lowest numbered is an
+             even-numbered register; or in a stack slot that is 8-byte
+             aligned. *)
+          int := Misc.align !int 2;
+          if !int <= last_int - 1 then begin
+            let reg_lower = phys_reg !int in
+            let reg_upper = phys_reg (1 + !int) in
+            loc.(i) <- [| reg_lower; reg_upper |];
+            int := !int + 2
+          end else begin
+            let size_int64 = size_int * 2 in
+            ofs := Misc.align !ofs size_int64;
+            let stack_lower = stack_slot (make_stack !ofs) Int in
+            let stack_upper = stack_slot (make_stack (size_int + !ofs)) Int in
+            loc.(i) <- [| stack_lower; stack_upper |];
+            ofs := !ofs + size_int64
+          end
+      | _, _ ->
+        let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in
+        fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \
+            type(s) for multi-register argument: %s, %s"
+          (f arg1.typ) (f arg2.typ))
+      end
+    | _ ->
+      fatal_error "Proc.calling_conventions: bad number of registers for \
+        multi-register argument"
+  done;
+  (loc, Misc.align !ofs 8)  (* keep stack 8-aligned *)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+(* OCaml calling convention:
+     first integer args in r0...r7
+     first float args in d0...d15 (EABI+VFP)
+     remaining args on stack.
+   Return values in r0...r7 or d0...d15. *)
+
+let max_arguments_for_tailcalls = 8
+
+let single_regs arg = Array.map (fun arg -> [| arg |]) arg
+let ensure_single_regs res =
+  Array.map (function
+      | [| res |] -> res
+      | _ -> failwith "Proc.ensure_single_regs")
+    res
+
+let loc_arguments arg =
+  let (loc, alignment) =
+    calling_conventions 0 7 100 115 outgoing (single_regs arg)
+  in
+  ensure_single_regs loc, alignment
+let loc_parameters arg =
+  let (loc, _) = calling_conventions 0 7 100 115 incoming (single_regs arg) in
+  ensure_single_regs loc
+let loc_results res =
+  let (loc, _) =
+    calling_conventions 0 7 100 115 not_supported (single_regs res)
+  in
+  ensure_single_regs loc
+
+(* C calling convention:
+     first integer args in r0...r3
+     first float args in d0...d7 (EABI+VFP)
+     remaining args on stack.
+   Return values in r0...r1 or d0. *)
+
+let loc_external_arguments arg =
+  calling_conventions 0 3 100 107 outgoing arg
+let loc_external_results res =
+  let (loc, _) =
+    calling_conventions 0 1 100 100 not_supported (single_regs res)
+  in
+  ensure_single_regs loc
+
+let loc_exn_bucket = phys_reg 0
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _rs = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_alloc =            (* r0-r6, d0-d15 preserved *)
+  Array.of_list (List.map
+                   phys_reg
+                   [7;8;
+                    116;117;118;119;120;121;122;123;
+                    124;125;126;127;128;129;130;131])
+
+let destroyed_at_c_call =
+  Array.of_list (List.map
+                   phys_reg
+                   (match abi with
+                      EABI ->       (* r4-r7 preserved *)
+                        [0;1;2;3;8;
+                         100;101;102;103;104;105;106;107;
+                         108;109;110;111;112;113;114;115;
+                         116;117;118;119;120;121;122;123;
+                         124;125;126;127;128;129;130;131]
+                    | EABI_HF ->    (* r4-r7, d8-d15 preserved *)
+                        [0;1;2;3;8;
+                         100;101;102;103;104;105;106;107;
+                         116;117;118;119;120;121;122;123;
+                         124;125;126;127;128;129;130;131]))
+
+let destroyed_at_oper = function
+    Iop(Icall_ind _ | Icall_imm _)
+  | Iop(Iextcall { alloc = true; _ }) ->
+      all_phys_regs
+  | Iop(Iextcall { alloc = false; _}) ->
+      destroyed_at_c_call
+  | Iop(Ialloc _) ->
+      destroyed_at_alloc
+  | Iop(Iconst_symbol _) when !Clflags.pic_code ->
+      [| phys_reg 3; phys_reg 8 |]  (* r3 and r12 destroyed *)
+  | Iop(Iintop Imulh) when !arch < ARMv6 ->
+      [| phys_reg 8 |]              (* r12 destroyed *)
+  | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) ->
+      [| phys_reg 107 |]            (* d7 (s14-s15) destroyed *)
+  | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure = function
+    Iextcall _ -> if abi = EABI then 0 else 4
+  | Ialloc _ -> if abi = EABI then 0 else 7
+  | Iconst_symbol _ when !Clflags.pic_code -> 7
+  | Iintop Imulh when !arch < ARMv6 -> 8
+  | _ -> 9
+
+let max_register_pressure = function
+    Iextcall _ -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |]
+  | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |]
+  | Iconst_symbol _ when !Clflags.pic_code -> [| 7; 16; 32 |]
+  | Iintoffloat | Ifloatofint
+  | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |]
+  | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |]
+  | _ -> [| 9; 16; 32 |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers). *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _)
+  | Ispecific(Ishiftcheckbound _) -> false
+  | _ -> true
+
+(* Layout of the stack *)
+
+let num_stack_slots = [| 0; 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler *)
+
+let assemble_file infile outfile =
+  Ccomp.command (Config.asm ^ " -o " ^
+                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+
+let init () = ()
diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml
new file mode 100644
index 00000000..f6d9b881
--- /dev/null
+++ b/asmcomp/arm/reload.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Reloading for the ARM *)
+
+let fundecl f =
+  (new Reloadgen.reload_generic)#fundecl f
diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml
new file mode 100644
index 00000000..4039eaac
--- /dev/null
+++ b/asmcomp/arm/scheduling.ml
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Arch
+open Mach
+
+(* Instruction scheduling for the ARM *)
+
+class scheduler = object
+
+inherit Schedgen.scheduler_generic as super
+
+(* Scheduling -- based roughly on the ARM11 (ARMv6) *)
+
+method oper_latency = function
+  (* Loads have a latency of two cycles in general *)
+    Iconst_symbol _
+  | Iconst_float _
+  | Iload(_, _)
+  | Ireload
+  | Ifloatofint       (* mcr/mrc count as memory access *)
+  | Iintoffloat -> 2
+  (* Multiplys have a latency of two cycles *)
+  | Iintop (Imul | Imulh)
+  | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2
+  (* VFP instructions *)
+  | Iaddf
+  | Isubf
+  | Idivf
+  | Imulf | Ispecific Inegmulf
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)
+  | Ispecific Isqrtf
+  | Inegf | Iabsf when !fpu >= VFPv2 -> 2
+  (* Everything else *)
+  | _ -> 1
+
+method! is_checkbound = function
+    Ispecific(Ishiftcheckbound _) -> true
+  | op -> super#is_checkbound op
+
+(* Issue cycles. Rough approximations *)
+
+method oper_issue_cycles = function
+    Ialloc _ -> 4
+  | Iintop(Ilsl | Ilsr | Iasr) -> 2
+  | Iintop(Icomp _)
+  | Iintop_imm(Icomp _, _) -> 3
+  | Iintop(Icheckbound _)
+  | Iintop_imm(Icheckbound _, _) -> 2
+  | Ispecific(Ishiftcheckbound _) -> 3
+  | Iintop(Imul | Imulh)
+  | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2
+  (* VFP instructions *)
+  | Iaddf
+  | Isubf -> 7
+  | Imulf
+  | Ispecific Inegmulf -> 9
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17
+  | Idivf
+  | Ispecific Isqrtf -> 27
+  | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv2 -> 4
+  (* Everything else *)
+  | _ -> 1
+
+end
+
+let fundecl f = (new scheduler)#schedule_fundecl f
diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml
new file mode 100644
index 00000000..3a3a5c61
--- /dev/null
+++ b/asmcomp/arm/selection.ml
@@ -0,0 +1,316 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the ARM processor *)
+
+open Arch
+open Proc
+open Cmm
+open Mach
+
+let is_offset chunk n =
+  match chunk with
+  (* VFPv{2,3} load/store have -1020 to 1020 *)
+    Single | Double | Double_u
+    when !fpu >= VFPv2 ->
+      n >= -1020 && n <= 1020
+  (* ARM load/store byte/word have -4095 to 4095 *)
+  | Byte_unsigned | Byte_signed
+  | Thirtytwo_unsigned | Thirtytwo_signed
+  | Word_int | Word_val | Single
+    when not !thumb ->
+      n >= -4095 && n <= 4095
+  (* Thumb-2 load/store have -255 to 4095 *)
+  | _ when !arch > ARMv6 && !thumb ->
+      n >= -255 && n <= 4095
+  (* Everything else has -255 to 255 *)
+  | _ ->
+      n >= -255 && n <= 255
+
+let select_shiftop = function
+    Clsl -> Ishiftlogicalleft
+  | Clsr -> Ishiftlogicalright
+  | Casr -> Ishiftarithmeticright
+  | __-> assert false
+
+(* Special constraints on operand and result registers *)
+
+exception Use_default
+
+let r1 = phys_reg 1
+let r6 = phys_reg 6
+let r7 = phys_reg 7
+
+let pseudoregs_for_operation op arg res =
+  match op with
+  (* For mul rd,rm,rs and mla rd,rm,rs,ra (pre-ARMv6) the registers rm
+     and rd must be different. We deal with this by pretending that rm
+     is also a result of the mul / mla operation. *)
+    Iintop Imul | Ispecific Imuladd when !arch < ARMv6 ->
+      (arg, [| res.(0); arg.(0) |])
+  (* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn
+     must be different.  Also, rdlo (whose contents we discard) is always
+     forced to be r12 in proc.ml, which means that neither rdhi and rn can
+     be r12.  To keep things simple, we force both of those two to specific
+     hard regs: rdhi in r6 and rn in r7. *)
+  | Iintop Imulh when !arch < ARMv6 ->
+      ([| r7; arg.(1) |], [| r6 |])
+  (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *)
+  | Iabsf | Inegf when !fpu = Soft ->
+      ([|res.(0); arg.(1)|], res)
+  (* VFPv{2,3} Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *)
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) ->
+      let arg' = Array.copy arg in
+      arg'.(0) <- res.(0);
+      (arg', res)
+  (* We use __aeabi_idivmod for Cmodi only, and hence we care only
+     for the remainder in r1, so fix up the destination register. *)
+  | Iextcall { func = "__aeabi_idivmod"; alloc = false; } ->
+      (arg, [|r1|])
+  (* Other instructions are regular *)
+  | _ -> raise Use_default
+
+(* Instruction selection *)
+class selector = object(self)
+
+inherit Selectgen.selector_generic as super
+
+method! regs_for tyv =
+  Reg.createv (if !fpu = Soft then begin
+                 (* Expand floats into pairs of integer registers *)
+                 (* CR mshinwell: we need to check this in conjunction with
+                    the unboxed external functionality *)
+                 let rec expand = function
+                   [] -> []
+                 | Float :: tyl -> Int :: Int :: expand tyl
+                 | ty :: tyl -> ty :: expand tyl in
+                 Array.of_list (expand (Array.to_list tyv))
+               end else begin
+                 tyv
+               end)
+
+method is_immediate n =
+  is_immediate (Int32.of_int n)
+
+method! is_simple_expr = function
+  (* inlined floating-point ops are simple if their arguments are *)
+  | Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 ->
+      List.for_all self#is_simple_expr args
+  (* inlined byte-swap ops are simple if their arguments are *)
+  | Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
+    when !arch >= ARMv6T2 ->
+      List.for_all self#is_simple_expr args
+  | Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _)
+    when !arch >= ARMv6 ->
+      List.for_all self#is_simple_expr args
+  | e -> super#is_simple_expr e
+
+method! effects_of e =
+  match e with
+  | Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 ->
+      Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+  | Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
+    when !arch >= ARMv6T2 ->
+      Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+  | Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _)
+    when !arch >= ARMv6 ->
+      Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+  | e -> super#effects_of e
+
+method select_addressing chunk = function
+  | Cop((Cadda | Caddv), [arg; Cconst_int n], _)
+    when is_offset chunk n ->
+      (Iindexed n, arg)
+  | Cop((Cadda | Caddv as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg)
+    when is_offset chunk n ->
+      (Iindexed n, Cop(op, [arg1; arg2], dbg))
+  | arg ->
+      (Iindexed 0, arg)
+
+method select_shift_arith op dbg arithop arithrevop args =
+  match args with
+    [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n], _)]
+    when n > 0 && n < 32 ->
+      (Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2])
+  | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2]
+    when n > 0 && n < 32 ->
+      (Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1])
+  | args ->
+      begin match super#select_operation op args dbg with
+      (* Recognize multiply high and add *)
+        (Iintop Iadd, [Cop(Cmulhi, args, _); arg3])
+      | (Iintop Iadd, [arg3; Cop(Cmulhi, args, _)]) as op_args
+        when !arch >= ARMv6 ->
+          begin match self#select_operation Cmulhi args dbg with
+            (Iintop Imulh, [arg1; arg2]) ->
+              (Ispecific Imulhadd, [arg1; arg2; arg3])
+          | _ -> op_args
+          end
+      (* Recognize multiply and add *)
+      | (Iintop Iadd, [Cop(Cmuli, args, _); arg3])
+      | (Iintop Iadd, [arg3; Cop(Cmuli, args, _)]) as op_args ->
+          begin match self#select_operation Cmuli args dbg with
+            (Iintop Imul, [arg1; arg2]) ->
+              (Ispecific Imuladd, [arg1; arg2; arg3])
+          | _ -> op_args
+          end
+      (* Recognize multiply and subtract *)
+      | (Iintop Isub, [arg3; Cop(Cmuli, args, _)]) as op_args
+        when !arch > ARMv6 ->
+          begin match self#select_operation Cmuli args dbg with
+            (Iintop Imul, [arg1; arg2]) ->
+              (Ispecific Imulsub, [arg1; arg2; arg3])
+          | _ -> op_args
+          end
+      | op_args -> op_args
+      end
+
+method private iextcall (func, alloc) =
+  Iextcall { func; alloc; label_after = Cmm.new_label (); }
+
+method! select_operation op args dbg =
+  match (op, args) with
+  (* Recognize special shift arithmetic *)
+    ((Caddv | Cadda | Caddi), [arg; Cconst_int n])
+    when n < 0 && self#is_immediate (-n) ->
+      (Iintop_imm(Isub, -n), [arg])
+  | ((Caddv | Cadda | Caddi as op), args) ->
+      self#select_shift_arith op dbg Ishiftadd Ishiftadd args
+  | (Csubi, [arg; Cconst_int n])
+    when n < 0 && self#is_immediate (-n) ->
+      (Iintop_imm(Iadd, -n), [arg])
+  | (Csubi, [Cconst_int n; arg])
+    when self#is_immediate n ->
+      (Ispecific(Irevsubimm n), [arg])
+  | (Csubi as op, args) ->
+      self#select_shift_arith op dbg Ishiftsub Ishiftsubrev args
+  | (Cand as op, args) ->
+      self#select_shift_arith op dbg Ishiftand Ishiftand args
+  | (Cor as op, args) ->
+      self#select_shift_arith op dbg Ishiftor Ishiftor args
+  | (Cxor as op, args) ->
+      self#select_shift_arith op dbg Ishiftxor Ishiftxor args
+  | (Ccheckbound,
+      [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2])
+    when n > 0 && n < 32 ->
+      (Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2])
+  (* ARM does not support immediate operands for multiplication *)
+  | (Cmuli, args) ->
+      (Iintop Imul, args)
+  | (Cmulhi, args) ->
+      (Iintop Imulh, args)
+  (* Turn integer division/modulus into runtime ABI calls *)
+  | (Cdivi, args) ->
+      (self#iextcall("__aeabi_idiv", false), args)
+  | (Cmodi, args) ->
+      (* See above for fix up of return register *)
+      (self#iextcall("__aeabi_idivmod", false), args)
+  (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *)
+  | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 ->
+      (Ispecific(Ibswap 16), args)
+  (* Recognize 32-bit bswap instructions (ARMv6 and above) *)
+  | (Cextcall("caml_int32_direct_bswap", _, _, _), args)
+    when !arch >= ARMv6 ->
+      (Ispecific(Ibswap 32), args)
+  (* Turn floating-point operations into runtime ABI calls for softfp *)
+  | (op, args) when !fpu = Soft -> self#select_operation_softfp op args dbg
+  (* Select operations for VFPv{2,3} *)
+  | (op, args) -> self#select_operation_vfpv3 op args dbg
+
+method private select_operation_softfp op args dbg =
+  match (op, args) with
+  (* Turn floating-point operations into runtime ABI calls *)
+  | (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), args)
+  | (Csubf, args) -> (self#iextcall("__aeabi_dsub", false), args)
+  | (Cmulf, args) -> (self#iextcall("__aeabi_dmul", false), args)
+  | (Cdivf, args) -> (self#iextcall("__aeabi_ddiv", false), args)
+  | (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args)
+  | (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args)
+  | (Ccmpf comp, args) ->
+      let func = (match comp with
+                    Cne    (* there's no __aeabi_dcmpne *)
+                  | Ceq -> "__aeabi_dcmpeq"
+                  | Clt -> "__aeabi_dcmplt"
+                  | Cle -> "__aeabi_dcmple"
+                  | Cgt -> "__aeabi_dcmpgt"
+                  | Cge -> "__aeabi_dcmpge") in
+      let comp = (match comp with
+                    Cne -> Ceq (* eq 0 => false *)
+                  | _   -> Cne (* ne 0 => true *)) in
+      (Iintop_imm(Icomp(Iunsigned comp), 0),
+       [Cop(Cextcall(func, typ_int, false, None), args, dbg)])
+  (* Add coercions around loads and stores of 32-bit floats *)
+  | (Cload (Single, mut), args) ->
+      (self#iextcall("__aeabi_f2d", false),
+        [Cop(Cload (Word_int, mut), args, dbg)])
+  | (Cstore (Single, init), [arg1; arg2]) ->
+      let arg2' =
+        Cop(Cextcall("__aeabi_d2f", typ_int, false, None), [arg2], dbg) in
+      self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] dbg
+  (* Other operations are regular *)
+  | (op, args) -> super#select_operation op args dbg
+
+method private select_operation_vfpv3 op args dbg =
+  match (op, args) with
+  (* Recognize floating-point negate and multiply *)
+    (Cnegf, [Cop(Cmulf, args, _)]) ->
+      (Ispecific Inegmulf, args)
+  (* Recognize floating-point multiply and add *)
+  | (Caddf, [arg; Cop(Cmulf, args, _)])
+  | (Caddf, [Cop(Cmulf, args, _); arg]) ->
+      (Ispecific Imuladdf, arg :: args)
+  (* Recognize floating-point negate, multiply and subtract *)
+  | (Csubf, [Cop(Cnegf, [arg], _); Cop(Cmulf, args, _)])
+  | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args, _)], _); arg]) ->
+      (Ispecific Inegmulsubf, arg :: args)
+  (* Recognize floating-point negate, multiply and add *)
+  | (Csubf, [arg; Cop(Cmulf, args, _)]) ->
+      (Ispecific Inegmuladdf, arg :: args)
+  (* Recognize multiply and subtract *)
+  | (Csubf, [Cop(Cmulf, args, _); arg]) ->
+      (Ispecific Imulsubf, arg :: args)
+  (* Recognize floating-point square root *)
+  | (Cextcall("sqrt", _, false, _), args) ->
+      (Ispecific Isqrtf, args)
+  (* Other operations are regular *)
+  | (op, args) -> super#select_operation op args dbg
+
+method! select_condition = function
+  (* Turn floating-point comparisons into runtime ABI calls *)
+    Cop(Ccmpf _ as op, args, dbg) when !fpu = Soft ->
+      begin match self#select_operation_softfp op args dbg with
+        (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg)
+      | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg)
+      | _ -> assert false
+      end
+  | expr ->
+      super#select_condition expr
+
+(* Deal with some register constraints *)
+
+method! insert_op_debug op dbg rs rd =
+  try
+    let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
+    self#insert_moves rs rsrc;
+    self#insert_debug (Iop op) dbg rsrc rdst;
+    self#insert_moves rdst rd;
+    rd
+  with Use_default ->
+    super#insert_op_debug op dbg rs rd
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml
new file mode 100644
index 00000000..b97f9227
--- /dev/null
+++ b/asmcomp/arm64/CSE.ml
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for ARM64 *)
+
+open Arch
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+  match op with
+  | Ispecific(Ishiftcheckbound _) -> Op_checkbound
+  | Ispecific _ -> Op_pure
+  | _ -> super#class_of_operation op
+
+method! is_cheap_operation op =
+  match op with
+  | Iconst_int n -> n <= 65535n && n >= 0n
+  | _ -> false
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/arm64/NOTES.md b/asmcomp/arm64/NOTES.md
new file mode 100644
index 00000000..e2134eb1
--- /dev/null
+++ b/asmcomp/arm64/NOTES.md
@@ -0,0 +1,12 @@
+# Supported platforms
+
+ARMv8 in 64-bit mode (AArch64).
+
+Debian architecture name: `arm64`.
+
+# Reference documents
+
+* Instruction set architecture:
+  _ARM Architecture Reference Manual, ARMv8_, restricted to the AArch64 subset.
+* Application binary interface:
+  _Procedure Call Standard for the ARM 64-bit Architecture (AArch64)_
diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml
new file mode 100644
index 00000000..4eb8b9d9
--- /dev/null
+++ b/asmcomp/arm64/arch.ml
@@ -0,0 +1,171 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Specific operations for the ARM processor, 64-bit mode *)
+
+open Format
+
+let command_line_options = []
+
+(* Addressing modes *)
+
+type addressing_mode =
+  | Iindexed of int                     (* reg + displ *)
+  | Ibased of string * int              (* global var + displ *)
+
+(* We do not support the reg + shifted reg addressing mode, because
+   what we really need is reg + shifted reg + displ,
+   and this is decomposed in two instructions (reg + shifted reg -> tmp,
+   then addressing tmp + displ). *)
+
+(* Specific operations *)
+
+type cmm_label = int
+  (* Do not introduce a dependency to Cmm *)
+
+type specific_operation =
+  | Ifar_alloc of { words : int; label_after_call_gc : cmm_label option; }
+  | Ifar_intop_checkbound of { label_after_error : cmm_label option; }
+  | Ifar_intop_imm_checkbound of
+      { bound : int; label_after_error : cmm_label option; }
+  | Ishiftarith of arith_operation * int
+  | Ishiftcheckbound of { shift : int; label_after_error : cmm_label option; }
+  | Ifar_shiftcheckbound of
+      { shift : int; label_after_error : cmm_label option; }
+  | Imuladd       (* multiply and add *)
+  | Imulsub       (* multiply and subtract *)
+  | Inegmulf      (* floating-point negate and multiply *)
+  | Imuladdf      (* floating-point multiply and add *)
+  | Inegmuladdf   (* floating-point negate, multiply and add *)
+  | Imulsubf      (* floating-point multiply and subtract *)
+  | Inegmulsubf   (* floating-point negate, multiply and subtract *)
+  | Isqrtf        (* floating-point square root *)
+  | Ibswap of int (* endianess conversion *)
+
+and arith_operation =
+    Ishiftadd
+  | Ishiftsub
+
+let spacetime_node_hole_pointer_is_live_before = function
+  | Ifar_alloc _ | Ifar_intop_checkbound _ | Ifar_intop_imm_checkbound _
+  | Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ -> false
+  | Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf
+  | Inegmulsubf | Isqrtf | Ibswap _ -> false
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let size_addr = 8
+let size_int = 8
+let size_float = 8
+
+let allow_unaligned_access = false
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+  | Iindexed n -> Iindexed(n + delta)
+  | Ibased(s, n) -> Ibased(s, n + delta)
+
+let num_args_addressing = function
+  | Iindexed _ -> 1
+  | Ibased _ -> 0
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Iindexed n ->
+      printreg ppf arg.(0);
+      if n <> 0 then fprintf ppf " + %i" n
+  | Ibased(s, 0) ->
+      fprintf ppf "\"%s\"" s
+  | Ibased(s, n) ->
+      fprintf ppf "\"%s\" + %i" s n
+
+let print_specific_operation printreg op ppf arg =
+  match op with
+  | Ifar_alloc { words; label_after_call_gc = _; } ->
+    fprintf ppf "(far) alloc %i" words
+  | Ifar_intop_checkbound _ ->
+    fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1)
+  | Ifar_intop_imm_checkbound { bound; _ } ->
+    fprintf ppf "%a (far) check > %i" printreg arg.(0) bound
+  | Ishiftarith(op, shift) ->
+      let op_name = function
+      | Ishiftadd -> "+"
+      | Ishiftsub -> "-" in
+      let shift_mark =
+       if shift >= 0
+       then sprintf "<< %i" shift
+       else sprintf ">> %i" (-shift) in
+      fprintf ppf "%a %s %a %s"
+       printreg arg.(0) (op_name op) printreg arg.(1) shift_mark
+  | Ishiftcheckbound { shift; _ } ->
+      fprintf ppf "check %a >> %i > %a" printreg arg.(0) shift
+        printreg arg.(1)
+  | Ifar_shiftcheckbound { shift; _ } ->
+      fprintf ppf
+        "(far) check %a >> %i > %a" printreg arg.(0) shift printreg arg.(1)
+  | Imuladd ->
+      fprintf ppf "(%a * %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imulsub ->
+      fprintf ppf "-(%a * %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmulf ->
+      fprintf ppf "-f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+  | Imuladdf ->
+      fprintf ppf "%a +f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmuladdf ->
+      fprintf ppf "(-f %a) -f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imulsubf ->
+      fprintf ppf "%a -f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmulsubf ->
+      fprintf ppf "(-f %a) +f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Isqrtf ->
+      fprintf ppf "sqrtf %a"
+        printreg arg.(0)
+  | Ibswap n ->
+      fprintf ppf "bswap%i %a" n
+        printreg arg.(0)
diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
new file mode 100644
index 00000000..f75646e1
--- /dev/null
+++ b/asmcomp/arm64/emit.mlp
@@ -0,0 +1,993 @@
+#2 "asmcomp/arm64/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of ARM assembly code, 64-bit mode *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+(* Names for special regs *)
+
+let reg_trap_ptr = phys_reg 23
+let reg_alloc_ptr = phys_reg 24
+let reg_alloc_limit = phys_reg 25
+let reg_tmp1 = phys_reg 26
+let reg_x15 = phys_reg 15
+
+(* Output a label *)
+
+let emit_label lbl =
+  emit_string ".L"; emit_int lbl
+
+(* Symbols *)
+
+let emit_symbol s =
+  Emitaux.emit_symbol '$' s
+
+(* Output a pseudo-register *)
+
+let emit_reg = function
+    {loc = Reg r} -> emit_string (register_name r)
+  | _ -> fatal_error "Emit.emit_reg"
+
+(* Likewise, but with the 32-bit name of the register *)
+
+let int_reg_name_w =
+  [| "w0";  "w1";  "w2";  "w3";  "w4";  "w5";  "w6";  "w7";
+     "w8";  "w9";  "w10"; "w11"; "w12"; "w13"; "w14"; "w15";
+     "w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25";
+     "w26"; "w27"; "w28"; "w16"; "w17" |]
+
+let emit_wreg = function
+    {loc = Reg r} -> emit_string int_reg_name_w.(r)
+  | _ -> fatal_error "Emit.emit_wreg"
+
+(* Layout of the stack frame *)
+
+let stack_offset = ref 0
+
+let frame_size () =
+  let sz =
+    !stack_offset +
+    8 * num_stack_slots.(0) +
+    8 * num_stack_slots.(1) +
+    (if !contains_calls then 8 else 0)
+  in Misc.align sz 16
+
+let slot_offset loc cl =
+  match loc with
+    Incoming n ->
+      assert (n >= 0);
+      frame_size() + n
+  | Local n ->
+      !stack_offset +
+      (if cl = 0
+       then n * 8
+       else num_stack_slots.(0) * 8 + n * 8)
+  | Outgoing n ->
+      assert (n >= 0);
+      n
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+  | Stack s ->
+      let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]`
+  | _ -> fatal_error "Emit.emit_stack"
+
+(* Output an addressing mode *)
+
+let emit_symbol_offset s ofs =
+  emit_symbol s;
+  if ofs > 0 then `+{emit_int ofs}`
+  else if ofs < 0 then `-{emit_int (-ofs)}`
+  else ()
+
+let emit_addressing addr r =
+  match addr with
+  | Iindexed ofs ->
+      `[{emit_reg r}, #{emit_int ofs}]`
+  | Ibased(s, ofs) ->
+      `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]`
+
+(* Record live pointers at call points *)
+
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := ((r lsl 1) + 1) :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ())
+    live;
+  record_frame_descr ~label:lbl ~frame_size:(frame_size())
+    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+  lbl
+
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_frame_lbl: label }               (* Label of frame descriptor *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  `{emit_label gc.gc_lbl}:	bl	{emit_symbol "caml_call_gc"}\n`;
+  `{emit_label gc.gc_frame_lbl}:	b	{emit_label gc.gc_return_lbl}\n`
+
+(* Record calls to caml_ml_array_bound_error.
+   In debug mode, we maintain one call to caml_ml_array_bound_error
+   per bound check site. Otherwise, we can share a single call. *)
+
+type bound_error_call =
+  { bd_lbl: label;                    (* Entry label *)
+    bd_frame_lbl: label }             (* Label of frame descriptor *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+
+let bound_error_label ?label dbg =
+  if !Clflags.debug || !bound_error_sites = [] then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    bound_error_sites :=
+      { bd_lbl = lbl_bound_error;
+        bd_frame_lbl = lbl_frame } :: !bound_error_sites;
+    lbl_bound_error
+  end else begin
+    let bd = List.hd !bound_error_sites in bd.bd_lbl
+  end
+
+let emit_call_bound_error bd =
+  `{emit_label bd.bd_lbl}:	bl	{emit_symbol "caml_ml_array_bound_error"}\n`;
+  `{emit_label bd.bd_frame_lbl}:\n`
+
+(* Names of various instructions *)
+
+let name_for_comparison = function
+  | Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
+  | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
+  | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
+  | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
+
+let name_for_int_operation = function
+  | Iadd -> "add"
+  | Isub -> "sub"
+  | Imul -> "mul"
+  | Idiv -> "sdiv"
+  | Iand -> "and"
+  | Ior  -> "orr"
+  | Ixor -> "eor"
+  | Ilsl -> "lsl"
+  | Ilsr -> "lsr"
+  | Iasr -> "asr"
+  | _ -> assert false
+
+(* Load an integer constant into a register *)
+
+let emit_intconst dst n =
+  let rec emit_pos first shift =
+    if shift < 0 then begin
+      if first then `	mov	{emit_reg dst}, xzr\n`
+    end else begin
+      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
+      if s = 0n then emit_pos first (shift - 16) else begin
+        if first then
+          `	movz	{emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`
+        else
+           `	movk	{emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`;
+        emit_pos false (shift - 16)
+      end
+    end
+  and emit_neg first shift =
+    if shift < 0 then begin
+      if first then `	movn	{emit_reg dst}, #0\n`
+    end else begin
+      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
+      if s = 0xFFFFn then emit_neg first (shift - 16) else begin
+        if first then
+          `	movn	{emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n`
+        else
+           `	movk	{emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`;
+        emit_neg false (shift - 16)
+      end
+    end
+  in
+    if n < 0n then emit_neg true 48 else emit_pos true 48
+
+let num_instructions_for_intconst n =
+  let num_instructions = ref 0 in
+  let rec count_pos first shift =
+    if shift < 0 then begin
+      if first then incr num_instructions
+    end else begin
+      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
+      if s = 0n then count_pos first (shift - 16) else begin
+        incr num_instructions;
+        count_pos false (shift - 16)
+      end
+    end
+  and count_neg first shift =
+    if shift < 0 then begin
+      if first then incr num_instructions
+    end else begin
+      let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in
+      if s = 0xFFFFn then count_neg first (shift - 16) else begin
+        incr num_instructions;
+        count_neg false (shift - 16)
+      end
+    end
+  in
+  if n < 0n then count_neg true 48 else count_pos true 48;
+  !num_instructions
+
+(* Recognize float constants appropriate for FMOV dst, #fpimm instruction:
+   "a normalized binary floating point encoding with 1 sign bit, 4
+    bits of fraction and a 3-bit exponent" *)
+
+let is_immediate_float bits =
+  let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in
+  let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in
+  exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant
+
+(* Adjust sp (up or down) by the given byte amount *)
+
+let emit_stack_adjustment n =
+  let instr = if n < 0 then "sub" else "add" in
+  let m = abs n in
+  assert (m < 0x1_000_000);
+  let ml = m land 0xFFF and mh = m land 0xFFF_000 in
+  if mh <> 0 then `	{emit_string instr}	sp, sp, #{emit_int mh}\n`;
+  if ml <> 0 then `	{emit_string instr}	sp, sp, #{emit_int ml}\n`;
+  if n <> 0 then cfi_adjust_cfa_offset (-n)
+
+(* Deallocate the stack frame and reload the return address
+   before a return or tail call *)
+
+let output_epilogue f =
+  let n = frame_size() in
+  if !contains_calls then
+    `	ldr	x30, [sp, #{emit_int (n-8)}]\n`;
+  if n > 0 then
+    emit_stack_adjustment n;
+  f();
+  (* reset CFA back because function body may continue *)
+  if n > 0 then cfi_adjust_cfa_offset n
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+(* Pending floating-point literals *)
+let float_literals = ref ([] : (int64 * label) list)
+
+(* Label a floating-point literal *)
+let float_literal f =
+  try
+    List.assoc f !float_literals
+  with Not_found ->
+    let lbl = new_label() in
+    float_literals := (f, lbl) :: !float_literals;
+    lbl
+
+(* Emit all pending literals *)
+let emit_literals() =
+  if !float_literals <> [] then begin
+    `	.align	3\n`;
+    List.iter
+      (fun (f, lbl) ->
+        `{emit_label lbl}:`; emit_float64_directive ".quad" f)
+      !float_literals;
+    float_literals := []
+  end
+
+(* Emit code to load the address of a symbol *)
+
+let emit_load_symbol_addr dst s =
+  if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin
+    `	adrp	{emit_reg dst}, {emit_symbol s}\n`;
+    `	add	{emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n`
+  end else begin
+    `	adrp	{emit_reg dst}, :got:{emit_symbol s}\n`;
+    `	ldr	{emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n`
+  end
+
+(* The following functions are used for calculating the sizes of the
+   call GC and bounds check points emitted out-of-line from the function
+   body.  See branch_relaxation.mli. *)
+
+let num_call_gc_and_check_bound_points instr =
+  let rec loop instr ((call_gc, check_bound) as totals) =
+    match instr.desc with
+    | Lend -> totals
+    | Lop (Ialloc _) when !fastcode_flag ->
+      loop instr.next (call_gc + 1, check_bound)
+    | Lop (Iintop Icheckbound _)
+    | Lop (Iintop_imm (Icheckbound _, _))
+    | Lop (Ispecific (Ishiftcheckbound _)) ->
+      let check_bound =
+        (* When not in debug mode, there is at most one check-bound point. *)
+        if not !Clflags.debug then 1
+        else check_bound + 1
+      in
+      loop instr.next (call_gc, check_bound)
+    (* The following four should never be seen, since this function is run
+       before branch relaxation. *)
+    | Lop (Ispecific (Ifar_alloc _))
+    | Lop (Ispecific Ifar_intop_checkbound _)
+    | Lop (Ispecific (Ifar_intop_imm_checkbound _))
+    | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false
+    | _ -> loop instr.next totals
+  in
+  loop instr (0, 0)
+
+let max_out_of_line_code_offset ~num_call_gc ~num_check_bound =
+  if num_call_gc < 1 && num_check_bound < 1 then 0
+  else begin
+    let size_of_call_gc = 2 in
+    let size_of_check_bound = 1 in
+    let size_of_last_thing =
+      (* Call-GC points come before check-bound points. *)
+      if num_check_bound >= 1 then size_of_check_bound else size_of_call_gc
+    in
+    let total_size =
+      size_of_call_gc*num_call_gc + size_of_check_bound*num_check_bound
+    in
+    let max_offset = total_size - size_of_last_thing in
+    assert (max_offset >= 0);
+    max_offset
+  end
+
+module BR = Branch_relaxation.Make (struct
+  (* CR-someday mshinwell: B and BL have +/- 128Mb ranges; for the moment we
+     assume we will never exceed this.  It would seem to be most likely to
+     occur for branches between functions; in this case, the linker should be
+     able to insert veneers anyway.  (See section 4.6.7 of the document
+     "ELF for the ARM 64-bit architecture (AArch64)".) *)
+
+  type distance = int
+
+  module Cond_branch = struct
+    type t = TB | CB | Bcc
+
+    let all = [TB; CB; Bcc]
+
+    (* AArch64 instructions are 32 bits wide, so [distance] in this module
+       means units of 32-bit words. *)
+    let max_displacement = function
+      | TB -> 32 * 1024 / 4  (* +/- 32Kb *)
+      | CB | Bcc -> 1 * 1024 * 1024 / 4  (* +/- 1Mb *)
+
+    let classify_instr = function
+      | Lop (Ialloc _)
+      | Lop (Iintop Icheckbound _)
+      | Lop (Iintop_imm (Icheckbound _, _))
+      | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc
+      (* The various "far" variants in [specific_operation] don't need to
+         return [Some] here, since their code sequences never contain any
+         conditional branches that might need relaxing. *)
+      | Lcondbranch (Itruetest, _)
+      | Lcondbranch (Ifalsetest, _) -> Some CB
+      | Lcondbranch (Iinttest _, _)
+      | Lcondbranch (Iinttest_imm _, _)
+      | Lcondbranch (Ifloattest _, _) -> Some Bcc
+      | Lcondbranch (Ioddtest, _)
+      | Lcondbranch (Ieventest, _) -> Some TB
+      | Lcondbranch3 _ -> Some Bcc
+      | _ -> None
+  end
+
+  let offset_pc_at_branch = 0
+
+  let epilogue_size () =
+    if !contains_calls then 3 else 2
+
+  let instr_size = function
+    | Lend -> 0
+    | Lop (Imove | Ispill | Ireload) -> 1
+    | Lop (Iconst_int n) ->
+      num_instructions_for_intconst n
+    | Lop (Iconst_float _) -> 2
+    | Lop (Iconst_symbol _) -> 2
+    | Lop (Icall_ind _) -> 1
+    | Lop (Icall_imm _) -> 1
+    | Lop (Itailcall_ind _) -> epilogue_size ()
+    | Lop (Itailcall_imm { func; _ }) ->
+      if func = !function_name then 1 else epilogue_size ()
+    | Lop (Iextcall { alloc = false; }) -> 1
+    | Lop (Iextcall { alloc = true; }) -> 3
+    | Lop (Istackoffset _) -> 2
+    | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) ->
+      let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in
+      based + begin match size with Single -> 2 | _ -> 1 end
+    | Lop (Ialloc _) when !fastcode_flag -> 4
+    | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5
+    | Lop (Ialloc { words = num_words; _ })
+    | Lop (Ispecific (Ifar_alloc { words = num_words; _ })) ->
+      begin match num_words with
+      | 16 | 24 | 32 -> 1
+      | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words)
+      end
+    | Lop (Iintop (Icomp _)) -> 2
+    | Lop (Iintop_imm (Icomp _, _)) -> 2
+    | Lop (Iintop (Icheckbound _)) -> 2
+    | Lop (Ispecific (Ifar_intop_checkbound _)) -> 3
+    | Lop (Iintop_imm (Icheckbound _, _)) -> 2
+    | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3
+    | Lop (Ispecific (Ishiftcheckbound _)) -> 2
+    | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3
+    | Lop (Iintop Imod) -> 2
+    | Lop (Iintop Imulh) -> 1
+    | Lop (Iintop _) -> 1
+    | Lop (Iintop_imm _) -> 1
+    | Lop (Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf) -> 1
+    | Lop (Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf) -> 1
+    | Lop (Ispecific (Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)) -> 1
+    | Lop (Ispecific (Ishiftarith _)) -> 1
+    | Lop (Ispecific (Imuladd | Imulsub)) -> 1
+    | Lop (Ispecific (Ibswap 16)) -> 2
+    | Lop (Ispecific (Ibswap _)) -> 1
+    | Lreloadretaddr -> 0
+    | Lreturn -> epilogue_size ()
+    | Llabel _ -> 0
+    | Lbranch _ -> 1
+    | Lcondbranch (tst, _) ->
+      begin match tst with
+      | Itruetest -> 1
+      | Ifalsetest -> 1
+      | Iinttest _ -> 2
+      | Iinttest_imm _ -> 2
+      | Ifloattest _ -> 2
+      | Ioddtest -> 1
+      | Ieventest -> 1
+      end
+    | Lcondbranch3 (lbl0, lbl1, lbl2) ->
+      1 + begin match lbl0 with None -> 0 | Some _ -> 1 end
+        + begin match lbl1 with None -> 0 | Some _ -> 1 end
+        + begin match lbl2 with None -> 0 | Some _ -> 1 end
+    | Lswitch jumptbl -> 3 + Array.length jumptbl
+    | Lsetuptrap _ -> 2
+    | Lpushtrap -> 3
+    | Lpoptrap -> 1
+    | Lraise k ->
+      begin match k with
+      | Cmm.Raise_withtrace -> 1
+      | Cmm.Raise_notrace -> 4
+      end
+
+  let relax_allocation ~num_words ~label_after_call_gc =
+    Lop (Ispecific (Ifar_alloc { words = num_words; label_after_call_gc; }))
+
+  let relax_intop_checkbound ~label_after_error =
+    Lop (Ispecific (Ifar_intop_checkbound { label_after_error; }))
+
+  let relax_intop_imm_checkbound ~bound ~label_after_error =
+    Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; }))
+
+  let relax_specific_op = function
+    | Ishiftcheckbound { shift; label_after_error; } ->
+      Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; }))
+    | _ -> assert false
+end)
+
+(* Output the assembly code for allocation. *)
+
+let assembly_code_for_allocation ?label_after_call_gc i ~n ~far =
+  let lbl_frame =
+    record_frame_label ?label:label_after_call_gc i.live false i.dbg
+  in
+  if !fastcode_flag then begin
+    let lbl_redo = new_label() in
+    let lbl_call_gc = new_label() in
+    `{emit_label lbl_redo}:`;
+    `	sub	{emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`;
+    `	cmp	{emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`;
+    `	add	{emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`;
+    if not far then begin
+      `	b.lo	{emit_label lbl_call_gc}\n`
+    end else begin
+      let lbl = new_label () in
+      `	b.cs	{emit_label lbl}\n`;
+      `	b	{emit_label lbl_call_gc}\n`;
+      `{emit_label lbl}:\n`
+    end;
+    call_gc_sites :=
+      { gc_lbl = lbl_call_gc;
+        gc_return_lbl = lbl_redo;
+        gc_frame_lbl = lbl_frame } :: !call_gc_sites
+  end else begin
+    begin match n with
+    | 16 -> `	bl	{emit_symbol "caml_alloc1"}\n`
+    | 24 -> `	bl	{emit_symbol "caml_alloc2"}\n`
+    | 32 -> `	bl	{emit_symbol "caml_alloc3"}\n`
+    | _  -> emit_intconst reg_x15 (Nativeint.of_int n);
+            `	bl	{emit_symbol "caml_allocN"}\n`
+    end;
+    `{emit_label lbl_frame}:	add	{emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`
+  end
+
+(* Output the assembly code for an instruction *)
+
+let emit_instr i =
+    emit_debug_info i.dbg;
+    match i.desc with
+    | Lend -> ()
+    | Lop(Imove | Ispill | Ireload) ->
+        let src = i.arg.(0) and dst = i.res.(0) in
+        if src.loc <> dst.loc then begin
+          match (src, dst) with
+          | {loc = Reg _; typ = Float}, {loc = Reg _} ->
+              `	fmov	{emit_reg dst}, {emit_reg src}\n`
+          | {loc = Reg _}, {loc = Reg _} ->
+              `	mov	{emit_reg dst}, {emit_reg src}\n`
+          | {loc = Reg _}, {loc = Stack _} ->
+              `	str	{emit_reg src}, {emit_stack dst}\n`
+          | {loc = Stack _}, {loc = Reg _} ->
+              `	ldr	{emit_reg dst}, {emit_stack src}\n`
+          | _ ->
+              assert false
+        end
+    | Lop(Iconst_int n) ->
+        emit_intconst i.res.(0) n
+    | Lop(Iconst_float f) ->
+        if f = 0L then
+          `	fmov	{emit_reg i.res.(0)}, xzr\n`
+        else if is_immediate_float f then
+          `	fmov	{emit_reg i.res.(0)}, #{emit_printf "0x%Lx" f}\n`
+        else begin
+          let lbl = float_literal f in
+          `	adrp	{emit_reg reg_tmp1}, {emit_label lbl}\n`;
+          `	ldr	{emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
+        end
+    | Lop(Iconst_symbol s) ->
+        emit_load_symbol_addr i.res.(0) s
+    | Lop(Icall_ind { label_after; }) ->
+        `	blr	{emit_reg i.arg.(0)}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+    | Lop(Icall_imm { func; label_after; }) ->
+        `	bl	{emit_symbol func}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+    | Lop(Itailcall_ind { label_after = _; }) ->
+        output_epilogue (fun () -> `	br	{emit_reg i.arg.(0)}\n`)
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then
+          `	b	{emit_label !tailrec_entry_point}\n`
+        else
+          output_epilogue (fun () -> `	b	{emit_symbol func}\n`)
+    | Lop(Iextcall { func; alloc = false; label_after = _; }) ->
+        `	bl	{emit_symbol func}\n`
+    | Lop(Iextcall { func; alloc = true; label_after; }) ->
+        emit_load_symbol_addr reg_x15 func;
+        `	bl	{emit_symbol "caml_c_call"}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+    | Lop(Istackoffset n) ->
+        assert (n mod 16 = 0);
+        emit_stack_adjustment (-n);
+        stack_offset := !stack_offset + n
+    | Lop(Iload(size, addr)) ->
+        let dst = i.res.(0) in
+        let base =
+          match addr with
+          | Iindexed _ -> i.arg.(0)
+          | Ibased(s, ofs) ->
+              `	adrp	{emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
+              reg_tmp1 in
+        begin match size with
+        | Byte_unsigned ->
+            `	ldrb	{emit_wreg dst}, {emit_addressing addr base}\n`
+        | Byte_signed ->
+            `	ldrsb	{emit_reg dst}, {emit_addressing addr base}\n`
+        | Sixteen_unsigned ->
+            `	ldrh	{emit_wreg dst}, {emit_addressing addr base}\n`
+        | Sixteen_signed ->
+            `	ldrsh	{emit_reg dst}, {emit_addressing addr base}\n`
+        | Thirtytwo_unsigned ->
+            `	ldr	{emit_wreg dst}, {emit_addressing addr base}\n`
+        | Thirtytwo_signed ->
+            `	ldrsw	{emit_reg dst}, {emit_addressing addr base}\n`
+        | Single ->
+            `	ldr	s7, {emit_addressing addr base}\n`;
+            `	fcvt	{emit_reg dst}, s7\n`
+        | Word_int | Word_val | Double | Double_u ->
+            `	ldr	{emit_reg dst}, {emit_addressing addr base}\n`
+        end
+    | Lop(Istore(size, addr, _)) ->
+        let src = i.arg.(0) in
+        let base =
+          match addr with
+          | Iindexed _ -> i.arg.(1)
+          | Ibased(s, ofs) ->
+              `	adrp	{emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
+              reg_tmp1 in
+        begin match size with
+        | Byte_unsigned | Byte_signed ->
+            `	strb	{emit_wreg src}, {emit_addressing addr base}\n`
+        | Sixteen_unsigned | Sixteen_signed ->
+            `	strh	{emit_wreg src}, {emit_addressing addr base}\n`
+        | Thirtytwo_unsigned | Thirtytwo_signed ->
+            `	str	{emit_wreg src}, {emit_addressing addr base}\n`
+        | Single ->
+            `	fcvt	s7, {emit_reg src}\n`;
+            `	str	s7, {emit_addressing addr base}\n`;
+        | Word_int | Word_val | Double | Double_u ->
+            `	str	{emit_reg src}, {emit_addressing addr base}\n`
+        end
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc
+    | Lop(Ispecific (Ifar_alloc { words = n; label_after_call_gc; })) ->
+        assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc
+    | Lop(Iintop(Icomp cmp)) ->
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	cset	{emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
+        `	cset	{emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
+    | Lop(Iintop (Icheckbound { label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	b.ls	{emit_label lbl}\n`
+    | Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        let lbl2 = new_label () in
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	b.hi	{emit_label lbl2}\n`;
+        `	b	{emit_label lbl}\n`;
+        `{emit_label lbl2}:\n`;
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
+        `	b.ls	{emit_label lbl}\n`
+    | Lop(Ispecific(
+          Ifar_intop_imm_checkbound { bound; label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        let lbl2 = new_label () in
+        `	cmp	{emit_reg i.arg.(0)}, #{emit_int bound}\n`;
+        `	b.hi	{emit_label lbl2}\n`;
+        `	b	{emit_label lbl}\n`;
+        `{emit_label lbl2}:\n`;
+    | Lop(Ispecific(Ishiftcheckbound { shift; label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        `	cmp	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
+        `	b.cs	{emit_label lbl}\n`
+    | Lop(Ispecific(Ifar_shiftcheckbound { shift; label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        let lbl2 = new_label () in
+        `	cmp	{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
+        `	b.lo	{emit_label lbl2}\n`;
+        `	b	{emit_label lbl}\n`;
+        `{emit_label lbl2}:\n`;
+    | Lop(Iintop Imod) ->
+        `	sdiv	{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	msub	{emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
+    | Lop(Iintop Imulh) ->
+        `	smulh	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Iintop op) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Iintop_imm(op, n)) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`
+    | Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) ->
+        let instr = (match op with
+                     | Ifloatofint      -> "scvtf"
+                     | Iintoffloat      -> "fcvtzs"
+                     | Iabsf            -> "fabs"
+                     | Inegf            -> "fneg"
+                     | Ispecific Isqrtf -> "fsqrt"
+                     | _                -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+    | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) ->
+        let instr = (match op with
+                     | Iaddf              -> "fadd"
+                     | Isubf              -> "fsub"
+                     | Imulf              -> "fmul"
+                     | Idivf              -> "fdiv"
+                     | Ispecific Inegmulf -> "fnmul"
+                     | _                  -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
+        let instr = (match op with
+                     | Imuladdf    -> "fmadd"
+                     | Inegmuladdf -> "fnmadd"
+                     | Imulsubf    -> "fmsub"
+                     | Inegmulsubf -> "fnmsub"
+                     | _ -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n`
+    | Lop(Ispecific(Ishiftarith(op, shift))) ->
+        let instr = (match op with
+                       Ishiftadd    -> "add"
+                     | Ishiftsub    -> "sub") in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
+        if shift >= 0
+        then `, lsl #{emit_int shift}\n`
+        else `, asr #{emit_int (-shift)}\n`
+    | Lop(Ispecific(Imuladd | Imulsub as op)) ->
+        let instr = (match op with
+                       Imuladd -> "madd"
+                     | Imulsub -> "msub"
+                     | _ -> assert false) in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
+    | Lop(Ispecific(Ibswap size)) ->
+        begin match size with
+        | 16 ->
+            `	rev16	{emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`;
+            `	ubfm	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #15\n`
+        | 32 ->
+            `	rev	{emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`
+        | 64 ->
+            `	rev	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+        | _ ->
+            assert false
+        end
+    | Lreloadretaddr ->
+        ()
+    | Lreturn ->
+        output_epilogue (fun () -> `	ret\n`)
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`
+    | Lbranch lbl ->
+        `	b	{emit_label lbl}\n`
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+        | Itruetest ->
+            `	cbnz	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
+        | Ifalsetest ->
+            `	cbz	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
+        | Iinttest cmp ->
+            `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            let comp = name_for_comparison cmp in
+            `	b.{emit_string comp}	{emit_label lbl}\n`
+        | Iinttest_imm(cmp, n) ->
+            `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
+            let comp = name_for_comparison cmp in
+            `	b.{emit_string comp}	{emit_label lbl}\n`
+        | Ifloattest(cmp, neg) ->
+            let comp = (match (cmp, neg) with
+                        | (Ceq, false) | (Cne, true) -> "eq"
+                        | (Cne, false) | (Ceq, true) -> "ne"
+                        | (Clt, false) -> "cc"
+                        | (Clt, true)  -> "cs"
+                        | (Cle, false) -> "ls"
+                        | (Cle, true)  -> "hi"
+                        | (Cgt, false) -> "gt"
+                        | (Cgt, true)  -> "le"
+                        | (Cge, false) -> "ge"
+                        | (Cge, true)  -> "lt") in
+            `	fcmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `	b.{emit_string comp}	{emit_label lbl}\n`
+        | Ioddtest ->
+            `	tbnz	{emit_reg i.arg.(0)}, #0, {emit_label lbl}\n`
+        | Ieventest ->
+            `	tbz	{emit_reg i.arg.(0)}, #0, {emit_label lbl}\n`
+        end
+    | Lcondbranch3(lbl0, lbl1, lbl2) ->
+        `	cmp	{emit_reg i.arg.(0)}, #1\n`;
+        begin match lbl0 with
+          None -> ()
+        | Some lbl -> `	b.lt	{emit_label lbl}\n`
+        end;
+        begin match lbl1 with
+          None -> ()
+        | Some lbl -> `	b.eq	{emit_label lbl}\n`
+        end;
+        begin match lbl2 with
+          None -> ()
+        | Some lbl -> `	b.gt	{emit_label lbl}\n`
+        end
+    | Lswitch jumptbl ->
+        let lbltbl = new_label() in
+        `	adr	{emit_reg reg_tmp1}, {emit_label lbltbl}\n`;
+        `	add	{emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`;
+        `	br	{emit_reg reg_tmp1}\n`;
+        `{emit_label lbltbl}:`;
+        for j = 0 to Array.length jumptbl - 1 do
+            `	b	{emit_label jumptbl.(j)}\n`
+        done
+(* Alternative:
+        let lbltbl = new_label() in
+        `	adr	{emit_reg reg_tmp1}, {emit_label lbltbl}\n`;
+        `	ldr	{emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`;
+        `	add	{emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`;
+        `	br	{emit_reg reg_tmp1}\n`;
+        `{emit_label lbltbl}:\n`;
+        for j = 0 to Array.length jumptbl - 1 do
+            `	.word	{emit_label jumptbl.(j)} - {emit_label lbltbl}\n`
+        done
+*)
+    | Lsetuptrap lbl ->
+        let lblnext = new_label() in
+        `	adr	{emit_reg reg_tmp1}, {emit_label lblnext}\n`;
+        `	b	{emit_label lbl}\n`;
+        `{emit_label lblnext}:\n`
+    | Lpushtrap ->
+        stack_offset := !stack_offset + 16;
+        `	str	{emit_reg reg_trap_ptr}, [sp, -16]!\n`;
+        `	str	{emit_reg reg_tmp1}, [sp, #8]\n`;
+        cfi_adjust_cfa_offset 16;
+        `	mov	{emit_reg reg_trap_ptr}, sp\n`
+    | Lpoptrap ->
+        `	ldr	{emit_reg reg_trap_ptr}, [sp], 16\n`;
+        cfi_adjust_cfa_offset (-16);
+        stack_offset := !stack_offset - 16
+    | Lraise k ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
+          `	bl	{emit_symbol "caml_raise_exn"}\n`;
+          `{record_frame Reg.Set.empty true i.dbg}\n`
+        | Cmm.Raise_notrace ->
+          `	mov	sp, {emit_reg reg_trap_ptr}\n`;
+          `	ldr	{emit_reg reg_tmp1}, [sp, #8]\n`;
+          `	ldr	{emit_reg reg_trap_ptr}, [sp], 16\n`;
+          `	br	{emit_reg reg_tmp1}\n`
+        end
+
+(* Emission of an instruction sequence *)
+
+let rec emit_all i =
+  if i.desc = Lend then () else (emit_instr i; emit_all i.next)
+
+(* Emission of the profiling prelude *)
+
+let emit_profile() = ()   (* TODO *)
+(*
+  match Config.system with
+    "linux_eabi" | "linux_eabihf" | "netbsd" ->
+      `	push	\{lr}\n`;
+      `	{emit_call "__gnu_mcount_nc"}\n`
+  | _ -> ()
+*)
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  fastcode_flag := fundecl.fun_fast;
+  tailrec_entry_point := new_label();
+  float_literals := [];
+  stack_offset := 0;
+  call_gc_sites := [];
+  bound_error_sites := [];
+  `	.text\n`;
+  `	.align	3\n`;
+  `	.globl	{emit_symbol fundecl.fun_name}\n`;
+  `	.type	{emit_symbol fundecl.fun_name}, %function\n`;
+  `{emit_symbol fundecl.fun_name}:\n`;
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc();
+  if !Clflags.gprofile then emit_profile();
+  let n = frame_size() in
+  if n > 0 then
+    emit_stack_adjustment (-n);
+  if !contains_calls then begin
+    cfi_offset ~reg:30 (* return address *) ~offset:(-8);
+    `	str	x30, [sp, #{emit_int (n-8)}]\n`
+  end;
+  `{emit_label !tailrec_entry_point}:\n`;
+  let num_call_gc, num_check_bound =
+    num_call_gc_and_check_bound_points fundecl.fun_body
+  in
+  let max_out_of_line_code_offset =
+    max_out_of_line_code_offset ~num_call_gc
+      ~num_check_bound
+  in
+  BR.relax fundecl.fun_body ~max_out_of_line_code_offset;
+  emit_all fundecl.fun_body;
+  List.iter emit_call_gc !call_gc_sites;
+  List.iter emit_call_bound_error !bound_error_sites;
+  assert (List.length !call_gc_sites = num_call_gc);
+  assert (List.length !bound_error_sites = num_check_bound);
+  cfi_endproc();
+  `	.type	{emit_symbol fundecl.fun_name}, %function\n`;
+  `	.size	{emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`;
+  emit_literals()
+
+(* Emission of data *)
+
+let emit_item = function
+  | Cglobal_symbol s -> `	.globl	{emit_symbol s}\n`;
+  | Cdefine_symbol s -> `{emit_symbol s}:\n`
+  | Cint8 n -> `	.byte	{emit_int n}\n`
+  | Cint16 n -> `	.short	{emit_int n}\n`
+  | Cint32 n -> `	.long	{emit_nativeint n}\n`
+  | Cint n -> `	.quad	{emit_nativeint n}\n`
+  | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
+  | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f)
+  | Csymbol_address s -> `	.quad	{emit_symbol s}\n`
+  | Cstring s -> emit_string_directive "	.ascii  " s
+  | Cskip n -> if n > 0 then `	.space	{emit_int n}\n`
+  | Calign n -> `	.align	{emit_int(Misc.log2 n)}\n`
+
+let data l =
+  `	.data\n`;
+  `	.align 3\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  reset_debug_info();
+  `	.file	\"\"\n`;  (* PR#7037 *)
+  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.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.make_symbol (Some "code_end") in
+  `	.text\n`;
+  `	.globl	{emit_symbol lbl_end}\n`;
+  `{emit_symbol lbl_end}:\n`;
+  let lbl_end = Compilenv.make_symbol (Some "data_end") in
+  `	.data\n`;
+  `	.globl	{emit_symbol lbl_end}\n`;
+  `{emit_symbol lbl_end}:\n`;
+  `	.long	0\n`;
+  let lbl = Compilenv.make_symbol (Some "frametable") in
+  `	.globl	{emit_symbol lbl}\n`;
+  `{emit_symbol lbl}:\n`;
+  emit_frames
+    { efa_code_label = (fun lbl ->
+                       `	.type	{emit_label lbl}, %function\n`;
+                       `	.quad	{emit_label lbl}\n`);
+      efa_data_label = (fun lbl ->
+                       `	.type	{emit_label lbl}, %object\n`;
+                       `	.quad	{emit_label lbl}\n`);
+      efa_16 = (fun n -> `	.short	{emit_int n}\n`);
+      efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
+      efa_word = (fun n -> `	.quad	{emit_int n}\n`);
+      efa_align = (fun n -> `	.align	{emit_int(Misc.log2 n)}\n`);
+      efa_label_rel = (fun lbl ofs ->
+                           `	.long	{emit_label lbl} - . + {emit_int32 ofs}\n`);
+      efa_def_label = (fun lbl -> `{emit_label lbl}:\n`);
+      efa_string = (fun s -> emit_string_directive "	.asciz	" s) };
+  `	.type	{emit_symbol lbl}, %object\n`;
+  `	.size	{emit_symbol lbl}, .-{emit_symbol lbl}\n`;
+  begin match Config.system with
+  | "linux" ->
+      (* Mark stack as non-executable *)
+      `	.section	.note.GNU-stack,\"\",%progbits\n`
+  | _ -> ()
+  end
diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml
new file mode 100644
index 00000000..94062bbf
--- /dev/null
+++ b/asmcomp/arm64/proc.ml
@@ -0,0 +1,237 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the ARM processor in 64-bit mode *)
+
+open Misc
+open Cmm
+open Reg
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Registers available for register allocation *)
+
+(* Integer register map:
+    x0 - x15              general purpose (caller-save)
+    x16, x17              temporaries (used by call veeners)
+    x18                   platform register (reserved)
+    x19 - x25             general purpose (callee-save)
+    x26                   trap pointer
+    x27                   alloc pointer
+    x28                   alloc limit
+    x29                   frame pointer
+    x30                   return address
+    sp / xzr              stack pointer / zero register
+   Floating-point register map:
+    d0 - d7               general purpose (caller-save)
+    d8 - d15              general purpose (callee-save)
+    d16 - d31             generat purpose (caller-save)
+*)
+
+let int_reg_name =
+  [| "x0";  "x1";  "x2";  "x3";  "x4";  "x5";  "x6";  "x7";
+     "x8";  "x9";  "x10"; "x11"; "x12"; "x13"; "x14"; "x15";
+     "x19"; "x20"; "x21"; "x22"; "x23"; "x24"; "x25";
+     "x26"; "x27"; "x28"; "x16"; "x17" |]
+
+let float_reg_name =
+  [| "d0";  "d1";  "d2";  "d3";  "d4";  "d5";  "d6";  "d7";
+     "d8";  "d9";  "d10"; "d11"; "d12"; "d13"; "d14"; "d15";
+     "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23";
+     "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |]
+
+let num_register_classes = 2
+
+let register_class r =
+  match r.typ with
+  | Val | Int | Addr  -> 0
+  | Float -> 1
+
+let num_available_registers =
+  [| 23; 32 |] (* first 23 int regs allocatable; all float regs allocatable *)
+
+let first_available_register =
+  [| 0; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+let rotate_registers = true
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 28 Reg.dummy in
+  for i = 0 to 27 do
+    v.(i) <- Reg.at_location Int (Reg i)
+  done;
+  v
+
+let hard_float_reg =
+  let v = Array.make 32 Reg.dummy in
+  for i = 0 to 31 do
+    v.(i) <- Reg.at_location Float (Reg(100 + i))
+  done;
+  v
+
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let reg_x15 = phys_reg 15
+let reg_d7 = phys_reg 107
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
+(* Calling conventions *)
+
+let calling_conventions
+    first_int last_int first_float last_float make_stack arg =
+  let loc = Array.make (Array.length arg) Reg.dummy in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref 0 in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+    | Val | Int | Addr as ty ->
+        if !int <= last_int then begin
+          loc.(i) <- phys_reg !int;
+          incr int
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !float <= last_float then begin
+          loc.(i) <- phys_reg !float;
+          incr float
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+(* OCaml calling convention:
+     first integer args in r0...r15
+     first float args in d0...d15
+     remaining args on stack.
+   Return values in r0...r15 or d0...d15. *)
+
+let max_arguments_for_tailcalls = 16
+
+let loc_arguments arg =
+  calling_conventions 0 15 100 115 outgoing arg
+let loc_parameters arg =
+  let (loc, _) = calling_conventions 0 15 100 115 incoming arg in loc
+let loc_results res =
+  let (loc, _) = calling_conventions 0 15 100 115 not_supported res in loc
+
+(* C calling convention:
+     first integer args in r0...r7
+     first float args in d0...d7
+     remaining args on stack.
+   Return values in r0...r1 or d0. *)
+
+let loc_external_arguments arg =
+  let arg =
+    Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg
+  in
+  let loc, alignment = calling_conventions 0 7 100 107 outgoing arg in
+  Array.map (fun reg -> [|reg|]) loc, alignment
+let loc_external_results res =
+  let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc
+
+let loc_exn_bucket = phys_reg 0
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _rs = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call =
+  (* x19-x28, d8-d15 preserved *)
+  Array.of_list (List.map phys_reg
+    [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;
+     100;101;102;103;104;105;106;107;
+     116;117;118;119;120;121;122;123;
+     124;125;126;127;128;129;130;131])
+
+let destroyed_at_oper = function
+  | Iop(Icall_ind _ | Icall_imm _) | Iop(Iextcall { alloc = true; }) ->
+      all_phys_regs
+  | Iop(Iextcall { alloc = false; }) ->
+      destroyed_at_c_call
+  | Iop(Ialloc _) ->
+      [| reg_x15 |]
+  | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) ->
+      [| reg_d7 |]            (* d7 / s7 destroyed *)
+  | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure = function
+  | Iextcall _ -> 8
+  | Ialloc _ -> 25
+  | _ -> 26
+
+let max_register_pressure = function
+  | Iextcall _ -> [| 10; 8 |]
+  | Ialloc _ -> [| 25; 32 |]
+  | Iintoffloat | Ifloatofint
+  | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |]
+  | _ -> [| 26; 32 |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers). *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _)
+  | Ispecific(Ishiftcheckbound _) -> false
+  | _ -> true
+
+(* Layout of the stack *)
+
+let num_stack_slots = [| 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler *)
+
+let assemble_file infile outfile =
+  Ccomp.command (Config.asm ^ " -o " ^
+                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+
+let init () = ()
diff --git a/asmcomp/arm64/reload.ml b/asmcomp/arm64/reload.ml
new file mode 100644
index 00000000..0d6cacd0
--- /dev/null
+++ b/asmcomp/arm64/reload.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Reloading for the ARM 64 bits *)
+
+let fundecl f =
+  (new Reloadgen.reload_generic)#fundecl f
diff --git a/asmcomp/arm64/scheduling.ml b/asmcomp/arm64/scheduling.ml
new file mode 100644
index 00000000..04f514e9
--- /dev/null
+++ b/asmcomp/arm64/scheduling.ml
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let _ = let module M = Schedgen in () (* to create a dependency *)
+
+(* Scheduling is turned off because the processor schedules dynamically
+   much better than what we could do. *)
+
+let fundecl f = f
diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml
new file mode 100644
index 00000000..d8ea7f83
--- /dev/null
+++ b/asmcomp/arm64/selection.ml
@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                 Benedikt Meurer, University of Siegen                  *)
+(*                                                                        *)
+(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2012 Benedikt Meurer.                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the ARM processor *)
+
+open Arch
+open Cmm
+open Mach
+
+let is_offset chunk n =
+   (n >= -256 && n <= 255)               (* 9 bits signed unscaled *)
+|| (n >= 0 &&
+    match chunk with     (* 12 bits unsigned, scaled by chunk size *)
+    | Byte_unsigned | Byte_signed ->
+        n < 0x1000
+    | Sixteen_unsigned | Sixteen_signed ->
+        n land 1 = 0 && n lsr 1 < 0x1000
+    | Thirtytwo_unsigned | Thirtytwo_signed | Single ->
+        n land 3 = 0 && n lsr 2 < 0x1000
+    | Word_int | Word_val | Double | Double_u ->
+        n land 7 = 0 && n lsr 3 < 0x1000)
+
+(* An automaton to recognize ( 0+1+0* | 1+0+1* )
+
+               0          1          0
+              / \        / \        / \
+              \ /        \ /        \ /
+        -0--> [1] --1--> [2] --0--> [3]
+       /
+     [0]
+       \
+        -1--> [4] --0--> [5] --1--> [6]
+              / \        / \        / \
+              \ /        \ /        \ /
+               1          0          1
+
+The accepting states are 2, 3, 5 and 6. *)
+
+let auto_table = [|   (* accepting?, next on 0, next on 1 *)
+  (* state 0 *) (false, 1, 4);
+  (* state 1 *) (false, 1, 2);
+  (* state 2 *) (true,  3, 2);
+  (* state 3 *) (true,  3, 7);
+  (* state 4 *) (false, 5, 4);
+  (* state 5 *) (true,  5, 6);
+  (* state 6 *) (true,  7, 6);
+  (* state 7 *) (false, 7, 7)   (* error state *)
+|]
+
+let rec run_automata nbits state input =
+  let (acc, next0, next1) = auto_table.(state) in
+  if nbits <= 0
+  then acc
+  else run_automata (nbits - 1)
+                    (if input land 1 = 0 then next0 else next1)
+                    (input asr 1)
+
+(* We are very conservative wrt what ARM64 supports: we don't support
+   repetitions of a 000111000 or 1110000111 pattern, just a single
+   pattern of this kind. *)
+
+let is_logical_immediate n =
+  n <> 0 && n <> -1 && run_automata 64 0 n
+
+(* If you update [inline_ops], you may need to update [is_simple_expr] and/or
+   [effects_of], below. *)
+let inline_ops =
+  [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
+    "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
+
+let use_direct_addressing symb =
+  (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb
+
+(* Instruction selection *)
+
+class selector = object(self)
+
+inherit Selectgen.selector_generic as super
+
+method is_immediate n =
+  let mn = -n in
+  n land 0xFFF = n || n land 0xFFF_000 = n
+  || mn land 0xFFF = mn || mn land 0xFFF_000 = mn
+
+method! is_simple_expr = function
+  (* inlined floating-point ops are simple if their arguments are *)
+  | Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops ->
+      List.for_all self#is_simple_expr args
+  | e -> super#is_simple_expr e
+
+method! effects_of e =
+  match e with
+  | Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops ->
+      Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+  | e -> super#effects_of e
+
+method select_addressing chunk = function
+  | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _)
+    when use_direct_addressing s ->
+      (Ibased(s, n), Ctuple [])
+  | Cop((Caddv | Cadda), [arg; Cconst_int n], _)
+    when is_offset chunk n ->
+      (Iindexed n, arg)
+  | Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg)
+    when is_offset chunk n ->
+      (Iindexed n, Cop(op, [arg1; arg2], dbg))
+  | Cconst_symbol s
+    when use_direct_addressing s ->
+      (Ibased(s, 0), Ctuple [])
+  | arg ->
+      (Iindexed 0, arg)
+
+method! select_operation op args dbg =
+  match op with
+  (* Integer addition *)
+  | Caddi | Caddv | Cadda ->
+      begin match args with
+      (* Add immediate *)
+      | [arg; Cconst_int n] when self#is_immediate n ->
+          ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)),
+           [arg])
+      | [Cconst_int n; arg] when self#is_immediate n ->
+          ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)),
+           [arg])
+      (* Shift-add *)
+      | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2])
+      | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2])
+      | [Cop(Clsl, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1])
+      | [Cop(Casr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1])
+      (* Multiply-add *)
+      | [arg1; Cop(Cmuli, args2, dbg)] | [Cop(Cmuli, args2, dbg); arg1] ->
+          begin match self#select_operation Cmuli args2 dbg with
+          | (Iintop_imm(Ilsl, l), [arg3]) ->
+              (Ispecific(Ishiftarith(Ishiftadd, l)), [arg1; arg3])
+          | (Iintop Imul, [arg3; arg4]) ->
+              (Ispecific Imuladd, [arg3; arg4; arg1])
+          | _ ->
+              super#select_operation op args dbg
+          end
+      | _ ->
+          super#select_operation op args dbg
+      end
+  (* Integer subtraction *)
+  | Csubi ->
+      begin match args with
+      (* Sub immediate *)
+      | [arg; Cconst_int n] when self#is_immediate n ->
+          ((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)),
+           [arg])
+      (* Shift-sub *)
+      | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2])
+      | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2])
+      (* Multiply-sub *)
+      | [arg1; Cop(Cmuli, args2, dbg)] ->
+          begin match self#select_operation Cmuli args2 dbg with
+          | (Iintop_imm(Ilsl, l), [arg3]) ->
+              (Ispecific(Ishiftarith(Ishiftsub, l)), [arg1; arg3])
+          | (Iintop Imul, [arg3; arg4]) ->
+              (Ispecific Imulsub, [arg3; arg4; arg1])
+          | _ ->
+              super#select_operation op args dbg
+          end
+      | _ ->
+          super#select_operation op args dbg
+      end
+  (* Checkbounds *)
+  | Ccheckbound ->
+      begin match args with
+      | [Cop(Clsr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
+          (Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }),
+            [arg1; arg2])
+      | _ ->
+          super#select_operation op args dbg
+      end
+  (* Integer multiplication *)
+  (* ARM does not support immediate operands for multiplication *)
+  | Cmuli ->
+      (Iintop Imul, args)
+  | Cmulhi ->
+      (Iintop Imulh, args)
+  (* Bitwise logical operations have a different range of immediate
+     operands than the other instructions *)
+  | Cand -> self#select_logical Iand args
+  | Cor -> self#select_logical Ior args
+  | Cxor -> self#select_logical Ixor args
+  (* Recognize floating-point negate and multiply *)
+  | Cnegf ->
+      begin match args with
+      | [Cop(Cmulf, args, _)] -> (Ispecific Inegmulf, args)
+      | _ -> super#select_operation op args dbg
+      end
+  (* Recognize floating-point multiply and add/sub *)
+  | Caddf ->
+      begin match args with
+      | [arg; Cop(Cmulf, args, _)] | [Cop(Cmulf, args, _); arg] ->
+          (Ispecific Imuladdf, arg :: args)
+      | _ ->
+          super#select_operation op args dbg
+      end
+  | Csubf ->
+      begin match args with
+      | [arg; Cop(Cmulf, args, _)] ->
+          (Ispecific Imulsubf, arg :: args)
+      | [Cop(Cmulf, args, _); arg] ->
+          (Ispecific Inegmulsubf, arg :: args)
+      | _ ->
+          super#select_operation op args dbg
+      end
+  (* Recognize floating-point square root *)
+  | Cextcall("sqrt", _, _, _) ->
+      (Ispecific Isqrtf, args)
+  (* Recognize bswap instructions *)
+  | Cextcall("caml_bswap16_direct", _, _, _) ->
+      (Ispecific(Ibswap 16), args)
+  | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+      (Ispecific(Ibswap 32), args)
+  | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"),
+              _, _, _) ->
+      (Ispecific (Ibswap 64), args)
+  (* Other operations are regular *)
+  | _ ->
+      super#select_operation op args dbg
+
+method select_logical op = function
+  | [arg; Cconst_int n] when is_logical_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | [Cconst_int n; arg] when is_logical_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | args ->
+      (Iintop op, args)
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
new file mode 100644
index 00000000..020732dd
--- /dev/null
+++ b/asmcomp/asmgen.ml
@@ -0,0 +1,270 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* From lambda to assembly code *)
+
+[@@@ocaml.warning "+a-4-9-40-41-42"]
+
+open Format
+open Config
+open Clflags
+open Misc
+open Cmm
+
+type error = Assembler_error of string
+
+exception Error of error
+
+let liveness ppf phrase =
+  Liveness.fundecl ppf phrase; phrase
+
+let dump_if ppf flag message phrase =
+  if !flag then Printmach.phase message ppf phrase
+
+let pass_dump_if ppf flag message phrase =
+  dump_if ppf flag message phrase; phrase
+
+let pass_dump_linear_if ppf flag message phrase =
+  if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
+  phrase
+
+let flambda_raw_clambda_dump_if ppf
+      ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _;
+        structured_constants; exported = _; } as input) =
+  if !dump_rawclambda then
+    begin
+      Format.fprintf ppf "@.clambda (before Un_anf):@.";
+      Printclambda.clambda ppf ulambda;
+      Symbol.Map.iter (fun sym cst ->
+          Format.fprintf ppf "%a:@ %a@."
+            Symbol.print sym
+            Printclambda.structured_constant cst)
+        structured_constants
+    end;
+  if !dump_cmm then Format.fprintf ppf "@.cmm:@.";
+  input
+
+type clambda_and_constants =
+  Clambda.ulambda *
+  Clambda.preallocated_block list *
+  Clambda.preallocated_constant list
+
+let raw_clambda_dump_if ppf
+      ((ulambda, _, structured_constants):clambda_and_constants) =
+  if !dump_rawclambda || !dump_clambda then
+    begin
+      Format.fprintf ppf "@.clambda:@.";
+      Printclambda.clambda ppf ulambda;
+      List.iter (fun {Clambda.symbol; definition} ->
+          Format.fprintf ppf "%s:@ %a@."
+            symbol
+            Printclambda.structured_constant definition)
+        structured_constants
+    end;
+  if !dump_cmm then Format.fprintf ppf "@.cmm:@."
+
+let rec regalloc ppf round fd =
+  if round > 50 then
+    fatal_error(fd.Mach.fun_name ^
+                ": function too complex, cannot complete register allocation");
+  dump_if ppf dump_live "Liveness analysis" fd;
+  Interf.build_graph fd;
+  if !dump_interf then Printmach.interferences ppf ();
+  if !dump_prefer then Printmach.preferences ppf ();
+  Coloring.allocate_registers();
+  dump_if ppf dump_regalloc "After register allocation" fd;
+  let (newfd, redo_regalloc) = Reload.fundecl fd in
+  dump_if ppf dump_reload "After insertion of reloading code" newfd;
+  if redo_regalloc then begin
+    Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd
+  end else newfd
+
+let (++) x f = f x
+
+let compile_fundecl (ppf : formatter) fd_cmm =
+  Proc.init ();
+  Reg.reset();
+  let build = Compilenv.current_build () in
+  fd_cmm
+  ++ Timings.(accumulate_time (Selection build)) Selection.fundecl
+  ++ pass_dump_if ppf dump_selection "After instruction selection"
+  ++ Timings.(accumulate_time (Comballoc build)) Comballoc.fundecl
+  ++ pass_dump_if ppf dump_combine "After allocation combining"
+  ++ Timings.(accumulate_time (CSE build)) CSE.fundecl
+  ++ pass_dump_if ppf dump_cse "After CSE"
+  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
+  ++ Timings.(accumulate_time (Deadcode build)) Deadcode.fundecl
+  ++ pass_dump_if ppf dump_live "Liveness analysis"
+  ++ Timings.(accumulate_time (Spill build)) Spill.fundecl
+  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
+  ++ pass_dump_if ppf dump_spill "After spilling"
+  ++ Timings.(accumulate_time (Split build)) Split.fundecl
+  ++ pass_dump_if ppf dump_split "After live range splitting"
+  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
+  ++ Timings.(accumulate_time (Regalloc build)) (regalloc ppf 1)
+  ++ Timings.(accumulate_time (Linearize build)) Linearize.fundecl
+  ++ pass_dump_linear_if ppf dump_linear "Linearized code"
+  ++ Timings.(accumulate_time (Scheduling build)) Scheduling.fundecl
+  ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
+  ++ Timings.(accumulate_time (Emit build)) Emit.fundecl
+
+let compile_phrase ppf p =
+  if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
+  match p with
+  | Cfunction fd -> compile_fundecl ppf fd
+  | Cdata dl -> Emit.data dl
+
+
+(* For the native toplevel: generates generic functions unless
+   they are already available in the process *)
+let compile_genfuns ppf f =
+  List.iter
+    (function
+       | (Cfunction {fun_name = name}) as ph when f name ->
+           compile_phrase ppf ph
+       | _ -> ())
+    (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
+
+let compile_unit ~source_provenance _output_prefix asm_filename keep_asm
+      obj_filename gen =
+  let create_asm = keep_asm || not !Emitaux.binary_backend_available in
+  Emitaux.create_asm_file := create_asm;
+  try
+    if create_asm then Emitaux.output_channel := open_out asm_filename;
+    begin try
+      gen ();
+      if create_asm then close_out !Emitaux.output_channel;
+    with exn when create_asm ->
+      close_out !Emitaux.output_channel;
+      if not keep_asm then remove_file asm_filename;
+      raise exn
+    end;
+    let assemble_result =
+      Timings.(time (Assemble source_provenance))
+        (Proc.assemble_file asm_filename) obj_filename
+    in
+    if assemble_result <> 0
+    then raise(Error(Assembler_error asm_filename));
+    if create_asm && not keep_asm then remove_file asm_filename
+  with exn ->
+    remove_file obj_filename;
+    raise exn
+
+let set_export_info (ulambda, prealloc, structured_constants, export) =
+  Compilenv.set_export_info export;
+  (ulambda, prealloc, structured_constants)
+
+let end_gen_implementation ?toplevel ~source_provenance ppf
+    (clambda:clambda_and_constants) =
+  Emit.begin_assembly ();
+  clambda
+  ++ Timings.(time (Cmm source_provenance)) Cmmgen.compunit
+  ++ Timings.(time (Compile_phrases source_provenance))
+       (List.iter (compile_phrase ppf))
+  ++ (fun () -> ());
+  (match toplevel with None -> () | Some f -> compile_genfuns ppf f);
+
+  (* We add explicit references to external primitive symbols.  This
+     is to ensure that the object files that define these symbols,
+     when part of a C library, won't be discarded by the linker.
+     This is important if a module that uses such a symbol is later
+     dynlinked. *)
+
+  compile_phrase ppf
+    (Cmmgen.reference_symbols
+       (List.filter (fun s -> s <> "" && s.[0] <> '%')
+          (List.map Primitive.native_name !Translmod.primitive_declarations))
+    );
+  Emit.end_assembly ()
+
+let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf
+    (program:Flambda.program) =
+  let export = Build_export_info.build_export_info ~backend program in
+  let (clambda, preallocated, constants) =
+    Timings.time (Flambda_pass ("backend", source_provenance)) (fun () ->
+      (program, export)
+      ++ Flambda_to_clambda.convert
+      ++ flambda_raw_clambda_dump_if ppf
+      ++ (fun { Flambda_to_clambda. expr; preallocated_blocks;
+                structured_constants; exported; } ->
+             (* "init_code" following the name used in
+                [Cmmgen.compunit_and_constants]. *)
+           Un_anf.apply expr ~what:"init_code", preallocated_blocks,
+           structured_constants, exported)
+      ++ set_export_info) ()
+  in
+  let constants =
+    List.map (fun (symbol, definition) ->
+        { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol);
+          exported = true;
+          definition })
+      (Symbol.Map.bindings constants)
+  in
+  end_gen_implementation ?toplevel ~source_provenance ppf
+    (clambda, preallocated, constants)
+
+let lambda_gen_implementation ?toplevel ~source_provenance ppf
+    (lambda:Lambda.program) =
+  let clambda = Closure.intro lambda.main_module_block_size lambda.code in
+  let preallocated_block =
+    Clambda.{
+      symbol = Compilenv.make_symbol None;
+      exported = true;
+      tag = 0;
+      size = lambda.main_module_block_size;
+    }
+  in
+  let clambda_and_constants =
+    clambda, [preallocated_block], []
+  in
+  raw_clambda_dump_if ppf clambda_and_constants;
+  end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants
+
+let compile_implementation_gen ?toplevel ~source_provenance prefixname
+    ~required_globals ppf gen_implementation program =
+  let asmfile =
+    if !keep_asm_file || !Emitaux.binary_backend_available
+    then prefixname ^ ext_asm
+    else Filename.temp_file "camlasm" ext_asm
+  in
+  compile_unit ~source_provenance prefixname asmfile !keep_asm_file
+      (prefixname ^ ext_obj) (fun () ->
+        Ident.Set.iter Compilenv.require_global required_globals;
+        gen_implementation ?toplevel ~source_provenance ppf program)
+
+let compile_implementation_clambda ?toplevel ~source_provenance prefixname
+    ppf (program:Lambda.program) =
+  compile_implementation_gen ?toplevel ~source_provenance prefixname
+    ~required_globals:program.Lambda.required_globals
+    ppf lambda_gen_implementation program
+
+let compile_implementation_flambda ?toplevel ~source_provenance prefixname
+    ~required_globals ~backend ppf (program:Flambda.program) =
+  compile_implementation_gen ?toplevel ~source_provenance prefixname
+    ~required_globals ppf (flambda_gen_implementation ~backend) program
+
+(* Error report *)
+
+let report_error ppf = function
+  | Assembler_error file ->
+      fprintf ppf "Assembler error, input left in file %a"
+        Location.print_filename file
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli
new file mode 100644
index 00000000..cc79edf9
--- /dev/null
+++ b/asmcomp/asmgen.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* From lambda to assembly code *)
+
+val compile_implementation_flambda :
+    ?toplevel:(string -> bool) ->
+    source_provenance:Timings.source_provenance ->
+    string ->
+    required_globals:Ident.Set.t ->
+    backend:(module Backend_intf.S) ->
+    Format.formatter -> Flambda.program -> unit
+
+val compile_implementation_clambda :
+    ?toplevel:(string -> bool) ->
+    source_provenance:Timings.source_provenance ->
+    string ->
+    Format.formatter -> Lambda.program -> unit
+
+val compile_phrase :
+    Format.formatter -> Cmm.phrase -> unit
+
+type error = Assembler_error of string
+exception Error of error
+val report_error: Format.formatter -> error -> unit
+
+
+val compile_unit:
+  source_provenance:Timings.source_provenance ->
+  string(*prefixname*) ->
+  string(*asm file*) -> bool(*keep asm*) ->
+  string(*obj file*) -> (unit -> unit) -> unit
diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml
new file mode 100644
index 00000000..6545a9f5
--- /dev/null
+++ b/asmcomp/asmlibrarian.ml
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Build libraries of .cmx files *)
+
+open Misc
+open Config
+open Cmx_format
+
+type error =
+    File_not_found of string
+  | Archiver_error of string
+
+exception Error of error
+
+let default_ui_export_info =
+  if Config.flambda then
+    Cmx_format.Flambda Export_info.empty
+  else
+    Cmx_format.Clambda Clambda.Value_unknown
+
+let read_info name =
+  let filename =
+    try
+      find_in_path !load_path name
+    with Not_found ->
+      raise(Error(File_not_found name)) in
+  let (info, crc) = Compilenv.read_unit_info filename in
+  info.ui_force_link <- info.ui_force_link || !Clflags.link_everything;
+  (* There is no need to keep the approximation in the .cmxa file,
+     since the compiler will go looking directly for .cmx files.
+     The linker, which is the only one that reads .cmxa files, does not
+     need the approximation. *)
+  info.ui_export_info <- default_ui_export_info;
+  (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc))
+
+let create_archive file_list lib_name =
+  let archive_name = Filename.remove_extension lib_name ^ ext_lib in
+  let outchan = open_out_bin lib_name in
+  try
+    output_string outchan cmxa_magic_number;
+    let (objfile_list, descr_list) =
+      List.split (List.map read_info file_list) in
+    List.iter2
+      (fun file_name (unit, crc) ->
+        Asmlink.check_consistency file_name unit crc)
+      file_list descr_list;
+    let infos =
+      { lib_units = descr_list;
+        lib_ccobjs = !Clflags.ccobjs;
+        lib_ccopts = !Clflags.all_ccopts } in
+    output_value outchan infos;
+    if Ccomp.create_archive archive_name objfile_list <> 0
+    then raise(Error(Archiver_error archive_name));
+    close_out outchan
+  with x ->
+    close_out outchan;
+    remove_file lib_name;
+    remove_file archive_name;
+    raise x
+
+open Format
+
+let report_error ppf = function
+  | File_not_found name ->
+      fprintf ppf "Cannot find file %s" name
+  | Archiver_error name ->
+      fprintf ppf "Error while creating the library %s" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli
new file mode 100644
index 00000000..4d66827c
--- /dev/null
+++ b/asmcomp/asmlibrarian.mli
@@ -0,0 +1,28 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Build libraries of .cmx files *)
+
+open Format
+
+val create_archive: string list -> string -> unit
+
+type error =
+    File_not_found of string
+  | Archiver_error of string
+
+exception Error of error
+
+val report_error: formatter -> error -> unit
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
new file mode 100644
index 00000000..fee71787
--- /dev/null
+++ b/asmcomp/asmlink.ml
@@ -0,0 +1,421 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Link a set of .cmx/.o files and produce an executable *)
+
+open Misc
+open Config
+open Cmx_format
+open Compilenv
+
+type error =
+    File_not_found of string
+  | Not_an_object_file of string
+  | Missing_implementations of (string * string list) list
+  | Inconsistent_interface of string * string * string
+  | Inconsistent_implementation of string * string * string
+  | Assembler_error of string
+  | Linking_error
+  | Multiple_definition of string * string * string
+  | Missing_cmx of string * string
+
+exception Error of error
+
+(* Consistency check between interfaces and implementations *)
+
+let crc_interfaces = Consistbl.create ()
+let interfaces = ref ([] : string list)
+let crc_implementations = Consistbl.create ()
+let implementations = ref ([] : string list)
+let implementations_defined = ref ([] : (string * string) list)
+let cmx_required = ref ([] : string list)
+
+let check_consistency file_name unit crc =
+  begin try
+    List.iter
+      (fun (name, crco) ->
+        interfaces := name :: !interfaces;
+        match crco with
+          None -> ()
+        | Some crc ->
+            if name = unit.ui_name
+            then Consistbl.set crc_interfaces name crc file_name
+            else Consistbl.check crc_interfaces name crc file_name)
+      unit.ui_imports_cmi
+  with Consistbl.Inconsistency(name, user, auth) ->
+    raise(Error(Inconsistent_interface(name, user, auth)))
+  end;
+  begin try
+    List.iter
+      (fun (name, crco) ->
+        implementations := name :: !implementations;
+        match crco with
+            None ->
+              if List.mem name !cmx_required then
+                raise(Error(Missing_cmx(file_name, name)))
+          | Some crc ->
+              Consistbl.check crc_implementations name crc file_name)
+      unit.ui_imports_cmx
+  with Consistbl.Inconsistency(name, user, auth) ->
+    raise(Error(Inconsistent_implementation(name, user, auth)))
+  end;
+  begin try
+    let source = List.assoc unit.ui_name !implementations_defined in
+    raise (Error(Multiple_definition(unit.ui_name, file_name, source)))
+  with Not_found -> ()
+  end;
+  implementations := unit.ui_name :: !implementations;
+  Consistbl.set crc_implementations unit.ui_name crc file_name;
+  implementations_defined :=
+    (unit.ui_name, file_name) :: !implementations_defined;
+  if unit.ui_symbol <> unit.ui_name then
+    cmx_required := unit.ui_name :: !cmx_required
+
+let extract_crc_interfaces () =
+  Consistbl.extract !interfaces crc_interfaces
+let extract_crc_implementations () =
+  Consistbl.extract !implementations crc_implementations
+
+(* Add C objects and options and "custom" info from a library descriptor.
+   See bytecomp/bytelink.ml for comments on the order of C objects. *)
+
+let lib_ccobjs = ref []
+let lib_ccopts = ref []
+
+let add_ccobjs origin l =
+  if not !Clflags.no_auto_link then begin
+    lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs;
+    let replace_origin =
+      Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin
+    in
+    lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts
+  end
+
+let runtime_lib () =
+  let libname =
+    if !Clflags.gprofile
+    then "libasmrunp" ^ ext_lib
+    else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in
+  try
+    if !Clflags.nopervasives then []
+    else [ find_in_path !load_path libname ]
+  with Not_found ->
+    raise(Error(File_not_found libname))
+
+let object_file_name name =
+  let file_name =
+    try
+      find_in_path !load_path name
+    with Not_found ->
+      fatal_error "Asmlink.object_file_name: not found" in
+  if Filename.check_suffix file_name ".cmx" then
+    Filename.chop_suffix file_name ".cmx" ^ ext_obj
+  else if Filename.check_suffix file_name ".cmxa" then
+    Filename.chop_suffix file_name ".cmxa" ^ ext_lib
+  else
+    fatal_error "Asmlink.object_file_name: bad ext"
+
+(* First pass: determine which units are needed *)
+
+let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t)
+
+let is_required name =
+  try ignore (Hashtbl.find missing_globals name); true
+  with Not_found -> false
+
+let add_required by (name, _crc) =
+  try
+    let rq = Hashtbl.find missing_globals name in
+    rq := by :: !rq
+  with Not_found ->
+    Hashtbl.add missing_globals name (ref [by])
+
+let remove_required name =
+  Hashtbl.remove missing_globals name
+
+let extract_missing_globals () =
+  let mg = ref [] in
+  Hashtbl.iter (fun md rq -> mg := (md, !rq) :: !mg) missing_globals;
+  !mg
+
+type file =
+  | Unit of string * unit_infos * Digest.t
+  | Library of string * library_infos
+
+let read_file obj_name =
+  let file_name =
+    try
+      find_in_path !load_path obj_name
+    with Not_found ->
+      raise(Error(File_not_found obj_name)) in
+  if Filename.check_suffix file_name ".cmx" then begin
+    (* This is a .cmx file. It must be linked in any case.
+       Read the infos to see which modules it requires. *)
+    let (info, crc) = read_unit_info file_name in
+    Unit (file_name,info,crc)
+  end
+  else if Filename.check_suffix file_name ".cmxa" then begin
+    let infos =
+      try read_library_info file_name
+      with Compilenv.Error(Not_a_unit_info _) ->
+        raise(Error(Not_an_object_file file_name))
+    in
+    Library (file_name,infos)
+  end
+  else raise(Error(Not_an_object_file file_name))
+
+let scan_file obj_name tolink = match read_file obj_name with
+  | Unit (file_name,info,crc) ->
+      (* This is a .cmx file. It must be linked in any case. *)
+      remove_required info.ui_name;
+      List.iter (add_required file_name) info.ui_imports_cmx;
+      (info, file_name, crc) :: tolink
+  | Library (file_name,infos) ->
+      (* This is an archive file. Each unit contained in it will be linked
+         in only if needed. *)
+      add_ccobjs (Filename.dirname file_name) infos;
+      List.fold_right
+        (fun (info, crc) reqd ->
+           if info.ui_force_link
+             || !Clflags.link_everything
+             || is_required info.ui_name
+           then begin
+             remove_required info.ui_name;
+             List.iter (add_required (Printf.sprintf "%s(%s)"
+                                        file_name info.ui_name))
+               info.ui_imports_cmx;
+             (info, file_name, crc) :: reqd
+           end else
+             reqd)
+        infos.lib_units tolink
+
+(* Second pass: generate the startup file and link it with everything else *)
+
+let make_startup_file ppf units_list =
+  let compile_phrase p = Asmgen.compile_phrase ppf p in
+  Location.input_name := "caml_startup"; (* set name of "current" input *)
+  Compilenv.reset ~source_provenance:Timings.Startup "_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 units = List.map (fun (info,_,_) -> info) units_list in
+  List.iter compile_phrase (Cmmgen.generic_functions false units);
+  Array.iteri
+    (fun i name -> compile_phrase (Cmmgen.predef_exception i name))
+    Runtimedef.builtin_exceptions;
+  compile_phrase (Cmmgen.global_table name_list);
+  compile_phrase
+    (Cmmgen.globals_map
+       (List.map
+          (fun (unit,_,crc) ->
+               let intf_crc =
+                 try
+                   match List.assoc unit.ui_name unit.ui_imports_cmi with
+                     None -> assert false
+                   | Some crc -> crc
+                 with Not_found -> assert false
+               in
+                 (unit.ui_name, intf_crc, crc, unit.ui_defines))
+          units_list));
+  compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list));
+  compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list));
+  let all_names = "_startup" :: "_system" :: name_list in
+  compile_phrase (Cmmgen.frame_table all_names);
+  if Config.spacetime then begin
+    compile_phrase (Cmmgen.spacetime_shapes all_names);
+  end;
+  Emit.end_assembly ()
+
+let make_shared_startup_file ppf units =
+  let compile_phrase p = Asmgen.compile_phrase ppf p in
+  Location.input_name := "caml_startup";
+  Compilenv.reset ~source_provenance:Timings.Startup "_shared_startup";
+  Emit.begin_assembly ();
+  List.iter compile_phrase
+    (Cmmgen.generic_functions true (List.map fst units));
+  compile_phrase (Cmmgen.plugin_header units);
+  compile_phrase
+    (Cmmgen.global_table
+       (List.map (fun (ui,_) -> ui.ui_symbol) units));
+  (* this is to force a reference to all units, otherwise the linker
+     might drop some of them (in case of libraries) *)
+  Emit.end_assembly ()
+
+let call_linker_shared file_list output_name =
+  if not (Ccomp.call_linker Ccomp.Dll output_name file_list "")
+  then raise(Error Linking_error)
+
+let link_shared ppf objfiles output_name =
+  let units_tolink = List.fold_right scan_file objfiles [] in
+  List.iter
+    (fun (info, file_name, crc) -> check_consistency file_name info crc)
+    units_tolink;
+  Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
+  Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
+  let objfiles = List.rev (List.map object_file_name objfiles) @
+    (List.rev !Clflags.ccobjs) in
+
+  let startup =
+    if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
+    then output_name ^ ".startup" ^ ext_asm
+    else Filename.temp_file "camlstartup" ext_asm in
+  let startup_obj = output_name ^ ".startup" ^ ext_obj in
+  Asmgen.compile_unit ~source_provenance:Timings.Startup output_name
+    startup !Clflags.keep_startup_file startup_obj
+    (fun () ->
+       make_shared_startup_file ppf
+         (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink)
+    );
+  call_linker_shared (startup_obj :: objfiles) output_name;
+  remove_file startup_obj
+
+let call_linker file_list startup_file output_name =
+  let main_dll = !Clflags.output_c_object
+                 && Filename.check_suffix output_name Config.ext_dll
+  and main_obj_runtime = !Clflags.output_complete_object
+  in
+  let files = startup_file :: (List.rev file_list) in
+  let libunwind =
+    if not Config.spacetime then []
+    else if not Config.libunwind_available then []
+    else String.split_on_char ' ' Config.libunwind_link_flags
+  in
+  let files, c_lib =
+    if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then
+      files @ (List.rev !Clflags.ccobjs) @ runtime_lib () @ libunwind,
+      (if !Clflags.nopervasives || main_obj_runtime
+       then "" else Config.native_c_libraries)
+    else
+      files, ""
+  in
+  let mode =
+    if main_dll then Ccomp.MainDll
+    else if !Clflags.output_c_object then Ccomp.Partial
+    else Ccomp.Exe
+  in
+  if not (Ccomp.call_linker mode output_name files c_lib)
+  then raise(Error Linking_error)
+
+(* Main entry point *)
+
+let link ppf objfiles output_name =
+  let stdlib =
+    if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in
+  let stdexit =
+    if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in
+  let objfiles =
+    if !Clflags.nopervasives then objfiles
+    else if !Clflags.output_c_object then stdlib :: objfiles
+    else stdlib :: (objfiles @ [stdexit]) in
+  let units_tolink = List.fold_right scan_file objfiles [] in
+  Array.iter remove_required Runtimedef.builtin_exceptions;
+  begin match extract_missing_globals() with
+    [] -> ()
+  | mg -> raise(Error(Missing_implementations mg))
+  end;
+  List.iter
+    (fun (info, file_name, crc) -> check_consistency file_name info crc)
+    units_tolink;
+  Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
+  Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
+                                               (* put user's opts first *)
+  let startup =
+    if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
+    then output_name ^ ".startup" ^ ext_asm
+    else Filename.temp_file "camlstartup" ext_asm in
+  let startup_obj = Filename.temp_file "camlstartup" ext_obj in
+  Asmgen.compile_unit ~source_provenance:Timings.Startup output_name
+    startup !Clflags.keep_startup_file startup_obj
+    (fun () -> make_startup_file ppf units_tolink);
+  Misc.try_finally
+    (fun () ->
+      call_linker (List.map object_file_name objfiles) startup_obj output_name)
+    (fun () -> remove_file startup_obj)
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | File_not_found name ->
+      fprintf ppf "Cannot find file %s" name
+  | Not_an_object_file name ->
+      fprintf ppf "The file %a is not a compilation unit description"
+        Location.print_filename name
+  | Missing_implementations l ->
+     let print_references ppf = function
+       | [] -> ()
+       | r1 :: rl ->
+           fprintf ppf "%s" r1;
+           List.iter (fun r -> fprintf ppf ",@ %s" r) rl in
+      let print_modules ppf =
+        List.iter
+         (fun (md, rq) ->
+            fprintf ppf "@ @[%s referenced from %a@]" md
+            print_references rq) in
+      fprintf ppf
+       "@[No implementations provided for the following modules:%a@]"
+       print_modules l
+  | Inconsistent_interface(intf, file1, file2) ->
+      fprintf ppf
+       "@[Files %a@ and %a@ make inconsistent assumptions \
+              over interface %s@]"
+       Location.print_filename file1
+       Location.print_filename file2
+       intf
+  | Inconsistent_implementation(intf, file1, file2) ->
+      fprintf ppf
+       "@[Files %a@ and %a@ make inconsistent assumptions \
+              over implementation %s@]"
+       Location.print_filename file1
+       Location.print_filename file2
+       intf
+  | Assembler_error file ->
+      fprintf ppf "Error while assembling %a" Location.print_filename file
+  | Linking_error ->
+      fprintf ppf "Error during linking"
+  | Multiple_definition(modname, file1, file2) ->
+      fprintf ppf
+        "@[Files %a@ and %a@ both define a module named %s@]"
+        Location.print_filename file1
+        Location.print_filename file2
+        modname
+  | Missing_cmx(filename, name) ->
+      fprintf ppf
+        "@[File %a@ was compiled without access@ \
+         to the .cmx file@ for module %s,@ \
+         which was produced by `ocamlopt -for-pack'.@ \
+         Please recompile %a@ with the correct `-I' option@ \
+         so that %s.cmx@ is found.@]"
+        Location.print_filename filename name
+        Location.print_filename  filename
+        name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
+
+let reset () =
+  Consistbl.clear crc_interfaces;
+  Consistbl.clear crc_implementations;
+  implementations_defined := [];
+  cmx_required := [];
+  interfaces := [];
+  implementations := []
diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli
new file mode 100644
index 00000000..55310bd9
--- /dev/null
+++ b/asmcomp/asmlink.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Link a set of .cmx/.o files and produce an executable or a plugin *)
+
+open Format
+
+val link: formatter -> string list -> string -> unit
+
+val link_shared: formatter -> string list -> string -> unit
+
+val call_linker_shared: string list -> string -> unit
+
+val reset : unit -> unit
+val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit
+val extract_crc_interfaces: unit -> (string * Digest.t option) list
+val extract_crc_implementations: unit -> (string * Digest.t option) list
+
+type error =
+    File_not_found of string
+  | Not_an_object_file of string
+  | Missing_implementations of (string * string list) list
+  | Inconsistent_interface of string * string * string
+  | Inconsistent_implementation of string * string * string
+  | Assembler_error of string
+  | Linking_error
+  | Multiple_definition of string * string * string
+  | Missing_cmx of string * string
+
+exception Error of error
+
+val report_error: formatter -> error -> unit
diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml
new file mode 100644
index 00000000..09db234b
--- /dev/null
+++ b/asmcomp/asmpackager.ml
@@ -0,0 +1,289 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
+   original compilation units as sub-modules. *)
+
+open Misc
+open Cmx_format
+
+type error =
+    Illegal_renaming of string * string * string
+  | Forward_reference of string * string
+  | Wrong_for_pack of string * string
+  | Linking_error
+  | Assembler_error of string
+  | File_not_found of string
+
+
+exception Error of error
+
+(* Read the unit information from a .cmx file. *)
+
+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 pack_path file = (
+  let name =
+    String.capitalize_ascii(Filename.basename(chop_extensions file)) in
+  let kind =
+    if Filename.check_suffix file ".cmi" then
+      PM_intf
+    else begin
+      let (info, crc) = Compilenv.read_unit_info file in
+      if info.ui_name <> name
+      then raise(Error(Illegal_renaming(name, file, info.ui_name)));
+      if info.ui_symbol <>
+         (Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name
+      then raise(Error(Wrong_for_pack(file, pack_path)));
+      Asmlink.check_consistency file info crc;
+      Compilenv.cache_unit_info info;
+      PM_impl info
+    end in
+  { pm_file = file; pm_name = name; pm_kind = kind }
+)
+
+(* Check absence of forward references *)
+
+let check_units members =
+  let rec check forbidden = function
+    [] -> ()
+  | 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
+
+(* Make the .o file for the package *)
+
+let make_package_object ppf members targetobj targetname coercion
+      ~backend =
+  let objtemp =
+    if !Clflags.keep_asm_file
+    then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj
+    else
+      (* Put the full name of the module in the temporary file name
+         to avoid collisions with MSVC's link /lib in case of successive
+         packs *)
+      Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
+  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
+  let module_ident = Ident.create_persistent targetname in
+  let source_provenance = Timings.Pack targetname in
+  let prefixname = Filename.remove_extension objtemp in
+  if Config.flambda then begin
+    let size, lam = Translmod.transl_package_flambda components coercion in
+    let flam =
+      Middle_end.middle_end ppf
+        ~source_provenance
+        ~prefixname
+        ~backend
+        ~size
+        ~filename:targetname
+        ~module_ident
+        ~module_initializer:lam
+    in
+    Asmgen.compile_implementation_flambda ~source_provenance
+      prefixname ~backend ~required_globals:Ident.Set.empty ppf flam;
+  end else begin
+    let main_module_block_size, code =
+      Translmod.transl_store_package
+        components (Ident.create_persistent targetname) coercion in
+    Asmgen.compile_implementation_clambda ~source_provenance
+      prefixname ppf { Lambda.code; main_module_block_size;
+                       module_ident; required_globals = Ident.Set.empty }
+  end;
+  let objfiles =
+    List.map
+      (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj)
+      (List.filter (fun m -> m.pm_kind <> PM_intf) members) in
+  let ok =
+    Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) ""
+  in
+  remove_file objtemp;
+  if not ok then raise(Error Linking_error)
+
+(* Make the .cmx file for the package *)
+
+let get_export_info ui =
+  assert(Config.flambda);
+  match ui.ui_export_info with
+  | Clambda _ -> assert false
+  | Flambda info -> info
+
+let get_approx ui =
+  assert(not Config.flambda);
+  match ui.ui_export_info with
+  | Flambda _ -> assert false
+  | Clambda info -> info
+
+let build_package_cmx members 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 =
+    List.fold_left
+      (List.fold_left
+          (fun accu n -> if List.mem n accu then accu else n :: accu))
+      [] lst in
+  let units =
+    List.fold_right
+      (fun m accu ->
+        match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
+      members [] in
+  let pack_units =
+    List.fold_left
+      (fun set info ->
+         let unit_id = Compilenv.unit_id_from_name info.ui_name in
+         Compilation_unit.Set.add
+           (Compilenv.unit_for_global unit_id) set)
+      Compilation_unit.Set.empty units in
+  let units =
+    if Config.flambda then
+      List.map (fun info ->
+          { info with
+            ui_export_info =
+              Flambda
+                (Export_info_for_pack.import_for_pack ~pack_units
+                   ~pack:(Compilenv.current_unit ())
+                   (get_export_info info)) })
+        units
+    else
+      units
+  in
+  let ui = Compilenv.current_unit_infos() in
+  let ui_export_info =
+    if Config.flambda then
+      let ui_export_info =
+        List.fold_left (fun acc info ->
+            Export_info.merge acc (get_export_info info))
+          (Export_info_for_pack.import_for_pack ~pack_units
+             ~pack:(Compilenv.current_unit ())
+             (get_export_info ui))
+          units
+      in
+      Flambda ui_export_info
+    else
+      Clambda (get_approx ui)
+  in
+  Export_info_for_pack.clear_import_state ();
+  let pkg_infos =
+    { ui_name = ui.ui_name;
+      ui_symbol = ui.ui_symbol;
+      ui_defines =
+          List.flatten (List.map (fun info -> info.ui_defines) units) @
+          [ui.ui_symbol];
+      ui_imports_cmi =
+          (ui.ui_name, Some (Env.crc_of_unit ui.ui_name)) ::
+          filter(Asmlink.extract_crc_interfaces());
+      ui_imports_cmx =
+          filter(Asmlink.extract_crc_implementations());
+      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;
+      ui_export_info;
+    } in
+  Compilenv.write_unit_info pkg_infos cmxfile
+
+(* Make the .cmx and the .o for the package *)
+
+let package_object_files ppf files targetcmx
+                         targetobj targetname coercion ~backend =
+  let pack_path =
+    match !Clflags.for_package with
+    | None -> targetname
+    | Some p -> p ^ "." ^ targetname in
+  let members = map_left_right (read_member_info pack_path) files in
+  check_units members;
+  make_package_object ppf members targetobj targetname coercion ~backend;
+  build_package_cmx members targetcmx
+
+(* The entry point *)
+
+let package_files ppf initial_env files targetcmx ~backend =
+  let files =
+    List.map
+      (fun f ->
+        try find_in_path !Config.load_path f
+        with Not_found -> raise(Error(File_not_found f)))
+      files in
+  let prefix = chop_extensions targetcmx in
+  let targetcmi = prefix ^ ".cmi" in
+  let targetobj = Filename.remove_extension targetcmx ^ Config.ext_obj in
+  let targetname = String.capitalize_ascii(Filename.basename prefix) in
+  (* Set the name of the current "input" *)
+  Location.input_name := targetcmx;
+  (* Set the name of the current compunit *)
+  Compilenv.reset ~source_provenance:(Timings.Pack targetname)
+    ?packname:!Clflags.for_package targetname;
+  try
+    let coercion =
+      Typemod.package_units initial_env files targetcmi targetname in
+    package_object_files ppf files targetcmx targetobj targetname coercion
+      ~backend
+  with x ->
+    remove_file targetcmx; remove_file targetobj;
+    raise x
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+    Illegal_renaming(name, file, id) ->
+      fprintf ppf "Wrong file naming: %a@ contains the code for\
+                   @ %s when %s was expected"
+        Location.print_filename file name id
+  | Forward_reference(file, ident) ->
+      fprintf ppf "Forward reference to %s in file %a" ident
+        Location.print_filename file
+  | Wrong_for_pack(file, path) ->
+      fprintf ppf "File %a@ was not compiled with the `-for-pack %s' option"
+              Location.print_filename file path
+  | File_not_found file ->
+      fprintf ppf "File %s not found" file
+  | Assembler_error file ->
+      fprintf ppf "Error while assembling %s" file
+  | Linking_error ->
+      fprintf ppf "Error during partial linking"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli
new file mode 100644
index 00000000..203fc301
--- /dev/null
+++ b/asmcomp/asmpackager.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
+   original compilation units as sub-modules. *)
+
+val package_files
+   : Format.formatter
+  -> Env.t
+  -> string list
+  -> string
+  -> backend:(module Backend_intf.S)
+  -> unit
+
+type error =
+    Illegal_renaming of string * string * string
+  | Forward_reference of string * string
+  | Wrong_for_pack of string * string
+  | Linking_error
+  | Assembler_error of string
+  | File_not_found of string
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml
new file mode 100644
index 00000000..6486d19c
--- /dev/null
+++ b/asmcomp/branch_relaxation.ml
@@ -0,0 +1,142 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Mark Shinwell, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Mach
+open Linearize
+
+module Make (T : Branch_relaxation_intf.S) = struct
+  let label_map code =
+    let map = Hashtbl.create 37 in
+    let rec fill_map pc instr =
+      match instr.desc with
+      | Lend -> (pc, map)
+      | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next
+      | op -> fill_map (pc + T.instr_size op) instr.next
+    in
+    fill_map 0 code
+
+  let branch_overflows map pc_branch lbl_dest max_branch_offset =
+    let pc_dest = Hashtbl.find map lbl_dest in
+    let delta = pc_dest - (pc_branch + T.offset_pc_at_branch) in
+    delta <= -max_branch_offset || delta >= max_branch_offset
+
+  let opt_branch_overflows map pc_branch opt_lbl_dest max_branch_offset =
+    match opt_lbl_dest with
+    | None -> false
+    | Some lbl_dest ->
+      branch_overflows map pc_branch lbl_dest max_branch_offset
+
+  let instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc =
+    match T.Cond_branch.classify_instr instr.desc with
+    | None -> false
+    | Some branch ->
+      let max_branch_offset =
+        (* Remember to cut some slack for multi-word instructions (in the
+           [Linearize] sense of the word) where the branch can be anywhere in
+           the middle.  12 words of slack is plenty. *)
+        T.Cond_branch.max_displacement branch - 12
+      in
+      match instr.desc with
+      | Lop (Ialloc _)
+      | Lop (Iintop (Icheckbound _))
+      | Lop (Iintop_imm (Icheckbound _, _))
+      | Lop (Ispecific _) ->
+        (* We assume that any branches eligible for relaxation generated
+           by these instructions only branch forward.  We further assume
+           that any of these may branch to an out-of-line code block. *)
+        code_size + max_out_of_line_code_offset - pc >= max_branch_offset
+      | Lcondbranch (_, lbl) ->
+        branch_overflows map pc lbl max_branch_offset
+      | Lcondbranch3 (lbl0, lbl1, lbl2) ->
+        opt_branch_overflows map pc lbl0 max_branch_offset
+          || opt_branch_overflows map pc lbl1 max_branch_offset
+          || opt_branch_overflows map pc lbl2 max_branch_offset
+      | _ ->
+        Misc.fatal_error "Unsupported instruction for branch relaxation"
+
+  let fixup_branches ~code_size ~max_out_of_line_code_offset map code =
+    let expand_optbranch lbl n arg next =
+      match lbl with
+      | None -> next
+      | Some l ->
+        instr_cons (Lcondbranch (Iinttest_imm (Isigned Cmm.Ceq, n), l))
+          arg [||] next
+    in
+    let rec fixup did_fix pc instr =
+      match instr.desc with
+      | Lend -> did_fix
+      | _ ->
+        let overflows =
+          instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc
+        in
+        if not overflows then
+          fixup did_fix (pc + T.instr_size instr.desc) instr.next
+        else
+          match instr.desc with
+          | Lop (Ialloc { words = num_words; label_after_call_gc; }) ->
+            instr.desc <- T.relax_allocation ~num_words ~label_after_call_gc;
+            fixup true (pc + T.instr_size instr.desc) instr.next
+          | Lop (Iintop (Icheckbound { label_after_error; })) ->
+            instr.desc <- T.relax_intop_checkbound ~label_after_error;
+            fixup true (pc + T.instr_size instr.desc) instr.next
+          | Lop (Iintop_imm (Icheckbound { label_after_error; }, bound)) ->
+            instr.desc
+              <- T.relax_intop_imm_checkbound ~bound ~label_after_error;
+            fixup true (pc + T.instr_size instr.desc) instr.next
+          | Lop (Ispecific specific) ->
+            instr.desc <- T.relax_specific_op specific;
+            fixup true (pc + T.instr_size instr.desc) instr.next
+          | Lcondbranch (test, lbl) ->
+            let lbl2 = Cmm.new_label() in
+            let cont =
+              instr_cons (Lbranch lbl) [||] [||]
+                (instr_cons (Llabel lbl2) [||] [||] instr.next)
+            in
+            instr.desc <- Lcondbranch (invert_test test, lbl2);
+            instr.next <- cont;
+            fixup true (pc + T.instr_size instr.desc) instr.next
+          | Lcondbranch3 (lbl0, lbl1, lbl2) ->
+            let cont =
+              expand_optbranch lbl0 0 instr.arg
+                (expand_optbranch lbl1 1 instr.arg
+                  (expand_optbranch lbl2 2 instr.arg instr.next))
+            in
+            instr.desc <- cont.desc;
+            instr.next <- cont.next;
+            fixup true pc instr
+          | _ ->
+            (* Any other instruction has already been rejected in
+               [instr_overflows] above.
+               We can *never* get here. *)
+            assert false
+    in
+    fixup false 0 code
+
+  (* Iterate branch expansion till all conditional branches are OK *)
+
+  let rec relax code ~max_out_of_line_code_offset =
+    let min_of_max_branch_offsets =
+      List.fold_left (fun min_of_max_branch_offsets branch ->
+          min min_of_max_branch_offsets
+            (T.Cond_branch.max_displacement branch))
+        max_int T.Cond_branch.all
+    in
+    let (code_size, map) = label_map code in
+    if code_size >= min_of_max_branch_offsets
+        && fixup_branches ~code_size ~max_out_of_line_code_offset map code
+    then relax code ~max_out_of_line_code_offset
+    else ()
+end
diff --git a/asmcomp/branch_relaxation.mli b/asmcomp/branch_relaxation.mli
new file mode 100644
index 00000000..170f306d
--- /dev/null
+++ b/asmcomp/branch_relaxation.mli
@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Mark Shinwell, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Fix up conditional branches that exceed hardware-allowed ranges. *)
+
+module Make (T : Branch_relaxation_intf.S) : sig
+  val relax
+     : Linearize.instruction
+    (* [max_offset_of_out_of_line_code] specifies the furthest distance,
+       measured from the first address immediately after the last instruction
+       of the function, that may be branched to from within the function in
+       order to execute "out of line" code blocks such as call GC and
+       bounds check points. *)
+    -> max_out_of_line_code_offset:T.distance
+    -> unit
+end
diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml
new file mode 100644
index 00000000..3b1fbac5
--- /dev/null
+++ b/asmcomp/branch_relaxation_intf.ml
@@ -0,0 +1,75 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Mark Shinwell, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type S = sig
+  (* The distance between two instructions, in arbitrary units (typically
+     the natural word size of instructions). *)
+  type distance = int
+
+  module Cond_branch : sig
+    (* The various types of conditional branches for a given target that
+       may require relaxation. *)
+    type t
+
+    (* All values of type [t] that the emitter may produce. *)
+    val all : t list
+
+    (* If [max_displacement branch] is [n] then [branch] is assumed to
+       reach any address in the range [pc - n, pc + n] (inclusive), after
+       the [pc] of the branch has been adjusted by [offset_pc_at_branch]
+       (see below). *)
+    val max_displacement : t -> distance
+
+    (* Which variety of conditional branch may be produced by the emitter for a
+       given instruction description.  For the moment we assume that only one
+       such variety per instruction description is needed.
+
+       N.B. The only instructions supported are the following:
+                - Lop (Ialloc _)
+                - Lop (Iintop Icheckbound)
+                - Lop (Iintop_imm (Icheckbound, _))
+                - Lop (Ispecific _)
+                - Lcondbranch (_, _)
+                - Lcondbranch3 (_, _, _)
+       [classify_instr] is expected to return [None] when called on any
+       instruction not in this list. *)
+    val classify_instr : Linearize.instruction_desc -> t option
+  end
+
+  (* The value to be added to the program counter (in [distance] units)
+     when it is at a branch instruction, prior to calculating the distance
+     to a branch target. *)
+  val offset_pc_at_branch : distance
+
+  (* The maximum size of a given instruction. *)
+  val instr_size : Linearize.instruction_desc -> distance
+
+  (* Insertion of target-specific code to relax operations that cannot be
+     relaxed generically.  It is assumed that these rewrites do not change
+     the size of out-of-line code (cf. branch_relaxation.mli). *)
+  val relax_allocation
+     : num_words:int
+    -> label_after_call_gc:Cmm.label option
+    -> Linearize.instruction_desc
+  val relax_intop_checkbound
+     : label_after_error:Cmm.label option
+    -> Linearize.instruction_desc
+  val relax_intop_imm_checkbound
+     : bound:int
+    -> label_after_error:Cmm.label option
+    -> Linearize.instruction_desc
+  val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc
+end
diff --git a/asmcomp/build_export_info.ml b/asmcomp/build_export_info.ml
new file mode 100644
index 00000000..80f97f05
--- /dev/null
+++ b/asmcomp/build_export_info.ml
@@ -0,0 +1,551 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module Env : sig
+  type t
+
+  val new_descr : t -> Export_info.descr -> Export_id.t
+  val record_descr : t -> Export_id.t -> Export_info.descr -> unit
+  val get_descr : t -> Export_info.approx -> Export_info.descr option
+
+  val add_approx : t -> Variable.t -> Export_info.approx -> t
+  val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t
+  val find_approx : t -> Variable.t -> Export_info.approx
+
+  val get_symbol_descr : t -> Symbol.t -> Export_info.descr option
+
+  val new_unit_descr : t -> Export_id.t
+
+  module Global : sig
+    (* "Global" as in "without local variable bindings". *)
+    type t
+
+    val create_empty : unit -> t
+
+    val add_symbol : t -> Symbol.t -> Export_id.t -> t
+    val new_symbol : t -> Symbol.t -> Export_id.t * t
+
+    val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t
+    val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t
+  end
+
+  (** Creates a new environment, sharing the mapping from export IDs to
+      export descriptions with the given global environment. *)
+  val empty_of_global : Global.t -> t
+end = struct
+  let fresh_id () = Export_id.create (Compilenv.current_unit ())
+
+  module Global = struct
+    type t =
+      { sym : Export_id.t Symbol.Map.t;
+        (* Note that [ex_table]s themselves are shared (hence [ref] and not
+           [mutable]). *)
+        ex_table : Export_info.descr Export_id.Map.t ref;
+      }
+
+    let create_empty () =
+      { sym = Symbol.Map.empty;
+        ex_table = ref Export_id.Map.empty;
+      }
+
+    let add_symbol t sym export_id =
+      if Symbol.Map.mem sym t.sym then begin
+        Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \
+            rebind symbol %a in environment"
+          Symbol.print sym
+      end;
+      { t with sym = Symbol.Map.add sym export_id t.sym }
+
+    let new_symbol t sym =
+      let export_id = fresh_id () in
+      export_id, add_symbol t sym export_id
+
+    let symbol_to_export_id_map t = t.sym
+    let export_id_to_descr_map t = !(t.ex_table)
+  end
+
+  (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of
+     the [ex_table] is kind of nasty.  Consider making it immutable. *)
+  type t =
+    { var : Export_info.approx Variable.Map.t;
+      sym : Export_id.t Symbol.Map.t;
+      ex_table : Export_info.descr Export_id.Map.t ref;
+    }
+
+  let empty_of_global (env : Global.t) =
+    { var = Variable.Map.empty;
+      sym = env.sym;
+      ex_table = env.ex_table;
+    }
+
+  let extern_id_descr export_id =
+    let export = Compilenv.approx_env () in
+    try Some (Export_info.find_description export export_id)
+    with Not_found -> None
+
+  let extern_symbol_descr sym =
+    if Compilenv.is_predefined_exception sym
+    then None
+    else
+      let export = Compilenv.approx_for_global (Symbol.compilation_unit sym) in
+      try
+        let id = Symbol.Map.find sym export.symbol_id in
+        let descr = Export_info.find_description export id in
+        Some descr
+      with
+      | Not_found -> None
+
+  let get_id_descr t export_id =
+    try Some (Export_id.Map.find export_id !(t.ex_table))
+    with Not_found -> extern_id_descr export_id
+
+  let get_symbol_descr t sym =
+    try
+      let export_id = Symbol.Map.find sym t.sym in
+      Some (Export_id.Map.find export_id !(t.ex_table))
+    with
+    | Not_found -> extern_symbol_descr sym
+
+  let get_descr t (approx : Export_info.approx) =
+    match approx with
+    | Value_unknown -> None
+    | Value_id export_id -> get_id_descr t export_id
+    | Value_symbol sym -> get_symbol_descr t sym
+
+  let record_descr t id (descr : Export_info.descr) =
+    if Export_id.Map.mem id !(t.ex_table) then begin
+      Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \
+          export ID %a in environment"
+        Export_id.print id
+    end;
+    t.ex_table := Export_id.Map.add id descr !(t.ex_table)
+
+  let new_descr t (descr : Export_info.descr) =
+    let id = fresh_id () in
+    record_descr t id descr;
+    id
+
+  let new_unit_descr t =
+    new_descr t (Value_constptr 0)
+
+  let add_approx t var approx =
+    if Variable.Map.mem var t.var then begin
+      Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \
+          variable %a in environment"
+        Variable.print var
+    end;
+    { t with var = Variable.Map.add var approx t.var; }
+
+  let add_approx_map t vars_to_approxs =
+    Variable.Map.fold (fun var approx t -> add_approx t var approx)
+      vars_to_approxs
+      t
+
+  let add_approx_maps t vars_to_approxs_list =
+    List.fold_left add_approx_map t vars_to_approxs_list
+
+  let find_approx t var : Export_info.approx =
+    try Variable.Map.find var t.var with
+    | Not_found -> Value_unknown
+end
+
+let descr_of_constant (c : Flambda.const) : Export_info.descr =
+  match c with
+  (* [Const_pointer] is an immediate value of a type whose values may be
+     boxed (typically a variant type with both constant and non-constant
+     constructors). *)
+  | Int i -> Value_int i
+  | Char c -> Value_char c
+  | Const_pointer i -> Value_constptr i
+
+let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr =
+  match c with
+  | Float f -> Value_float f
+  | Int32 i -> Value_boxed_int (Int32, i)
+  | Int64 i -> Value_boxed_int (Int64, i)
+  | Nativeint i -> Value_boxed_int (Nativeint, i)
+  | String s ->
+    let v_string : Export_info.value_string =
+      { size = String.length s; contents = Unknown_or_mutable; }
+    in
+    Value_string v_string
+  | Immutable_string s ->
+    let v_string : Export_info.value_string =
+      { size = String.length s; contents = Contents s; }
+    in
+    Value_string v_string
+  | Immutable_float_array fs ->
+    Value_float_array {
+      contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs));
+      size = List.length fs;
+    }
+  | Float_array fs ->
+    Value_float_array {
+      contents = Unknown_or_mutable;
+      size = List.length fs;
+    }
+
+let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx =
+  match flam with
+  | Var var -> Env.find_approx env var
+  | Let { var; defining_expr; body; _ } ->
+    let approx = descr_of_named env defining_expr in
+    let env = Env.add_approx env var approx in
+    approx_of_expr env body
+  | Let_mutable { body } ->
+    approx_of_expr env body
+  | Let_rec (defs, body) ->
+    let env =
+      List.fold_left (fun env (var, defining_expr) ->
+          let approx = descr_of_named env defining_expr in
+          Env.add_approx env var approx)
+        env defs
+    in
+    approx_of_expr env body
+  | Apply { func; kind; _ } ->
+    begin match kind with
+    | Indirect -> Value_unknown
+    | Direct closure_id' ->
+      match Env.get_descr env (Env.find_approx env func) with
+      | Some (Value_closure
+          { closure_id; set_of_closures = { results; _ }; }) ->
+        assert (Closure_id.equal closure_id closure_id');
+        assert (Closure_id.Map.mem closure_id results);
+        Closure_id.Map.find closure_id results
+      | _ -> Value_unknown
+    end
+  | Assign _ -> Value_id (Env.new_unit_descr env)
+  | For _ -> Value_id (Env.new_unit_descr env)
+  | While _ -> Value_id (Env.new_unit_descr env)
+  | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _
+  | Switch _ | String_switch _ | Send _ | Proved_unreachable ->
+    Value_unknown
+
+and descr_of_named (env : Env.t) (named : Flambda.named)
+      : Export_info.approx =
+  match named with
+  | Expr expr -> approx_of_expr env expr
+  | Symbol sym -> Value_symbol sym
+  | Read_mutable _ -> Value_unknown
+  | Read_symbol_field (sym, i) ->
+    begin match Env.get_symbol_descr env sym with
+    | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
+    | _ -> Value_unknown
+    end
+  | Const const ->
+    Value_id (Env.new_descr env (descr_of_constant const))
+  | Allocated_const const ->
+    Value_id (Env.new_descr env (descr_of_allocated_constant const))
+  | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) ->
+    let approxs = List.map (Env.find_approx env) args in
+    let descr : Export_info.descr =
+      Value_block (Tag.create_exn tag, Array.of_list approxs)
+    in
+    Value_id (Env.new_descr env descr)
+  | Prim (Pfield i, [arg], _) ->
+    begin match Env.get_descr env (Env.find_approx env arg) with
+    | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
+    | _ -> Value_unknown
+    end
+  | Prim (Pgetglobal id, _, _) ->
+    Value_symbol (Compilenv.symbol_for_global' id)
+  | Prim _ -> Value_unknown
+  | Set_of_closures set ->
+    let descr : Export_info.descr =
+      Value_set_of_closures (describe_set_of_closures env set)
+    in
+    Value_id (Env.new_descr env descr)
+  | Project_closure { set_of_closures; closure_id; } ->
+    begin match Env.get_descr env (Env.find_approx env set_of_closures) with
+    | Some (Value_set_of_closures set_of_closures) ->
+      if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin
+        Misc.fatal_errorf "Could not build export description for \
+            [Project_closure]: closure ID %a not in set of closures"
+          Closure_id.print closure_id
+      end;
+      let descr : Export_info.descr =
+        Value_closure { closure_id = closure_id; set_of_closures; }
+      in
+      Value_id (Env.new_descr env descr)
+    | _ ->
+      (* It would be nice if this were [assert false], but owing to the fact
+         that this pass may propagate less information than for example
+         [Inline_and_simplify], we might end up here. *)
+      Value_unknown
+    end
+  | Move_within_set_of_closures { closure; start_from; move_to; } ->
+    begin match Env.get_descr env (Env.find_approx env closure) with
+    | Some (Value_closure { set_of_closures; closure_id; }) ->
+      assert (Closure_id.equal closure_id start_from);
+      let descr : Export_info.descr =
+        Value_closure { closure_id = move_to; set_of_closures; }
+      in
+      Value_id (Env.new_descr env descr)
+    | _ -> Value_unknown
+    end
+  | Project_var { closure; closure_id = closure_id'; var; } ->
+    begin match Env.get_descr env (Env.find_approx env closure) with
+    | Some (Value_closure
+        { set_of_closures = { bound_vars; _ }; closure_id; }) ->
+      assert (Closure_id.equal closure_id closure_id');
+      if not (Var_within_closure.Map.mem var bound_vars) then begin
+        Misc.fatal_errorf "Project_var from %a (closure ID %a) of \
+            variable %a that is not bound by the closure.  \
+            Variables bound by the closure are: %a"
+          Variable.print closure
+          Closure_id.print closure_id
+          Var_within_closure.print var
+          (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars
+      end;
+      Var_within_closure.Map.find var bound_vars
+    | _ -> Value_unknown
+    end
+
+and describe_set_of_closures env (set : Flambda.set_of_closures)
+      : Export_info.value_set_of_closures =
+  let bound_vars_approx =
+    Variable.Map.map (fun (external_var : Flambda.specialised_to) ->
+        Env.find_approx env external_var.var)
+      set.free_vars
+  in
+  let specialised_args_approx =
+    Variable.Map.map (fun (spec_to : Flambda.specialised_to) ->
+        Env.find_approx env spec_to.var)
+      set.specialised_args
+  in
+  let closures_approx =
+    (* To build an approximation of the results, we need an
+       approximation of the functions. The first one we can build is
+       one where every function returns something unknown.
+    *)
+    (* CR-someday pchambart: we could improve a bit on that by building a
+       recursive approximation of the closures: The value_closure
+       description contains a [value_set_of_closures]. We could replace
+       this field by a [Expr_id.t] or an [approx].
+       mshinwell: Deferred for now.
+    *)
+    let initial_value_set_of_closures =
+      { Export_info.
+        set_of_closures_id = set.function_decls.set_of_closures_id;
+        bound_vars = Var_within_closure.wrap_map bound_vars_approx;
+        results =
+          Closure_id.wrap_map
+            (Variable.Map.map (fun _ -> Export_info.Value_unknown)
+              set.function_decls.funs);
+        aliased_symbol = None;
+      }
+    in
+    Variable.Map.mapi (fun fun_var _function_decl ->
+        let descr : Export_info.descr =
+          Value_closure
+            { closure_id = Closure_id.wrap fun_var;
+              set_of_closures = initial_value_set_of_closures;
+            }
+        in
+        Export_info.Value_id (Env.new_descr env descr))
+      set.function_decls.funs
+  in
+  let closure_env =
+    Env.add_approx_maps env
+      [closures_approx; bound_vars_approx; specialised_args_approx]
+  in
+  let results =
+    let result_approx _var (function_decl : Flambda.function_declaration) =
+      approx_of_expr closure_env function_decl.body
+    in
+    Variable.Map.mapi result_approx set.function_decls.funs
+  in
+  { set_of_closures_id = set.function_decls.set_of_closures_id;
+    bound_vars = Var_within_closure.wrap_map bound_vars_approx;
+    results = Closure_id.wrap_map results;
+    aliased_symbol = None;
+  }
+
+let approx_of_constant_defining_value_block_field env
+      (c : Flambda.constant_defining_value_block_field) : Export_info.approx =
+  match c with
+  | Symbol s -> Value_symbol s
+  | Const c -> Value_id (Env.new_descr env (descr_of_constant c))
+
+let describe_constant_defining_value env export_id symbol
+      (const : Flambda.constant_defining_value) =
+  let env =
+    (* Assignments of variables to export IDs are local to each constant
+       defining value. *)
+    Env.empty_of_global env
+  in
+  match const with
+  | Allocated_const alloc_const ->
+    let descr = descr_of_allocated_constant alloc_const in
+    Env.record_descr env export_id descr
+  | Block (tag, fields) ->
+    let approxs =
+      List.map (approx_of_constant_defining_value_block_field env) fields
+    in
+    Env.record_descr env export_id (Value_block (tag, Array.of_list approxs))
+  | Set_of_closures set_of_closures ->
+    let descr : Export_info.descr =
+      Value_set_of_closures
+        { (describe_set_of_closures env set_of_closures) with
+          aliased_symbol = Some symbol;
+        }
+    in
+    Env.record_descr env export_id descr
+  | Project_closure (sym, closure_id) ->
+    begin match Env.get_symbol_descr env sym with
+    | Some (Value_set_of_closures set_of_closures) ->
+      if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin
+        Misc.fatal_errorf "Could not build export description for \
+            [Project_closure] constant defining value: closure ID %a not in \
+            set of closures"
+          Closure_id.print closure_id
+      end;
+      let descr =
+        Export_info.Value_closure
+          { closure_id = closure_id; set_of_closures; }
+      in
+      Env.record_descr env export_id descr
+    | None ->
+      Misc.fatal_errorf
+        "Cannot project symbol %a to closure_id %a.  \
+          No available export description@."
+        Symbol.print sym
+        Closure_id.print closure_id
+    | Some (Value_closure _) ->
+      Misc.fatal_errorf
+        "Cannot project symbol %a to closure_id %a.  \
+          The symbol is a closure instead of a set of closures.@."
+        Symbol.print sym
+        Closure_id.print closure_id
+    | Some _ ->
+      Misc.fatal_errorf
+        "Cannot project symbol %a to closure_id %a.  \
+          The symbol is not a set of closures.@."
+        Symbol.print sym
+        Closure_id.print closure_id
+    end
+
+let describe_program (env : Env.Global.t) (program : Flambda.program) =
+  let rec loop env (program : Flambda.program_body) =
+    match program with
+    | Let_symbol (symbol, constant_defining_value, program) ->
+      let id, env = Env.Global.new_symbol env symbol in
+      describe_constant_defining_value env id symbol constant_defining_value;
+      loop env program
+    | Let_rec_symbol (defs, program) ->
+      let env, defs =
+        List.fold_left (fun (env, defs) (symbol, def) ->
+            let id, env = Env.Global.new_symbol env symbol in
+            env, ((id, symbol, def) :: defs))
+          (env, []) defs
+      in
+      (* [Project_closure]s are separated to be handled last.  They are the
+         only values that need a description for their argument. *)
+      let project_closures, other_constants =
+        List.partition (function
+            | _, _, Flambda.Project_closure _ -> true
+            | _ -> false)
+          defs
+      in
+      List.iter (fun (id, symbol, def) ->
+          describe_constant_defining_value env id symbol def)
+        other_constants;
+      List.iter (fun (id, symbol, def) ->
+          describe_constant_defining_value env id symbol def)
+        project_closures;
+      loop env program
+    | Initialize_symbol (symbol, tag, fields, program) ->
+      let id =
+        let env =
+          (* Assignments of variables to export IDs are local to each
+             [Initialize_symbol] construction. *)
+          Env.empty_of_global env
+        in
+        let field_approxs = List.map (approx_of_expr env) fields in
+        let descr : Export_info.descr =
+          Value_block (tag, Array.of_list field_approxs)
+        in
+        Env.new_descr env descr
+      in
+      let env = Env.Global.add_symbol env symbol id in
+      loop env program
+    | Effect (_expr, program) -> loop env program
+    | End symbol -> symbol, env
+  in
+  loop env program.program_body
+
+let build_export_info ~(backend : (module Backend_intf.S))
+      (program : Flambda.program) : Export_info.t =
+  if !Clflags.opaque then
+    Export_info.empty
+  else
+    (* CR-soon pchambart: Should probably use that instead of the ident of
+       the module as global identifier.
+       mshinwell: Is "that" the variable "_global_symbol"?
+       Yes it is.  We are just assuming that the symbol produced from
+       the identifier of the module is the right one. *)
+    let _global_symbol, env =
+      describe_program (Env.Global.create_empty ()) program
+    in
+    let sets_of_closures =
+      Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program
+    in
+    let closures =
+      Flambda_utils.all_function_decls_indexed_by_closure_id program
+    in
+    let invariant_params =
+      Set_of_closures_id.Map.map
+        (fun { Flambda. function_decls; _ } ->
+           Invariant_params.invariant_params_in_recursion
+             ~backend function_decls)
+        (Flambda_utils.all_sets_of_closures_map program)
+    in
+    let unnested_values =
+      Env.Global.export_id_to_descr_map env
+    in
+    let invariant_params =
+      let export = Compilenv.approx_env () in
+      Export_id.Map.fold (fun _eid (descr:Export_info.descr)
+                           (invariant_params) ->
+          match descr with
+          | Value_closure { set_of_closures }
+          | Value_set_of_closures set_of_closures ->
+            let { Export_info.set_of_closures_id } = set_of_closures in
+            begin match
+              Set_of_closures_id.Map.find set_of_closures_id
+                export.invariant_params
+            with
+            | exception Not_found ->
+              invariant_params
+            | (set:Variable.Set.t Variable.Map.t) ->
+              Set_of_closures_id.Map.add set_of_closures_id set invariant_params
+            end
+          | _ ->
+            invariant_params)
+        unnested_values invariant_params
+    in
+    let values =
+      Export_info.nest_eid_map unnested_values
+    in
+    Export_info.create ~values
+      ~symbol_id:(Env.Global.symbol_to_export_id_map env)
+      ~offset_fun:Closure_id.Map.empty
+      ~offset_fv:Var_within_closure.Map.empty
+      ~sets_of_closures ~closures
+      ~constant_sets_of_closures:Set_of_closures_id.Set.empty
+      ~invariant_params
diff --git a/asmcomp/build_export_info.mli b/asmcomp/build_export_info.mli
new file mode 100644
index 00000000..2a824ea3
--- /dev/null
+++ b/asmcomp/build_export_info.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Construct export information, for emission into .cmx files, from an
+    Flambda program. *)
+
+val build_export_info :
+  backend:(module Backend_intf.S) ->
+  Flambda.program ->
+  Export_info.t
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
new file mode 100644
index 00000000..7d21fcd8
--- /dev/null
+++ b/asmcomp/clambda.ml
@@ -0,0 +1,175 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A variant of the "lambda" code with direct / indirect calls explicit
+   and closures explicit too *)
+
+open Asttypes
+open Lambda
+
+type function_label = string
+
+type ustructured_constant =
+  | Uconst_float of float
+  | Uconst_int32 of int32
+  | Uconst_int64 of int64
+  | Uconst_nativeint of nativeint
+  | Uconst_block of int * uconstant list
+  | Uconst_float_array of float list
+  | Uconst_string of string
+  | Uconst_closure of ufunction list * string * uconstant list
+
+and uconstant =
+  | Uconst_ref of string * ustructured_constant option
+  | Uconst_int of int
+  | Uconst_ptr of int
+
+and ulambda =
+    Uvar of Ident.t
+  | Uconst of uconstant
+  | Udirect_apply of function_label * ulambda list * Debuginfo.t
+  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+  | Uclosure of ufunction list * ulambda list
+  | Uoffset of ulambda * int
+  | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
+  | Uletrec of (Ident.t * ulambda) list * ulambda
+  | Uprim of primitive * ulambda list * Debuginfo.t
+  | Uswitch of ulambda * ulambda_switch
+  | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
+  | Ustaticfail of int * ulambda list
+  | Ucatch of int * Ident.t list * ulambda * ulambda
+  | Utrywith of ulambda * Ident.t * ulambda
+  | Uifthenelse of ulambda * ulambda * ulambda
+  | Usequence of ulambda * ulambda
+  | Uwhile of ulambda * ulambda
+  | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
+  | Uassign of Ident.t * ulambda
+  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+  | Uunreachable
+
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : Ident.t list;
+  body   : ulambda;
+  dbg    : Debuginfo.t;
+  env    : Ident.t option;
+}
+
+and ulambda_switch =
+  { us_index_consts: int array;
+    us_actions_consts : ulambda array;
+    us_index_blocks: int array;
+    us_actions_blocks: ulambda array}
+
+(* Description of known functions *)
+
+type function_description =
+  { fun_label: function_label;          (* Label of direct entry point *)
+    fun_arity: int;                     (* Number of arguments *)
+    mutable fun_closed: bool;           (* True if environment not used *)
+    mutable fun_inline: (Ident.t list * ulambda) option;
+    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
+  }
+
+(* Approximation of values *)
+
+type value_approximation =
+    Value_closure of function_description * value_approximation
+  | Value_tuple of value_approximation array
+  | Value_unknown
+  | Value_const of uconstant
+  | Value_global_field of string * int
+
+(* Preallocated globals *)
+
+type preallocated_block = {
+  symbol : string;
+  exported : bool;
+  tag : int;
+  size : int;
+}
+
+type preallocated_constant = {
+  symbol : string;
+  exported : bool;
+  definition : ustructured_constant;
+}
+
+(* Comparison functions for constants.  We must not use Pervasives.compare
+   because it compares "0.0" and "-0.0" equal.  (PR#6442) *)
+
+let compare_floats x1 x2 =
+  Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
+
+let rec compare_float_lists l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _::_ -> -1
+  | _::_, [] -> 1
+  | h1::t1, h2::t2 ->
+      let c = compare_floats h1 h2 in
+      if c <> 0 then c else compare_float_lists t1 t2
+
+let compare_constants c1 c2 =
+  match c1, c2 with
+  | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2
+      (* Same labels -> same constants.
+         Different labels -> different constants, even if the contents
+           match, because of string constants that must not be
+           reshared. *)
+  | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2
+  | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2
+  | Uconst_ref _, _ -> -1
+  | Uconst_int _, Uconst_ref _ -> 1
+  | Uconst_int _, Uconst_ptr _ -> -1
+  | Uconst_ptr _, _ -> 1
+
+let rec compare_constant_lists l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _::_ -> -1
+  | _::_, [] -> 1
+  | h1::t1, h2::t2 ->
+      let c = compare_constants h1 h2 in
+      if c <> 0 then c else compare_constant_lists t1 t2
+
+let rank_structured_constant = function
+  | Uconst_float _ -> 0
+  | Uconst_int32 _ -> 1
+  | Uconst_int64 _ -> 2
+  | Uconst_nativeint _ -> 3
+  | Uconst_block _ -> 4
+  | Uconst_float_array _ -> 5
+  | Uconst_string _ -> 6
+  | Uconst_closure _ -> 7
+
+let compare_structured_constants c1 c2 =
+  match c1, c2 with
+  | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2
+  | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2
+  | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2
+  | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2
+  | Uconst_block(t1, l1), Uconst_block(t2, l2) ->
+      let c = t1 - t2 (* no overflow possible here *) in
+      if c <> 0 then c else compare_constant_lists l1 l2
+  | Uconst_float_array l1, Uconst_float_array l2 ->
+      compare_float_lists l1 l2
+  | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
+  | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) ->
+      String.compare lbl1 lbl2
+  | _, _ ->
+    (* no overflow possible here *)
+    rank_structured_constant c1 - rank_structured_constant c2
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
new file mode 100644
index 00000000..6a6bc1b2
--- /dev/null
+++ b/asmcomp/clambda.mli
@@ -0,0 +1,114 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A variant of the "lambda" code with direct / indirect calls explicit
+   and closures explicit too *)
+
+open Asttypes
+open Lambda
+
+type function_label = string
+
+type ustructured_constant =
+  | Uconst_float of float
+  | Uconst_int32 of int32
+  | Uconst_int64 of int64
+  | Uconst_nativeint of nativeint
+  | Uconst_block of int * uconstant list
+  | Uconst_float_array of float list
+  | Uconst_string of string
+  | Uconst_closure of ufunction list * string * uconstant list
+
+and uconstant =
+  | Uconst_ref of string * ustructured_constant option
+  | Uconst_int of int
+  | Uconst_ptr of int
+
+and ulambda =
+    Uvar of Ident.t
+  | Uconst of uconstant
+  | Udirect_apply of function_label * ulambda list * Debuginfo.t
+  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+  | Uclosure of ufunction list * ulambda list
+  | Uoffset of ulambda * int
+  | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
+  | Uletrec of (Ident.t * ulambda) list * ulambda
+  | Uprim of primitive * ulambda list * Debuginfo.t
+  | Uswitch of ulambda * ulambda_switch
+  | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
+  | Ustaticfail of int * ulambda list
+  | Ucatch of int * Ident.t list * ulambda * ulambda
+  | Utrywith of ulambda * Ident.t * ulambda
+  | Uifthenelse of ulambda * ulambda * ulambda
+  | Usequence of ulambda * ulambda
+  | Uwhile of ulambda * ulambda
+  | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
+  | Uassign of Ident.t * ulambda
+  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+  | Uunreachable
+
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : Ident.t list;
+  body   : ulambda;
+  dbg    : Debuginfo.t;
+  env    : Ident.t option;
+}
+
+and ulambda_switch =
+  { us_index_consts: int array;
+    us_actions_consts: ulambda array;
+    us_index_blocks: int array;
+    us_actions_blocks: ulambda array}
+
+(* Description of known functions *)
+
+type function_description =
+  { fun_label: function_label;          (* Label of direct entry point *)
+    fun_arity: int;                     (* Number of arguments *)
+    mutable fun_closed: bool;           (* True if environment not used *)
+    mutable fun_inline: (Ident.t list * ulambda) option;
+    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
+  }
+
+(* Approximation of values *)
+
+type value_approximation =
+    Value_closure of function_description * value_approximation
+  | Value_tuple of value_approximation array
+  | Value_unknown
+  | Value_const of uconstant
+  | Value_global_field of string * int
+
+(* Comparison functions for constants *)
+
+val compare_structured_constants:
+        ustructured_constant -> ustructured_constant -> int
+val compare_constants:
+        uconstant -> uconstant -> int
+
+type preallocated_block = {
+  symbol : string;
+  exported : bool;
+  tag : int;
+  size : int;
+}
+
+type preallocated_constant = {
+  symbol : string;
+  exported : bool;
+  definition : ustructured_constant;
+}
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
new file mode 100644
index 00000000..1bdc4392
--- /dev/null
+++ b/asmcomp/closure.ml
@@ -0,0 +1,1376 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Introduction of closures, uncurrying, recognition of direct calls *)
+
+open Misc
+open Asttypes
+open Primitive
+open Lambda
+open Switch
+open Clambda
+
+module Storer =
+  Switch.Store
+    (struct
+      type t = lambda
+      type key = lambda
+      let make_key =  Lambda.make_key
+    end)
+
+(* Auxiliaries for compiling functions *)
+
+let rec split_list n l =
+  if n <= 0 then ([], l) else begin
+    match l with
+      [] -> fatal_error "Closure.split_list"
+    | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2)
+  end
+
+let rec build_closure_env env_param pos = function
+    [] -> Tbl.empty
+  | id :: rem ->
+      Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none))
+              (build_closure_env env_param (pos+1) rem)
+
+(* Auxiliary for accessing globals.  We change the name of the global
+   to the name of the corresponding asm symbol.  This is done here
+   and no longer in Cmmgen so that approximations stored in .cmx files
+   contain the right names if the -for-pack option is active. *)
+
+let getglobal dbg id =
+  Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
+        [], dbg)
+
+(* Check if a variable occurs in a [clambda] term. *)
+
+let occurs_var var u =
+  let rec occurs = function
+      Uvar v -> v = var
+    | Uconst _ -> false
+    | Udirect_apply(_lbl, args, _) -> List.exists occurs args
+    | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
+    | Uclosure(_fundecls, clos) -> List.exists occurs clos
+    | Uoffset(u, _ofs) -> occurs u
+    | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body
+    | Uletrec(decls, body) ->
+        List.exists (fun (_id, u) -> occurs u) decls || occurs body
+    | Uprim(_p, args, _) -> List.exists occurs args
+    | Uswitch(arg, s) ->
+        occurs arg ||
+        occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
+    | Ustringswitch(arg,sw,d) ->
+        occurs arg ||
+        List.exists (fun (_,e) -> occurs e) sw ||
+        (match d with None -> false | Some d -> occurs d)
+    | Ustaticfail (_, args) -> List.exists occurs args
+    | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr
+    | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr
+    | Uifthenelse(cond, ifso, ifnot) ->
+        occurs cond || occurs ifso || occurs ifnot
+    | Usequence(u1, u2) -> occurs u1 || occurs u2
+    | Uwhile(cond, body) -> occurs cond || occurs body
+    | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body
+    | Uassign(id, u) -> id = var || occurs u
+    | Usend(_, met, obj, args, _) ->
+        occurs met || occurs obj || List.exists occurs args
+    | Uunreachable -> false
+  and occurs_array a =
+    try
+      for i = 0 to Array.length a - 1 do
+        if occurs a.(i) then raise Exit
+      done;
+      false
+    with Exit ->
+      true
+  in occurs u
+
+(* Determine whether the estimated size of a clambda term is below
+   some threshold *)
+
+let prim_size prim args =
+  match prim with
+    Pidentity | Pbytes_to_string | Pbytes_of_string -> 0
+  | Pgetglobal _ -> 1
+  | Psetglobal _ -> 1
+  | Pmakeblock _ -> 5 + List.length args
+  | Pfield _ -> 1
+  | Psetfield(_f, isptr, init) ->
+    begin match init with
+    | Root_initialization -> 1  (* never causes a write barrier hit *)
+    | Assignment | Heap_initialization ->
+      match isptr with
+      | Pointer -> 4
+      | Immediate -> 1
+    end
+  | Pfloatfield _ -> 1
+  | Psetfloatfield _ -> 1
+  | Pduprecord _ -> 10 + List.length args
+  | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
+  | Praise _ -> 4
+  | Pstringlength -> 5
+  | Pbyteslength -> 5
+  | Pstringrefs  -> 6
+  | Pbytesrefs | Pbytessets -> 6
+  | Pmakearray _ -> 5 + List.length args
+  | Parraylength kind -> if kind = Pgenarray then 6 else 2
+  | Parrayrefu kind -> if kind = Pgenarray then 12 else 2
+  | Parraysetu kind -> if kind = Pgenarray then 16 else 4
+  | Parrayrefs kind -> if kind = Pgenarray then 18 else 8
+  | Parraysets kind -> if kind = Pgenarray then 22 else 10
+  | Pbittest -> 3
+  | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6
+  | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6
+  | _ -> 2 (* arithmetic and comparisons *)
+
+(* Very raw approximation of switch cost *)
+
+let lambda_smaller lam threshold =
+  let size = ref 0 in
+  let rec lambda_size lam =
+    if !size > threshold then raise Exit;
+    match lam with
+      Uvar _ -> ()
+    | Uconst _ -> incr size
+    | Udirect_apply(_, args, _) ->
+        size := !size + 4; lambda_list_size args
+    | Ugeneric_apply(fn, args, _) ->
+        size := !size + 6; lambda_size fn; lambda_list_size args
+    | Uclosure _ ->
+        raise Exit (* inlining would duplicate function definitions *)
+    | Uoffset(lam, _ofs) ->
+        incr size; lambda_size lam
+    | Ulet(_str, _kind, _id, lam, body) ->
+        lambda_size lam; lambda_size body
+    | Uletrec _ ->
+        raise Exit (* usually too large *)
+    | Uprim(prim, args, _) ->
+        size := !size + prim_size prim args;
+        lambda_list_size args
+    | Uswitch(lam, cases) ->
+        if Array.length cases.us_actions_consts > 1 then size := !size + 5 ;
+        if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ;
+        lambda_size lam;
+        lambda_array_size cases.us_actions_consts ;
+        lambda_array_size cases.us_actions_blocks
+    | Ustringswitch (lam,sw,d) ->
+        lambda_size lam ;
+       (* as ifthenelse *)
+        List.iter
+          (fun (_,lam) ->
+            size := !size+2 ;
+            lambda_size lam)
+          sw ;
+        Misc.may lambda_size d
+    | Ustaticfail (_,args) -> lambda_list_size args
+    | Ucatch(_, _, body, handler) ->
+        incr size; lambda_size body; lambda_size handler
+    | Utrywith(body, _id, handler) ->
+        size := !size + 8; lambda_size body; lambda_size handler
+    | Uifthenelse(cond, ifso, ifnot) ->
+        size := !size + 2;
+        lambda_size cond; lambda_size ifso; lambda_size ifnot
+    | Usequence(lam1, lam2) ->
+        lambda_size lam1; lambda_size lam2
+    | Uwhile(cond, body) ->
+        size := !size + 2; lambda_size cond; lambda_size body
+    | Ufor(_id, low, high, _dir, body) ->
+        size := !size + 4; lambda_size low; lambda_size high; lambda_size body
+    | Uassign(_id, lam) ->
+        incr size;  lambda_size lam
+    | Usend(_, met, obj, args, _) ->
+        size := !size + 8;
+        lambda_size met; lambda_size obj; lambda_list_size args
+    | Uunreachable -> ()
+  and lambda_list_size l = List.iter lambda_size l
+  and lambda_array_size a = Array.iter lambda_size a in
+  try
+    lambda_size lam; !size <= threshold
+  with Exit ->
+    false
+
+let is_pure_prim p =
+  let open Semantics_of_primitives in
+  match Semantics_of_primitives.for_primitive p with
+  | (No_effects | Only_generative_effects), _ -> true
+  | Arbitrary_effects, _ -> false
+
+(* Check if a clambda term is ``pure'',
+   that is without side-effects *and* not containing function definitions *)
+
+let rec is_pure_clambda = function
+    Uvar _ -> true
+  | Uconst _ -> true
+  | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure_clambda args
+  | _ -> false
+
+(* Simplify primitive operations on known arguments *)
+
+let make_const c = (Uconst c, Value_const c)
+let make_const_ref c =
+  make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c,
+    Some c))
+let make_const_int n = make_const (Uconst_int n)
+let make_const_ptr n = make_const (Uconst_ptr n)
+let make_const_bool b = make_const_ptr(if b then 1 else 0)
+let make_comparison cmp x y =
+  make_const_bool
+    (match cmp with
+       Ceq -> x = y
+     | Cneq -> x <> y
+     | Clt -> x < y
+     | Cgt -> x > y
+     | Cle -> x <= y
+     | Cge -> x >= y)
+let make_const_float n = make_const_ref (Uconst_float n)
+let make_const_natint n = make_const_ref (Uconst_nativeint n)
+let make_const_int32 n = make_const_ref (Uconst_int32 n)
+let make_const_int64 n = make_const_ref (Uconst_int64 n)
+
+(* The [fpc] parameter is true if constant propagation of
+   floating-point computations is allowed *)
+
+let simplif_arith_prim_pure fpc p (args, approxs) dbg =
+  let default = (Uprim(p, args, dbg), Value_unknown) in
+  match approxs with
+  (* int (or enumerated type) *)
+  | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] ->
+      begin match p with
+      | Pnot -> make_const_bool (n1 = 0)
+      | Pnegint -> make_const_int (- n1)
+      | Poffsetint n -> make_const_int (n + n1)
+      | Pfloatofint when fpc -> make_const_float (float_of_int n1)
+      | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1)
+      | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1)
+      | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1)
+      | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8)
+                                    lor ((n1 land 0xff00) lsr 8))
+      | _ -> default
+      end
+  (* int (or enumerated type), int (or enumerated type) *)
+  | [ Value_const(Uconst_int n1 | Uconst_ptr n1);
+      Value_const(Uconst_int n2 | Uconst_ptr n2) ] ->
+      begin match p with
+      | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0)
+      | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0)
+      | Paddint -> make_const_int (n1 + n2)
+      | Psubint -> make_const_int (n1 - n2)
+      | Pmulint -> make_const_int (n1 * n2)
+      | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2)
+      | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2)
+      | Pandint -> make_const_int (n1 land n2)
+      | Porint -> make_const_int (n1 lor n2)
+      | Pxorint -> make_const_int (n1 lxor n2)
+      | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_int (n1 lsl n2)
+      | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_int (n1 lsr n2)
+      | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_int (n1 asr n2)
+      | Pintcomp c -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* float *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc ->
+      begin match p with
+      | Pintoffloat -> make_const_int (int_of_float n1)
+      | Pnegfloat -> make_const_float (-. n1)
+      | Pabsfloat -> make_const_float (abs_float n1)
+      | _ -> default
+      end
+  (* float, float *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_float n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc ->
+      begin match p with
+      | Paddfloat -> make_const_float (n1 +. n2)
+      | Psubfloat -> make_const_float (n1 -. n2)
+      | Pmulfloat -> make_const_float (n1 *. n2)
+      | Pdivfloat -> make_const_float (n1 /. n2)
+      | Pfloatcomp c  -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* nativeint *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] ->
+      begin match p with
+      | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n)
+      | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n)
+      | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n)
+      | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n)
+      | _ -> default
+      end
+  (* nativeint, nativeint *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] ->
+      begin match p with
+      | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2)
+      | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2)
+      | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2)
+      | Pdivbint {size=Pnativeint} when n2 <> 0n ->
+          make_const_natint (Nativeint.div n1 n2)
+      | Pmodbint {size=Pnativeint} when n2 <> 0n ->
+          make_const_natint (Nativeint.rem n1 n2)
+      | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2)
+      | Porbint Pnativeint ->  make_const_natint (Nativeint.logor n1 n2)
+      | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2)
+      | Pbintcomp(Pnativeint, c)  -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* nativeint, int *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_natint (Nativeint.shift_left n1 n2)
+      | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_natint (Nativeint.shift_right_logical n1 n2)
+      | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_natint (Nativeint.shift_right n1 n2)
+      | _ -> default
+      end
+  (* int32 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] ->
+      begin match p with
+      | Pintofbint Pint32 -> make_const_int (Int32.to_int n)
+      | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n)
+      | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n)
+      | Pnegbint Pint32 -> make_const_int32 (Int32.neg n)
+      | _ -> default
+      end
+  (* int32, int32 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] ->
+      begin match p with
+      | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2)
+      | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2)
+      | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2)
+      | Pdivbint {size=Pint32} when n2 <> 0l ->
+          make_const_int32 (Int32.div n1 n2)
+      | Pmodbint {size=Pint32} when n2 <> 0l ->
+          make_const_int32 (Int32.rem n1 n2)
+      | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2)
+      | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2)
+      | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2)
+      | Pbintcomp(Pint32, c) -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* int32, int *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_left n1 n2)
+      | Plsrbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_right_logical n1 n2)
+      | Pasrbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_right n1 n2)
+      | _ -> default
+      end
+  (* int64 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] ->
+      begin match p with
+      | Pintofbint Pint64 -> make_const_int (Int64.to_int n)
+      | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n)
+      | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n)
+      | Pnegbint Pint64 -> make_const_int64 (Int64.neg n)
+      | _ -> default
+      end
+  (* int64, int64 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] ->
+      begin match p with
+      | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2)
+      | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2)
+      | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2)
+      | Pdivbint {size=Pint64} when n2 <> 0L ->
+          make_const_int64 (Int64.div n1 n2)
+      | Pmodbint {size=Pint64} when n2 <> 0L ->
+          make_const_int64 (Int64.rem n1 n2)
+      | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2)
+      | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2)
+      | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2)
+      | Pbintcomp(Pint64, c) -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* int64, int *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_left n1 n2)
+      | Plsrbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_right_logical n1 n2)
+      | Pasrbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_right n1 n2)
+      | _ -> default
+      end
+  (* TODO: Pbbswap *)
+  (* Catch-all *)
+  | _ ->
+     default
+
+let field_approx n = function
+  | Value_tuple a when n < Array.length a -> a.(n)
+  | Value_const (Uconst_ref(_, Some (Uconst_block(_, l))))
+    when n < List.length l ->
+      Value_const (List.nth l n)
+  | _ -> Value_unknown
+
+let simplif_prim_pure fpc p (args, approxs) dbg =
+  match p, args, approxs with
+  (* Block construction *)
+  | Pmakeblock(tag, Immutable, _kind), _, _ ->
+      let field = function
+        | Value_const c -> c
+        | _ -> raise Exit
+      in
+      begin try
+        let cst = Uconst_block (tag, List.map field approxs) in
+        let name =
+          Compilenv.new_structured_constant cst ~shared:true
+        in
+        make_const (Uconst_ref (name, Some cst))
+      with Exit ->
+        (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
+      end
+  (* Field access *)
+  | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
+    when n < List.length l ->
+      make_const (List.nth l n)
+  | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx]
+    when n < List.length ul ->
+      (List.nth ul n, field_approx n approx)
+  (* Strings *)
+  | (Pstringlength | Pbyteslength),
+     _,
+     [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
+      make_const_int (String.length s)
+  (* Identity *)
+  | (Pidentity | Pbytes_to_string | Pbytes_of_string), [arg1], [app1] ->
+      (arg1, app1)
+  (* Kind test *)
+  | Pisint, _, [a1] ->
+      begin match a1 with
+      | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true
+      | Value_const(Uconst_ref _) -> make_const_bool false
+      | Value_closure _ | Value_tuple _ -> make_const_bool false
+      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      end
+  (* Compile-time constants *)
+  | Pctconst c, _, _ ->
+      begin match c with
+        | Big_endian -> make_const_bool Arch.big_endian
+        | Word_size -> make_const_int (8*Arch.size_int)
+        | Int_size -> make_const_int (8*Arch.size_int - 1)
+        | Max_wosize -> make_const_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )
+        | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
+        | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
+        | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
+        | Backend_type ->
+            make_const_ptr 0 (* tag 0 is the same as Native here *)
+      end
+  (* Catch-all *)
+  | _ ->
+      simplif_arith_prim_pure fpc p (args, approxs) dbg
+
+let simplif_prim fpc p (args, approxs as args_approxs) dbg =
+  if List.for_all is_pure_clambda args
+  then simplif_prim_pure fpc p args_approxs dbg
+  else
+    (* XXX : always return the same approxs as simplif_prim_pure? *)
+    let approx =
+      match p with
+      | Pmakeblock(_, Immutable, _kind) ->
+          Value_tuple (Array.of_list approxs)
+      | _ ->
+          Value_unknown
+    in
+    (Uprim(p, args, dbg), approx)
+
+(* Substitute variables in a [ulambda] term (a body of an inlined function)
+   and perform some more simplifications on integer primitives.
+   Also perform alpha-conversion on let-bound identifiers to avoid
+   clashes with locally-generated identifiers.
+   The variables must not be assigned in the term.
+   This is used to substitute "trivial" arguments for parameters
+   during inline expansion, and also for the translation of let rec
+   over functions. *)
+
+let approx_ulam = function
+    Uconst c -> Value_const c
+  | _ -> Value_unknown
+
+let find_action idxs acts tag =
+  if 0 <= tag && tag < Array.length idxs then begin
+    let idx = idxs.(tag) in
+    assert(0 <= idx && idx < Array.length acts);
+    Some acts.(idx)
+  end else
+    (* Can this happen? *)
+    None
+
+let subst_debuginfo loc dbg =
+  if !Clflags.debug then
+    Debuginfo.inline loc dbg
+  else
+    dbg
+
+let rec substitute loc fpc sb ulam =
+  match ulam with
+    Uvar v ->
+      begin try Tbl.find v sb with Not_found -> ulam end
+  | Uconst _ -> ulam
+  | Udirect_apply(lbl, args, dbg) ->
+      let dbg = subst_debuginfo loc dbg in
+      Udirect_apply(lbl, List.map (substitute loc fpc sb) args, dbg)
+  | Ugeneric_apply(fn, args, dbg) ->
+      let dbg = subst_debuginfo loc dbg in
+      Ugeneric_apply(substitute loc fpc sb fn,
+                     List.map (substitute loc fpc sb) args, dbg)
+  | Uclosure(defs, env) ->
+      (* Question: should we rename function labels as well?  Otherwise,
+         there is a risk that function labels are not globally unique.
+         This should not happen in the current system because:
+         - Inlined function bodies contain no Uclosure nodes
+           (cf. function [lambda_smaller])
+         - When we substitute offsets for idents bound by let rec
+           in [close], case [Lletrec], we discard the original
+           let rec body and use only the substituted term. *)
+      Uclosure(defs, List.map (substitute loc fpc sb) env)
+  | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb u, ofs)
+  | Ulet(str, kind, id, u1, u2) ->
+      let id' = Ident.rename id in
+      Ulet(str, kind, id', substitute loc fpc sb u1,
+           substitute loc fpc (Tbl.add id (Uvar id') sb) u2)
+  | Uletrec(bindings, body) ->
+      let bindings1 =
+        List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
+      let sb' =
+        List.fold_right
+          (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
+          bindings1 sb in
+      Uletrec(
+        List.map
+           (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rhs))
+           bindings1,
+        substitute loc fpc sb' body)
+  | Uprim(p, args, dbg) ->
+      let sargs = List.map (substitute loc fpc sb) args in
+      let dbg = subst_debuginfo loc dbg in
+      let (res, _) =
+        simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
+      res
+  | Uswitch(arg, sw) ->
+      let sarg = substitute loc fpc sb arg in
+      let action =
+        (* Unfortunately, we cannot easily deal with the
+           case of a constructed block (makeblock) bound to a local
+           identifier.  This would require to keep track of
+           local let bindings (at least their approximations)
+           in this substitute function.
+        *)
+        match sarg with
+        | Uconst (Uconst_ref (_,  Some (Uconst_block (tag, _)))) ->
+            find_action sw.us_index_blocks sw.us_actions_blocks tag
+        | Uconst (Uconst_ptr tag) ->
+            find_action sw.us_index_consts sw.us_actions_consts tag
+        | _ -> None
+      in
+      begin match action with
+      | Some u -> substitute loc fpc sb u
+      | None ->
+          Uswitch(sarg,
+                  { sw with
+                    us_actions_consts =
+                      Array.map (substitute loc fpc sb) sw.us_actions_consts;
+                    us_actions_blocks =
+                      Array.map (substitute loc fpc sb) sw.us_actions_blocks;
+                  })
+      end
+  | Ustringswitch(arg,sw,d) ->
+      Ustringswitch
+        (substitute loc fpc sb arg,
+         List.map (fun (s,act) -> s,substitute loc fpc sb act) sw,
+         Misc.may_map (substitute loc fpc sb) d)
+  | Ustaticfail (nfail, args) ->
+      Ustaticfail (nfail, List.map (substitute loc fpc sb) args)
+  | Ucatch(nfail, ids, u1, u2) ->
+      let ids' = List.map Ident.rename ids in
+      let sb' =
+        List.fold_right2
+          (fun id id' s -> Tbl.add id (Uvar id') s)
+          ids ids' sb
+      in
+      Ucatch(nfail, ids', substitute loc fpc sb u1, substitute loc fpc sb' u2)
+  | Utrywith(u1, id, u2) ->
+      let id' = Ident.rename id in
+      Utrywith(substitute loc fpc sb u1, id',
+               substitute loc fpc (Tbl.add id (Uvar id') sb) u2)
+  | Uifthenelse(u1, u2, u3) ->
+      begin match substitute loc fpc sb u1 with
+        Uconst (Uconst_ptr n) ->
+          if n <> 0 then substitute loc fpc sb u2 else substitute loc fpc sb u3
+      | Uprim(Pmakeblock _, _, _) ->
+          substitute loc fpc sb u2
+      | su1 ->
+          Uifthenelse(su1, substitute loc fpc sb u2, substitute loc fpc sb u3)
+      end
+  | Usequence(u1, u2) ->
+      Usequence(substitute loc fpc sb u1, substitute loc fpc sb u2)
+  | Uwhile(u1, u2) ->
+      Uwhile(substitute loc fpc sb u1, substitute loc fpc sb u2)
+  | Ufor(id, u1, u2, dir, u3) ->
+      let id' = Ident.rename id in
+      Ufor(id', substitute loc fpc sb u1, substitute loc fpc sb u2, dir,
+           substitute loc fpc (Tbl.add id (Uvar id') sb) u3)
+  | Uassign(id, u) ->
+      let id' =
+        try
+          match Tbl.find id sb with Uvar i -> i | _ -> assert false
+        with Not_found ->
+          id in
+      Uassign(id', substitute loc fpc sb u)
+  | Usend(k, u1, u2, ul, dbg) ->
+      let dbg = subst_debuginfo loc dbg in
+      Usend(k, substitute loc fpc sb u1, substitute loc fpc sb u2,
+            List.map (substitute loc fpc sb) ul, dbg)
+  | Uunreachable ->
+      Uunreachable
+
+(* Perform an inline expansion *)
+
+let is_simple_argument = function
+  | Uvar _  | Uconst _ -> true
+  | _ -> false
+
+let no_effects = function
+  | Uclosure _ -> true
+  | u -> is_pure_clambda u
+
+let rec bind_params_rec loc fpc subst params args body =
+  match (params, args) with
+    ([], []) -> substitute loc fpc subst body
+  | (p1 :: pl, a1 :: al) ->
+      if is_simple_argument a1 then
+        bind_params_rec loc fpc (Tbl.add p1 a1 subst) pl al body
+      else begin
+        let p1' = Ident.rename p1 in
+        let u1, u2 =
+          match Ident.name p1, a1 with
+          | "*opt*", Uprim(Pmakeblock(0, Immutable, kind), [a], dbg) ->
+              a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar p1'], dbg)
+          | _ ->
+              a1, Uvar p1'
+        in
+        let body' =
+          bind_params_rec loc fpc (Tbl.add p1 u2 subst) pl al body in
+        if occurs_var p1 body then Ulet(Immutable, Pgenval, p1', u1, body')
+        else if no_effects a1 then body'
+        else Usequence(a1, body')
+      end
+  | (_, _) -> assert false
+
+let bind_params loc fpc params args body =
+  (* Reverse parameters and arguments to preserve right-to-left
+     evaluation order (PR#2910). *)
+  bind_params_rec loc fpc Tbl.empty (List.rev params) (List.rev args) body
+
+(* Check if a lambda term is ``pure'',
+   that is without side-effects *and* not containing function definitions *)
+
+let rec is_pure = function
+    Lvar _ -> true
+  | Lconst _ -> true
+  | Lprim(p, args,_) -> is_pure_prim p && List.for_all is_pure args
+  | Levent(lam, _ev) -> is_pure lam
+  | _ -> false
+
+let warning_if_forced_inline ~loc ~attribute warning =
+  if attribute = Always_inline then
+    Location.prerr_warning loc
+      (Warnings.Inlining_impossible warning)
+
+(* Generate a direct application *)
+
+let direct_apply fundesc funct ufunct uargs ~loc ~attribute =
+  let app_args =
+    if fundesc.fun_closed then uargs else uargs @ [ufunct] in
+  let app =
+    match fundesc.fun_inline, attribute with
+    | _, Never_inline | None, _ ->
+      let dbg = Debuginfo.from_location loc in
+        warning_if_forced_inline ~loc ~attribute
+          "Function information unavailable";
+        Udirect_apply(fundesc.fun_label, app_args, dbg)
+    | Some(params, body), _  ->
+        bind_params loc fundesc.fun_float_const_prop params app_args body
+  in
+  (* If ufunct can contain side-effects or function definitions,
+     we must make sure that it is evaluated exactly once.
+     If the function is not closed, we evaluate ufunct as part of the
+     arguments.
+     If the function is closed, we force the evaluation of ufunct first. *)
+  if not fundesc.fun_closed || is_pure funct
+  then app
+  else Usequence(ufunct, app)
+
+(* Add [Value_integer] or [Value_constptr] info to the approximation
+   of an application *)
+
+let strengthen_approx appl approx =
+  match approx_ulam appl with
+    (Value_const _) as intapprox ->
+      intapprox
+  | _ -> approx
+
+(* If a term has approximation Value_integer or Value_constptr and is pure,
+   replace it by an integer constant *)
+
+let check_constant_result lam ulam approx =
+  match approx with
+    Value_const c when is_pure lam -> make_const c
+  | Value_global_field (id, i) when is_pure lam ->
+      begin match ulam with
+      | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx)
+      | _ ->
+          let glb =
+            Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none)
+          in
+          Uprim(Pfield i, [glb], Debuginfo.none), approx
+      end
+  | _ -> (ulam, approx)
+
+(* Evaluate an expression with known value for its side effects only,
+   or discard it if it's pure *)
+
+let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) =
+  if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2)
+
+(* Maintain the approximation of the global structure being defined *)
+
+let global_approx = ref([||] : value_approximation array)
+
+(* Maintain the nesting depth for functions *)
+
+let function_nesting_depth = ref 0
+let excessive_function_nesting_depth = 5
+
+(* Uncurry an expression and explicitate closures.
+   Also return the approximation of the expression.
+   The approximation environment [fenv] maps idents to approximations.
+   Idents not bound in [fenv] approximate to [Value_unknown].
+   The closure environment [cenv] maps idents to [ulambda] terms.
+   It is used to substitute environment accesses for free identifiers. *)
+
+exception NotClosed
+
+let close_approx_var fenv cenv id =
+  let approx = try Tbl.find id fenv with Not_found -> Value_unknown in
+  match approx with
+    Value_const c -> make_const c
+  | approx ->
+      let subst = try Tbl.find id cenv with Not_found -> Uvar id in
+      (subst, approx)
+
+let close_var fenv cenv id =
+  let (ulam, _app) = close_approx_var fenv cenv id in ulam
+
+let rec close fenv cenv = function
+    Lvar id ->
+      close_approx_var fenv cenv id
+  | Lconst cst ->
+      let str ?(shared = true) cst =
+        let name =
+          Compilenv.new_structured_constant cst ~shared
+        in
+        Uconst_ref (name, Some cst)
+      in
+      let rec transl = function
+        | Const_base(Const_int n) -> Uconst_int n
+        | Const_base(Const_char c) -> Uconst_int (Char.code c)
+        | Const_pointer n -> Uconst_ptr n
+        | Const_block (tag, fields) ->
+            str (Uconst_block (tag, List.map transl fields))
+        | Const_float_array sl ->
+            (* constant float arrays are really immutable *)
+            str (Uconst_float_array (List.map float_of_string sl))
+        | Const_immstring s ->
+            str (Uconst_string s)
+        | Const_base (Const_string (s, _)) ->
+              (* Strings (even literal ones) must be assumed to be mutable...
+                 except when OCaml has been configured with
+                 -safe-string.  Passing -safe-string at compilation
+                 time is not enough, since the unit could be linked
+                 with another one compiled without -safe-string, and
+                 that one could modify our string literal.  *)
+            str ~shared:Config.safe_string (Uconst_string s)
+        | Const_base(Const_float x) -> str (Uconst_float (float_of_string x))
+        | Const_base(Const_int32 x) -> str (Uconst_int32 x)
+        | Const_base(Const_int64 x) -> str (Uconst_int64 x)
+        | Const_base(Const_nativeint x) -> str (Uconst_nativeint x)
+      in
+      make_const (transl cst)
+  | Lfunction _ as funct ->
+      close_one_function fenv cenv (Ident.create "fun") funct
+
+    (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
+       when fun_arity > nargs *)
+  | Lapply{ap_func = funct; ap_args = args; ap_loc = loc;
+        ap_inlined = attribute} ->
+      let nargs = List.length args in
+      begin match (close fenv cenv funct, close_list fenv cenv args) with
+        ((ufunct, Value_closure(fundesc, approx_res)),
+         [Uprim(Pmakeblock _, uargs, _)])
+        when List.length uargs = - fundesc.fun_arity ->
+          let app =
+            direct_apply ~loc ~attribute fundesc funct ufunct uargs in
+          (app, strengthen_approx app approx_res)
+      | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
+        when nargs = fundesc.fun_arity ->
+          let app =
+            direct_apply ~loc ~attribute fundesc funct ufunct uargs in
+          (app, strengthen_approx app approx_res)
+
+      | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
+          when nargs < fundesc.fun_arity ->
+        let first_args = List.map (fun arg ->
+          (Ident.create "arg", arg) ) uargs in
+        let final_args =
+          Array.to_list (Array.init (fundesc.fun_arity - nargs)
+                                    (fun _ -> Ident.create "arg")) in
+        let rec iter args body =
+          match args with
+              [] -> body
+            | (arg1, arg2) :: args ->
+              iter args
+                (Ulet (Immutable, Pgenval, arg1, arg2, body))
+        in
+        let internal_args =
+          (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
+          @ (List.map (fun arg -> Lvar arg ) final_args)
+        in
+        let funct_var = Ident.create "funct" in
+        let fenv = Tbl.add funct_var fapprox fenv in
+        let (new_fun, approx) = close fenv cenv
+          (Lfunction{
+               kind = Curried;
+               params = final_args;
+               body = Lapply{ap_should_be_tailcall=false;
+                             ap_loc=loc;
+                             ap_func=(Lvar funct_var);
+                             ap_args=internal_args;
+                             ap_inlined=Default_inline;
+                             ap_specialised=Default_specialise};
+               loc;
+               attr = default_function_attribute})
+        in
+        let new_fun =
+          iter first_args
+            (Ulet (Immutable, Pgenval, funct_var, ufunct, new_fun))
+        in
+        warning_if_forced_inline ~loc ~attribute "Partial application";
+        (new_fun, approx)
+
+      | ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
+        when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
+          let args = List.map (fun arg -> Ident.create "arg", arg) uargs in
+          let (first_args, rem_args) = split_list fundesc.fun_arity args in
+          let first_args = List.map (fun (id, _) -> Uvar id) first_args in
+          let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in
+          let dbg = Debuginfo.from_location loc in
+          warning_if_forced_inline ~loc ~attribute "Over-application";
+          let body =
+            Ugeneric_apply(direct_apply ~loc ~attribute
+                              fundesc funct ufunct first_args,
+                           rem_args, dbg)
+          in
+          let result =
+            List.fold_left (fun body (id, defining_expr) ->
+                Ulet (Immutable, Pgenval, id, defining_expr, body))
+              body
+              args
+          in
+          result, Value_unknown
+      | ((ufunct, _), uargs) ->
+          let dbg = Debuginfo.from_location loc in
+          warning_if_forced_inline ~loc ~attribute "Unknown function";
+          (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
+      end
+  | Lsend(kind, met, obj, args, loc) ->
+      let (umet, _) = close fenv cenv met in
+      let (uobj, _) = close fenv cenv obj in
+      let dbg = Debuginfo.from_location loc in
+      (Usend(kind, umet, uobj, close_list fenv cenv args, dbg),
+       Value_unknown)
+  | Llet(str, kind, id, lam, body) ->
+      let (ulam, alam) = close_named fenv cenv id lam in
+      begin match (str, alam) with
+        (Variable, _) ->
+          let (ubody, abody) = close fenv cenv body in
+          (Ulet(Mutable, kind, id, ulam, ubody), abody)
+      | (_, Value_const _)
+        when str = Alias || is_pure lam ->
+          close (Tbl.add id alam fenv) cenv body
+      | (_, _) ->
+          let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in
+          (Ulet(Immutable, kind, id, ulam, ubody), abody)
+      end
+  | Lletrec(defs, body) ->
+      if List.for_all
+           (function (_id, Lfunction _) -> true | _ -> false)
+           defs
+      then begin
+        (* Simple case: only function definitions *)
+        let (clos, infos) = close_functions fenv cenv defs in
+        let clos_ident = Ident.create "clos" in
+        let fenv_body =
+          List.fold_right
+            (fun (id, _pos, approx) fenv -> Tbl.add id approx fenv)
+            infos fenv in
+        let (ubody, approx) = close fenv_body cenv body in
+        let sb =
+          List.fold_right
+            (fun (id, pos, _approx) sb ->
+              Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
+            infos Tbl.empty in
+        (Ulet(Immutable, Pgenval, clos_ident, clos,
+              substitute Location.none !Clflags.float_const_prop sb ubody),
+         approx)
+      end else begin
+        (* General case: recursive definition of values *)
+        let rec clos_defs = function
+          [] -> ([], fenv)
+        | (id, lam) :: rem ->
+            let (udefs, fenv_body) = clos_defs rem in
+            let (ulam, approx) = close_named fenv cenv id lam in
+            ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in
+        let (udefs, fenv_body) = clos_defs defs in
+        let (ubody, approx) = close fenv_body cenv body in
+        (Uletrec(udefs, ubody), approx)
+      end
+  | Lprim(Pdirapply,[funct;arg], loc)
+  | Lprim(Prevapply,[arg;funct], loc) ->
+      close fenv cenv (Lapply{ap_should_be_tailcall=false;
+                              ap_loc=loc;
+                              ap_func=funct;
+                              ap_args=[arg];
+                              ap_inlined=Default_inline;
+                              ap_specialised=Default_specialise})
+  | Lprim(Pgetglobal id, [], loc) as lam ->
+      let dbg = Debuginfo.from_location loc in
+      check_constant_result lam
+                            (getglobal dbg id)
+                            (Compilenv.global_approx id)
+  | Lprim(Pfield n, [lam], loc) ->
+      let (ulam, approx) = close fenv cenv lam in
+      let dbg = Debuginfo.from_location loc in
+      check_constant_result lam (Uprim(Pfield n, [ulam], dbg))
+                            (field_approx n approx)
+  | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
+      let (ulam, approx) = close fenv cenv lam in
+      if approx <> Value_unknown then
+        (!global_approx).(n) <- approx;
+      let dbg = Debuginfo.from_location loc in
+      (Uprim(Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),
+       Value_unknown)
+  | Lprim(Praise k, [arg], loc) ->
+      let (ulam, _approx) = close fenv cenv arg in
+      let dbg = Debuginfo.from_location loc in
+      (Uprim(Praise k, [ulam], dbg),
+       Value_unknown)
+  | Lprim(p, args, loc) ->
+      let dbg = Debuginfo.from_location loc in
+      simplif_prim !Clflags.float_const_prop
+                   p (close_list_approx fenv cenv args) dbg
+  | Lswitch(arg, sw) ->
+      let fn fail =
+        let (uarg, _) = close fenv cenv arg in
+        let const_index, const_actions, fconst =
+          close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail
+        and block_index, block_actions, fblock =
+          close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in
+        let ulam =
+          Uswitch
+            (uarg,
+             {us_index_consts = const_index;
+              us_actions_consts = const_actions;
+              us_index_blocks = block_index;
+              us_actions_blocks = block_actions})  in
+        (fconst (fblock ulam),Value_unknown) in
+(* NB: failaction might get copied, thus it should be some Lstaticraise *)
+      let fail = sw.sw_failaction in
+      begin match fail with
+      | None|Some (Lstaticraise (_,_)) -> fn fail
+      | Some lamfail ->
+          if
+            (sw.sw_numconsts - List.length sw.sw_consts) +
+            (sw.sw_numblocks - List.length sw.sw_blocks) > 1
+          then
+            let i = next_raise_count () in
+            let ubody,_ = fn (Some (Lstaticraise (i,[])))
+            and uhandler,_ = close fenv cenv lamfail in
+            Ucatch (i,[],ubody,uhandler),Value_unknown
+          else fn fail
+      end
+  | Lstringswitch(arg,sw,d,_) ->
+      let uarg,_ = close fenv cenv arg in
+      let usw =
+        List.map
+          (fun (s,act) ->
+            let uact,_ = close fenv cenv act in
+            s,uact)
+          sw in
+      let ud =
+        Misc.may_map
+          (fun d ->
+            let ud,_ = close fenv cenv d in
+            ud) d in
+      Ustringswitch (uarg,usw,ud),Value_unknown
+  | Lstaticraise (i, args) ->
+      (Ustaticfail (i, close_list fenv cenv args), Value_unknown)
+  | Lstaticcatch(body, (i, vars), handler) ->
+      let (ubody, _) = close fenv cenv body in
+      let (uhandler, _) = close fenv cenv handler in
+      (Ucatch(i, vars, ubody, uhandler), Value_unknown)
+  | Ltrywith(body, id, handler) ->
+      let (ubody, _) = close fenv cenv body in
+      let (uhandler, _) = close fenv cenv handler in
+      (Utrywith(ubody, id, uhandler), Value_unknown)
+  | Lifthenelse(arg, ifso, ifnot) ->
+      begin match close fenv cenv arg with
+        (uarg, Value_const (Uconst_ptr n)) ->
+          sequence_constant_expr arg uarg
+            (close fenv cenv (if n = 0 then ifnot else ifso))
+      | (uarg, _ ) ->
+          let (uifso, _) = close fenv cenv ifso in
+          let (uifnot, _) = close fenv cenv ifnot in
+          (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
+      end
+  | Lsequence(lam1, lam2) ->
+      let (ulam1, _) = close fenv cenv lam1 in
+      let (ulam2, approx) = close fenv cenv lam2 in
+      (Usequence(ulam1, ulam2), approx)
+  | Lwhile(cond, body) ->
+      let (ucond, _) = close fenv cenv cond in
+      let (ubody, _) = close fenv cenv body in
+      (Uwhile(ucond, ubody), Value_unknown)
+  | Lfor(id, lo, hi, dir, body) ->
+      let (ulo, _) = close fenv cenv lo in
+      let (uhi, _) = close fenv cenv hi in
+      let (ubody, _) = close fenv cenv body in
+      (Ufor(id, ulo, uhi, dir, ubody), Value_unknown)
+  | Lassign(id, lam) ->
+      let (ulam, _) = close fenv cenv lam in
+      (Uassign(id, ulam), Value_unknown)
+  | Levent(lam, _) ->
+      close fenv cenv lam
+  | Lifused _ ->
+      assert false
+
+and close_list fenv cenv = function
+    [] -> []
+  | lam :: rem ->
+      let (ulam, _) = close fenv cenv lam in
+      ulam :: close_list fenv cenv rem
+
+and close_list_approx fenv cenv = function
+    [] -> ([], [])
+  | lam :: rem ->
+      let (ulam, approx) = close fenv cenv lam in
+      let (ulams, approxs) = close_list_approx fenv cenv rem in
+      (ulam :: ulams, approx :: approxs)
+
+and close_named fenv cenv id = function
+    Lfunction _ as funct ->
+      close_one_function fenv cenv id funct
+  | lam ->
+      close fenv cenv lam
+
+(* Build a shared closure for a set of mutually recursive functions *)
+
+and close_functions fenv cenv fun_defs =
+  let fun_defs =
+    List.flatten
+      (List.map
+         (function
+           | (id, Lfunction{kind; params; body; attr; loc}) ->
+               Simplif.split_default_wrapper ~id ~kind ~params
+                 ~body ~attr ~loc
+           | _ -> assert false
+         )
+         fun_defs)
+  in
+  let inline_attribute = match fun_defs with
+    | [_, Lfunction{attr = { inline; }}] -> inline
+    | _ -> Default_inline (* recursive functions can't be inlined *)
+  in
+  (* Update and check nesting depth *)
+  incr function_nesting_depth;
+  let initially_closed =
+    !function_nesting_depth < excessive_function_nesting_depth in
+  (* Determine the free variables of the functions *)
+  let fv =
+    IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
+  (* Build the function descriptors for the functions.
+     Initially all functions are assumed not to need their environment
+     parameter. *)
+  let uncurried_defs =
+    List.map
+      (function
+          (id, Lfunction{kind; params; body; loc}) ->
+            let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
+            let arity = List.length params in
+            let fundesc =
+              {fun_label = label;
+               fun_arity = (if kind = Tupled then -arity else arity);
+               fun_closed = initially_closed;
+               fun_inline = None;
+               fun_float_const_prop = !Clflags.float_const_prop } in
+            let dbg = Debuginfo.from_location loc in
+            (id, params, body, fundesc, dbg)
+        | (_, _) -> fatal_error "Closure.close_functions")
+      fun_defs in
+  (* Build an approximate fenv for compiling the functions *)
+  let fenv_rec =
+    List.fold_right
+      (fun (id, _params, _body, fundesc, _dbg) fenv ->
+        Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
+      uncurried_defs fenv in
+  (* Determine the offsets of each function's closure in the shared block *)
+  let env_pos = ref (-1) in
+  let clos_offsets =
+    List.map
+      (fun (_id, _params, _body, fundesc, _dbg) ->
+        let pos = !env_pos + 1 in
+        env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
+        pos)
+      uncurried_defs in
+  let fv_pos = !env_pos in
+  (* This reference will be set to false if the hypothesis that a function
+     does not use its environment parameter is invalidated. *)
+  let useless_env = ref initially_closed in
+  (* Translate each function definition *)
+  let clos_fundef (id, params, body, fundesc, dbg) env_pos =
+    let env_param = Ident.create "env" in
+    let cenv_fv =
+      build_closure_env env_param (fv_pos - env_pos) fv in
+    let cenv_body =
+      List.fold_right2
+        (fun (id, _params, _body, _fundesc, _dbg) pos env ->
+          Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
+        uncurried_defs clos_offsets cenv_fv in
+    let (ubody, approx) = close fenv_rec cenv_body body in
+    if !useless_env && occurs_var env_param ubody then raise NotClosed;
+    let fun_params = if !useless_env then params else params @ [env_param] in
+    let f =
+      {
+        label  = fundesc.fun_label;
+        arity  = fundesc.fun_arity;
+        params = fun_params;
+        body   = ubody;
+        dbg;
+        env = Some env_param;
+      }
+    in
+    (* give more chance of function with default parameters (i.e.
+       their wrapper functions) to be inlined *)
+    let n =
+      List.fold_left
+        (fun n id -> n + if Ident.name id = "*opt*" then 8 else 1)
+        0
+        fun_params
+    in
+    let threshold =
+      match inline_attribute with
+      | Default_inline ->
+          let inline_threshold =
+            Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold
+          in
+          let magic_scale_constant = 8. in
+          int_of_float (inline_threshold *. magic_scale_constant) + n
+      | Always_inline -> max_int
+      | Never_inline -> min_int
+      | Unroll _ -> assert false
+    in
+    if lambda_smaller ubody threshold
+    then fundesc.fun_inline <- Some(fun_params, ubody);
+
+    (f, (id, env_pos, Value_closure(fundesc, approx))) in
+  (* Translate all function definitions. *)
+  let clos_info_list =
+    if initially_closed then begin
+      let snap = Compilenv.snapshot () in
+      try List.map2 clos_fundef uncurried_defs clos_offsets
+      with NotClosed ->
+      (* If the hypothesis that the environment parameters are useless has been
+         invalidated, then set [fun_closed] to false in all descriptions and
+         recompile *)
+        Compilenv.backtrack snap; (* PR#6337 *)
+        List.iter
+          (fun (_id, _params, _body, fundesc, _dbg) ->
+             fundesc.fun_closed <- false;
+             fundesc.fun_inline <- None;
+          )
+          uncurried_defs;
+        useless_env := false;
+        List.map2 clos_fundef uncurried_defs clos_offsets
+    end else
+      (* Excessive closure nesting: assume environment parameter is used *)
+        List.map2 clos_fundef uncurried_defs clos_offsets
+    in
+  (* Update nesting depth *)
+  decr function_nesting_depth;
+  (* Return the Uclosure node and the list of all identifiers defined,
+     with offsets and approximations. *)
+  let (clos, infos) = List.split clos_info_list in
+  let fv = if !useless_env then [] else fv in
+  (Uclosure(clos, List.map (close_var fenv cenv) fv), infos)
+
+(* Same, for one non-recursive function *)
+
+and close_one_function fenv cenv id funct =
+  match close_functions fenv cenv [id, funct] with
+  | (clos, (i, _, approx) :: _) when id = i -> (clos, approx)
+  | _ -> fatal_error "Closure.close_one_function"
+
+(* Close a switch *)
+
+and close_switch fenv cenv cases num_keys default =
+  let ncases = List.length cases in
+  let index = Array.make num_keys 0
+  and store = Storer.mk_store () in
+
+  (* First default case *)
+  begin match default with
+  | Some def when ncases < num_keys ->
+      assert (store.act_store def = 0)
+  | _ -> ()
+  end ;
+  (* Then all other cases *)
+  List.iter
+    (fun (key,lam) ->
+     index.(key) <- store.act_store lam)
+    cases ;
+
+  (*  Explicit sharing with catch/exit, as switcher compilation may
+      later unshare *)
+  let acts = store.act_get_shared () in
+  let hs = ref (fun e -> e) in
+
+  (* Compile actions *)
+  let actions =
+    Array.map
+      (function
+        | Single lam|Shared (Lstaticraise (_,[]) as lam) ->
+            let ulam,_ = close fenv cenv lam in
+            ulam
+        | Shared lam ->
+            let ulam,_ = close fenv cenv lam in
+            let i = next_raise_count () in
+(*
+            let string_of_lambda e =
+              Printlambda.lambda Format.str_formatter e ;
+              Format.flush_str_formatter () in
+            Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i
+                (string_of_lambda arg)
+                (string_of_lambda lam) ;
+*)
+            let ohs = !hs in
+            hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ;
+            Ustaticfail (i,[]))
+      acts in
+  match actions with
+  | [| |] -> [| |], [| |], !hs (* May happen when default is None *)
+  | _     -> index, actions, !hs
+
+
+(* Collect exported symbols for structured constants *)
+
+let collect_exported_structured_constants a =
+  let rec approx = function
+    | Value_closure (fd, a) ->
+        approx a;
+        begin match fd.fun_inline with
+        | Some (_, u) -> ulam u
+        | None -> ()
+        end
+    | Value_tuple a -> Array.iter approx a
+    | Value_const c -> const c
+    | Value_unknown | Value_global_field _ -> ()
+  and const = function
+    | Uconst_ref (s, (Some c)) ->
+        Compilenv.add_exported_constant s;
+        structured_constant c
+    | Uconst_ref (_s, None) -> assert false (* Cannot be generated *)
+    | Uconst_int _ | Uconst_ptr _ -> ()
+  and structured_constant = function
+    | Uconst_block (_, ul) -> List.iter const ul
+    | Uconst_float _ | Uconst_int32 _
+    | Uconst_int64 _ | Uconst_nativeint _
+    | Uconst_float_array _ | Uconst_string _ -> ()
+    | Uconst_closure _ -> assert false (* Cannot be generated *)
+  and ulam = function
+    | Uvar _ -> ()
+    | Uconst c -> const c
+    | Udirect_apply (_, ul, _) -> List.iter ulam ul
+    | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul
+    | Uclosure (fl, ul) ->
+        List.iter (fun f -> ulam f.body) fl;
+        List.iter ulam ul
+    | Uoffset(u, _) -> ulam u
+    | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2
+    | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u
+    | Uprim (_, ul, _) -> List.iter ulam ul
+    | Uswitch (u, sl) ->
+        ulam u;
+        Array.iter ulam sl.us_actions_consts;
+        Array.iter ulam sl.us_actions_blocks
+    | Ustringswitch (u,sw,d) ->
+        ulam u ;
+        List.iter (fun (_,act) -> ulam act) sw ;
+        Misc.may ulam d
+    | Ustaticfail (_, ul) -> List.iter ulam ul
+    | Ucatch (_, _, u1, u2)
+    | Utrywith (u1, _, u2)
+    | Usequence (u1, u2)
+    | Uwhile (u1, u2)  -> ulam u1; ulam u2
+    | Uifthenelse (u1, u2, u3)
+    | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3
+    | Uassign (_, u) -> ulam u
+    | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul
+    | Uunreachable -> ()
+  in
+  approx a
+
+let reset () =
+  global_approx := [||];
+  function_nesting_depth := 0
+
+(* The entry point *)
+
+let intro size lam =
+  reset ();
+  let id = Compilenv.make_symbol None in
+  global_approx := Array.init size (fun i -> Value_global_field (id, i));
+  Compilenv.set_global_approx(Value_tuple !global_approx);
+  let (ulam, _approx) = close Tbl.empty Tbl.empty lam in
+  let opaque =
+    !Clflags.opaque
+    || Env.is_imported_opaque (Compilenv.current_unit_name ())
+  in
+  if opaque
+  then Compilenv.set_global_approx(Value_unknown)
+  else collect_exported_structured_constants (Value_tuple !global_approx);
+  global_approx := [||];
+  ulam
diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli
new file mode 100644
index 00000000..f930e0fe
--- /dev/null
+++ b/asmcomp/closure.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Introduction of closures, uncurrying, recognition of direct calls *)
+
+val intro: int -> Lambda.lambda -> Clambda.ulambda
+val reset : unit -> unit
diff --git a/asmcomp/closure_offsets.ml b/asmcomp/closure_offsets.ml
new file mode 100644
index 00000000..94eb4a1f
--- /dev/null
+++ b/asmcomp/closure_offsets.ml
@@ -0,0 +1,138 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type result = {
+  function_offsets : int Closure_id.Map.t;
+  free_variable_offsets : int Var_within_closure.Map.t;
+}
+
+let add_closure_offsets
+      { function_offsets; free_variable_offsets }
+      ({ function_decls; free_vars } : Flambda.set_of_closures) =
+  (* Build the table mapping the functions declared by the set of closures
+     to the positions of their individual "infix" closures inside the runtime
+     closure block.  (All of the environment entries will come afterwards.) *)
+  let assign_function_offset id function_decl (map, env_pos) =
+    let pos = env_pos + 1 in
+    let env_pos =
+      let arity = Flambda_utils.function_arity function_decl in
+      env_pos
+        + 1  (* GC header; either [Closure_tag] or [Infix_tag] *)
+        + 1  (* full application code pointer *)
+        + 1  (* arity *)
+        + (if arity > 1 then 1 else 0)  (* partial application code pointer *)
+    in
+    let closure_id = Closure_id.wrap id in
+    if Closure_id.Map.mem closure_id map then begin
+      Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \
+          offset for %a would be defined multiple times"
+        Closure_id.print closure_id
+    end;
+    let map = Closure_id.Map.add closure_id pos map in
+    (map, env_pos)
+  in
+  let function_offsets, free_variable_pos =
+    Variable.Map.fold assign_function_offset
+      function_decls.funs (function_offsets, -1)
+  in
+  (* Adds the mapping of free variables to their offset.  Recall that
+     projections of [Var_within_closure]s are only currently used when
+     compiling accesses to the closure of a function from outside that
+     function (in particular, as a result of inlining).  Accesses to
+     a function's own closure are compiled directly via normal [Var]
+     accesses. *)
+  (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't
+     ideal, and the self accesses should be explicitly marked too. *)
+  let assign_free_variable_offset var _ (map, pos) =
+    let var_within_closure = Var_within_closure.wrap var in
+    if Var_within_closure.Map.mem var_within_closure map then begin
+      Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \
+          offset for %a would be defined multiple times"
+        Var_within_closure.print var_within_closure
+    end;
+    let map = Var_within_closure.Map.add var_within_closure pos map in
+    (map, pos + 1)
+  in
+  let free_variable_offsets, _ =
+    Variable.Map.fold assign_free_variable_offset
+      free_vars (free_variable_offsets, free_variable_pos)
+  in
+  { function_offsets;
+    free_variable_offsets;
+  }
+
+let compute (program:Flambda.program) =
+  let init : result =
+    { function_offsets = Closure_id.Map.empty;
+      free_variable_offsets = Var_within_closure.Map.empty;
+    }
+  in
+  let r =
+    List.fold_left add_closure_offsets
+      init (Flambda_utils.all_sets_of_closures program)
+  in
+  r
+
+let compute_reexported_offsets program
+      ~current_unit_offset_fun ~current_unit_offset_fv
+      ~imported_units_offset_fun ~imported_units_offset_fv =
+  let offset_fun = ref current_unit_offset_fun in
+  let offset_fv = ref current_unit_offset_fv in
+  let used_closure_id closure_id =
+    match Closure_id.Map.find closure_id imported_units_offset_fun with
+    | offset ->
+      assert (not (Closure_id.Map.mem closure_id current_unit_offset_fun));
+      begin match Closure_id.Map.find closure_id !offset_fun with
+      | exception Not_found ->
+        offset_fun := Closure_id.Map.add closure_id offset !offset_fun
+      | offset' -> assert (offset = offset')
+      end
+    | exception Not_found ->
+      assert (Closure_id.Map.mem closure_id current_unit_offset_fun)
+  in
+  let used_var_within_closure var =
+    match Var_within_closure.Map.find var imported_units_offset_fv with
+    | offset ->
+      assert (not (Var_within_closure.Map.mem var current_unit_offset_fv));
+      begin match Var_within_closure.Map.find var !offset_fv with
+      | exception Not_found ->
+        offset_fv := Var_within_closure.Map.add var offset !offset_fv
+      | offset' -> assert (offset = offset')
+      end
+    | exception Not_found ->
+      assert (Var_within_closure.Map.mem var current_unit_offset_fv)
+  in
+  Flambda_iterators.iter_named_of_program program
+    ~f:(fun (named : Flambda.named) ->
+      match named with
+      | Project_closure { closure_id; _ } ->
+        used_closure_id closure_id
+      | Move_within_set_of_closures { start_from; move_to; _ } ->
+        used_closure_id start_from;
+        used_closure_id move_to
+      | Project_var { closure_id; var; _ } ->
+        used_closure_id closure_id;
+        used_var_within_closure var
+      | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Read_symbol_field _ | Set_of_closures _ | Prim _ | Expr _ -> ());
+  Flambda_iterators.iter_constant_defining_values_on_program program
+    ~f:(fun (const : Flambda.constant_defining_value) ->
+      match const with
+      | Project_closure (_, closure_id) -> used_closure_id closure_id
+      | Allocated_const _ | Block _ | Set_of_closures _ -> ());
+  !offset_fun, !offset_fv
diff --git a/asmcomp/closure_offsets.mli b/asmcomp/closure_offsets.mli
new file mode 100644
index 00000000..7acb8449
--- /dev/null
+++ b/asmcomp/closure_offsets.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Assign numerical offsets, within closure blocks, for code pointers and
+    environment entries. *)
+
+type result = private {
+  function_offsets : int Closure_id.Map.t;
+  free_variable_offsets : int Var_within_closure.Map.t;
+}
+
+val compute : Flambda.program -> result
+
+(** If compilation unit [C] references [B], which contains functions inlined
+    from another compilation unit [A], then we may need to know the layout of
+    closures inside (or constructed by code inside) a.cmx in order to
+    compile c.cmx.  Unfortunately a.cmx is permitted to be absent during such
+    compilation; c.cmx will be compiled using just b.cmx.  As such, when
+    building the .cmx export information for a given compilation unit, we
+    also include information about the layout of any closures that it depends
+    on from other compilation units.  This means that when situations as just
+    describe arise, we always have access to the necessary closure offsets. *)
+val compute_reexported_offsets
+   : Flambda.program
+  -> current_unit_offset_fun:int Closure_id.Map.t
+  -> current_unit_offset_fv:int Var_within_closure.Map.t
+  -> imported_units_offset_fun:int Closure_id.Map.t
+  -> imported_units_offset_fv:int Var_within_closure.Map.t
+  -> int Closure_id.Map.t * int Var_within_closure.Map.t
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
new file mode 100644
index 00000000..5b2fd6b8
--- /dev/null
+++ b/asmcomp/cmm.ml
@@ -0,0 +1,206 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type machtype_component =
+  | Val
+  | Addr
+  | Int
+  | Float
+
+type machtype = machtype_component array
+
+let typ_void = ([||] : machtype_component array)
+let typ_val = [|Val|]
+let typ_addr = [|Addr|]
+let typ_int = [|Int|]
+let typ_float = [|Float|]
+
+let size_component = function
+  | Val | Addr -> Arch.size_addr
+  | Int -> Arch.size_int
+  | Float -> Arch.size_float
+
+(** [machtype_component]s are partially ordered as follows:
+
+      Addr     Float
+       ^
+       |
+      Val
+       ^
+       |
+      Int
+
+  In particular, [Addr] must be above [Val], to ensure that if there is
+  a join point between a code path yielding [Addr] and one yielding [Val]
+  then the result is treated as a derived pointer into the heap (i.e. [Addr]).
+  (Such a result may not be live across any call site or a fatal compiler
+  error will result.)
+*)
+
+let lub_component comp1 comp2 =
+  match comp1, comp2 with
+  | Int, Int -> Int
+  | Int, Val -> Val
+  | Int, Addr -> Addr
+  | Val, Int -> Val
+  | Val, Val -> Val
+  | Val, Addr -> Addr
+  | Addr, Int -> Addr
+  | Addr, Addr -> Addr
+  | Addr, Val -> Addr
+  | Float, Float -> Float
+  | (Int | Addr | Val), Float
+  | Float, (Int | Addr | Val) ->
+    (* Float unboxing code must be sure to avoid this case. *)
+    assert false
+
+let ge_component comp1 comp2 =
+  match comp1, comp2 with
+  | Int, Int -> true
+  | Int, Addr -> false
+  | Int, Val -> false
+  | Val, Int -> true
+  | Val, Val -> true
+  | Val, Addr -> false
+  | Addr, Int -> true
+  | Addr, Addr -> true
+  | Addr, Val -> true
+  | Float, Float -> true
+  | (Int | Addr | Val), Float
+  | Float, (Int | Addr | Val) ->
+    assert false
+
+let size_machtype mty =
+  let size = ref 0 in
+  for i = 0 to Array.length mty - 1 do
+    size := !size + size_component mty.(i)
+  done;
+  !size
+
+type comparison =
+    Ceq
+  | Cne
+  | Clt
+  | Cle
+  | Cgt
+  | Cge
+
+let negate_comparison = function
+    Ceq -> Cne | Cne -> Ceq
+  | Clt -> Cge | Cle -> Cgt
+  | Cgt -> Cle | Cge -> Clt
+
+let swap_comparison = function
+    Ceq -> Ceq | Cne -> Cne
+  | Clt -> Cgt | Cle -> Cge
+  | Cgt -> Clt | Cge -> Cle
+
+type label = int
+
+let label_counter = ref 99
+
+let new_label() = incr label_counter; !label_counter
+
+type raise_kind =
+  | Raise_withtrace
+  | Raise_notrace
+
+type rec_flag = Nonrecursive | Recursive
+
+type memory_chunk =
+    Byte_unsigned
+  | Byte_signed
+  | Sixteen_unsigned
+  | Sixteen_signed
+  | Thirtytwo_unsigned
+  | Thirtytwo_signed
+  | Word_int
+  | Word_val
+  | Single
+  | Double
+  | Double_u
+
+and operation =
+    Capply of machtype
+  | Cextcall of string * machtype * bool * label option
+    (** If specified, the given label will be placed immediately after the
+        call (at the same place as any frame descriptor would reference). *)
+  | Cload of memory_chunk * Asttypes.mutable_flag
+  | Calloc
+  | Cstore of memory_chunk * Lambda.initialization_or_assignment
+  | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
+  | Cand | Cor | Cxor | Clsl | Clsr | Casr
+  | Ccmpi of comparison
+  | Caddv | Cadda
+  | Ccmpa of comparison
+  | Cnegf | Cabsf
+  | Caddf | Csubf | Cmulf | Cdivf
+  | Cfloatofint | Cintoffloat
+  | Ccmpf of comparison
+  | Craise of raise_kind
+  | Ccheckbound
+
+type expression =
+    Cconst_int of int
+  | Cconst_natint of nativeint
+  | Cconst_float of float
+  | Cconst_symbol of string
+  | Cconst_pointer of int
+  | Cconst_natpointer of nativeint
+  | Cblockheader of nativeint * Debuginfo.t
+  | Cvar of Ident.t
+  | Clet of Ident.t * expression * expression
+  | Cassign of Ident.t * expression
+  | Ctuple of expression list
+  | Cop of operation * expression list * Debuginfo.t
+  | Csequence of expression * expression
+  | Cifthenelse of expression * expression * expression
+  | Cswitch of expression * int array * expression array * Debuginfo.t
+  | Cloop of expression
+  | Ccatch of rec_flag * (int * Ident.t list * expression) list * expression
+  | Cexit of int * expression list
+  | Ctrywith of expression * Ident.t * expression
+
+type fundecl =
+  { fun_name: string;
+    fun_args: (Ident.t * machtype) list;
+    fun_body: expression;
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t;
+  }
+
+type data_item =
+    Cdefine_symbol of string
+  | Cglobal_symbol of string
+  | Cint8 of int
+  | Cint16 of int
+  | Cint32 of nativeint
+  | Cint of nativeint
+  | Csingle of float
+  | Cdouble of float
+  | Csymbol_address of string
+  | Cstring of string
+  | Cskip of int
+  | Calign of int
+
+type phrase =
+    Cfunction of fundecl
+  | Cdata of data_item list
+
+let ccatch (i, ids, e1, e2)=
+  Ccatch(Nonrecursive, [i, ids, e2], e1)
+
+let reset () =
+  label_counter := 99
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
new file mode 100644
index 00000000..a62578f6
--- /dev/null
+++ b/asmcomp/cmm.mli
@@ -0,0 +1,180 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Second intermediate language (machine independent) *)
+
+type machtype_component =
+  | Val
+  | Addr
+  | Int
+  | Float
+
+(* - [Val] denotes a valid OCaml value: either a pointer to the beginning
+     of a heap block, an infix pointer if it is preceded by the correct
+     infix header, or a 2n+1 encoded integer.
+   - [Int] is for integers (not necessarily 2n+1 encoded) and for
+     pointers outside the heap.
+   - [Addr] denotes pointers that are neither [Val] nor [Int], i.e.
+     pointers into the heap that point in the middle of a heap block.
+     Such derived pointers are produced by e.g. array indexing.
+   - [Float] is for unboxed floating-point numbers.
+
+The purpose of these types is twofold.  First, they guide register
+allocation: type [Float] goes in FP registers, the other types go
+into integer registers.  Second, they determine how local variables are
+tracked by the GC:
+   - Variables of type [Val] are GC roots.  If they are pointers, the
+     GC will not deallocate the addressed heap block, and will update
+     the local variable if the heap block moves.
+   - Variables of type [Int] and [Float] are ignored by the GC.
+     The GC does not change their values.
+   - Variables of type [Addr] must never be live across an allocation
+     point or function call.  They cannot be given as roots to the GC
+     because they don't point after a well-formed block header of the
+     kind that the GC needs.  However, the GC may move the block pointed
+     into, invalidating the value of the [Addr] variable.
+*)
+
+type machtype = machtype_component array
+
+val typ_void: machtype
+val typ_val: machtype
+val typ_addr: machtype
+val typ_int: machtype
+val typ_float: machtype
+
+val size_component: machtype_component -> int
+
+(** Least upper bound of two [machtype_component]s. *)
+val lub_component
+   : machtype_component
+  -> machtype_component
+  -> machtype_component
+
+(** Returns [true] iff the first supplied [machtype_component] is greater than
+    or equal to the second under the relation used by [lub_component]. *)
+val ge_component
+   : machtype_component
+  -> machtype_component
+  -> bool
+
+val size_machtype: machtype -> int
+
+type comparison =
+    Ceq
+  | Cne
+  | Clt
+  | Cle
+  | Cgt
+  | Cge
+
+val negate_comparison: comparison -> comparison
+val swap_comparison: comparison -> comparison
+
+type label = int
+val new_label: unit -> label
+
+type raise_kind =
+  | Raise_withtrace
+  | Raise_notrace
+
+type rec_flag = Nonrecursive | Recursive
+
+type memory_chunk =
+    Byte_unsigned
+  | Byte_signed
+  | Sixteen_unsigned
+  | Sixteen_signed
+  | Thirtytwo_unsigned
+  | Thirtytwo_signed
+  | Word_int                           (* integer or pointer outside heap *)
+  | Word_val                           (* pointer inside heap or encoded int *)
+  | Single
+  | Double                             (* 64-bit-aligned 64-bit float *)
+  | Double_u                           (* word-aligned 64-bit float *)
+
+and operation =
+    Capply of machtype
+  | Cextcall of string * machtype * bool * label option
+  | Cload of memory_chunk * Asttypes.mutable_flag
+  | Calloc
+  | Cstore of memory_chunk * Lambda.initialization_or_assignment
+  | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
+  | Cand | Cor | Cxor | Clsl | Clsr | Casr
+  | Ccmpi of comparison
+  | Caddv (* pointer addition that produces a [Val] (well-formed Caml value) *)
+  | Cadda (* pointer addition that produces a [Addr] (derived heap pointer) *)
+  | Ccmpa of comparison
+  | Cnegf | Cabsf
+  | Caddf | Csubf | Cmulf | Cdivf
+  | Cfloatofint | Cintoffloat
+  | Ccmpf of comparison
+  | Craise of raise_kind
+  | Ccheckbound
+
+(** Not all cmm expressions currently have [Debuginfo.t] values attached to
+    them.  The ones that do are those that are likely to generate code that
+    can fairly robustly be mapped back to a source location.  In the future
+    it might be the case that more [Debuginfo.t] annotations are desirable. *)
+and expression =
+    Cconst_int of int
+  | Cconst_natint of nativeint
+  | Cconst_float of float
+  | Cconst_symbol of string
+  | Cconst_pointer of int
+  | Cconst_natpointer of nativeint
+  | Cblockheader of nativeint * Debuginfo.t
+  | Cvar of Ident.t
+  | Clet of Ident.t * expression * expression
+  | Cassign of Ident.t * expression
+  | Ctuple of expression list
+  | Cop of operation * expression list * Debuginfo.t
+  | Csequence of expression * expression
+  | Cifthenelse of expression * expression * expression
+  | Cswitch of expression * int array * expression array * Debuginfo.t
+  | Cloop of expression
+  | Ccatch of rec_flag * (int * Ident.t list * expression) list * expression
+  | Cexit of int * expression list
+  | Ctrywith of expression * Ident.t * expression
+
+type fundecl =
+  { fun_name: string;
+    fun_args: (Ident.t * machtype) list;
+    fun_body: expression;
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t;
+  }
+
+type data_item =
+    Cdefine_symbol of string
+  | Cglobal_symbol of string
+  | Cint8 of int
+  | Cint16 of int
+  | Cint32 of nativeint
+  | Cint of nativeint
+  | Csingle of float
+  | Cdouble of float
+  | Csymbol_address of string
+  | Cstring of string
+  | Cskip of int
+  | Calign of int
+
+type phrase =
+    Cfunction of fundecl
+  | Cdata of data_item list
+
+val ccatch : int * Ident.t list * expression * expression -> expression
+
+val reset : unit -> unit
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
new file mode 100644
index 00000000..4ac4b40c
--- /dev/null
+++ b/asmcomp/cmmgen.ml
@@ -0,0 +1,3501 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Translation from closed lambda to C-- *)
+
+open Misc
+open Arch
+open Asttypes
+open Primitive
+open Types
+open Lambda
+open Clambda
+open Cmm
+open Cmx_format
+
+(* Environments used for translation to Cmm. *)
+
+type boxed_number =
+  | Boxed_float of Debuginfo.t
+  | Boxed_integer of boxed_integer * Debuginfo.t
+
+type env = {
+  unboxed_ids : (Ident.t * boxed_number) Ident.tbl;
+  environment_param : Ident.t option;
+}
+
+let empty_env =
+  {
+    unboxed_ids =Ident.empty;
+    environment_param = None;
+  }
+
+let create_env ~environment_param =
+  { unboxed_ids = Ident.empty;
+    environment_param;
+  }
+
+let is_unboxed_id id env =
+  try Some (Ident.find_same id env.unboxed_ids)
+  with Not_found -> None
+
+let add_unboxed_id id unboxed_id bn env =
+  { env with
+    unboxed_ids = Ident.add id (unboxed_id, bn) env.unboxed_ids;
+  }
+
+(* Local binding of complex expressions *)
+
+let bind name arg fn =
+  match arg with
+    Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
+  | Cconst_pointer _ | Cconst_natpointer _
+  | Cblockheader _ -> fn arg
+  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
+
+let bind_load name arg fn =
+  match arg with
+  | Cop(Cload _, [Cvar _], _) -> fn arg
+  | _ -> bind name arg fn
+
+let bind_nonvar name arg fn =
+  match arg with
+    Cconst_int _ | Cconst_natint _ | Cconst_symbol _
+  | Cconst_pointer _ | Cconst_natpointer _
+  | Cblockheader _ -> fn arg
+  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
+
+let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
+    (* cf. byterun/gc.h *)
+
+(* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
+
+let floatarray_tag = Cconst_int Obj.double_array_tag
+
+let block_header tag sz =
+  Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10)
+                (Nativeint.of_int tag)
+(* Static data corresponding to "value"s must be marked black in case we are
+   in no-naked-pointers mode.  See [caml_darken] and the code below that emits
+   structured constants and static module definitions. *)
+let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black
+let white_closure_header sz = block_header Obj.closure_tag sz
+let black_closure_header sz = black_block_header Obj.closure_tag sz
+let infix_header ofs = block_header Obj.infix_tag ofs
+let float_header = block_header Obj.double_tag (size_float / size_addr)
+let floatarray_header len =
+  (* Zero-sized float arrays have tag zero for consistency with
+     [caml_alloc_float_array]. *)
+  assert (len >= 0);
+  if len = 0 then block_header 0 0
+  else block_header Obj.double_array_tag (len * size_float / size_addr)
+let string_header len =
+      block_header Obj.string_tag ((len + size_addr) / size_addr)
+let boxedint32_header = block_header Obj.custom_tag 2
+let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
+let boxedintnat_header = block_header Obj.custom_tag 2
+
+let alloc_float_header dbg = Cblockheader (float_header, dbg)
+let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg)
+let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg)
+let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg)
+let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg)
+let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg)
+let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg)
+
+(* Integers *)
+
+let max_repr_int = max_int asr 1
+let min_repr_int = min_int asr 1
+
+let int_const n =
+  if n <= max_repr_int && n >= min_repr_int
+  then Cconst_int((n lsl 1) + 1)
+  else Cconst_natint
+          (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
+
+let cint_const n =
+  Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
+
+let add_no_overflow n x c dbg =
+  let d = n + x in
+  if d = 0 then c else Cop(Caddi, [c; Cconst_int d], dbg)
+
+let rec add_const c n dbg =
+  if n = 0 then c
+  else match c with
+  | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n)
+  | Cop(Caddi, [Cconst_int x; c], _)
+    when no_overflow_add n x ->
+      add_no_overflow n x c dbg
+  | Cop(Caddi, [c; Cconst_int x], _)
+    when no_overflow_add n x ->
+      add_no_overflow n x c dbg
+  | Cop(Csubi, [Cconst_int x; c], _) when no_overflow_add n x ->
+      Cop(Csubi, [Cconst_int (n + x); c], dbg)
+  | Cop(Csubi, [c; Cconst_int x], _) when no_overflow_sub n x ->
+      add_const c (n - x) dbg
+  | c -> Cop(Caddi, [c; Cconst_int n], dbg)
+
+let incr_int c dbg = add_const c 1 dbg
+let decr_int c dbg = add_const c (-1) dbg
+
+let rec add_int c1 c2 dbg =
+  match (c1, c2) with
+  | (Cconst_int n, c) | (c, Cconst_int n) ->
+      add_const c n dbg
+  | (Cop(Caddi, [c1; Cconst_int n1], _), c2) ->
+      add_const (add_int c1 c2 dbg) n1 dbg
+  | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) ->
+      add_const (add_int c1 c2 dbg) n2 dbg
+  | (_, _) ->
+      Cop(Caddi, [c1; c2], dbg)
+
+let rec sub_int c1 c2 dbg =
+  match (c1, c2) with
+  | (c1, Cconst_int n2) when n2 <> min_int ->
+      add_const c1 (-n2) dbg
+  | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) when n2 <> min_int ->
+      add_const (sub_int c1 c2 dbg) (-n2) dbg
+  | (Cop(Caddi, [c1; Cconst_int n1], _), c2) ->
+      add_const (sub_int c1 c2 dbg) n1 dbg
+  | (c1, c2) ->
+      Cop(Csubi, [c1; c2], dbg)
+
+let rec lsl_int c1 c2 dbg =
+  match (c1, c2) with
+  | (Cop(Clsl, [c; Cconst_int n1], _), Cconst_int n2)
+    when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
+      Cop(Clsl, [c; Cconst_int (n1 + n2)], dbg)
+  | (Cop(Caddi, [c1; Cconst_int n1], _), Cconst_int n2)
+    when no_overflow_lsl n1 n2 ->
+      add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg
+  | (_, _) ->
+      Cop(Clsl, [c1; c2], dbg)
+
+let is_power2 n = n = 1 lsl Misc.log2 n
+
+and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n)) dbg
+
+let rec mul_int c1 c2 dbg =
+  match (c1, c2) with
+  | (c, Cconst_int 0) | (Cconst_int 0, c) -> Csequence (c, Cconst_int 0)
+  | (c, Cconst_int 1) | (Cconst_int 1, c) ->
+      c
+  | (c, Cconst_int(-1)) | (Cconst_int(-1), c) ->
+      sub_int (Cconst_int 0) c dbg
+  | (c, Cconst_int n) when is_power2 n -> mult_power2 c n dbg
+  | (Cconst_int n, c) when is_power2 n -> mult_power2 c n dbg
+  | (Cop(Caddi, [c; Cconst_int n], _), Cconst_int k) |
+    (Cconst_int k, Cop(Caddi, [c; Cconst_int n], _))
+    when no_overflow_mul n k ->
+      add_const (mul_int c (Cconst_int k) dbg) (n * k) dbg
+  | (c1, c2) ->
+      Cop(Cmuli, [c1; c2], dbg)
+
+
+let ignore_low_bit_int = function
+    Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n], _) as c); Cconst_int 1], _)
+      when n > 0
+      -> c
+  | Cop(Cor, [c; Cconst_int 1], _) -> c
+  | c -> c
+
+let lsr_int c1 c2 dbg =
+  match c2 with
+    Cconst_int 0 ->
+      c1
+  | Cconst_int n when n > 0 ->
+      Cop(Clsr, [ignore_low_bit_int c1; c2], dbg)
+  | _ ->
+      Cop(Clsr, [c1; c2], dbg)
+
+let asr_int c1 c2 dbg =
+  match c2 with
+    Cconst_int 0 ->
+      c1
+  | Cconst_int n when n > 0 ->
+      Cop(Casr, [ignore_low_bit_int c1; c2], dbg)
+  | _ ->
+      Cop(Casr, [c1; c2], dbg)
+
+let tag_int i dbg =
+  match i with
+    Cconst_int n ->
+      int_const n
+  | Cop(Casr, [c; Cconst_int n], _) when n > 0 ->
+      Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg)
+  | c ->
+      incr_int (lsl_int c (Cconst_int 1) dbg) dbg
+
+let force_tag_int i dbg =
+  match i with
+    Cconst_int n ->
+      int_const n
+  | Cop(Casr, [c; Cconst_int n], dbg) when n > 0 ->
+      Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg)
+  | c ->
+      Cop(Cor, [lsl_int c (Cconst_int 1) dbg; Cconst_int 1], dbg)
+
+let untag_int i dbg =
+  match i with
+    Cconst_int n -> Cconst_int(n asr 1)
+  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c
+  | Cop(Cor, [Cop(Casr, [c; Cconst_int n], _); Cconst_int 1], _)
+    when n > 0 && n < size_int * 8 ->
+      Cop(Casr, [c; Cconst_int (n+1)], dbg)
+  | Cop(Cor, [Cop(Clsr, [c; Cconst_int n], _); Cconst_int 1], _)
+    when n > 0 && n < size_int * 8 ->
+      Cop(Clsr, [c; Cconst_int (n+1)], dbg)
+  | Cop(Cor, [c; Cconst_int 1], _) -> Cop(Casr, [c; Cconst_int 1], dbg)
+  | c -> Cop(Casr, [c; Cconst_int 1], dbg)
+
+let if_then_else (cond, ifso, ifnot) =
+  match cond with
+  | Cconst_int 0 -> ifnot
+  | Cconst_int 1 -> ifso
+  | _ ->
+    Cifthenelse(cond, ifso, ifnot)
+
+(* Turning integer divisions into multiply-high then shift.
+   The [division_parameters] function is used in module Emit for
+   those target platforms that support this optimization. *)
+
+(* Unsigned comparison between native integers. *)
+
+let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int))
+
+(* Unsigned division and modulus at type nativeint.
+   Algorithm: Hacker's Delight section 9.3 *)
+
+let udivmod n d = Nativeint.(
+  if d < 0n then
+    if ucompare n d < 0 then (0n, n) else (1n, sub n d)
+  else begin
+    let q = shift_left (div (shift_right_logical n 1) d) 1 in
+    let r = sub n (mul q d) in
+    if ucompare r d >= 0 then (succ q, sub r d) else (q, r)
+  end)
+
+(* Compute division parameters.
+   Algorithm: Hacker's Delight chapter 10, fig 10-1. *)
+
+let divimm_parameters d = Nativeint.(
+  assert (d > 0n);
+  let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *)
+  let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in
+  let rec loop p (q1, r1) (q2, r2) =
+    let p = p + 1 in
+    let q1 = shift_left q1 1 and r1 = shift_left r1 1 in
+    let (q1, r1) =
+      if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in
+    let q2 = shift_left q2 1 and r2 = shift_left r2 1 in
+    let (q2, r2) =
+      if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in
+    let delta = sub d r2 in
+    if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n)
+    then loop p (q1, r1) (q2, r2)
+    else (succ q2, p - size)
+  in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d))
+
+(* The result [(m, p)] of [divimm_parameters d] satisfies the following
+   inequality:
+
+      2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1)    (i)
+
+   from which it follows that
+
+      floor(n / d) = floor(n * m / 2^(wordsize+p))
+                              if 0 <= n < 2^(wordsize-1)
+      ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1
+                              if -2^(wordsize-1) <= n < 0
+
+   The correctness condition (i) above can be checked by the code below.
+   It was exhaustively tested for values of d from 2 to 10^9 in the
+   wordsize = 64 case.
+
+let add2 (xh, xl) (yh, yl) =
+  let zl = add xl yl and zh = add xh yh in
+  ((if ucompare zl xl < 0 then succ zh else zh), zl)
+
+let shl2 (xh, xl) n =
+  assert (0 < n && n < size + size);
+  if n < size
+  then (logor (shift_left xh n) (shift_right_logical xl (size - n)),
+        shift_left xl n)
+  else (shift_left xl (n - size), 0n)
+
+let mul2 x y =
+  let halfsize = size / 2 in
+  let halfmask = pred (shift_left 1n halfsize) in
+  let xl = logand x halfmask and xh = shift_right_logical x halfsize in
+  let yl = logand y halfmask and yh = shift_right_logical y halfsize in
+  add2 (mul xh yh, 0n)
+    (add2 (shl2 (0n, mul xl yh) halfsize)
+       (add2 (shl2 (0n, mul xh yl) halfsize)
+          (0n, mul xl yl)))
+
+let ucompare2 (xh, xl) (yh, yl) =
+  let c = ucompare xh yh in if c = 0 then ucompare xl yl else c
+
+let validate d m p =
+  let md = mul2 m d in
+  let one2 = (0n, 1n) in
+  let twoszp = shl2 one2 (size + p) in
+  let twop1 = shl2 one2 (p + 1) in
+  ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0
+*)
+
+let raise_regular dbg exc =
+  Csequence(
+    Cop(Cstore (Thirtytwo_signed, Assignment),
+        [(Cconst_symbol "caml_backtrace_pos"); Cconst_int 0], dbg),
+      Cop(Craise Raise_withtrace,[exc], dbg))
+
+let raise_symbol dbg symb =
+  raise_regular dbg (Cconst_symbol symb)
+
+let rec div_int c1 c2 is_safe dbg =
+  match (c1, c2) with
+    (c1, Cconst_int 0) ->
+      Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
+  | (c1, Cconst_int 1) ->
+      c1
+  | (Cconst_int n1, Cconst_int n2) ->
+      Cconst_int (n1 / n2)
+  | (c1, Cconst_int n) when n <> min_int ->
+      let l = Misc.log2 n in
+      if n = 1 lsl l then
+        (* Algorithm:
+              t = shift-right-signed(c1, l - 1)
+              t = shift-right(t, W - l)
+              t = c1 + t
+              res = shift-right-signed(c1 + t, l)
+        *)
+        Cop(Casr, [bind "dividend" c1 (fun c1 ->
+                     let t = asr_int c1 (Cconst_int (l - 1)) dbg in
+                     let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in
+                     add_int c1 t dbg);
+                   Cconst_int l], dbg)
+      else if n < 0 then
+        sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg) dbg
+      else begin
+        let (m, p) = divimm_parameters (Nativeint.of_int n) in
+        (* Algorithm:
+              t = multiply-high-signed(c1, m)
+              if m < 0, t = t + c1
+              if p > 0, t = shift-right-signed(t, p)
+              res = t + sign-bit(c1)
+        *)
+        bind "dividend" c1 (fun c1 ->
+          let t = Cop(Cmulhi, [c1; Cconst_natint m], dbg) in
+          let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in
+          let t = if p > 0 then Cop(Casr, [t; Cconst_int p], dbg) else t in
+          add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)) dbg) dbg)
+      end
+  | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
+      Cop(Cdivi, [c1; c2], dbg)
+  | (c1, c2) ->
+      bind "divisor" c2 (fun c2 ->
+        bind "dividend" c1 (fun c1 ->
+          Cifthenelse(c2,
+                      Cop(Cdivi, [c1; c2], dbg),
+                      raise_symbol dbg "caml_exn_Division_by_zero")))
+
+let mod_int c1 c2 is_safe dbg =
+  match (c1, c2) with
+    (c1, Cconst_int 0) ->
+      Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
+  | (c1, Cconst_int (1 | (-1))) ->
+      Csequence(c1, Cconst_int 0)
+  | (Cconst_int n1, Cconst_int n2) ->
+      Cconst_int (n1 mod n2)
+  | (c1, (Cconst_int n as c2)) when n <> min_int ->
+      let l = Misc.log2 n in
+      if n = 1 lsl l then
+        (* Algorithm:
+              t = shift-right-signed(c1, l - 1)
+              t = shift-right(t, W - l)
+              t = c1 + t
+              t = bit-and(t, -n)
+              res = c1 - t
+         *)
+        bind "dividend" c1 (fun c1 ->
+          let t = asr_int c1 (Cconst_int (l - 1)) dbg in
+          let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in
+          let t = add_int c1 t dbg in
+          let t = Cop(Cand, [t; Cconst_int (-n)], dbg) in
+          sub_int c1 t dbg)
+      else
+        bind "dividend" c1 (fun c1 ->
+          sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg)
+  | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
+      (* Flambda already generates that test *)
+      Cop(Cmodi, [c1; c2], dbg)
+  | (c1, c2) ->
+      bind "divisor" c2 (fun c2 ->
+        bind "dividend" c1 (fun c1 ->
+          Cifthenelse(c2,
+                      Cop(Cmodi, [c1; c2], dbg),
+                      raise_symbol dbg "caml_exn_Division_by_zero")))
+
+(* Division or modulo on boxed integers.  The overflow case min_int / -1
+   can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
+
+let is_different_from x = function
+    Cconst_int n -> n <> x
+  | Cconst_natint n -> n <> Nativeint.of_int x
+  | _ -> false
+
+let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg =
+  bind "dividend" c1 (fun c1 ->
+  bind "divisor" c2 (fun c2 ->
+    let c = mkop c1 c2 is_safe dbg in
+    if Arch.division_crashes_on_overflow
+    && (size_int = 4 || bi <> Pint32)
+    && not (is_different_from (-1) c2)
+    then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)], dbg), c, mkm1 c1 dbg)
+    else c))
+
+let safe_div_bi is_safe =
+  safe_divmod_bi div_int is_safe
+    (fun c1 dbg -> Cop(Csubi, [Cconst_int 0; c1], dbg))
+
+let safe_mod_bi is_safe =
+  safe_divmod_bi mod_int is_safe (fun _ _ -> Cconst_int 0)
+
+(* Bool *)
+
+let test_bool dbg cmm =
+  match cmm with
+  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c
+  | Cconst_int n ->
+      if n = 1 then
+        Cconst_int 0
+      else
+        Cconst_int 1
+  | c -> Cop(Ccmpi Cne, [c; Cconst_int 1], dbg)
+
+(* Float *)
+
+let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg)
+
+let map_ccatch f rec_flag handlers body =
+  let handlers = List.map
+      (fun (n, ids, handler) -> (n, ids, f handler))
+      handlers in
+  Ccatch(rec_flag, handlers, f body)
+
+let rec unbox_float dbg cmm =
+  match cmm with
+  | Cop(Calloc, [_header; c], _) -> c
+  | Clet(id, exp, body) -> Clet(id, exp, unbox_float dbg body)
+  | Cifthenelse(cond, e1, e2) ->
+      Cifthenelse(cond, unbox_float dbg e1, unbox_float dbg e2)
+  | Csequence(e1, e2) -> Csequence(e1, unbox_float dbg e2)
+  | Cswitch(e, tbl, el, dbg) ->
+    Cswitch(e, tbl, Array.map (unbox_float dbg) el, dbg)
+  | Ccatch(rec_flag, handlers, body) ->
+    map_ccatch (unbox_float dbg) rec_flag handlers body
+  | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2)
+  | c -> Cop(Cload (Double_u, Immutable), [c], dbg)
+
+(* Complex *)
+
+let box_complex dbg c_re c_im =
+  Cop(Calloc, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg)
+
+let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg)
+let complex_im c dbg = Cop(Cload (Double_u, Immutable),
+                        [Cop(Cadda, [c; Cconst_int size_float], dbg)], dbg)
+
+(* Unit *)
+
+let return_unit c = Csequence(c, Cconst_pointer 1)
+
+let rec remove_unit = function
+    Cconst_pointer 1 -> Ctuple []
+  | Csequence(c, Cconst_pointer 1) -> c
+  | Csequence(c1, c2) ->
+      Csequence(c1, remove_unit c2)
+  | Cifthenelse(cond, ifso, ifnot) ->
+      Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
+  | Cswitch(sel, index, cases, dbg) ->
+      Cswitch(sel, index, Array.map remove_unit cases, dbg)
+  | Ccatch(rec_flag, handlers, body) ->
+      map_ccatch remove_unit rec_flag handlers body
+  | Ctrywith(body, exn, handler) ->
+      Ctrywith(remove_unit body, exn, remove_unit handler)
+  | Clet(id, c1, c2) ->
+      Clet(id, c1, remove_unit c2)
+  | Cop(Capply _mty, args, dbg) ->
+      Cop(Capply typ_void, args, dbg)
+  | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) ->
+      Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg)
+  | Cexit (_,_) as c -> c
+  | Ctuple [] as c -> c
+  | c -> Csequence(c, Ctuple [])
+
+(* Access to block fields *)
+
+let field_address ptr n dbg =
+  if n = 0
+  then ptr
+  else Cop(Cadda, [ptr; Cconst_int(n * size_addr)], dbg)
+
+let get_field env ptr n dbg =
+  let mut =
+    match env.environment_param with
+    | None -> Mutable
+    | Some environment_param ->
+      match ptr with
+      | Cvar ptr ->
+        (* Loads from the current function's closure are immutable. *)
+        if Ident.same environment_param ptr then Immutable
+        else Mutable
+      | _ -> Mutable
+  in
+  Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg)
+
+let set_field ptr n newval init dbg =
+  Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg)
+
+let non_profinfo_mask = (1 lsl (64 - Config.profinfo_width)) - 1
+
+let get_header ptr dbg =
+  (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate]
+     and [Obj.set_tag]. *)
+  Cop(Cload (Word_int, Mutable),
+    [Cop(Cadda, [ptr; Cconst_int(-size_int)], dbg)], dbg)
+
+let get_header_without_profinfo ptr dbg =
+  if Config.profinfo then
+    Cop(Cand, [get_header ptr dbg; Cconst_int non_profinfo_mask], dbg)
+  else
+    get_header ptr dbg
+
+let tag_offset =
+  if big_endian then -1 else -size_int
+
+let get_tag ptr dbg =
+  if Proc.word_addressed then           (* If byte loads are slow *)
+    Cop(Cand, [get_header ptr dbg; Cconst_int 255], dbg)
+  else                                  (* If byte loads are efficient *)
+    Cop(Cload (Byte_unsigned, Mutable), (* Same comment as [get_header] above *)
+        [Cop(Cadda, [ptr; Cconst_int(tag_offset)], dbg)], dbg)
+
+let get_size ptr dbg =
+  Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int 10], dbg)
+
+(* Array indexing *)
+
+let log2_size_addr = Misc.log2 size_addr
+let log2_size_float = Misc.log2 size_float
+
+let wordsize_shift = 9
+let numfloat_shift = 9 + log2_size_float - log2_size_addr
+
+let is_addr_array_hdr hdr dbg =
+  Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255], dbg); floatarray_tag], dbg)
+
+let is_addr_array_ptr ptr dbg =
+  Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag], dbg)
+
+let addr_array_length hdr dbg =
+  Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg)
+let float_array_length hdr dbg =
+  Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg)
+
+let lsl_const c n dbg =
+  if n = 0 then c
+  else Cop(Clsl, [c; Cconst_int n], dbg)
+
+(* Produces a pointer to the element of the array [ptr] on the position [ofs]
+   with the given element [log2size] log2 element size. [ofs] is given as a
+   tagged int expression.
+   The optional ?typ argument is the C-- type of the result.
+   By default, it is Addr, meaning we are constructing a derived pointer
+   into the heap.  If we know the pointer is outside the heap
+   (this is the case for bigarray indexing), we give type Int instead. *)
+
+let array_indexing ?typ log2size ptr ofs dbg =
+  let add =
+    match typ with
+    | None | Some Addr -> Cadda
+    | Some Int -> Caddi
+    | _ -> assert false in
+  match ofs with
+  | Cconst_int n ->
+      let i = n asr 1 in
+      if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)], dbg)
+  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) ->
+      Cop(add, [ptr; lsl_const c log2size dbg], dbg)
+  | Cop(Caddi, [c; Cconst_int n], _) when log2size = 0 ->
+      Cop(add, [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1)],
+        dbg)
+  | Cop(Caddi, [c; Cconst_int n], _) ->
+      Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg);
+                    Cconst_int((n-1) lsl (log2size - 1))], dbg)
+  | _ when log2size = 0 ->
+      Cop(add, [ptr; untag_int ofs dbg], dbg)
+  | _ ->
+      Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg);
+                    Cconst_int((-1) lsl (log2size - 1))], dbg)
+
+let addr_array_ref arr ofs dbg =
+  Cop(Cload (Word_val, Mutable),
+    [array_indexing log2_size_addr arr ofs dbg], dbg)
+let int_array_ref arr ofs dbg =
+  Cop(Cload (Word_int, Mutable),
+    [array_indexing log2_size_addr arr ofs dbg], dbg)
+let unboxed_float_array_ref arr ofs dbg =
+  Cop(Cload (Double_u, Mutable),
+    [array_indexing log2_size_float arr ofs dbg], dbg)
+let float_array_ref dbg arr ofs =
+  box_float dbg (unboxed_float_array_ref arr ofs dbg)
+
+let addr_array_set arr ofs newval dbg =
+  Cop(Cextcall("caml_modify", typ_void, false, None),
+      [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let addr_array_initialize arr ofs newval dbg =
+  Cop(Cextcall("caml_initialize", typ_void, false, None),
+      [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let int_array_set arr ofs newval dbg =
+  Cop(Cstore (Word_int, Assignment),
+    [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let float_array_set arr ofs newval dbg =
+  Cop(Cstore (Double_u, Assignment),
+    [array_indexing log2_size_float arr ofs dbg; newval], dbg)
+
+(* String length *)
+
+(* Length of string block *)
+
+let string_length exp dbg =
+  bind "str" exp (fun str ->
+    let tmp_var = Ident.create "tmp" in
+    Clet(tmp_var,
+         Cop(Csubi,
+             [Cop(Clsl,
+                   [get_size str dbg;
+                     Cconst_int log2_size_addr],
+                   dbg);
+              Cconst_int 1],
+             dbg),
+         Cop(Csubi,
+             [Cvar tmp_var;
+               Cop(Cload (Byte_unsigned, Mutable),
+                     [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg)))
+
+(* Message sending *)
+
+let lookup_tag obj tag dbg =
+  bind "tag" tag (fun tag ->
+    Cop(Cextcall("caml_get_public_method", typ_val, false, None),
+        [obj; tag],
+        dbg))
+
+let lookup_label obj lab dbg =
+  bind "lab" lab (fun lab ->
+    let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in
+    addr_array_ref table lab dbg)
+
+let call_cached_method obj tag cache pos args dbg =
+  let arity = List.length args in
+  let cache = array_indexing log2_size_addr cache pos dbg in
+  Compilenv.need_send_fun arity;
+  Cop(Capply typ_val,
+      Cconst_symbol("caml_send" ^ string_of_int arity) ::
+        obj :: tag :: cache :: args,
+      dbg)
+
+(* Allocation *)
+
+let make_alloc_generic set_fn dbg tag wordsize args =
+  if wordsize <= Config.max_young_wosize then
+    Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg)
+  else begin
+    let id = Ident.create "alloc" in
+    let rec fill_fields idx = function
+      [] -> Cvar id
+    | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg,
+                          fill_fields (idx + 2) el) in
+    Clet(id,
+         Cop(Cextcall("caml_alloc", typ_val, true, None),
+                 [Cconst_int wordsize; Cconst_int tag], dbg),
+         fill_fields 1 args)
+  end
+
+let make_alloc dbg tag args =
+  let addr_array_init arr ofs newval dbg =
+    Cop(Cextcall("caml_initialize", typ_void, false, None),
+        [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+  in
+  make_alloc_generic addr_array_init dbg tag (List.length args) args
+
+let make_float_alloc dbg tag args =
+  make_alloc_generic float_array_set dbg tag
+                     (List.length args * size_float / size_addr) args
+
+(* Bounds checking *)
+
+let make_checkbound dbg = function
+  | [Cop(Clsr, [a1; Cconst_int n], _); Cconst_int m] when (m lsl n) > n ->
+      Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1)], dbg)
+  | args ->
+      Cop(Ccheckbound, args, dbg)
+
+(* To compile "let rec" over values *)
+
+let fundecls_size fundecls =
+  let sz = ref (-1) in
+  List.iter
+    (fun f ->
+       let indirect_call_code_pointer_size =
+         match f.arity with
+         | 0 | 1 -> 0
+           (* arity 1 does not need an indirect call handler.
+              arity 0 cannot be indirect called *)
+         | _ -> 1
+           (* For other arities there is an indirect call handler.
+              if arity >= 2 it is caml_curry...
+              if arity < 0 it is caml_tuplify... *)
+       in
+       sz := !sz + 1 + 2 + indirect_call_code_pointer_size)
+    fundecls;
+  !sz
+
+type rhs_kind =
+  | RHS_block of int
+  | RHS_floatblock of int
+  | RHS_nonrec
+;;
+let rec expr_size env = function
+  | Uvar id ->
+      begin try Ident.find_same id env with Not_found -> RHS_nonrec end
+  | Uclosure(fundecls, clos_vars) ->
+      RHS_block (fundecls_size fundecls + List.length clos_vars)
+  | Ulet(_str, _kind, id, exp, body) ->
+      expr_size (Ident.add id (expr_size env exp) env) body
+  | Uletrec(_bindings, body) ->
+      expr_size env body
+  | Uprim(Pmakeblock _, args, _) ->
+      RHS_block (List.length args)
+  | Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) ->
+      RHS_block (List.length args)
+  | Uprim(Pmakearray(Pfloatarray, _), args, _) ->
+      RHS_floatblock (List.length args)
+  | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
+      RHS_block sz
+  | Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
+      assert false
+  | Uprim (Pduprecord (Record_extension, sz), _, _) ->
+      RHS_block (sz + 1)
+  | Uprim (Pduprecord (Record_float, sz), _, _) ->
+      RHS_floatblock sz
+  | Uprim (Pccall { prim_name; _ }, closure::_, _)
+        when prim_name = "caml_check_value_is_closure" ->
+      (* Used for "-clambda-checks". *)
+      expr_size env closure
+  | Usequence(_exp, exp') ->
+      expr_size env exp'
+  | _ -> RHS_nonrec
+
+(* Record application and currying functions *)
+
+let apply_function n =
+  Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n
+let curry_function n =
+  Compilenv.need_curry_fun n;
+  if n >= 0
+  then "caml_curry" ^ string_of_int n
+  else "caml_tuplify" ^ string_of_int (-n)
+
+(* Comparisons *)
+
+let transl_comparison = function
+    Lambda.Ceq -> Ceq
+  | Lambda.Cneq -> Cne
+  | Lambda.Cge -> Cge
+  | Lambda.Cgt -> Cgt
+  | Lambda.Cle -> Cle
+  | Lambda.Clt -> Clt
+
+(* Translate structured constants *)
+
+let transl_constant = function
+  | Uconst_int n ->
+      int_const n
+  | Uconst_ptr n ->
+      if n <= max_repr_int && n >= min_repr_int
+      then Cconst_pointer((n lsl 1) + 1)
+      else Cconst_natpointer
+              (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
+  | Uconst_ref (label, _) ->
+      Cconst_symbol label
+
+let transl_structured_constant cst =
+  let label = Compilenv.new_structured_constant cst ~shared:true in
+  Cconst_symbol label
+
+(* Translate constant closures *)
+
+type is_global = Global | Not_global
+
+type symbol_defn = string * is_global
+
+type cmm_constant =
+  | Const_closure of symbol_defn * ufunction list * uconstant list
+  | Const_table of symbol_defn * data_item list
+
+let cmm_constants =
+  ref ([] : cmm_constant list)
+
+let add_cmm_constant c =
+  cmm_constants := c :: !cmm_constants
+
+(* Boxed integers *)
+
+let box_int_constant bi n =
+  match bi with
+    Pnativeint -> Uconst_nativeint n
+  | Pint32 -> Uconst_int32 (Nativeint.to_int32 n)
+  | Pint64 -> Uconst_int64 (Int64.of_nativeint n)
+
+let operations_boxed_int bi =
+  match bi with
+    Pnativeint -> "caml_nativeint_ops"
+  | Pint32 -> "caml_int32_ops"
+  | Pint64 -> "caml_int64_ops"
+
+let alloc_header_boxed_int bi =
+  match bi with
+    Pnativeint -> alloc_boxedintnat_header
+  | Pint32 -> alloc_boxedint32_header
+  | Pint64 -> alloc_boxedint64_header
+
+let box_int dbg bi arg =
+  match arg with
+    Cconst_int n ->
+      transl_structured_constant (box_int_constant bi (Nativeint.of_int n))
+  | Cconst_natint n ->
+      transl_structured_constant (box_int_constant bi n)
+  | _ ->
+      let arg' =
+        if bi = Pint32 && size_int = 8 && big_endian
+        then Cop(Clsl, [arg; Cconst_int 32], dbg)
+        else arg in
+      Cop(Calloc, [alloc_header_boxed_int bi dbg;
+                   Cconst_symbol(operations_boxed_int bi);
+                   arg'], dbg)
+
+let split_int64_for_32bit_target arg dbg =
+  bind "split_int64" arg (fun arg ->
+    let first = Cop (Cadda, [Cconst_int size_int; arg], dbg) in
+    let second = Cop (Cadda, [Cconst_int (2 * size_int); arg], dbg) in
+    Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg);
+            Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)])
+
+let rec unbox_int bi arg dbg =
+  match arg with
+    Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32], dbg')], dbg)
+    when bi = Pint32 && size_int = 8 && big_endian ->
+      (* Force sign-extension of low 32 bits *)
+      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg'); Cconst_int 32],
+        dbg)
+  | Cop(Calloc, [_hdr; _ops; contents], dbg)
+    when bi = Pint32 && size_int = 8 && not big_endian ->
+      (* Force sign-extension of low 32 bits *)
+      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg); Cconst_int 32], dbg)
+  | Cop(Calloc, [_hdr; _ops; contents], _dbg) ->
+      contents
+  | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body dbg)
+  | Cifthenelse(cond, e1, e2) ->
+      Cifthenelse(cond, unbox_int bi e1 dbg, unbox_int bi e2 dbg)
+  | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2 dbg)
+  | Cswitch(e, tbl, el, dbg) ->
+      Cswitch(e, tbl, Array.map (fun e -> unbox_int bi e dbg) el, dbg)
+  | Ccatch(rec_flag, handlers, body) ->
+      map_ccatch (fun e -> unbox_int bi e dbg) rec_flag handlers body
+  | Ctrywith(e1, id, e2) ->
+      Ctrywith(unbox_int bi e1 dbg, id, unbox_int bi e2 dbg)
+  | _ ->
+      if size_int = 4 && bi = Pint64 then
+        split_int64_for_32bit_target arg dbg
+      else
+        Cop(
+          Cload((if bi = Pint32 then Thirtytwo_signed else Word_int), Mutable),
+          [Cop(Cadda, [arg; Cconst_int size_addr], dbg)], dbg)
+
+let make_unsigned_int bi arg dbg =
+  if bi = Pint32 && size_int = 8
+  then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn], dbg)
+  else arg
+
+(* Boxed numbers *)
+
+let equal_unboxed_integer ui1 ui2 =
+  match ui1, ui2 with
+  | Pnativeint, Pnativeint -> true
+  | Pint32, Pint32 -> true
+  | Pint64, Pint64 -> true
+  | _, _ -> false
+
+let equal_boxed_number bn1 bn2 =
+  match bn1, bn2 with
+  | Boxed_float _, Boxed_float _ -> true
+  | Boxed_integer(ui1, _), Boxed_integer(ui2, _) ->
+    equal_unboxed_integer ui1 ui2
+  | _, _ -> false
+
+let box_number bn arg =
+  match bn with
+  | Boxed_float dbg -> box_float dbg arg
+  | Boxed_integer (bi, dbg) -> box_int dbg bi arg
+
+(* Big arrays *)
+
+let bigarray_elt_size = function
+    Pbigarray_unknown -> assert false
+  | Pbigarray_float32 -> 4
+  | Pbigarray_float64 -> 8
+  | Pbigarray_sint8 -> 1
+  | Pbigarray_uint8 -> 1
+  | Pbigarray_sint16 -> 2
+  | Pbigarray_uint16 -> 2
+  | Pbigarray_int32 -> 4
+  | Pbigarray_int64 -> 8
+  | Pbigarray_caml_int -> size_int
+  | Pbigarray_native_int -> size_int
+  | Pbigarray_complex32 -> 8
+  | Pbigarray_complex64 -> 16
+
+(* Produces a pointer to the element of the bigarray [b] on the position
+   [args].  [args] is given as a list of tagged int expressions, one per array
+   dimension. *)
+let bigarray_indexing unsafe elt_kind layout b args dbg =
+  let check_ba_bound bound idx v =
+    Csequence(make_checkbound dbg [bound;idx], v) in
+  (* Validates the given multidimensional offset against the array bounds and
+     transforms it into a one dimensional offset.  The offsets are expressions
+     evaluating to tagged int. *)
+  let rec ba_indexing dim_ofs delta_ofs = function
+    [] -> assert false
+  | [arg] ->
+      if unsafe then arg
+      else
+        bind "idx" arg (fun idx ->
+          (* Load the untagged int bound for the given dimension *)
+          let bound =
+            Cop(Cload (Word_int, Mutable),[field_address b dim_ofs dbg], dbg)
+          in
+          let idxn = untag_int idx dbg in
+          check_ba_bound bound idxn idx)
+  | arg1 :: argl ->
+      (* The remainder of the list is transformed into a one dimensional offset
+         *)
+      let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
+      (* Load the untagged int bound for the given dimension *)
+      let bound =
+        Cop(Cload (Word_int, Mutable), [field_address b dim_ofs dbg], dbg)
+      in
+      if unsafe then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg
+      else
+        bind "idx" arg1 (fun idx ->
+          bind "bound" bound (fun bound ->
+            let idxn = untag_int idx dbg in
+            (* [offset = rem * (tag_int bound) + idx] *)
+            let offset =
+              add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg
+            in
+            check_ba_bound bound idxn offset)) in
+  (* The offset as an expression evaluating to int *)
+  let offset =
+    match layout with
+      Pbigarray_unknown_layout ->
+        assert false
+    | Pbigarray_c_layout ->
+        ba_indexing (4 + List.length args) (-1) (List.rev args)
+    | Pbigarray_fortran_layout ->
+        ba_indexing 5 1
+          (List.map (fun idx -> sub_int idx (Cconst_int 2) dbg) args)
+  and elt_size =
+    bigarray_elt_size elt_kind in
+  (* [array_indexing] can simplify the given expressions *)
+  array_indexing ~typ:Int (log2 elt_size)
+                 (Cop(Cload (Word_int, Mutable),
+                    [field_address b 1 dbg], dbg)) offset dbg
+
+let bigarray_word_kind = function
+    Pbigarray_unknown -> assert false
+  | Pbigarray_float32 -> Single
+  | Pbigarray_float64 -> Double
+  | Pbigarray_sint8 -> Byte_signed
+  | Pbigarray_uint8 -> Byte_unsigned
+  | Pbigarray_sint16 -> Sixteen_signed
+  | Pbigarray_uint16 -> Sixteen_unsigned
+  | Pbigarray_int32 -> Thirtytwo_signed
+  | Pbigarray_int64 -> Word_int
+  | Pbigarray_caml_int -> Word_int
+  | Pbigarray_native_int -> Word_int
+  | Pbigarray_complex32 -> Single
+  | Pbigarray_complex64 -> Double
+
+let bigarray_get unsafe elt_kind layout b args dbg =
+  bind "ba" b (fun b ->
+    match elt_kind with
+      Pbigarray_complex32 | Pbigarray_complex64 ->
+        let kind = bigarray_word_kind elt_kind in
+        let sz = bigarray_elt_size elt_kind / 2 in
+        bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
+          (fun addr ->
+          box_complex dbg
+            (Cop(Cload (kind, Mutable), [addr], dbg))
+            (Cop(Cload (kind, Mutable),
+              [Cop(Cadda, [addr; Cconst_int sz], dbg)], dbg)))
+    | _ ->
+        Cop(Cload (bigarray_word_kind elt_kind, Mutable),
+            [bigarray_indexing unsafe elt_kind layout b args dbg],
+            dbg))
+
+let bigarray_set unsafe elt_kind layout b args newval dbg =
+  bind "ba" b (fun b ->
+    match elt_kind with
+      Pbigarray_complex32 | Pbigarray_complex64 ->
+        let kind = bigarray_word_kind elt_kind in
+        let sz = bigarray_elt_size elt_kind / 2 in
+        bind "newval" newval (fun newv ->
+        bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
+          (fun addr ->
+          Csequence(
+            Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg),
+            Cop(Cstore (kind, Assignment),
+                [Cop(Cadda, [addr; Cconst_int sz], dbg); complex_im newv dbg],
+                dbg))))
+    | _ ->
+        Cop(Cstore (bigarray_word_kind elt_kind, Assignment),
+            [bigarray_indexing unsafe elt_kind layout b args dbg; newval],
+            dbg))
+
+let unaligned_load_16 ptr idx dbg =
+  if Arch.allow_unaligned_access
+  then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg)
+  else
+    let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
+    let v2 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in
+    let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
+    Cop(Cor, [lsl_int b1 (Cconst_int 8) dbg; b2], dbg)
+
+let unaligned_set_16 ptr idx newval dbg =
+  if Arch.allow_unaligned_access
+  then
+    Cop(Cstore (Sixteen_unsigned, Assignment),
+      [add_int ptr idx dbg; newval], dbg)
+  else
+    let v1 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg)
+    in
+    let v2 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in
+    let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
+    Csequence(
+        Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg),
+        Cop(Cstore (Byte_unsigned, Assignment),
+            [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg))
+
+let unaligned_load_32 ptr idx dbg =
+  if Arch.allow_unaligned_access
+  then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg)
+  else
+    let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
+    let v2 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in
+    let v3 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in
+    let v4 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in
+    let b1, b2, b3, b4 =
+      if Arch.big_endian
+      then v1, v2, v3, v4
+      else v4, v3, v2, v1 in
+    Cop(Cor,
+      [Cop(Cor, [lsl_int b1 (Cconst_int 24) dbg;
+         lsl_int b2 (Cconst_int 16) dbg], dbg);
+       Cop(Cor, [lsl_int b3 (Cconst_int 8) dbg; b4], dbg)],
+      dbg)
+
+let unaligned_set_32 ptr idx newval dbg =
+  if Arch.allow_unaligned_access
+  then
+    Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval],
+      dbg)
+  else
+    let v1 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24], dbg); Cconst_int 0xFF], dbg)
+    in
+    let v2 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16], dbg); Cconst_int 0xFF], dbg)
+    in
+    let v3 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg)
+    in
+    let v4 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in
+    let b1, b2, b3, b4 =
+      if Arch.big_endian
+      then v1, v2, v3, v4
+      else v4, v3, v2, v1 in
+    Csequence(
+        Csequence(
+            Cop(Cstore (Byte_unsigned, Assignment),
+                [add_int ptr idx dbg; b1], dbg),
+            Cop(Cstore (Byte_unsigned, Assignment),
+                [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg)),
+        Csequence(
+            Cop(Cstore (Byte_unsigned, Assignment),
+                [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3], dbg),
+            Cop(Cstore (Byte_unsigned, Assignment),
+                [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4], dbg)))
+
+let unaligned_load_64 ptr idx dbg =
+  assert(size_int = 8);
+  if Arch.allow_unaligned_access
+  then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg)
+  else
+    let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
+    let v2 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in
+    let v3 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in
+    let v4 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in
+    let v5 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg], dbg) in
+    let v6 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg], dbg) in
+    let v7 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg], dbg) in
+    let v8 = Cop(Cload (Byte_unsigned, Mutable),
+                 [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg], dbg) in
+    let b1, b2, b3, b4, b5, b6, b7, b8 =
+      if Arch.big_endian
+      then v1, v2, v3, v4, v5, v6, v7, v8
+      else v8, v7, v6, v5, v4, v3, v2, v1 in
+    Cop(Cor,
+        [Cop(Cor,
+             [Cop(Cor, [lsl_int b1 (Cconst_int (8*7)) dbg;
+                        lsl_int b2 (Cconst_int (8*6)) dbg], dbg);
+              Cop(Cor, [lsl_int b3 (Cconst_int (8*5)) dbg;
+                        lsl_int b4 (Cconst_int (8*4)) dbg], dbg)],
+             dbg);
+         Cop(Cor,
+             [Cop(Cor, [lsl_int b5 (Cconst_int (8*3)) dbg;
+                        lsl_int b6 (Cconst_int (8*2)) dbg], dbg);
+              Cop(Cor, [lsl_int b7 (Cconst_int 8) dbg;
+                        b8], dbg)],
+             dbg)], dbg)
+
+let unaligned_set_64 ptr idx newval dbg =
+  assert(size_int = 8);
+  if Arch.allow_unaligned_access
+  then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg)
+  else
+    let v1 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v2 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v3 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v4 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v5 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v6 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v7 =
+      Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF],
+        dbg)
+    in
+    let v8 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in
+    let b1, b2, b3, b4, b5, b6, b7, b8 =
+      if Arch.big_endian
+      then v1, v2, v3, v4, v5, v6, v7, v8
+      else v8, v7, v6, v5, v4, v3, v2, v1 in
+    Csequence(
+        Csequence(
+            Csequence(
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int ptr idx dbg; b1],
+                    dbg),
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2],
+                    dbg)),
+            Csequence(
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3],
+                    dbg),
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4],
+                    dbg))),
+        Csequence(
+            Csequence(
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg; b5],
+                    dbg),
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg; b6],
+                    dbg)),
+            Csequence(
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg; b7],
+                    dbg),
+                Cop(Cstore (Byte_unsigned, Assignment),
+                    [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg; b8],
+                    dbg))))
+
+let max_or_zero a dbg =
+  bind "size" a (fun a ->
+    (* equivalent to
+       Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a)
+
+       if a is positive, sign is 0 hence sign_negation is full of 1
+                         so sign_negation&a = a
+       if a is negative, sign is full of 1 hence sign_negation is 0
+                         so sign_negation&a = 0 *)
+    let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)], dbg) in
+    let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)], dbg) in
+    Cop(Cand, [sign_negation; a], dbg))
+
+let check_bound unsafe dbg a1 a2 k =
+  if unsafe then k
+  else Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k)
+
+(* Simplification of some primitives into C calls *)
+
+let default_prim name =
+  Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true
+
+let simplif_primitive_32bits = function
+    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 {size=Pint64} -> Pccall (default_prim "caml_int64_div")
+  | Pmodbint {size=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(_unsafe, n, Pbigarray_int64, _layout) ->
+      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
+  | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
+      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
+  | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64")
+  | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64")
+  | Pbigstring_load_64(_) -> Pccall (default_prim "caml_ba_uint8_get64")
+  | Pbigstring_set_64(_) -> Pccall (default_prim "caml_ba_uint8_set64")
+  | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
+  | p -> p
+
+let simplif_primitive p =
+  match p with
+  | Pduprecord _ ->
+      Pccall (default_prim "caml_obj_dup")
+  | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) ->
+      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
+  | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) ->
+      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
+  | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
+      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
+  | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
+      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
+  | p ->
+      if size_int = 8 then p else simplif_primitive_32bits p
+
+(* Build switchers both for constants and blocks *)
+
+let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg
+
+(* Build an actual switch (ie jump table) *)
+
+let make_switch arg cases actions dbg =
+  let is_const = function
+    (* Constant integers loaded from a table should end in 1,
+       so that Cload never produces untagged integers *)
+    | Cconst_int n
+    | Cconst_pointer n -> (n land 1) = 1
+    | Cconst_natint n
+    | Cconst_natpointer n -> (Nativeint.(to_int (logand n one) = 1))
+    | Cconst_symbol _ -> true
+    | _ -> false in
+  if Array.for_all is_const actions then
+    let to_data_item = function
+      | Cconst_int n
+      | Cconst_pointer n -> Cint (Nativeint.of_int n)
+      | Cconst_natint n
+      | Cconst_natpointer n -> Cint n
+      | Cconst_symbol s -> Csymbol_address s
+      | _ -> assert false in
+    let const_actions = Array.map to_data_item actions in
+    let table = Compilenv.new_const_symbol () in
+    add_cmm_constant (Const_table ((table, Not_global),
+        Array.to_list (Array.map (fun act ->
+          const_actions.(act)) cases)));
+    addr_array_ref (Cconst_symbol table) (tag_int arg dbg) dbg
+  else
+    Cswitch (arg,cases,actions,dbg)
+
+module SArgBlocks =
+struct
+  type primitive = operation
+
+  let eqint = Ccmpi Ceq
+  let neint = Ccmpi Cne
+  let leint = Ccmpi Cle
+  let ltint = Ccmpi Clt
+  let geint = Ccmpi Cge
+  let gtint = Ccmpi Cgt
+
+  type act = expression
+
+  let make_const i =  Cconst_int i
+  (* CR mshinwell: fix debuginfo *)
+  let make_prim p args = Cop (p,args, Debuginfo.none)
+  let make_offset arg n = add_const arg n Debuginfo.none
+  let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
+  let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
+  let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
+  let make_switch arg cases actions =
+    make_switch arg cases actions Debuginfo.none
+  let bind arg body = bind "switcher" arg body
+
+  let make_catch handler = match handler with
+  | Cexit (i,[]) -> i,fun e -> e
+  | _ ->
+      let i = next_raise_count () in
+(*
+      Printf.eprintf  "SHARE CMM: %i\n" i ;
+      Printcmm.expression Format.str_formatter handler ;
+      Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ;
+*)
+      i,
+      (fun body -> match body with
+      | Cexit (j,_) ->
+          if i=j then handler
+          else body
+      | _ ->  ccatch (i,[],body,handler))
+
+  let make_exit i = Cexit (i,[])
+
+end
+
+(* cmm store, as sharing as normally been detected in previous
+   phases, we only share exits *)
+module StoreExp =
+  Switch.Store
+    (struct
+      type t = expression
+      type key = int
+      let make_key = function
+        | Cexit (i,[]) -> Some i
+        | _ -> None
+    end)
+
+module SwitcherBlocks = Switch.Make(SArgBlocks)
+
+(* Int switcher, arg in [low..high],
+   cases is list of individual cases, and is sorted by first component *)
+
+let transl_int_switch arg low high cases default = match cases with
+| [] -> assert false
+| _::_ ->
+    let store = StoreExp.mk_store () in
+    assert (store.Switch.act_store default = 0) ;
+    let cases =
+      List.map
+        (fun (i,act) -> i,store.Switch.act_store act)
+        cases in
+    let rec inters plow phigh pact = function
+      | [] ->
+          if phigh = high then [plow,phigh,pact]
+          else [(plow,phigh,pact); (phigh+1,high,0) ]
+      | (i,act)::rem ->
+          if i = phigh+1 then
+            if pact = act then
+              inters plow i pact rem
+            else
+              (plow,phigh,pact)::inters i i act rem
+          else (* insert default *)
+            if pact = 0 then
+              if act = 0 then
+                inters plow i 0 rem
+              else
+                (plow,i-1,pact)::
+                inters i i act rem
+            else (* pact <> 0 *)
+              (plow,phigh,pact)::
+              begin
+                if act = 0 then inters (phigh+1) i 0 rem
+                else (phigh+1,i-1,0)::inters i i act rem
+              end in
+    let inters = match cases with
+    | [] -> assert false
+    | (k0,act0)::rem ->
+        if k0 = low then inters k0 k0 act0 rem
+        else inters low (k0-1) 0 cases in
+    bind "switcher" arg
+      (fun a ->
+        SwitcherBlocks.zyva
+          (low,high)
+          a
+          (Array.of_list inters) store)
+
+
+(* Auxiliary functions for optimizing "let" of boxed numbers (floats and
+   boxed integers *)
+
+type unboxed_number_kind =
+    No_unboxing
+  | Boxed of boxed_number * bool (* true: boxed form available at no cost *)
+  | No_result (* expression never returns a result *)
+
+let unboxed_number_kind_of_unbox dbg = function
+  | Same_as_ocaml_repr -> No_unboxing
+  | Unboxed_float -> Boxed (Boxed_float dbg, false)
+  | Unboxed_integer bi -> Boxed (Boxed_integer (bi, dbg), false)
+  | Untagged_int -> No_unboxing
+
+let rec is_unboxed_number ~strict env e =
+  (* Given unboxed_number_kind from two branches of the code, returns the
+     resulting unboxed_number_kind.
+
+     If [strict=false], one knows that the type of the expression
+     is an unboxable number, and we decide to return an unboxed value
+     if this indeed eliminates at least one allocation.
+
+     If [strict=true], we need to ensure that all possible branches
+     return an unboxable number (of the same kind).  This could not
+     be the case in presence of GADTs.
+ *)
+  let join k1 e =
+    match k1, is_unboxed_number ~strict env e with
+    | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 ->
+        Boxed (b1, c1 && c2)
+    | No_result, k | k, No_result ->
+        k (* if a branch never returns, it is safe to unbox it *)
+    | No_unboxing, k | k, No_unboxing when not strict ->
+        k
+    | _, _ -> No_unboxing
+  in
+  match e with
+  | Uvar id ->
+      begin match is_unboxed_id id env with
+      | None -> No_unboxing
+      | Some (_, bn) -> Boxed (bn, false)
+      end
+
+  | Uconst(Uconst_ref(_, Some (Uconst_float _))) ->
+      Boxed (Boxed_float Debuginfo.none, true)
+  | Uconst(Uconst_ref(_, Some (Uconst_int32 _))) ->
+      Boxed (Boxed_integer (Pint32, Debuginfo.none), true)
+  | Uconst(Uconst_ref(_, Some (Uconst_int64 _))) ->
+      Boxed (Boxed_integer (Pint64, Debuginfo.none), true)
+  | Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) ->
+      Boxed (Boxed_integer (Pnativeint, Debuginfo.none), true)
+  | Uprim(p, _, dbg) ->
+      begin match simplif_primitive p with
+        | Pccall p -> unboxed_number_kind_of_unbox dbg p.prim_native_repr_res
+        | Pfloatfield _
+        | Pfloatofint
+        | Pnegfloat
+        | Pabsfloat
+        | Paddfloat
+        | Psubfloat
+        | Pmulfloat
+        | Pdivfloat
+        | Parrayrefu Pfloatarray
+        | Parrayrefs Pfloatarray -> Boxed (Boxed_float dbg, false)
+        | Pbintofint bi
+        | Pcvtbint(_, bi)
+        | Pnegbint bi
+        | Paddbint bi
+        | Psubbint bi
+        | Pmulbint bi
+        | Pdivbint {size=bi}
+        | Pmodbint {size=bi}
+        | Pandbint bi
+        | Porbint bi
+        | Pxorbint bi
+        | Plslbint bi
+        | Plsrbint bi
+        | Pasrbint bi
+        | Pbbswap bi -> Boxed (Boxed_integer (bi, dbg), false)
+        | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) ->
+            Boxed (Boxed_float dbg, false)
+        | Pbigarrayref(_, _, Pbigarray_int32, _) ->
+            Boxed (Boxed_integer (Pint32, dbg), false)
+        | Pbigarrayref(_, _, Pbigarray_int64, _) ->
+            Boxed (Boxed_integer (Pint64, dbg), false)
+        | Pbigarrayref(_, _, Pbigarray_native_int,_) ->
+            Boxed (Boxed_integer (Pnativeint, dbg), false)
+        | Pstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false)
+        | Pstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false)
+        | Pbigstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false)
+        | Pbigstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false)
+        | Praise _ -> No_result
+        | _ -> No_unboxing
+      end
+  | Ulet (_, _, _, _, e) | Uletrec (_, e) | Usequence (_, e) ->
+      is_unboxed_number ~strict env e
+  | Uswitch (_, switch) ->
+      let k = Array.fold_left join No_result switch.us_actions_consts in
+      Array.fold_left join k switch.us_actions_blocks
+  | Ustringswitch (_, actions, default_opt) ->
+      let k = List.fold_left (fun k (_, e) -> join k e) No_result actions in
+      begin match default_opt with
+        None -> k
+      | Some default -> join k default
+      end
+  | Ustaticfail _ -> No_result
+  | Uifthenelse (_, e1, e2) | Ucatch (_, _, e1, e2) | Utrywith (e1, _, e2) ->
+      join (is_unboxed_number ~strict env e1) e2
+  | _ -> No_unboxing
+
+(* Helper for compilation of initialization and assignment operations *)
+
+type assignment_kind = Caml_modify | Caml_initialize | Simple
+
+let assignment_kind ptr init =
+  match init, ptr with
+  | Assignment, Pointer -> Caml_modify
+  | Heap_initialization, Pointer -> Caml_initialize
+  | Assignment, Immediate
+  | Heap_initialization, Immediate
+  | Root_initialization, (Immediate | Pointer) -> Simple
+
+(* Translate an expression *)
+
+let functions = (Queue.create() : ufunction Queue.t)
+
+let strmatch_compile =
+  let module S =
+    Strmatch.Make
+      (struct
+        let string_block_length ptr = get_size ptr Debuginfo.none
+        let transl_switch = transl_int_switch
+      end) in
+  S.compile
+
+let rec transl env e =
+  match e with
+    Uvar id ->
+      begin match is_unboxed_id id env with
+      | None -> Cvar id
+      | Some (unboxed_id, bn) -> box_number bn (Cvar unboxed_id)
+      end
+  | Uconst sc ->
+      transl_constant sc
+  | Uclosure(fundecls, []) ->
+      let lbl = Compilenv.new_const_symbol() in
+      add_cmm_constant (
+        Const_closure ((lbl, Not_global), fundecls, []));
+      List.iter (fun f -> Queue.add f functions) fundecls;
+      Cconst_symbol lbl
+  | Uclosure(fundecls, clos_vars) ->
+      let block_size =
+        fundecls_size fundecls + List.length clos_vars in
+      let rec transl_fundecls pos = function
+          [] ->
+            List.map (transl env) clos_vars
+        | f :: rem ->
+            Queue.add f functions;
+            let header =
+              if pos = 0
+              then alloc_closure_header block_size f.dbg
+              else alloc_infix_header pos f.dbg in
+            if f.arity = 1 || f.arity = 0 then
+              header ::
+              Cconst_symbol f.label ::
+              int_const f.arity ::
+              transl_fundecls (pos + 3) rem
+            else
+              header ::
+              Cconst_symbol(curry_function f.arity) ::
+              int_const f.arity ::
+              Cconst_symbol f.label ::
+              transl_fundecls (pos + 4) rem in
+      Cop(Calloc, transl_fundecls 0 fundecls, Debuginfo.none)
+  | Uoffset(arg, offset) ->
+      (* produces a valid Caml value, pointing just after an infix header *)
+      let ptr = transl env arg in
+      if offset = 0
+      then ptr
+      else Cop(Caddv, [ptr; Cconst_int(offset * size_addr)], Debuginfo.none)
+  | Udirect_apply(lbl, args, dbg) ->
+      Cop(Capply typ_val, Cconst_symbol lbl :: List.map (transl env) args, dbg)
+  | Ugeneric_apply(clos, [arg], dbg) ->
+      bind "fun" (transl env clos) (fun clos ->
+        Cop(Capply typ_val, [get_field env clos 0 dbg; transl env arg; clos],
+          dbg))
+  | Ugeneric_apply(clos, args, dbg) ->
+      let arity = List.length args in
+      let cargs = Cconst_symbol(apply_function arity) ::
+        List.map (transl env) (args @ [clos]) in
+      Cop(Capply typ_val, cargs, dbg)
+  | Usend(kind, met, obj, args, dbg) ->
+      let call_met obj args clos =
+        if args = [] then
+          Cop(Capply typ_val, [get_field env clos 0 dbg; obj; clos], dbg)
+        else
+          let arity = List.length args + 1 in
+          let cargs = Cconst_symbol(apply_function arity) :: obj ::
+            (List.map (transl env) args) @ [clos] in
+          Cop(Capply typ_val, cargs, dbg)
+      in
+      bind "obj" (transl env obj) (fun obj ->
+        match kind, args with
+          Self, _ ->
+            bind "met" (lookup_label obj (transl env met) dbg)
+              (call_met obj args)
+        | Cached, cache :: pos :: args ->
+            call_cached_method obj
+              (transl env met) (transl env cache) (transl env pos)
+              (List.map (transl env) args) dbg
+        | _ ->
+            bind "met" (lookup_tag obj (transl env met) dbg)
+              (call_met obj args))
+  | Ulet(str, kind, id, exp, body) ->
+      transl_let env str kind id exp body
+  | Uletrec(bindings, body) ->
+      transl_letrec env bindings (transl env body)
+
+  (* Primitives *)
+  | Uprim(prim, args, dbg) ->
+      begin match (simplif_primitive prim, args) with
+        (Pgetglobal id, []) ->
+          Cconst_symbol (Ident.name id)
+      | (Pmakeblock _, []) ->
+          assert false
+      | (Pmakeblock(tag, _mut, _kind), args) ->
+          make_alloc dbg tag (List.map (transl env) args)
+      | (Pccall prim, args) ->
+          transl_ccall env prim args dbg
+      | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) ->
+          (* We arrive here in two cases:
+             1. When using Closure, all the time.
+             2. When using Flambda, if a float array longer than
+             [Translcore.use_dup_for_constant_arrays_bigger_than] turns out
+             to be non-constant.
+             If for some reason Flambda fails to lift a constant array we
+             could in theory also end up here.
+             Note that [kind] above is unconstrained, but with the current
+             state of [Translcore], we will in fact only get here with
+             [Pfloatarray]s. *)
+          assert (kind = kind');
+          transl_make_array dbg env kind args
+      | (Pduparray _, [arg]) ->
+          let prim_obj_dup =
+            Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+          in
+          transl_ccall env prim_obj_dup [arg] dbg
+      | (Pmakearray _, []) ->
+          transl_structured_constant (Uconst_block(0, []))
+      | (Pmakearray (kind, _), args) -> transl_make_array dbg env kind args
+      | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
+          let elt =
+            bigarray_get unsafe elt_kind layout
+              (transl env arg1) (List.map (transl env) argl) dbg in
+          begin match elt_kind with
+            Pbigarray_float32 | Pbigarray_float64 -> box_float dbg elt
+          | Pbigarray_complex32 | Pbigarray_complex64 -> elt
+          | Pbigarray_int32 -> box_int dbg Pint32 elt
+          | Pbigarray_int64 -> box_int dbg Pint64 elt
+          | Pbigarray_native_int -> box_int dbg Pnativeint elt
+          | Pbigarray_caml_int -> force_tag_int elt dbg
+          | _ -> tag_int elt dbg
+          end
+      | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
+          let (argidx, argnewval) = split_last argl in
+          return_unit(bigarray_set unsafe elt_kind layout
+            (transl env arg1)
+            (List.map (transl env) argidx)
+            (match elt_kind with
+              Pbigarray_float32 | Pbigarray_float64 ->
+                transl_unbox_float dbg env argnewval
+            | Pbigarray_complex32 | Pbigarray_complex64 -> transl env argnewval
+            | Pbigarray_int32 -> transl_unbox_int dbg env Pint32 argnewval
+            | Pbigarray_int64 -> transl_unbox_int dbg env Pint64 argnewval
+            | Pbigarray_native_int ->
+                transl_unbox_int dbg env Pnativeint argnewval
+            | _ -> untag_int (transl env argnewval) dbg)
+            dbg)
+      | (Pbigarraydim(n), [b]) ->
+          let dim_ofs = 4 + n in
+          tag_int (Cop(Cload (Word_int, Mutable),
+            [field_address (transl env b) dim_ofs dbg],
+            dbg)) dbg
+      | (p, [arg]) ->
+          transl_prim_1 env p arg dbg
+      | (p, [arg1; arg2]) ->
+          transl_prim_2 env p arg1 arg2 dbg
+      | (p, [arg1; arg2; arg3]) ->
+          transl_prim_3 env p arg1 arg2 arg3 dbg
+      | (_, _) ->
+          fatal_error "Cmmgen.transl:prim"
+      end
+
+  (* Control structures *)
+  | Uswitch(arg, s) ->
+      let dbg = Debuginfo.none in
+      (* As in the bytecode interpreter, only matching against constants
+         can be checked *)
+      if Array.length s.us_index_blocks = 0 then
+        make_switch
+          (untag_int (transl env arg) dbg)
+          s.us_index_consts
+          (Array.map (transl env) s.us_actions_consts)
+          dbg
+      else if Array.length s.us_index_consts = 0 then
+        transl_switch dbg env (get_tag (transl env arg) dbg)
+          s.us_index_blocks s.us_actions_blocks
+      else
+        bind "switch" (transl env arg) (fun arg ->
+          Cifthenelse(
+          Cop(Cand, [arg; Cconst_int 1], dbg),
+          transl_switch dbg env
+            (untag_int arg dbg) s.us_index_consts s.us_actions_consts,
+          transl_switch dbg env
+            (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks))
+  | Ustringswitch(arg,sw,d) ->
+      let dbg = Debuginfo.none in
+      bind "switch" (transl env arg)
+        (fun arg ->
+          strmatch_compile dbg arg (Misc.may_map (transl env) d)
+            (List.map (fun (s,act) -> s,transl env act) sw))
+  | Ustaticfail (nfail, args) ->
+      Cexit (nfail, List.map (transl env) args)
+  | Ucatch(nfail, [], body, handler) ->
+      make_catch nfail (transl env body) (transl env handler)
+  | Ucatch(nfail, ids, body, handler) ->
+      ccatch(nfail, ids, transl env body, transl env handler)
+  | Utrywith(body, exn, handler) ->
+      Ctrywith(transl env body, exn, transl env handler)
+  | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
+      transl env (Uifthenelse(arg, ifnot, ifso))
+  | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
+      let dbg = Debuginfo.none in
+      exit_if_false dbg env cond (transl env ifso) nfail
+  | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) ->
+      let dbg = Debuginfo.none in
+      exit_if_true dbg env cond nfail (transl env ifnot)
+  | Uifthenelse(Uprim(Psequand, _, dbg) as cond, ifso, ifnot) ->
+      let raise_num = next_raise_count () in
+      make_catch
+        raise_num
+        (exit_if_false dbg env cond (transl env ifso) raise_num)
+        (transl env ifnot)
+  | Uifthenelse(Uprim(Psequor, _, dbg) as cond, ifso, ifnot) ->
+      let raise_num = next_raise_count () in
+      make_catch
+        raise_num
+        (exit_if_true dbg env cond raise_num (transl env ifnot))
+        (transl env ifso)
+  | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) ->
+      let dbg = Debuginfo.none in
+      let num_true = next_raise_count () in
+      make_catch
+        num_true
+        (make_catch2
+           (fun shared_false ->
+             if_then_else
+               (test_bool dbg (transl env cond),
+                exit_if_true dbg env condso num_true shared_false,
+                exit_if_true dbg env condnot num_true shared_false))
+           (transl env ifnot))
+        (transl env ifso)
+  | Uifthenelse(cond, ifso, ifnot) ->
+      let dbg = Debuginfo.none in
+      if_then_else(test_bool dbg (transl env cond), transl env ifso,
+        transl env ifnot)
+  | Usequence(exp1, exp2) ->
+      Csequence(remove_unit(transl env exp1), transl env exp2)
+  | Uwhile(cond, body) ->
+      let dbg = Debuginfo.none in
+      let raise_num = next_raise_count () in
+      return_unit
+        (ccatch
+           (raise_num, [],
+            Cloop(exit_if_false dbg env cond
+                    (remove_unit(transl env body)) raise_num),
+            Ctuple []))
+  | Ufor(id, low, high, dir, body) ->
+      let dbg = Debuginfo.none in
+      let tst = match dir with Upto -> Cgt   | Downto -> Clt in
+      let inc = match dir with Upto -> Caddi | Downto -> Csubi in
+      let raise_num = next_raise_count () in
+      let id_prev = Ident.rename id in
+      return_unit
+        (Clet
+           (id, transl env low,
+            bind_nonvar "bound" (transl env high) (fun high ->
+              ccatch
+                (raise_num, [],
+                 Cifthenelse
+                   (Cop(Ccmpi tst, [Cvar id; high], dbg),
+                    Cexit (raise_num, []),
+                    Cloop
+                      (Csequence
+                         (remove_unit(transl env body),
+                         Clet(id_prev, Cvar id,
+                          Csequence
+                            (Cassign(id,
+                               Cop(inc, [Cvar id; Cconst_int 2],
+                                 dbg)),
+                             Cifthenelse
+                               (Cop(Ccmpi Ceq, [Cvar id_prev; high],
+                                  dbg),
+                                Cexit (raise_num,[]), Ctuple [])))))),
+                 Ctuple []))))
+  | Uassign(id, exp) ->
+      let dbg = Debuginfo.none in
+      begin match is_unboxed_id id env with
+      | None ->
+          return_unit (Cassign(id, transl env exp))
+      | Some (unboxed_id, bn) ->
+          return_unit(Cassign(unboxed_id,
+            transl_unbox_number dbg env bn exp))
+      end
+  | Uunreachable ->
+      let dbg = Debuginfo.none in
+      Cop(Cload (Word_int, Mutable), [Cconst_int 0], dbg)
+
+and transl_make_array dbg env kind args =
+  match kind with
+  | Pgenarray ->
+      Cop(Cextcall("caml_make_array", typ_val, true, None),
+          [make_alloc dbg 0 (List.map (transl env) args)], dbg)
+  | Paddrarray | Pintarray ->
+      make_alloc dbg 0 (List.map (transl env) args)
+  | Pfloatarray ->
+      make_float_alloc dbg Obj.double_array_tag
+                      (List.map (transl_unbox_float dbg env) args)
+
+and transl_ccall env prim args dbg =
+  let transl_arg native_repr arg =
+    match native_repr with
+    | Same_as_ocaml_repr -> transl env arg
+    | Unboxed_float -> transl_unbox_float dbg env arg
+    | Unboxed_integer bi -> transl_unbox_int dbg env bi arg
+    | Untagged_int -> untag_int (transl env arg) dbg
+  in
+  let rec transl_args native_repr_args args =
+    match native_repr_args, args with
+    | [], args ->
+        (* We don't require the two lists to be of the same length as
+           [default_prim] always sets the arity to [0]. *)
+        List.map (transl env) args
+    | _, [] -> assert false
+    | native_repr :: native_repr_args, arg :: args ->
+        transl_arg native_repr arg :: transl_args native_repr_args args
+  in
+  let typ_res, wrap_result =
+    match prim.prim_native_repr_res with
+    | Same_as_ocaml_repr -> (typ_val, fun x -> x)
+    | Unboxed_float -> (typ_float, box_float dbg)
+    | Unboxed_integer Pint64 when size_int = 4 ->
+        ([|Int; Int|], box_int dbg Pint64)
+    | Unboxed_integer bi -> (typ_int, box_int dbg bi)
+    | Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
+  in
+  let args = transl_args prim.prim_native_repr_args args in
+  wrap_result
+    (Cop(Cextcall(Primitive.native_name prim,
+                  typ_res, prim.prim_alloc, None), args, dbg))
+
+and transl_prim_1 env p arg dbg =
+  match p with
+  (* Generic operations *)
+    Pidentity | Pbytes_to_string | Pbytes_of_string | Popaque ->
+      transl env arg
+  | Pignore ->
+      return_unit(remove_unit (transl env arg))
+  (* Heap operations *)
+  | Pfield n ->
+      get_field env (transl env arg) n dbg
+  | Pfloatfield n ->
+      let ptr = transl env arg in
+      box_float dbg (
+        Cop(Cload (Double_u, Mutable),
+            [if n = 0 then ptr
+                       else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg)],
+            dbg))
+  | Pint_as_pointer ->
+     Cop(Caddi, [transl env arg; Cconst_int (-1)], dbg)
+     (* always a pointer outside the heap *)
+  (* Exceptions *)
+  | Praise _ when not (!Clflags.debug) ->
+      Cop(Craise Cmm.Raise_notrace, [transl env arg], dbg)
+  | Praise Lambda.Raise_notrace ->
+      Cop(Craise Cmm.Raise_notrace, [transl env arg], dbg)
+  | Praise Lambda.Raise_reraise ->
+      Cop(Craise Cmm.Raise_withtrace, [transl env arg], dbg)
+  | Praise Lambda.Raise_regular ->
+      raise_regular dbg (transl env arg)
+  (* Integer operations *)
+  | Pnegint ->
+      Cop(Csubi, [Cconst_int 2; transl env arg], dbg)
+  | Pctconst c ->
+      let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) dbg in
+      begin
+        match c with
+        | Big_endian -> const_of_bool Arch.big_endian
+        | Word_size -> tag_int (Cconst_int (8*Arch.size_int)) dbg
+        | Int_size -> tag_int (Cconst_int ((8*Arch.size_int) - 1)) dbg
+        | Max_wosize ->
+            tag_int (Cconst_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )) dbg
+        | Ostype_unix -> const_of_bool (Sys.os_type = "Unix")
+        | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32")
+        | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin")
+        | Backend_type ->
+            tag_int (Cconst_int 0) dbg (* tag 0 is the same as Native here *)
+      end
+  | Poffsetint n ->
+      if no_overflow_lsl n 1 then
+        add_const (transl env arg) (n lsl 1) dbg
+      else
+        transl_prim_2 env Paddint arg (Uconst (Uconst_int n))
+                      Debuginfo.none
+  | Poffsetref n ->
+      return_unit
+        (bind "ref" (transl env arg) (fun arg ->
+          Cop(Cstore (Word_int, Assignment),
+              [arg;
+               add_const (Cop(Cload (Word_int, Mutable), [arg], dbg))
+                 (n lsl 1) dbg],
+              dbg)))
+  (* Floating-point operations *)
+  | Pfloatofint ->
+      box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
+  | Pintoffloat ->
+     tag_int(Cop(Cintoffloat, [transl_unbox_float dbg env arg], dbg)) dbg
+  | Pnegfloat ->
+      box_float dbg (Cop(Cnegf, [transl_unbox_float dbg env arg], dbg))
+  | Pabsfloat ->
+      box_float dbg (Cop(Cabsf, [transl_unbox_float dbg env arg], dbg))
+  (* String operations *)
+  | Pstringlength | Pbyteslength ->
+      tag_int(string_length (transl env arg) dbg) dbg
+  (* Array operations *)
+  | Parraylength kind ->
+      let hdr = get_header_without_profinfo (transl env arg) dbg in
+      begin match kind with
+        Pgenarray ->
+          let len =
+            if wordsize_shift = numfloat_shift then
+              Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg)
+            else
+              bind "header" hdr (fun hdr ->
+                Cifthenelse(is_addr_array_hdr hdr dbg,
+                            Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg),
+                            Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg))) in
+          Cop(Cor, [len; Cconst_int 1], dbg)
+      | Paddrarray | Pintarray ->
+          Cop(Cor, [addr_array_length hdr dbg; Cconst_int 1], dbg)
+      | Pfloatarray ->
+          Cop(Cor, [float_array_length hdr dbg; Cconst_int 1], dbg)
+      end
+  (* Boolean operations *)
+  | Pnot ->
+      Cop(Csubi, [Cconst_int 4; transl env arg], dbg) (* 1 -> 3, 3 -> 1 *)
+  (* Test integer/block *)
+  | Pisint ->
+      tag_int(Cop(Cand, [transl env arg; Cconst_int 1], dbg)) dbg
+  (* Boxed integers *)
+  | Pbintofint bi ->
+      box_int dbg bi (untag_int (transl env arg) dbg)
+  | Pintofbint bi ->
+      force_tag_int (transl_unbox_int dbg env bi arg) dbg
+  | Pcvtbint(bi1, bi2) ->
+      box_int dbg bi2 (transl_unbox_int dbg env bi1 arg)
+  | Pnegbint bi ->
+      box_int dbg bi
+        (Cop(Csubi, [Cconst_int 0; transl_unbox_int dbg env bi arg], dbg))
+  | Pbbswap bi ->
+      let prim = match bi with
+        | Pnativeint -> "nativeint"
+        | Pint32 -> "int32"
+        | Pint64 -> "int64" in
+      box_int dbg bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
+                               typ_int, false, None),
+                      [transl_unbox_int dbg env bi arg],
+                      dbg))
+  | Pbswap16 ->
+      tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None),
+                   [untag_int (transl env arg) dbg],
+                   dbg))
+              dbg
+  | prim ->
+      fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim
+
+and transl_prim_2 env p arg1 arg2 dbg =
+  match p with
+  (* Heap operations *)
+  | Pfield_computed ->
+      addr_array_ref (transl env arg1) (transl env arg2) dbg
+  | Psetfield(n, ptr, init) ->
+      begin match assignment_kind ptr init with
+      | Caml_modify ->
+        return_unit(Cop(Cextcall("caml_modify", typ_void, false, None),
+                        [field_address (transl env arg1) n dbg;
+                         transl env arg2],
+                        dbg))
+      | Caml_initialize ->
+        return_unit(Cop(Cextcall("caml_initialize", typ_void, false, None),
+                        [field_address (transl env arg1) n dbg;
+                         transl env arg2],
+                        dbg))
+      | Simple ->
+        return_unit(set_field (transl env arg1) n (transl env arg2) init dbg)
+      end
+  | Psetfloatfield (n, init) ->
+      let ptr = transl env arg1 in
+      return_unit(
+        Cop(Cstore (Double_u, init),
+            [if n = 0 then ptr
+                       else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg);
+                   transl_unbox_float dbg env arg2], dbg))
+
+  (* Boolean operations *)
+  | Psequand ->
+      if_then_else(test_bool dbg (transl env arg1),
+        transl env arg2, Cconst_int 1)
+      (* let id = Ident.create "res1" in
+      Clet(id, transl env arg1,
+           Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *)
+  | Psequor ->
+      if_then_else(test_bool dbg (transl env arg1),
+        Cconst_int 3, transl env arg2)
+
+  (* Integer operations *)
+  | Paddint ->
+      decr_int(add_int (transl env arg1) (transl env arg2) dbg) dbg
+  | Psubint ->
+      incr_int(sub_int (transl env arg1) (transl env arg2) dbg) dbg
+  | Pmulint ->
+     begin
+       (* decrementing the non-constant part helps when the multiplication is
+          followed by an addition;
+          for example, using this trick compiles (100 * a + 7) into
+            (+ ( * a 100) -85)
+          rather than
+            (+ ( * 200 (>>s a 1)) 15)
+        *)
+       match transl env arg1, transl env arg2 with
+         | Cconst_int _ as c1, c2 ->
+             incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg
+         | c1, c2 ->
+             incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg
+     end
+  | Pdivint is_safe ->
+      tag_int(div_int (untag_int(transl env arg1) dbg)
+        (untag_int(transl env arg2) dbg) is_safe dbg) dbg
+  | Pmodint is_safe ->
+      tag_int(mod_int (untag_int(transl env arg1) dbg)
+        (untag_int(transl env arg2) dbg) is_safe dbg) dbg
+  | Pandint ->
+      Cop(Cand, [transl env arg1; transl env arg2], dbg)
+  | Porint ->
+      Cop(Cor, [transl env arg1; transl env arg2], dbg)
+  | Pxorint ->
+      Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl env arg1);
+                           ignore_low_bit_int(transl env arg2)], dbg);
+                Cconst_int 1], dbg)
+  | Plslint ->
+      incr_int(lsl_int (decr_int(transl env arg1) dbg)
+        (untag_int(transl env arg2) dbg) dbg) dbg
+  | Plsrint ->
+      Cop(Cor, [lsr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg;
+                Cconst_int 1], dbg)
+  | Pasrint ->
+      Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg;
+                Cconst_int 1], dbg)
+  | Pintcomp cmp ->
+      tag_int(Cop(Ccmpi(transl_comparison cmp),
+                  [transl env arg1; transl env arg2], dbg)) dbg
+  | Pisout ->
+      transl_isout (transl env arg1) (transl env arg2) dbg
+  (* Float operations *)
+  | Paddfloat ->
+      box_float dbg (Cop(Caddf,
+                    [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+                    dbg))
+  | Psubfloat ->
+      box_float dbg (Cop(Csubf,
+                    [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+                    dbg))
+  | Pmulfloat ->
+      box_float dbg (Cop(Cmulf,
+                    [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+                    dbg))
+  | Pdivfloat ->
+      box_float dbg (Cop(Cdivf,
+                    [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+                    dbg))
+  | Pfloatcomp cmp ->
+      tag_int(Cop(Ccmpf(transl_comparison cmp),
+                  [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+                  dbg)) dbg
+
+  (* String operations *)
+  | Pstringrefu | Pbytesrefu ->
+      tag_int(Cop(Cload (Byte_unsigned, Mutable),
+                  [add_int (transl env arg1) (untag_int(transl env arg2) dbg)
+                    dbg],
+                  dbg)) dbg
+  | Pstringrefs | Pbytesrefs ->
+      tag_int
+        (bind "str" (transl env arg1) (fun str ->
+          bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+            Csequence(
+              make_checkbound dbg [string_length str dbg; idx],
+              Cop(Cload (Byte_unsigned, Mutable),
+                [add_int str idx dbg], dbg))))) dbg
+
+  | Pstring_load_16(unsafe) ->
+     tag_int
+       (bind "str" (transl env arg1) (fun str ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+          check_bound unsafe dbg
+             (sub_int (string_length str dbg) (Cconst_int 1) dbg)
+             idx (unaligned_load_16 str idx dbg)))) dbg
+
+  | Pbigstring_load_16(unsafe) ->
+     tag_int
+       (bind "ba" (transl env arg1) (fun ba ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "ba_data"
+         (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
+         (fun ba_data ->
+          check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+                                               [field_address ba 5 dbg], dbg))
+                                          (Cconst_int 1) dbg) idx
+                      (unaligned_load_16 ba_data idx dbg))))) dbg
+
+  | Pstring_load_32(unsafe) ->
+     box_int dbg Pint32
+       (bind "str" (transl env arg1) (fun str ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+          check_bound unsafe dbg
+            (sub_int (string_length str dbg) (Cconst_int 3) dbg)
+            idx (unaligned_load_32 str idx dbg))))
+
+  | Pbigstring_load_32(unsafe) ->
+     box_int dbg Pint32
+       (bind "ba" (transl env arg1) (fun ba ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "ba_data"
+         (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
+         (fun ba_data ->
+          check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+                                               [field_address ba 5 dbg], dbg))
+                                          (Cconst_int 3) dbg) idx
+                      (unaligned_load_32 ba_data idx dbg)))))
+
+  | Pstring_load_64(unsafe) ->
+     box_int dbg Pint64
+       (bind "str" (transl env arg1) (fun str ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+          check_bound unsafe dbg
+            (sub_int (string_length str dbg) (Cconst_int 7) dbg)
+            idx (unaligned_load_64 str idx dbg))))
+
+  | Pbigstring_load_64(unsafe) ->
+     box_int dbg Pint64
+       (bind "ba" (transl env arg1) (fun ba ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "ba_data"
+         (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
+         (fun ba_data ->
+          check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+                                               [field_address ba 5 dbg], dbg))
+                                          (Cconst_int 7) dbg) idx
+                      (unaligned_load_64 ba_data idx dbg)))))
+
+  (* Array operations *)
+  | Parrayrefu kind ->
+      begin match kind with
+        Pgenarray ->
+          bind "arr" (transl env arg1) (fun arr ->
+            bind "index" (transl env arg2) (fun idx ->
+              Cifthenelse(is_addr_array_ptr arr dbg,
+                          addr_array_ref arr idx dbg,
+                          float_array_ref dbg arr idx)))
+      | Paddrarray ->
+          addr_array_ref (transl env arg1) (transl env arg2) dbg
+      | Pintarray ->
+          (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *)
+          int_array_ref (transl env arg1) (transl env arg2) dbg
+      | Pfloatarray ->
+          float_array_ref dbg (transl env arg1) (transl env arg2)
+      end
+  | Parrayrefs kind ->
+      begin match kind with
+      | Pgenarray ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+          bind "header" (get_header_without_profinfo arr dbg) (fun hdr ->
+            if wordsize_shift = numfloat_shift then
+              Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+                        Cifthenelse(is_addr_array_hdr hdr dbg,
+                                    addr_array_ref arr idx dbg,
+                                    float_array_ref dbg arr idx))
+            else
+              Cifthenelse(is_addr_array_hdr hdr dbg,
+                Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+                          addr_array_ref arr idx dbg),
+                Csequence(make_checkbound dbg [float_array_length hdr dbg; idx],
+                          float_array_ref dbg arr idx)))))
+      | Paddrarray ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+            Csequence(make_checkbound dbg [
+              addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+                      addr_array_ref arr idx dbg)))
+      | Pintarray ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+            Csequence(make_checkbound dbg [
+              addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+                      int_array_ref arr idx dbg)))
+      | Pfloatarray ->
+          box_float dbg (
+            bind "index" (transl env arg2) (fun idx ->
+            bind "arr" (transl env arg1) (fun arr ->
+              Csequence(make_checkbound dbg
+                [float_array_length(get_header_without_profinfo arr dbg) dbg;
+                  idx],
+                unboxed_float_array_ref arr idx dbg))))
+      end
+
+  (* Operations on bitvects *)
+  | Pbittest ->
+      bind "index" (untag_int(transl env arg2) dbg) (fun idx ->
+        tag_int(
+          Cop(Cand, [Cop(Clsr, [Cop(Cload (Byte_unsigned, Mutable),
+                                    [add_int (transl env arg1)
+                                      (Cop(Clsr, [idx; Cconst_int 3], dbg))
+                                      dbg],
+                                    dbg);
+                                Cop(Cand, [idx; Cconst_int 7], dbg)], dbg);
+                     Cconst_int 1], dbg)) dbg)
+
+  (* Boxed integers *)
+  | Paddbint bi ->
+      box_int dbg bi (Cop(Caddi,
+                      [transl_unbox_int dbg env bi arg1;
+                       transl_unbox_int dbg env bi arg2], dbg))
+  | Psubbint bi ->
+      box_int dbg bi (Cop(Csubi,
+                      [transl_unbox_int dbg env bi arg1;
+                       transl_unbox_int dbg env bi arg2], dbg))
+  | Pmulbint bi ->
+      box_int dbg bi (Cop(Cmuli,
+                      [transl_unbox_int dbg env bi arg1;
+                       transl_unbox_int dbg env bi arg2], dbg))
+  | Pdivbint { size = bi; is_safe } ->
+      box_int dbg bi (safe_div_bi is_safe
+                      (transl_unbox_int dbg env bi arg1)
+                      (transl_unbox_int dbg env bi arg2)
+                      bi dbg)
+  | Pmodbint { size = bi; is_safe } ->
+      box_int dbg bi (safe_mod_bi is_safe
+                      (transl_unbox_int dbg env bi arg1)
+                      (transl_unbox_int dbg env bi arg2)
+                      bi dbg)
+  | Pandbint bi ->
+      box_int dbg bi (Cop(Cand,
+                     [transl_unbox_int dbg env bi arg1;
+                      transl_unbox_int dbg env bi arg2], dbg))
+  | Porbint bi ->
+      box_int dbg bi (Cop(Cor,
+                     [transl_unbox_int dbg env bi arg1;
+                      transl_unbox_int dbg env bi arg2], dbg))
+  | Pxorbint bi ->
+      box_int dbg bi (Cop(Cxor,
+                     [transl_unbox_int dbg env bi arg1;
+                      transl_unbox_int dbg env bi arg2], dbg))
+  | Plslbint bi ->
+      box_int dbg bi (Cop(Clsl,
+                     [transl_unbox_int dbg env bi arg1;
+                      untag_int(transl env arg2) dbg], dbg))
+  | Plsrbint bi ->
+      box_int dbg bi (Cop(Clsr,
+                     [make_unsigned_int bi (transl_unbox_int dbg env bi arg1) dbg;
+                      untag_int(transl env arg2) dbg], dbg))
+  | Pasrbint bi ->
+      box_int dbg bi (Cop(Casr,
+                     [transl_unbox_int dbg env bi arg1;
+                      untag_int(transl env arg2) dbg], dbg))
+  | Pbintcomp(bi, cmp) ->
+      tag_int (Cop(Ccmpi(transl_comparison cmp),
+                     [transl_unbox_int dbg env bi arg1;
+                      transl_unbox_int dbg env bi arg2], dbg)) dbg
+  | prim ->
+      fatal_errorf "Cmmgen.transl_prim_2: %a" Printlambda.primitive prim
+
+and transl_prim_3 env p arg1 arg2 arg3 dbg =
+  match p with
+  (* Heap operations *)
+  | Psetfield_computed(ptr, init) ->
+      begin match assignment_kind ptr init with
+      | Caml_modify ->
+        return_unit (
+          addr_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+            dbg)
+      | Caml_initialize ->
+        return_unit (
+          addr_array_initialize (transl env arg1) (transl env arg2)
+            (transl env arg3) dbg)
+      | Simple ->
+        return_unit (
+          int_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+            dbg)
+      end
+  (* String operations *)
+  | Pbytessetu ->
+      return_unit(Cop(Cstore (Byte_unsigned, Assignment),
+                      [add_int (transl env arg1)
+                          (untag_int(transl env arg2) dbg)
+                          dbg;
+                        untag_int(transl env arg3) dbg], dbg))
+  | Pbytessets ->
+      return_unit
+        (bind "str" (transl env arg1) (fun str ->
+          bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+            Csequence(
+              make_checkbound dbg [string_length str dbg; idx],
+              Cop(Cstore (Byte_unsigned, Assignment),
+                  [add_int str idx dbg; untag_int(transl env arg3) dbg],
+                  dbg)))))
+
+  (* Array operations *)
+  | Parraysetu kind ->
+      return_unit(begin match kind with
+        Pgenarray ->
+          bind "newval" (transl env arg3) (fun newval ->
+            bind "index" (transl env arg2) (fun index ->
+              bind "arr" (transl env arg1) (fun arr ->
+                Cifthenelse(is_addr_array_ptr arr dbg,
+                            addr_array_set arr index newval dbg,
+                            float_array_set arr index (unbox_float dbg newval)
+                              dbg))))
+      | Paddrarray ->
+          addr_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+            dbg
+      | Pintarray ->
+          int_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+            dbg
+      | Pfloatarray ->
+          float_array_set (transl env arg1) (transl env arg2)
+            (transl_unbox_float dbg env arg3)
+            dbg
+      end)
+  | Parraysets kind ->
+      return_unit(begin match kind with
+      | Pgenarray ->
+          bind "newval" (transl env arg3) (fun newval ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+          bind "header" (get_header_without_profinfo arr dbg) (fun hdr ->
+            if wordsize_shift = numfloat_shift then
+              Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+                        Cifthenelse(is_addr_array_hdr hdr dbg,
+                                    addr_array_set arr idx newval dbg,
+                                    float_array_set arr idx
+                                                    (unbox_float dbg newval)
+                                                    dbg))
+            else
+              Cifthenelse(is_addr_array_hdr hdr dbg,
+                Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+                          addr_array_set arr idx newval dbg),
+                Csequence(make_checkbound dbg [float_array_length hdr dbg; idx],
+                          float_array_set arr idx
+                                          (unbox_float dbg newval) dbg))))))
+      | Paddrarray ->
+          bind "newval" (transl env arg3) (fun newval ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+            Csequence(make_checkbound dbg [
+              addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+                      addr_array_set arr idx newval dbg))))
+      | Pintarray ->
+          bind "newval" (transl env arg3) (fun newval ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+            Csequence(make_checkbound dbg [
+              addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+                      int_array_set arr idx newval dbg))))
+      | Pfloatarray ->
+          bind_load "newval" (transl_unbox_float dbg env arg3) (fun newval ->
+          bind "index" (transl env arg2) (fun idx ->
+          bind "arr" (transl env arg1) (fun arr ->
+            Csequence(make_checkbound dbg [
+              float_array_length (get_header_without_profinfo arr dbg) dbg;idx],
+                      float_array_set arr idx newval dbg))))
+      end)
+
+  | Pstring_set_16(unsafe) ->
+     return_unit
+       (bind "str" (transl env arg1) (fun str ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "newval" (untag_int (transl env arg3) dbg) (fun newval ->
+          check_bound unsafe dbg
+                      (sub_int (string_length str dbg) (Cconst_int 1) dbg)
+                      idx (unaligned_set_16 str idx newval dbg)))))
+
+  | Pbigstring_set_16(unsafe) ->
+     return_unit
+       (bind "ba" (transl env arg1) (fun ba ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "newval" (untag_int (transl env arg3) dbg) (fun newval ->
+        bind "ba_data"
+             (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
+             (fun ba_data ->
+          check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+                                               [field_address ba 5 dbg], dbg))
+                                          (Cconst_int 1)
+                                          dbg)
+                      idx (unaligned_set_16 ba_data idx newval dbg))))))
+
+  | Pstring_set_32(unsafe) ->
+     return_unit
+       (bind "str" (transl env arg1) (fun str ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval ->
+          check_bound unsafe dbg
+                      (sub_int (string_length str dbg) (Cconst_int 3) dbg)
+                      idx (unaligned_set_32 str idx newval dbg)))))
+
+  | Pbigstring_set_32(unsafe) ->
+     return_unit
+       (bind "ba" (transl env arg1) (fun ba ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval ->
+        bind "ba_data"
+             (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
+             (fun ba_data ->
+          check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+                                               [field_address ba 5 dbg], dbg))
+                                          (Cconst_int 3)
+                                          dbg)
+                      idx (unaligned_set_32 ba_data idx newval dbg))))))
+
+  | Pstring_set_64(unsafe) ->
+     return_unit
+       (bind "str" (transl env arg1) (fun str ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval ->
+          check_bound unsafe dbg
+                      (sub_int (string_length str dbg) (Cconst_int 7) dbg)
+                      idx (unaligned_set_64 str idx newval dbg)))))
+
+  | Pbigstring_set_64(unsafe) ->
+     return_unit
+       (bind "ba" (transl env arg1) (fun ba ->
+        bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+        bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval ->
+        bind "ba_data"
+             (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
+             (fun ba_data ->
+          check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+                                               [field_address ba 5 dbg], dbg))
+                                          (Cconst_int 7)
+                                          dbg) idx
+                      (unaligned_set_64 ba_data idx newval dbg))))))
+
+  | prim ->
+      fatal_errorf "Cmmgen.transl_prim_3: %a" Printlambda.primitive prim
+
+and transl_unbox_float dbg env = function
+    Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f
+  | exp -> unbox_float dbg (transl env exp)
+
+and transl_unbox_int dbg env bi = function
+    Uconst(Uconst_ref(_, Some (Uconst_int32 n))) ->
+      Cconst_natint (Nativeint.of_int32 n)
+  | Uconst(Uconst_ref(_, Some (Uconst_nativeint n))) ->
+      Cconst_natint n
+  | Uconst(Uconst_ref(_, Some (Uconst_int64 n))) ->
+      if size_int = 8 then
+        Cconst_natint (Int64.to_nativeint n)
+      else begin
+        let low = Int64.to_nativeint n in
+        let high = Int64.to_nativeint (Int64.shift_right_logical n 32) in
+        if big_endian then Ctuple [Cconst_natint high; Cconst_natint low]
+        else Ctuple [Cconst_natint low; Cconst_natint high]
+      end
+  | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' ->
+      Cconst_int i
+  | exp -> unbox_int bi (transl env exp) dbg
+
+and transl_unbox_number dbg env bn arg =
+  match bn with
+  | Boxed_float _ -> transl_unbox_float dbg env arg
+  | Boxed_integer (bi, _) -> transl_unbox_int dbg env bi arg
+
+and transl_let env str kind id exp body =
+  let dbg = Debuginfo.none in
+  let unboxing =
+    (* If [id] is a mutable variable (introduced to eliminate a local
+       reference) and it contains a type of unboxable numbers, then
+       force unboxing.  Indeed, if not boxed, each assignment to the variable
+       might require some boxing, but such local references are often
+       used in loops and we really want to avoid repeated boxing. *)
+    match str, kind with
+    | Mutable, Pfloatval ->
+        Boxed (Boxed_float dbg, false)
+    | Mutable, Pboxedintval bi ->
+        Boxed (Boxed_integer (bi, dbg), false)
+    | _, (Pfloatval | Pboxedintval _) ->
+        (* It would be safe to always unbox in this case, but
+           we do it only if this indeed allows us to get rid of
+           some allocations in the bound expression. *)
+        is_unboxed_number ~strict:false env exp
+    | _, Pgenval ->
+        (* Here we don't know statically that the bound expression
+           evaluates to an unboxable number type.  We need to be stricter
+           and ensure that all possible branches in the expression
+           return a boxed value (of the same kind).  Indeed, with GADTs,
+           different branches could return different types. *)
+        is_unboxed_number ~strict:true env exp
+    | _, Pintval ->
+        No_unboxing
+  in
+  match unboxing with
+  | No_unboxing | Boxed (_, true) | No_result ->
+      (* N.B. [body] must still be traversed even if [exp] will never return:
+         there may be constant closures inside that need lifting out. *)
+      Clet(id, transl env exp, transl env body)
+  | Boxed (boxed_number, _false) ->
+      let unboxed_id = Ident.create (Ident.name id) in
+      Clet(unboxed_id, transl_unbox_number dbg env boxed_number exp,
+           transl (add_unboxed_id id unboxed_id boxed_number env) body)
+
+and make_catch ncatch body handler = match body with
+| Cexit (nexit,[]) when nexit=ncatch -> handler
+| _ ->  ccatch (ncatch, [], body, handler)
+
+and make_catch2 mk_body handler = match handler with
+| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
+    mk_body handler
+| _ ->
+    let nfail = next_raise_count () in
+    make_catch
+      nfail
+      (mk_body (Cexit (nfail,[])))
+      handler
+
+and exit_if_true dbg env cond nfail otherwise =
+  match cond with
+  | Uconst (Uconst_ptr 0) -> otherwise
+  | Uconst (Uconst_ptr 1) -> Cexit (nfail,[])
+  | Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2)
+  | Uprim(Psequor, [arg1; arg2], _) ->
+      exit_if_true dbg env arg1 nfail
+        (exit_if_true dbg env arg2 nfail otherwise)
+  | Uifthenelse (_, _, Uconst (Uconst_ptr 0))
+  | Uprim(Psequand, _, _) ->
+      begin match otherwise with
+      | Cexit (raise_num,[]) ->
+          exit_if_false dbg env cond (Cexit (nfail,[])) raise_num
+      | _ ->
+          let raise_num = next_raise_count () in
+          make_catch
+            raise_num
+            (exit_if_false dbg env cond (Cexit (nfail,[])) raise_num)
+            otherwise
+      end
+  | Uprim(Pnot, [arg], _) ->
+      exit_if_false dbg env arg otherwise nfail
+  | Uifthenelse (cond, ifso, ifnot) ->
+      make_catch2
+        (fun shared ->
+          if_then_else
+            (test_bool dbg (transl env cond),
+             exit_if_true dbg env ifso nfail shared,
+             exit_if_true dbg env ifnot nfail shared))
+        otherwise
+  | _ ->
+      if_then_else(test_bool dbg (transl env cond),
+        Cexit (nfail, []), otherwise)
+
+and exit_if_false dbg env cond otherwise nfail =
+  match cond with
+  | Uconst (Uconst_ptr 0) -> Cexit (nfail,[])
+  | Uconst (Uconst_ptr 1) -> otherwise
+  | Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0))
+  | Uprim(Psequand, [arg1; arg2], _) ->
+      exit_if_false dbg env arg1
+        (exit_if_false dbg env arg2 otherwise nfail) nfail
+  | Uifthenelse (_, Uconst (Uconst_ptr 1), _)
+  | Uprim(Psequor, _, _) ->
+      begin match otherwise with
+      | Cexit (raise_num,[]) ->
+          exit_if_true dbg env cond raise_num (Cexit (nfail,[]))
+      | _ ->
+          let raise_num = next_raise_count () in
+          make_catch
+            raise_num
+            (exit_if_true dbg env cond raise_num (Cexit (nfail,[])))
+            otherwise
+      end
+  | Uprim(Pnot, [arg], _) ->
+      exit_if_true dbg env arg nfail otherwise
+  | Uifthenelse (cond, ifso, ifnot) ->
+      make_catch2
+        (fun shared ->
+          if_then_else
+            (test_bool dbg (transl env cond),
+             exit_if_false dbg env ifso shared nfail,
+             exit_if_false dbg env ifnot shared nfail))
+        otherwise
+  | _ ->
+      if_then_else (test_bool dbg (transl env cond), otherwise,
+        Cexit (nfail, []))
+
+and transl_switch _dbg env arg index cases = match Array.length cases with
+| 0 -> fatal_error "Cmmgen.transl_switch"
+| 1 -> transl env cases.(0)
+| _ ->
+    let cases = Array.map (transl env) cases in
+    let store = StoreExp.mk_store () in
+    let index =
+      Array.map
+        (fun j -> store.Switch.act_store cases.(j))
+        index in
+    let n_index = Array.length index in
+    let inters = ref []
+    and this_high = ref (n_index-1)
+    and this_low = ref (n_index-1)
+    and this_act = ref index.(n_index-1) in
+    for i = n_index-2 downto 0 do
+      let act = index.(i) in
+      if act = !this_act then
+        decr this_low
+      else begin
+        inters := (!this_low, !this_high, !this_act) :: !inters ;
+        this_high := i ;
+        this_low := i ;
+        this_act := act
+      end
+    done ;
+    inters := (0, !this_high, !this_act) :: !inters ;
+    match !inters with
+    | [_] -> cases.(0)
+    | inters ->
+        bind "switcher" arg
+          (fun a ->
+            SwitcherBlocks.zyva
+              (0,n_index-1)
+              a
+              (Array.of_list inters) store)
+
+and transl_letrec env bindings cont =
+  let dbg = Debuginfo.none in
+  let bsz =
+    List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp))
+      bindings
+  in
+  let op_alloc prim sz =
+    Cop(Cextcall(prim, typ_val, true, None), [int_const sz], dbg) in
+  let rec init_blocks = function
+    | [] -> fill_nonrec bsz
+    | (id, _exp, RHS_block sz) :: rem ->
+        Clet(id, op_alloc "caml_alloc_dummy" sz,
+          init_blocks rem)
+    | (id, _exp, RHS_floatblock sz) :: rem ->
+        Clet(id, op_alloc "caml_alloc_dummy_float" sz,
+          init_blocks rem)
+    | (id, _exp, RHS_nonrec) :: rem ->
+        Clet (id, Cconst_int 0, init_blocks rem)
+  and fill_nonrec = function
+    | [] -> fill_blocks bsz
+    | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+        fill_nonrec rem
+    | (id, exp, RHS_nonrec) :: rem ->
+        Clet(id, transl env exp, fill_nonrec rem)
+  and fill_blocks = function
+    | [] -> cont
+    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+        let op =
+          Cop(Cextcall("caml_update_dummy", typ_void, false, None),
+              [Cvar id; transl env exp], dbg) in
+        Csequence(op, fill_blocks rem)
+    | (_id, _exp, RHS_nonrec) :: rem ->
+        fill_blocks rem
+  in init_blocks bsz
+
+(* Translate a function definition *)
+
+let transl_function f =
+  let body =
+    if Config.flambda then
+      Un_anf.apply f.body ~what:f.label
+    else
+      f.body
+  in
+  let cmm_body =
+    let env = create_env ~environment_param:f.env in
+    if !Clflags.afl_instrument then
+      Afl_instrument.instrument_function (transl env body)
+    else
+      transl env body in
+  Cfunction {fun_name = f.label;
+             fun_args = List.map (fun id -> (id, typ_val)) f.params;
+             fun_body = cmm_body;
+             fun_fast = !Clflags.optimize_for_speed;
+             fun_dbg  = f.dbg}
+
+(* Translate all function definitions *)
+
+module StringSet =
+  Set.Make(struct
+    type t = string
+    let compare (x:t) y = compare x y
+  end)
+
+let rec transl_all_functions already_translated cont =
+  try
+    let f = Queue.take functions in
+    if StringSet.mem f.label already_translated then
+      transl_all_functions already_translated cont
+    else begin
+      transl_all_functions
+        (StringSet.add f.label already_translated)
+        ((f.dbg, transl_function f) :: cont)
+    end
+  with Queue.Empty ->
+    cont, already_translated
+
+let cdefine_symbol (symb, global) =
+  match global with
+  | Global -> [Cglobal_symbol symb; Cdefine_symbol symb]
+  | Not_global -> [Cdefine_symbol symb]
+
+(* Emit structured constants *)
+
+let rec emit_structured_constant symb cst cont =
+  let emit_block white_header symb cont =
+    (* Headers for structured constants must be marked black in case we
+       are in no-naked-pointers mode.  See [caml_darken]. *)
+    let black_header = Nativeint.logor white_header caml_black in
+    Cint black_header :: cdefine_symbol symb @ cont
+  in
+  match cst with
+  | Uconst_float s->
+      emit_block float_header symb (Cdouble s :: cont)
+  | Uconst_string s ->
+      emit_block (string_header (String.length s)) symb
+        (emit_string_constant s cont)
+  | Uconst_int32 n ->
+      emit_block boxedint32_header symb
+        (emit_boxed_int32_constant n cont)
+  | Uconst_int64 n ->
+      emit_block boxedint64_header symb
+        (emit_boxed_int64_constant n cont)
+  | Uconst_nativeint n ->
+      emit_block boxedintnat_header symb
+        (emit_boxed_nativeint_constant n cont)
+  | Uconst_block (tag, csts) ->
+      let cont = List.fold_right emit_constant csts cont in
+      emit_block (block_header tag (List.length csts)) symb cont
+  | Uconst_float_array fields ->
+      emit_block (floatarray_header (List.length fields)) symb
+        (Misc.map_end (fun f -> Cdouble f) fields cont)
+  | Uconst_closure(fundecls, lbl, fv) ->
+      assert(lbl = fst symb);
+      add_cmm_constant (Const_closure (symb, fundecls, fv));
+      List.iter (fun f -> Queue.add f functions) fundecls;
+      cont
+
+and emit_constant cst cont =
+  match cst with
+  | Uconst_int n | Uconst_ptr n ->
+      cint_const n
+      :: cont
+  | Uconst_ref (label, _) ->
+      Csymbol_address label :: cont
+
+and emit_string_constant s cont =
+  let n = size_int - 1 - (String.length s) mod size_int in
+  Cstring s :: Cskip n :: Cint8 n :: cont
+
+and emit_boxed_int32_constant n cont =
+  let n = Nativeint.of_int32 n in
+  if size_int = 8 then
+    Csymbol_address("caml_int32_ops") :: Cint32 n :: Cint32 0n :: cont
+  else
+    Csymbol_address("caml_int32_ops") :: Cint n :: cont
+
+and emit_boxed_nativeint_constant 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("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("caml_int64_ops") :: Cint hi :: Cint lo :: cont
+    else
+      Csymbol_address("caml_int64_ops") :: Cint lo :: Cint hi :: cont
+  end
+
+(* Emit constant closures *)
+
+let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
+  let closure_symbol f =
+    if Config.flambda then
+      cdefine_symbol (f.label ^ "_closure", global_symb)
+    else
+      []
+  in
+  match fundecls with
+    [] ->
+      (* This should probably not happen: dead code has normally been
+         eliminated and a closure cannot be accessed without going through
+         a [Project_closure], which depends on the function. *)
+      assert (clos_vars = []);
+      cdefine_symbol symb @
+        List.fold_right emit_constant clos_vars cont
+  | f1 :: remainder ->
+      let rec emit_others pos = function
+          [] ->
+            List.fold_right emit_constant clos_vars cont
+      | f2 :: rem ->
+          if f2.arity = 1 || f2.arity = 0 then
+            Cint(infix_header pos) ::
+            (closure_symbol f2) @
+            Csymbol_address f2.label ::
+            cint_const f2.arity ::
+            emit_others (pos + 3) rem
+          else
+            Cint(infix_header pos) ::
+            (closure_symbol f2) @
+            Csymbol_address(curry_function f2.arity) ::
+            cint_const f2.arity ::
+            Csymbol_address f2.label ::
+            emit_others (pos + 4) rem in
+      Cint(black_closure_header (fundecls_size fundecls
+                                 + List.length clos_vars)) ::
+      cdefine_symbol symb @
+      (closure_symbol f1) @
+      if f1.arity = 1 || f1.arity = 0 then
+        Csymbol_address f1.label ::
+        cint_const f1.arity ::
+        emit_others 3 remainder
+      else
+        Csymbol_address(curry_function f1.arity) ::
+        cint_const f1.arity ::
+        Csymbol_address f1.label ::
+        emit_others 4 remainder
+
+(* Emit constant blocks *)
+
+let emit_constant_table symb elems =
+  cdefine_symbol symb @
+  elems
+
+(* Emit all structured constants *)
+
+let emit_constants cont (constants:Clambda.preallocated_constant list) =
+  let c = ref cont in
+  List.iter
+    (fun { symbol = lbl; exported; definition = cst } ->
+       let global = if exported then Global else Not_global in
+       let cst = emit_structured_constant (lbl, global) cst [] in
+         c:= Cdata(cst):: !c)
+    constants;
+  List.iter
+    (function
+    | Const_closure (symb, fundecls, clos_vars) ->
+        c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c
+    | Const_table (symb, elems) ->
+        c := Cdata(emit_constant_table symb elems) :: !c)
+    !cmm_constants;
+  cmm_constants := [];
+  !c
+
+let emit_all_constants cont =
+  let constants = Compilenv.structured_constants () in
+  Compilenv.clear_structured_constants ();
+  emit_constants cont constants
+
+let transl_all_functions_and_emit_all_constants cont =
+  let rec aux already_translated cont translated_functions =
+    if Compilenv.structured_constants () = [] &&
+       Queue.is_empty functions
+    then cont, translated_functions
+    else
+      let translated_functions, already_translated =
+        transl_all_functions already_translated translated_functions
+      in
+      let cont = emit_all_constants cont in
+      aux already_translated cont translated_functions
+  in
+  let cont, translated_functions =
+    aux StringSet.empty cont []
+  in
+  let translated_functions =
+    (* Sort functions according to source position *)
+    List.map snd
+      (List.sort (fun (dbg1, _) (dbg2, _) ->
+           Debuginfo.compare dbg1 dbg2) translated_functions)
+  in
+  translated_functions @ cont
+
+(* Build the NULL terminated array of gc roots *)
+
+let emit_gc_roots_table ~symbols cont =
+  let table_symbol = Compilenv.make_symbol (Some "gc_roots") in
+  Cdata(Cglobal_symbol table_symbol ::
+        Cdefine_symbol table_symbol ::
+        List.map (fun s -> Csymbol_address s) symbols @
+        [Cint 0n])
+  :: cont
+
+(* Build preallocated blocks (used for Flambda [Initialize_symbol]
+   constructs, and Clambda global module) *)
+
+let preallocate_block cont { Clambda.symbol; exported; tag; size } =
+  let space =
+    (* These words will be registered as roots and as such must contain
+       valid values, in case we are in no-naked-pointers mode.  Likewise
+       the block header must be black, below (see [caml_darken]), since
+       the overall record may be referenced. *)
+    Array.to_list
+      (Array.init size (fun _index ->
+        Cint (Nativeint.of_int 1 (* Val_unit *))))
+  in
+  let data =
+    Cint(black_block_header tag size) ::
+    if exported then
+      Cglobal_symbol symbol ::
+      Cdefine_symbol symbol :: space
+    else
+      Cdefine_symbol symbol :: space
+  in
+  Cdata data :: cont
+
+let emit_preallocated_blocks preallocated_blocks cont =
+  let symbols =
+    List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol)
+      preallocated_blocks
+  in
+  let c1 = emit_gc_roots_table ~symbols cont in
+  List.fold_left preallocate_block c1 preallocated_blocks
+
+(* Translate a compilation unit *)
+
+let compunit (ulam, preallocated_blocks, constants) =
+  let init_code =
+    if !Clflags.afl_instrument then
+      Afl_instrument.instrument_initialiser (transl empty_env ulam)
+    else
+      transl empty_env ulam in
+  let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
+                       fun_args = [];
+                       fun_body = init_code; fun_fast = false;
+                       fun_dbg  = Debuginfo.none }] in
+  let c2 = emit_constants c1 constants in
+  let c3 = transl_all_functions_and_emit_all_constants c2 in
+  emit_preallocated_blocks preallocated_blocks 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 dbg =
+  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_int, Mutable), [meths], dbg),
+  Csequence(
+  ccatch
+    (raise_num, [],
+     Cloop
+       (Clet(
+        mi,
+        Cop(Cor,
+            [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); Cconst_int 1],
+               dbg);
+             Cconst_int 1],
+            dbg),
+        Csequence(
+        Cifthenelse
+          (Cop (Ccmpi Clt,
+                [tag;
+                 Cop(Cload (Word_int, Mutable),
+                     [Cop(Cadda,
+                          [meths; lsl_const (Cvar mi) log2_size_addr dbg],
+                          dbg)],
+                     dbg)], dbg),
+           Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2], dbg)),
+           Cassign(li, Cvar mi)),
+        Cifthenelse
+          (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), Cexit (raise_num, []),
+           Ctuple [])))),
+     Ctuple []),
+  Clet (
+    tagged,
+      Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg;
+        Cconst_int(1 - 3 * size_addr)], dbg),
+    Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg),
+              Cvar tagged)))))
+
+(* Generate an application function:
+     (defun caml_applyN (a1 ... aN clos)
+       (if (= clos.arity N)
+         (app clos.direct a1 ... aN clos)
+         (let (clos1 (app clos.code a1 clos)
+               clos2 (app clos1.code a2 clos)
+               ...
+               closN-1 (app closN-2.code aN-1 closN-2))
+           (app closN-1.code aN closN-1))))
+*)
+
+let apply_function_body arity =
+  let dbg = Debuginfo.none in
+  let arg = Array.make arity (Ident.create "arg") in
+  for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done;
+  let clos = Ident.create "clos" in
+  let env = empty_env in
+  let rec app_fun clos n =
+    if n = arity-1 then
+      Cop(Capply typ_val,
+          [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg)
+    else begin
+      let newclos = Ident.create "clos" in
+      Clet(newclos,
+           Cop(Capply typ_val,
+               [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg),
+           app_fun newclos (n+1))
+    end 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 env (Cvar clos) 1 dbg; int_const arity], dbg),
+   Cop(Capply typ_val,
+       get_field env (Cvar clos) 2 dbg :: List.map (fun s -> Cvar s) all_args,
+       dbg),
+   app_fun clos 0))
+
+let send_function arity =
+  let dbg = Debuginfo.none in
+  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 env = empty_env 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 env (Cvar meths) 1 dbg in
+    let cached_pos = Cvar cached in
+    let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg);
+                              Cconst_int(3*size_addr-1)], dbg) in
+    let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg) in
+    Clet (
+    meths, Cop(Cload (Word_val, Mutable), [obj], dbg),
+    Clet (
+    cached,
+      Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg); mask], dbg),
+    Clet (
+    real,
+    Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg),
+                cache_public_method (Cvar meths) tag cache dbg,
+                cached_pos),
+    Cop(Cload (Word_val, Mutable),
+      [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg);
+       Cconst_int(2*size_addr-1)], dbg)], dbg))))
+
+  in
+  let body = Clet(clos', clos, body) in
+  let cache = cache in
+  let fun_args =
+    [obj, typ_val; tag, typ_int; cache, typ_val]
+    @ List.map (fun id -> (id, typ_val)) (List.tl args) in
+  let fun_name = "caml_send" ^ string_of_int arity in
+  Cfunction
+   {fun_name;
+    fun_args = fun_args;
+    fun_body = body;
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none }
+
+let apply_function arity =
+  let (args, clos, body) = apply_function_body arity in
+  let all_args = args @ [clos] in
+  let fun_name = "caml_apply" ^ string_of_int arity in
+  Cfunction
+   {fun_name;
+    fun_args = List.map (fun id -> (id, typ_val)) all_args;
+    fun_body = body;
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none;
+   }
+
+(* Generate tuplifying functions:
+      (defun caml_tuplifyN (arg clos)
+        (app clos.direct #0(arg) ... #N-1(arg) clos)) *)
+
+let tuplify_function arity =
+  let dbg = Debuginfo.none in
+  let arg = Ident.create "arg" in
+  let clos = Ident.create "clos" in
+  let env = empty_env in
+  let rec access_components i =
+    if i >= arity
+    then []
+    else get_field env (Cvar arg) i dbg :: access_components(i+1) in
+  let fun_name = "caml_tuplify" ^ string_of_int arity in
+  Cfunction
+   {fun_name;
+    fun_args = [arg, typ_val; clos, typ_val];
+    fun_body =
+      Cop(Capply typ_val,
+          get_field env (Cvar clos) 2 dbg :: access_components 0 @ [Cvar clos],
+          dbg);
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none;
+   }
+
+(* Generate currying functions:
+      (defun caml_curryN (arg clos)
+         (alloc HDR caml_curryN_1  caml_curry_N_1_app arg clos))
+      (defun caml_curryN_1 (arg clos)
+         (alloc HDR caml_curryN_2  caml_curry_N_2_app arg clos))
+      ...
+      (defun caml_curryN_N-1 (arg clos)
+         (let (closN-2 clos.vars[1]
+               closN-3 closN-2.vars[1]
+               ...
+               clos1 clos2.vars[1]
+               clos clos1.vars[1])
+           (app clos.direct
+                clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos)))
+
+    Special "shortcut" functions are also generated to handle the
+    case where a partially applied function is applied to all remaining
+    arguments in one go.  For instance:
+      (defun caml_curry_N_1_app (arg2 ... argN clos)
+        (let clos' clos.vars[1]
+           (app clos'.direct clos.vars[0] arg2 ... argN clos')))
+
+    Those shortcuts may lead to a quadratic number of application
+    primitives being generated in the worst case, which resulted in
+    linking time blowup in practice (PR#5933), so we only generate and
+    use them when below a fixed arity 'max_arity_optimized'.
+*)
+
+let max_arity_optimized = 15
+let final_curry_function arity =
+  let dbg = Debuginfo.none in
+  let last_arg = Ident.create "arg" in
+  let last_clos = Ident.create "clos" in
+  let env = empty_env in
+  let rec curry_fun args clos n =
+    if n = 0 then
+      Cop(Capply typ_val,
+          get_field env (Cvar clos) 2 dbg ::
+            args @ [Cvar last_arg; Cvar clos],
+          dbg)
+    else
+      if n = arity - 1 || arity > max_arity_optimized then
+        begin
+      let newclos = Ident.create "clos" in
+      Clet(newclos,
+           get_field env (Cvar clos) 3 dbg,
+           curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1))
+        end else
+        begin
+          let newclos = Ident.create "clos" in
+          Clet(newclos,
+               get_field env (Cvar clos) 4 dbg,
+               curry_fun (get_field env (Cvar clos) 3 dbg :: args) newclos (n-1))
+    end in
+  Cfunction
+   {fun_name = "caml_curry" ^ string_of_int arity ^
+               "_" ^ string_of_int (arity-1);
+    fun_args = [last_arg, typ_val; last_clos, typ_val];
+    fun_body = curry_fun [] last_clos (arity-1);
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none }
+
+let rec intermediate_curry_functions arity num =
+  let dbg = Debuginfo.none in
+  let env = empty_env in
+  if num = arity - 1 then
+    [final_curry_function arity]
+  else begin
+    let name1 = "caml_curry" ^ string_of_int arity in
+    let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in
+    let arg = Ident.create "arg" and clos = Ident.create "clos" in
+    Cfunction
+     {fun_name = name2;
+      fun_args = [arg, typ_val; clos, typ_val];
+      fun_body =
+         if arity - num > 2 && arity <= max_arity_optimized then
+           Cop(Calloc,
+               [alloc_closure_header 5 Debuginfo.none;
+                Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
+                int_const (arity - num - 1);
+                Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app");
+                Cvar arg; Cvar clos],
+               dbg)
+         else
+           Cop(Calloc,
+                [alloc_closure_header 4 Debuginfo.none;
+                 Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
+                 int_const 1; Cvar arg; Cvar clos],
+                dbg);
+      fun_fast = true;
+      fun_dbg  = Debuginfo.none }
+    ::
+      (if arity <= max_arity_optimized && arity - num > 2 then
+          let rec iter i =
+            if i <= arity then
+              let arg = Ident.create (Printf.sprintf "arg%d" i) in
+              (arg, typ_val) :: iter (i+1)
+            else []
+          in
+          let direct_args = iter (num+2) in
+          let rec iter i args clos =
+            if i = 0 then
+              Cop(Capply typ_val,
+                  (get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos],
+                  dbg)
+            else
+              let newclos = Ident.create "clos" in
+              Clet(newclos,
+                   get_field env (Cvar clos) 4 dbg,
+                   iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos)
+          in
+          let cf =
+            Cfunction
+              {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app";
+               fun_args = direct_args @ [clos, typ_val];
+               fun_body = iter (num+1)
+                  (List.map (fun (arg,_) -> Cvar arg) direct_args) clos;
+               fun_fast = true;
+               fun_dbg = Debuginfo.none }
+          in
+          cf :: intermediate_curry_functions arity (num+1)
+       else
+          intermediate_curry_functions arity (num+1))
+  end
+
+let curry_function arity =
+  assert(arity <> 0);
+  (* Functions with arity = 0 does not have a curry_function *)
+  if arity > 0
+  then intermediate_curry_functions arity 0
+  else [tuplify_function (-arity)]
+
+
+module IntSet = Set.Make(
+  struct
+    type t = int
+    let compare (x:t) y = compare x y
+  end)
+
+let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty)
+  (* These apply funs are always present in the main program because
+     the run-time system needs them (cf. asmrun/.S) . *)
+
+let generic_functions shared units =
+  let (apply,send,curry) =
+    List.fold_left
+      (fun (apply,send,curry) ui ->
+         List.fold_right IntSet.add ui.ui_apply_fun apply,
+         List.fold_right IntSet.add ui.ui_send_fun send,
+         List.fold_right IntSet.add ui.ui_curry_fun curry)
+      (IntSet.empty,IntSet.empty,IntSet.empty)
+      units in
+  let apply = if shared then apply else IntSet.union apply default_apply in
+  let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in
+  let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in
+  IntSet.fold (fun n accu -> curry_function n @ accu) curry accu
+
+(* Generate the entry point *)
+
+let entry_point namelist =
+  (* CR mshinwell: review all of these "None"s.  We should be able to at
+     least have filenames for these. *)
+  let dbg = Debuginfo.none in
+  let incr_global_inited =
+    Cop(Cstore (Word_int, Assignment),
+        [Cconst_symbol "caml_globals_inited";
+         Cop(Caddi, [Cop(Cload (Word_int, Mutable),
+                       [Cconst_symbol "caml_globals_inited"], dbg);
+                     Cconst_int 1], dbg)], dbg) in
+  let body =
+    List.fold_right
+      (fun name next ->
+        let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
+        Csequence(Cop(Capply typ_void,
+                         [Cconst_symbol entry_sym], dbg),
+                  Csequence(incr_global_inited, next)))
+      namelist (Cconst_int 1) in
+  Cfunction {fun_name = "caml_program";
+             fun_args = [];
+             fun_body = body;
+             fun_fast = false;
+             fun_dbg  = Debuginfo.none }
+
+(* Generate the table of globals *)
+
+let cint_zero = Cint 0n
+
+let global_table namelist =
+  let mksym name =
+    Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "gc_roots"))
+  in
+  Cdata(Cglobal_symbol "caml_globals" ::
+        Cdefine_symbol "caml_globals" ::
+        List.map mksym namelist @
+        [cint_zero])
+
+let reference_symbols namelist =
+  let mksym name = Csymbol_address name in
+  Cdata(List.map mksym namelist)
+
+let global_data name v =
+  Cdata(emit_structured_constant (name, Global)
+          (Uconst_string (Marshal.to_string v [])) [])
+
+let globals_map v = global_data "caml_globals_map" v
+
+(* 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 mksym namelist
+        @ [cint_zero])
+
+(* Generate the master table of Spacetime shapes *)
+
+let spacetime_shapes namelist =
+  let mksym name =
+    Csymbol_address (
+      Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes"))
+  in
+  Cdata(Cglobal_symbol "caml_spacetime_shapes" ::
+        Cdefine_symbol "caml_spacetime_shapes" ::
+        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 addsyms namelist [cint_zero])
+
+let data_segment_table namelist =
+  segment_table namelist "caml_data_segments" "data_begin" "data_end"
+
+let code_segment_table namelist =
+  segment_table namelist "caml_code_segments" "code_begin" "code_end"
+
+(* Initialize a predefined exception *)
+
+let predef_exception i name =
+  let symname = "caml_exn_" ^ name in
+  let cst = Uconst_string name in
+  let label = Compilenv.new_const_symbol () in
+  let cont = emit_structured_constant (label, Not_global) cst [] in
+  Cdata(emit_structured_constant (symname, Global)
+          (Uconst_block(Obj.object_tag,
+                       [
+                         Uconst_ref(label, Some cst);
+                         Uconst_int (-i-1);
+                       ])) cont)
+
+(* Header for a plugin *)
+
+let plugin_header units =
+  let mk (ui,crc) =
+    { dynu_name = ui.ui_name;
+      dynu_crc = crc;
+      dynu_imports_cmi = ui.ui_imports_cmi;
+      dynu_imports_cmx = ui.ui_imports_cmx;
+      dynu_defines = ui.ui_defines
+    } in
+  global_data "caml_plugin_header"
+    { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units }
diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli
new file mode 100644
index 00000000..8104afab
--- /dev/null
+++ b/asmcomp/cmmgen.mli
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Translation from closed lambda to C-- *)
+
+val compunit:
+    Clambda.ulambda
+    * Clambda.preallocated_block list
+    * Clambda.preallocated_constant list
+  -> Cmm.phrase list
+
+val apply_function: int -> Cmm.phrase
+val send_function: int -> Cmm.phrase
+val curry_function: int -> Cmm.phrase list
+val generic_functions: bool -> Cmx_format.unit_infos list -> Cmm.phrase list
+val entry_point: string list -> Cmm.phrase
+val global_table: string list -> Cmm.phrase
+val reference_symbols: string list -> Cmm.phrase
+val globals_map: (string * Digest.t * Digest.t * string list) list ->
+  Cmm.phrase
+val frame_table: string list -> Cmm.phrase
+val spacetime_shapes: string list -> Cmm.phrase
+val data_segment_table: string list -> Cmm.phrase
+val code_segment_table: string list -> Cmm.phrase
+val predef_exception: int -> string -> Cmm.phrase
+val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase
+val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint
diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli
new file mode 100644
index 00000000..0e3cf285
--- /dev/null
+++ b/asmcomp/cmx_format.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Format of .cmx, .cmxa and .cmxs files *)
+
+(* Each .o file has a matching .cmx file that provides the following infos
+   on the compilation unit:
+     - list of other units imported, with MD5s of their .cmx files
+     - approximation of the structure implemented
+       (includes descriptions of known functions: arity and direct entry
+        points)
+     - list of currying functions and application functions needed
+   The .cmx file contains these infos (as an externed record) plus a MD5
+   of these infos *)
+
+type export_info =
+  | Clambda of Clambda.value_approximation
+  | Flambda of Export_info.t
+
+type unit_infos =
+  { mutable ui_name: string;                    (* Name of unit implemented *)
+    mutable ui_symbol: string;            (* Prefix for symbols *)
+    mutable ui_defines: string list;      (* Unit and sub-units implemented *)
+    mutable ui_imports_cmi:
+              (string * Digest.t option) list; (* Interfaces imported *)
+    mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *)
+    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_export_info: export_info;
+    mutable ui_force_link: bool }               (* Always linked *)
+
+(* Each .a library has a matching .cmxa file that provides the following
+   infos on the library: *)
+
+type library_infos =
+  { lib_units: (unit_infos * Digest.t) list;  (* List of unit infos w/ MD5s *)
+    lib_ccobjs: string list;            (* C object files needed *)
+    lib_ccopts: string list }           (* Extra opts to C compiler *)
+
+(* Each .cmxs dynamically-loaded plugin contains a symbol
+   "caml_plugin_header" containing the following info
+   (as an externed record) *)
+
+type dynunit = {
+  dynu_name: string;
+  dynu_crc: Digest.t;
+  dynu_imports_cmi: (string * Digest.t option) list;
+  dynu_imports_cmx: (string * Digest.t option) list;
+  dynu_defines: string list;
+}
+
+type dynheader = {
+  dynu_magic: string;
+  dynu_units: dynunit list;
+}
diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml
new file mode 100644
index 00000000..62a9b0da
--- /dev/null
+++ b/asmcomp/coloring.ml
@@ -0,0 +1,226 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Register allocation by coloring of the interference graph *)
+
+module OrderedRegSet =
+  Set.Make(struct
+    type t = Reg.t
+    let compare r1 r2 =
+      let open Reg in
+      let c1 = r1.spill_cost and d1 = r1.degree in
+      let c2 = r2.spill_cost and d2 = r2.degree in
+      let n = c2 * d1 - c1 * d2 in
+      if n <> 0 then n else
+        let n = c2 - c1 in
+        if n <> 0 then n else
+          let n = d1 - d2 in
+          if n <> 0 then n else r1.stamp - r2.stamp
+  end)
+
+open Reg
+
+let allocate_registers() =
+
+  (* Constrained regs with degree >= number of available registers,
+     sorted by spill cost (highest first).
+     The spill cost measure is [r.spill_cost / r.degree].
+     [r.spill_cost] estimates the number of accesses to [r]. *)
+  let constrained = ref OrderedRegSet.empty in
+
+  (* Unconstrained regs with degree < number of available registers *)
+  let unconstrained = ref [] in
+
+  (* Preallocate the spilled registers in the stack.
+     Split the remaining registers into constrained and unconstrained. *)
+  let remove_reg reg =
+    let cl = Proc.register_class reg in
+    if reg.spill then begin
+      (* Preallocate the registers in the stack *)
+      let nslots = Proc.num_stack_slots.(cl) in
+      let conflict = Array.make nslots false in
+      List.iter
+        (fun r ->
+          match r.loc with
+            Stack(Local n) ->
+              if Proc.register_class r = cl then conflict.(n) <- true
+          | _ -> ())
+        reg.interf;
+      let slot = ref 0 in
+      while !slot < nslots && conflict.(!slot) do incr slot done;
+      reg.loc <- Stack(Local !slot);
+      if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1
+    end else if reg.degree < Proc.num_available_registers.(cl) then
+      unconstrained := reg :: !unconstrained
+    else begin
+      constrained := OrderedRegSet.add reg !constrained
+    end in
+
+  (* Iterate over all registers preferred by the given register (transitive) *)
+  let iter_preferred f reg =
+    let rec walk r w =
+      if not r.visited then begin
+        f r w;
+        begin match r.prefer with
+            [] -> ()
+          | p  -> r.visited <- true;
+                  List.iter (fun (r1, w1) -> walk r1 (min w w1)) p;
+                  r.visited <- false
+        end
+      end in
+    reg.visited <- true;
+    List.iter (fun (r, w) -> walk r w) reg.prefer;
+    reg.visited <- false in
+
+  (* Where to start the search for a suitable register.
+     Used to introduce some "randomness" in the choice between registers
+     with equal scores. This offers more opportunities for scheduling. *)
+  let start_register = Array.make Proc.num_register_classes 0 in
+
+  (* Assign a location to a register, the best we can. *)
+  let assign_location reg =
+    let cl = Proc.register_class reg in
+    let first_reg = Proc.first_available_register.(cl) in
+    let num_regs = Proc.num_available_registers.(cl) in
+    let score = Array.make num_regs 0 in
+    let best_score = ref (-1000000) and best_reg = ref (-1) in
+    let start = start_register.(cl) in
+    if num_regs <> 0 then begin
+      (* Favor the registers that have been assigned to pseudoregs for which
+         we have a preference. If these pseudoregs have not been assigned
+         already, avoid the registers with which they conflict. *)
+      iter_preferred
+        (fun r w ->
+          match r.loc with
+            Reg n -> let n = n - first_reg in
+                     if n < num_regs then
+                       score.(n) <- score.(n) + w
+          | Unknown ->
+              List.iter
+                (fun neighbour ->
+                  match neighbour.loc with
+                    Reg n -> let n = n - first_reg in
+                             if n < num_regs then
+                               score.(n) <- score.(n) - w
+                  | _ -> ())
+                r.interf
+          | _ -> ())
+        reg;
+      List.iter
+        (fun neighbour ->
+          (* Prohibit the registers that have been assigned
+             to our neighbours *)
+          begin match neighbour.loc with
+            Reg n -> let n = n - first_reg in
+                     if n < num_regs then
+                       score.(n) <- (-1000000)
+          | _ -> ()
+          end;
+          (* Avoid the registers that have been assigned to pseudoregs
+             for which our neighbours have a preference *)
+          iter_preferred
+            (fun r w ->
+              match r.loc with
+                Reg n -> let n = n - first_reg in
+                         if n < num_regs then
+                           score.(n) <- score.(n) - (w-1)
+                         (* w-1 to break the symmetry when two conflicting regs
+                            have the same preference for a third reg. *)
+              | _ -> ())
+            neighbour)
+        reg.interf;
+      (* Pick the register with the best score *)
+      for n = start to num_regs - 1 do
+        if score.(n) > !best_score then begin
+          best_score := score.(n);
+          best_reg := n
+        end
+      done;
+      for n = 0 to start - 1 do
+        if score.(n) > !best_score then begin
+          best_score := score.(n);
+          best_reg := n
+        end
+      done
+    end;
+    (* Found a register? *)
+    if !best_reg >= 0 then begin
+      reg.loc <- Reg(first_reg + !best_reg);
+      if Proc.rotate_registers then
+        start_register.(cl) <- (let start = start + 1 in
+                                if start >= num_regs then 0 else start)
+    end else begin
+      (* Sorry, we must put the pseudoreg in a stack location *)
+      let nslots = Proc.num_stack_slots.(cl) in
+      let score = Array.make nslots 0 in
+      (* Compute the scores as for registers *)
+      List.iter
+        (fun (r, w) ->
+          match r.loc with
+            Stack(Local n) -> score.(n) <- score.(n) + w
+          | Unknown ->
+              List.iter
+                (fun neighbour ->
+                  match neighbour.loc with
+                    Stack(Local n) -> score.(n) <- score.(n) - w
+                  | _ -> ())
+                r.interf
+          | _ -> ())
+        reg.prefer;
+      List.iter
+        (fun neighbour ->
+          begin match neighbour.loc with
+              Stack(Local n) -> score.(n) <- (-1000000)
+          | _ -> ()
+          end;
+          List.iter
+            (fun (r, w) ->
+              match r.loc with
+                Stack(Local n) -> score.(n) <- score.(n) - w
+              | _ -> ())
+            neighbour.prefer)
+        reg.interf;
+      (* Pick the location with the best score *)
+      let best_score = ref (-1000000) and best_slot = ref (-1) in
+      for n = 0 to nslots - 1 do
+        if score.(n) > !best_score then begin
+          best_score := score.(n);
+          best_slot := n
+        end
+      done;
+      (* Found one? *)
+      if !best_slot >= 0 then
+        reg.loc <- Stack(Local !best_slot)
+      else begin
+        (* Allocate a new stack slot *)
+        reg.loc <- Stack(Local nslots);
+        Proc.num_stack_slots.(cl) <- nslots + 1
+      end
+    end;
+    (* Cancel the preferences of this register so that they don't influence
+       transitively the allocation of registers that prefer this reg. *)
+    reg.prefer <- [] in
+
+  (* Reset the stack slot counts *)
+  for i = 0 to Proc.num_register_classes - 1 do
+    Proc.num_stack_slots.(i) <- 0;
+  done;
+
+  (* First pass: preallocate spill registers and split remaining regs
+     Second pass: assign locations to constrained regs
+     Third pass: assign locations to unconstrained regs *)
+  List.iter remove_reg (Reg.all_registers());
+  OrderedRegSet.iter assign_location !constrained;
+  List.iter assign_location !unconstrained
diff --git a/asmcomp/coloring.mli b/asmcomp/coloring.mli
new file mode 100644
index 00000000..874a6f98
--- /dev/null
+++ b/asmcomp/coloring.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Register allocation by coloring of the interference graph *)
+
+val allocate_registers: unit -> unit
diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
new file mode 100644
index 00000000..b4e1b1ef
--- /dev/null
+++ b/asmcomp/comballoc.ml
@@ -0,0 +1,98 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Combine heap allocations occurring in the same basic block *)
+
+open Mach
+
+type allocation_state =
+    No_alloc                            (* no allocation is pending *)
+  | Pending_alloc of Reg.t * int        (* an allocation is pending *)
+(* The arguments of Pending_alloc(reg, ofs) are:
+     reg  the register holding the result of the last allocation
+     ofs  the alloc position in the allocated block *)
+
+let allocated_size = function
+    No_alloc -> 0
+  | Pending_alloc(_, ofs) -> ofs
+
+let rec combine i allocstate =
+  match i.desc with
+    Iend | Ireturn | Iexit _ | Iraise _ ->
+      (i, allocated_size allocstate)
+  | Iop(Ialloc { words = sz; _ }) ->
+      begin match allocstate with
+        No_alloc ->
+          let (newnext, newsz) =
+            combine i.next (Pending_alloc(i.res.(0), sz)) in
+          (instr_cons_debug (Iop(Ialloc {words = newsz; spacetime_index = 0;
+              label_after_call_gc = None; }))
+            i.arg i.res i.dbg newnext, 0)
+      | Pending_alloc(reg, ofs) ->
+          if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin
+            let (newnext, newsz) =
+              combine i.next (Pending_alloc(reg, ofs + sz)) in
+            (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext,
+             newsz)
+          end else begin
+            let (newnext, newsz) =
+              combine i.next (Pending_alloc(i.res.(0), sz)) in
+            (instr_cons_debug (Iop(Ialloc { words = newsz; spacetime_index = 0;
+                label_after_call_gc = None; }))
+              i.arg i.res i.dbg newnext, ofs)
+          end
+      end
+  | Iop(Icall_ind _ | Icall_imm _ | Iextcall _ |
+        Itailcall_ind _ | Itailcall_imm _) ->
+      let newnext = combine_restart i.next in
+      (instr_cons_debug i.desc i.arg i.res i.dbg newnext,
+       allocated_size allocstate)
+  | Iop _ ->
+      let (newnext, sz) = combine i.next allocstate in
+      (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz)
+  | Iifthenelse(test, ifso, ifnot) ->
+      let newifso = combine_restart ifso in
+      let newifnot = combine_restart ifnot in
+      let newnext = combine_restart i.next in
+      (instr_cons (Iifthenelse(test, newifso, newifnot)) i.arg i.res newnext,
+       allocated_size allocstate)
+  | Iswitch(table, cases) ->
+      let newcases = Array.map combine_restart cases in
+      let newnext = combine_restart i.next in
+      (instr_cons (Iswitch(table, newcases)) i.arg i.res newnext,
+       allocated_size allocstate)
+  | Iloop(body) ->
+      let newbody = combine_restart body in
+      (instr_cons (Iloop(newbody)) i.arg i.res i.next,
+       allocated_size allocstate)
+  | Icatch(rec_flag, handlers, body) ->
+      let (newbody, sz) = combine body allocstate in
+      let newhandlers =
+        List.map (fun (io, handler) -> io, combine_restart handler) handlers in
+      let newnext = combine_restart i.next in
+      (instr_cons (Icatch(rec_flag, newhandlers, newbody))
+         i.arg i.res newnext, sz)
+  | Itrywith(body, handler) ->
+      let (newbody, sz) = combine body allocstate in
+      let newhandler = combine_restart handler in
+      let newnext = combine_restart i.next in
+      (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, sz)
+
+and combine_restart i =
+  let (newi, _) = combine i No_alloc in newi
+
+let fundecl f =
+  if Config.spacetime then f
+  else {f with fun_body = combine_restart f.fun_body}
diff --git a/asmcomp/comballoc.mli b/asmcomp/comballoc.mli
new file mode 100644
index 00000000..19d8fdee
--- /dev/null
+++ b/asmcomp/comballoc.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Combine heap allocations occurring in the same basic block *)
+
+val fundecl: Mach.fundecl -> Mach.fundecl
diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml
new file mode 100644
index 00000000..a50c57f4
--- /dev/null
+++ b/asmcomp/compilenv.ml
@@ -0,0 +1,460 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compilation environments for compilation units *)
+
+[@@@ocaml.warning "+a-4-9-40-41-42"]
+
+open Config
+open Misc
+open Cmx_format
+
+type error =
+    Not_a_unit_info of string
+  | Corrupted_unit_info of string
+  | Illegal_renaming of string * string * string
+
+exception Error of error
+
+let global_infos_table =
+  (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
+let export_infos_table =
+  (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t)
+
+let imported_sets_of_closures_table =
+  (Set_of_closures_id.Tbl.create 10
+   : Flambda.function_declarations option Set_of_closures_id.Tbl.t)
+
+let sourcefile = ref None
+
+module CstMap =
+  Map.Make(struct
+    type t = Clambda.ustructured_constant
+    let compare = Clambda.compare_structured_constants
+    (* PR#6442: it is incorrect to use Pervasives.compare on values of type t
+       because it compares "0.0" and "-0.0" equal. *)
+  end)
+
+type structured_constants =
+  {
+    strcst_shared: string CstMap.t;
+    strcst_all: (string * Clambda.ustructured_constant) list;
+  }
+
+let structured_constants_empty  =
+  {
+    strcst_shared = CstMap.empty;
+    strcst_all = [];
+  }
+
+let structured_constants = ref structured_constants_empty
+
+
+let exported_constants = Hashtbl.create 17
+
+let merged_environment = ref Export_info.empty
+
+let default_ui_export_info =
+  if Config.flambda then
+    Cmx_format.Flambda Export_info.empty
+  else
+    Cmx_format.Clambda Value_unknown
+
+let current_unit =
+  { ui_name = "";
+    ui_symbol = "";
+    ui_defines = [];
+    ui_imports_cmi = [];
+    ui_imports_cmx = [];
+    ui_curry_fun = [];
+    ui_apply_fun = [];
+    ui_send_fun = [];
+    ui_force_link = false;
+    ui_export_info = default_ui_export_info }
+
+let symbolname_for_pack pack name =
+  match pack with
+  | None -> name
+  | Some p ->
+      let b = Buffer.create 64 in
+      for i = 0 to String.length p - 1 do
+        match p.[i] with
+        | '.' -> Buffer.add_string b "__"
+        |  c  -> Buffer.add_char b c
+      done;
+      Buffer.add_string b "__";
+      Buffer.add_string b name;
+      Buffer.contents b
+
+let unit_id_from_name name = Ident.create_persistent name
+
+let concat_symbol unitname id =
+  unitname ^ "__" ^ id
+
+let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
+  let prefix = "caml" ^ unitname in
+  match idopt with
+  | None -> prefix
+  | Some id -> concat_symbol prefix id
+
+let current_unit_linkage_name () =
+  Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
+
+let reset ?packname ~source_provenance:file name =
+  Hashtbl.clear global_infos_table;
+  Set_of_closures_id.Tbl.clear imported_sets_of_closures_table;
+  let symbol = symbolname_for_pack packname name in
+  sourcefile := Some file;
+  current_unit.ui_name <- name;
+  current_unit.ui_symbol <- symbol;
+  current_unit.ui_defines <- [symbol];
+  current_unit.ui_imports_cmi <- [];
+  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 <- !Clflags.link_everything;
+  Hashtbl.clear exported_constants;
+  structured_constants := structured_constants_empty;
+  current_unit.ui_export_info <- default_ui_export_info;
+  merged_environment := Export_info.empty;
+  Hashtbl.clear export_infos_table;
+  let compilation_unit =
+    Compilation_unit.create
+      (Ident.create_persistent name)
+      (current_unit_linkage_name ())
+  in
+  Compilation_unit.set_current compilation_unit
+
+let current_unit_infos () =
+  current_unit
+
+let current_unit_name () =
+  current_unit.ui_name
+
+let current_build () =
+  match !sourcefile with
+  | None -> assert false
+  | Some v -> v
+
+let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
+  let prefix = "caml" ^ unitname in
+  match idopt with
+  | None -> prefix
+  | Some id -> prefix ^ "__" ^ id
+
+let symbol_in_current_unit name =
+  let prefix = "caml" ^ current_unit.ui_symbol in
+  name = prefix ||
+  (let lp = String.length prefix in
+   String.length name >= 2 + lp
+   && String.sub name 0 lp = prefix
+   && name.[lp] = '_'
+   && name.[lp + 1] = '_')
+
+let read_unit_info filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer = really_input_string ic (String.length cmx_magic_number) in
+    if buffer <> cmx_magic_number then begin
+      close_in ic;
+      raise(Error(Not_a_unit_info filename))
+    end;
+    let ui = (input_value ic : unit_infos) in
+    let crc = Digest.input ic in
+    close_in ic;
+    (ui, crc)
+  with End_of_file | Failure _ ->
+    close_in ic;
+    raise(Error(Corrupted_unit_info(filename)))
+
+let read_library_info filename =
+  let ic = open_in_bin filename in
+  let buffer = really_input_string ic (String.length cmxa_magic_number) in
+  if buffer <> cmxa_magic_number then
+    raise(Error(Not_a_unit_info filename));
+  let infos = (input_value ic : library_infos) in
+  close_in ic;
+  infos
+
+
+(* Read and cache info on global identifiers *)
+
+let get_global_info global_ident = (
+  let modname = Ident.name global_ident in
+  if modname = current_unit.ui_name then
+    Some current_unit
+  else begin
+    try
+      Hashtbl.find global_infos_table modname
+    with Not_found ->
+      let (infos, crc) =
+        if Env.is_imported_opaque modname then (None, None)
+        else begin
+          try
+            let filename =
+              find_in_path_uncap !load_path (modname ^ ".cmx") in
+            let (ui, crc) = read_unit_info filename in
+            if ui.ui_name <> modname then
+              raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
+            (Some ui, Some crc)
+          with Not_found ->
+            let warn = Warnings.No_cmx_file modname in
+              Location.prerr_warning Location.none warn;
+              (None, None)
+          end
+      in
+      current_unit.ui_imports_cmx <-
+        (modname, crc) :: current_unit.ui_imports_cmx;
+      Hashtbl.add global_infos_table modname infos;
+      infos
+  end
+)
+
+let cache_unit_info ui =
+  Hashtbl.add global_infos_table ui.ui_name (Some ui)
+
+(* Return the approximation of a global identifier *)
+
+let get_clambda_approx ui =
+  assert(not Config.flambda);
+  match ui.ui_export_info with
+  | Flambda _ -> assert false
+  | Clambda approx -> approx
+
+let toplevel_approx :
+  (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16
+
+let record_global_approx_toplevel () =
+  Hashtbl.add toplevel_approx current_unit.ui_name
+    (get_clambda_approx current_unit)
+
+let global_approx id =
+  if Ident.is_predef_exn id then Clambda.Value_unknown
+  else try Hashtbl.find toplevel_approx (Ident.name id)
+  with Not_found ->
+    match get_global_info id with
+      | None -> Clambda.Value_unknown
+      | Some ui -> get_clambda_approx ui
+
+(* Return the symbol used to refer to a global identifier *)
+
+let symbol_for_global id =
+  if Ident.is_predef_exn id then
+    "caml_exn_" ^ Ident.name id
+  else begin
+    let unitname = Ident.name id in
+    match
+      try ignore (Hashtbl.find toplevel_approx unitname); None
+      with Not_found -> get_global_info id
+    with
+    | None -> make_symbol ~unitname:(Ident.name id) None
+    | Some ui -> make_symbol ~unitname:ui.ui_symbol None
+  end
+
+(* Register the approximation of the module being compiled *)
+
+let unit_for_global id =
+  let sym_label = Linkage_name.create (symbol_for_global id) in
+  Compilation_unit.create id sym_label
+
+let predefined_exception_compilation_unit =
+  Compilation_unit.create (Ident.create_persistent "__dummy__")
+    (Linkage_name.create "__dummy__")
+
+let is_predefined_exception sym =
+  Compilation_unit.equal
+    predefined_exception_compilation_unit
+    (Symbol.compilation_unit sym)
+
+let symbol_for_global' id =
+  let sym_label = Linkage_name.create (symbol_for_global id) in
+  if Ident.is_predef_exn id then
+    Symbol.unsafe_create predefined_exception_compilation_unit sym_label
+  else
+    Symbol.unsafe_create (unit_for_global id) sym_label
+
+let set_global_approx approx =
+  assert(not Config.flambda);
+  current_unit.ui_export_info <- Clambda approx
+
+(* Exporting and importing cross module information *)
+
+let get_flambda_export_info ui =
+  assert(Config.flambda);
+  match ui.ui_export_info with
+  | Clambda _ -> assert false
+  | Flambda ei -> ei
+
+let set_export_info export_info =
+  assert(Config.flambda);
+  current_unit.ui_export_info <- Flambda export_info
+
+let approx_for_global comp_unit =
+  let id = Compilation_unit.get_persistent_ident comp_unit in
+  if (Compilation_unit.equal
+      predefined_exception_compilation_unit
+      comp_unit)
+     || Ident.is_predef_exn id
+     || not (Ident.global id)
+  then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id);
+  let modname = Ident.name id in
+  try Hashtbl.find export_infos_table modname with
+  | Not_found ->
+    let exported = match get_global_info id with
+      | None -> Export_info.empty
+      | Some ui -> get_flambda_export_info ui in
+    Hashtbl.add export_infos_table modname exported;
+    merged_environment := Export_info.merge !merged_environment exported;
+    exported
+
+let approx_env () = !merged_environment
+
+(* Record that a currying function or application function is needed *)
+
+let need_curry_fun n =
+  if not (List.mem n current_unit.ui_curry_fun) then
+    current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
+
+let need_apply_fun n =
+  assert(n > 0);
+  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 =
+  let oc = open_out_bin filename in
+  output_string oc cmx_magic_number;
+  output_value oc info;
+  flush oc;
+  let crc = Digest.file filename in
+  Digest.output oc crc;
+  close_out oc
+
+let save_unit_info filename =
+  current_unit.ui_imports_cmi <- Env.imports();
+  write_unit_info current_unit filename
+
+let current_unit_linkage_name () =
+  Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
+
+let current_unit () =
+  match Compilation_unit.get_current () with
+  | Some current_unit -> current_unit
+  | None -> Misc.fatal_error "Compilenv.current_unit"
+
+let current_unit_symbol () =
+  Symbol.unsafe_create (current_unit ()) (current_unit_linkage_name ())
+
+let const_label = ref 0
+
+let new_const_symbol () =
+  incr const_label;
+  make_symbol (Some (string_of_int !const_label))
+
+let snapshot () = !structured_constants
+let backtrack s = structured_constants := s
+
+let new_structured_constant cst ~shared =
+  let {strcst_shared; strcst_all} = !structured_constants in
+  if shared then
+    try
+      CstMap.find cst strcst_shared
+    with Not_found ->
+      let lbl = new_const_symbol() in
+      structured_constants :=
+        {
+          strcst_shared = CstMap.add cst lbl strcst_shared;
+          strcst_all = (lbl, cst) :: strcst_all;
+        };
+      lbl
+  else
+    let lbl = new_const_symbol() in
+    structured_constants :=
+      {
+        strcst_shared;
+        strcst_all = (lbl, cst) :: strcst_all;
+      };
+    lbl
+
+let add_exported_constant s =
+  Hashtbl.replace exported_constants s ()
+
+let clear_structured_constants () =
+  structured_constants := structured_constants_empty
+
+let structured_constants () =
+  List.map
+    (fun (symbol, definition) ->
+       {
+         Clambda.symbol;
+         exported = Hashtbl.mem exported_constants symbol;
+         definition;
+       })
+    (!structured_constants).strcst_all
+
+let closure_symbol fv =
+  let compilation_unit = Closure_id.get_compilation_unit fv in
+  let unitname =
+    Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit)
+  in
+  let linkage_name =
+    concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure")
+  in
+  Symbol.unsafe_create compilation_unit (Linkage_name.create linkage_name)
+
+let function_label fv =
+  let compilation_unit = Closure_id.get_compilation_unit fv in
+  let unitname =
+    Linkage_name.to_string
+      (Compilation_unit.get_linkage_name compilation_unit)
+  in
+  (concat_symbol unitname (Closure_id.unique_name fv))
+
+let require_global global_ident =
+  if not (Ident.is_predef_exn global_ident) then
+    ignore (get_global_info global_ident : Cmx_format.unit_infos option)
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Not_a_unit_info filename ->
+      fprintf ppf "%a@ is not a compilation unit description."
+        Location.print_filename filename
+  | Corrupted_unit_info filename ->
+      fprintf ppf "Corrupted compilation unit description@ %a"
+        Location.print_filename filename
+  | Illegal_renaming(name, modname, filename) ->
+      fprintf ppf "%a@ contains the description for unit\
+                   @ %s when %s was expected"
+        Location.print_filename filename name modname
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli
new file mode 100644
index 00000000..fa3cfc34
--- /dev/null
+++ b/asmcomp/compilenv.mli
@@ -0,0 +1,158 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compilation environments for compilation units *)
+
+open Cmx_format
+
+(* CR-soon mshinwell: this is a bit ugly
+   mshinwell: deferred CR, this has been addressed in the export info
+   improvement feature.
+*)
+val imported_sets_of_closures_table
+  : Flambda.function_declarations option Set_of_closures_id.Tbl.t
+        (* flambda-only *)
+
+val reset: ?packname:string -> source_provenance:Timings.source_provenance ->
+        string -> unit
+        (* Reset the environment and record the name of the unit being
+           compiled (arg).  Optional argument is [-for-pack] prefix. *)
+
+val unit_id_from_name: string -> Ident.t
+        (* flambda-only *)
+
+val current_unit_infos: unit -> unit_infos
+        (* Return the infos for the unit being compiled *)
+
+val current_unit_name: unit -> string
+        (* Return the name of the unit being compiled
+           clambda-only *)
+
+val current_unit_linkage_name: unit -> Linkage_name.t
+        (* Return the linkage_name of the unit being compiled.
+           flambda-only *)
+
+val current_build: unit -> Timings.source_provenance
+        (* Return the kind of build source being compiled. If it is a
+           file compilation it also provides the filename. *)
+
+val current_unit: unit -> Compilation_unit.t
+        (* flambda-only *)
+
+val current_unit_symbol: unit -> Symbol.t
+        (* flambda-only *)
+
+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 symbol_in_current_unit: string -> bool
+        (* Return true if the given asm symbol belongs to the
+           current compilation unit, false otherwise. *)
+
+val is_predefined_exception: Symbol.t -> bool
+        (* flambda-only *)
+
+val unit_for_global: Ident.t -> Compilation_unit.t
+        (* flambda-only *)
+
+val symbol_for_global: Ident.t -> string
+        (* Return the asm symbol that refers to the given global identifier
+           flambda-only *)
+val symbol_for_global': Ident.t -> Symbol.t
+        (* flambda-only *)
+val global_approx: Ident.t -> Clambda.value_approximation
+        (* Return the approximation for the given global identifier
+           clambda-only *)
+val set_global_approx: Clambda.value_approximation -> unit
+        (* Record the approximation of the unit being compiled
+           clambda-only *)
+val record_global_approx_toplevel: unit -> unit
+        (* Record the current approximation for the current toplevel phrase
+           clambda-only *)
+
+val set_export_info: Export_info.t -> unit
+        (* Record the informations of the unit being compiled
+           flambda-only *)
+val approx_env: unit -> Export_info.t
+        (* Returns all the information loaded from extenal compilation units
+           flambda-only *)
+val approx_for_global: Compilation_unit.t -> Export_info.t
+        (* Loads the exported information declaring the compilation_unit
+           flambda-only *)
+
+val need_curry_fun: int -> unit
+val need_apply_fun: int -> unit
+val need_send_fun: int -> unit
+        (* Record the need of a currying (resp. application,
+           message sending) function with the given arity *)
+
+val new_const_symbol : unit -> string
+val closure_symbol : Closure_id.t -> Symbol.t
+        (* Symbol of a function if the function is
+           closed (statically allocated)
+           flambda-only *)
+val function_label : Closure_id.t -> string
+        (* linkage name of the code of a function
+           flambda-only *)
+
+val new_structured_constant:
+  Clambda.ustructured_constant ->
+  shared:bool -> (* can be shared with another structually equal constant *)
+  string
+val structured_constants:
+  unit -> Clambda.preallocated_constant list
+val clear_structured_constants: unit -> unit
+val add_exported_constant: string -> unit
+        (* clambda-only *)
+type structured_constants
+        (* clambda-only *)
+val snapshot: unit -> structured_constants
+        (* clambda-only *)
+val backtrack: structured_constants -> unit
+        (* clambda-only *)
+
+val read_unit_info: string -> unit_infos * Digest.t
+        (* Read infos and MD5 from a [.cmx] file. *)
+val write_unit_info: unit_infos -> string -> unit
+        (* Save the given infos in the given file *)
+val save_unit_info: string -> unit
+        (* Save the infos for the current unit in the given file *)
+val cache_unit_info: unit_infos -> unit
+        (* Enter the given infos in the cache.  The infos will be
+           honored by [symbol_for_global] and [global_approx]
+           without looking at the corresponding .cmx file. *)
+
+val require_global: Ident.t -> unit
+        (* Enforce a link dependency of the current compilation
+           unit to the required module *)
+
+val read_library_info: string -> library_infos
+
+type error =
+    Not_a_unit_info of string
+  | Corrupted_unit_info of string
+  | Illegal_renaming of string * string * string
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml
new file mode 100644
index 00000000..c713b64b
--- /dev/null
+++ b/asmcomp/deadcode.ml
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Dead code elimination: remove pure instructions whose results are
+   not used. *)
+
+open Mach
+
+(* [deadcode i] returns a pair of an optimized instruction [i']
+   and a set of registers live "before" instruction [i]. *)
+
+let rec deadcode i =
+  let arg =
+    if Config.spacetime
+      && Mach.spacetime_node_hole_pointer_is_live_before i
+    then Array.append i.arg [| Proc.loc_spacetime_node_hole |]
+    else i.arg
+  in
+  match i.desc with
+  | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ ->
+      (i, Reg.add_set_array i.live arg)
+  | Iop op ->
+      let (s, before) = deadcode i.next in
+      if Proc.op_is_pure op                     (* no side effects *)
+      && Reg.disjoint_set_array before i.res    (* results are not used after *)
+      && not (Proc.regs_are_volatile arg)      (* no stack-like hard reg *)
+      && not (Proc.regs_are_volatile i.res)    (*            is involved *)
+      then begin
+        assert (Array.length i.res > 0);  (* sanity check *)
+        (s, before)
+      end else begin
+        ({i with next = s}, Reg.add_set_array i.live arg)
+      end
+  | Iifthenelse(test, ifso, ifnot) ->
+      let (ifso', _) = deadcode ifso in
+      let (ifnot', _) = deadcode ifnot in
+      let (s, _) = deadcode i.next in
+      ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s},
+       Reg.add_set_array i.live arg)
+  | Iswitch(index, cases) ->
+      let cases' = Array.map (fun c -> fst (deadcode c)) cases in
+      let (s, _) = deadcode i.next in
+      ({i with desc = Iswitch(index, cases'); next = s},
+       Reg.add_set_array i.live arg)
+  | Iloop(body) ->
+      let (body', _) = deadcode body in
+      let (s, _) = deadcode i.next in
+      ({i with desc = Iloop body'; next = s}, i.live)
+  | Icatch(rec_flag, handlers, body) ->
+      let (body', _) = deadcode body in
+      let handlers' =
+        List.map (fun (nfail, handler) ->
+            let (handler', _) = deadcode handler in
+            nfail, handler')
+          handlers
+      in
+      let (s, _) = deadcode i.next in
+      ({i with desc = Icatch(rec_flag, handlers', body'); next = s}, i.live)
+  | Iexit _nfail ->
+      (i, i.live)
+  | Itrywith(body, handler) ->
+      let (body', _) = deadcode body in
+      let (handler', _) = deadcode handler in
+      let (s, _) = deadcode i.next in
+      ({i with desc = Itrywith(body', handler'); next = s}, i.live)
+
+let fundecl f =
+  let (new_body, _) = deadcode f.fun_body in
+  {f with fun_body = new_body}
diff --git a/asmcomp/deadcode.mli b/asmcomp/deadcode.mli
new file mode 100644
index 00000000..c566cfbd
--- /dev/null
+++ b/asmcomp/deadcode.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Dead code elimination: remove pure instructions whose results are
+   not used. *)
+
+val fundecl: Mach.fundecl -> Mach.fundecl
diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli
new file mode 100644
index 00000000..cab50833
--- /dev/null
+++ b/asmcomp/emit.mli
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Generation of assembly code *)
+
+val fundecl: Linearize.fundecl -> unit
+val data: Cmm.data_item list -> unit
+val begin_assembly: unit -> unit
+val end_assembly: unit -> unit
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
new file mode 100644
index 00000000..22173f4d
--- /dev/null
+++ b/asmcomp/emitaux.ml
@@ -0,0 +1,315 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Common functions for emitting assembly code *)
+
+let output_channel = ref stdout
+
+let emit_string s = output_string !output_channel s
+
+let emit_int n = output_string !output_channel (string_of_int n)
+
+let emit_char c = output_char !output_channel c
+
+let emit_nativeint n = output_string !output_channel (Nativeint.to_string n)
+
+let emit_printf fmt =
+  Printf.fprintf !output_channel fmt
+
+let emit_int32 n = emit_printf "0x%lx" n
+
+let emit_symbol esc s =
+  for i = 0 to String.length s - 1 do
+    let c = s.[i] in
+    match c with
+      'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
+        output_char !output_channel c
+    | _ ->
+        Printf.fprintf !output_channel "%c%02x" esc (Char.code c)
+  done
+
+let emit_string_literal s =
+  let last_was_escape = ref false in
+  emit_string "\"";
+  for i = 0 to String.length s - 1 do
+    let c = s.[i] in
+    if c >= '0' && c <= '9' then
+      if !last_was_escape
+      then Printf.fprintf !output_channel "\\%o" (Char.code c)
+      else output_char !output_channel c
+    else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin
+      output_char !output_channel c;
+      last_was_escape := false
+    end else begin
+      Printf.fprintf !output_channel "\\%o" (Char.code c);
+      last_was_escape := true
+    end
+  done;
+  emit_string "\""
+
+let emit_string_directive directive s =
+  let l = String.length s in
+  if l = 0 then ()
+  else if l < 80 then begin
+    emit_string directive;
+    emit_string_literal s;
+    emit_char '\n'
+  end else begin
+    let i = ref 0 in
+    while !i < l do
+      let n = min (l - !i) 80 in
+      emit_string directive;
+      emit_string_literal (String.sub s !i n);
+      emit_char '\n';
+      i := !i + n
+    done
+  end
+
+let emit_bytes_directive directive s =
+   let pos = ref 0 in
+   for i = 0 to String.length s - 1 do
+     if !pos = 0
+     then emit_string directive
+     else emit_char ',';
+     emit_int(Char.code s.[i]);
+     incr pos;
+     if !pos >= 16 then begin emit_char '\n'; pos := 0 end
+   done;
+   if !pos > 0 then emit_char '\n'
+
+let emit_float64_directive directive x =
+  emit_printf "\t%s\t0x%Lx\n" directive x
+
+let emit_float64_split_directive directive x =
+  let lo = Int64.logand x 0xFFFF_FFFFL
+  and hi = Int64.shift_right_logical x 32 in
+  emit_printf "\t%s\t0x%Lx, 0x%Lx\n"
+    directive
+    (if Arch.big_endian then hi else lo)
+    (if Arch.big_endian then lo else hi)
+
+let emit_float32_directive directive x =
+  emit_printf "\t%s\t0x%lx\n" directive x
+
+(* Record live pointers at call points *)
+
+type frame_descr =
+  { fd_lbl: int;                        (* Return address *)
+    fd_frame_size: int;                 (* Size of stack frame *)
+    fd_live_offset: int list;           (* Offsets/regs of live addresses *)
+    fd_raise: bool;                     (* Is frame for a raise? *)
+    fd_debuginfo: Debuginfo.t }         (* Location, if any *)
+
+let frame_descriptors = ref([] : frame_descr list)
+
+let record_frame_descr ~label ~frame_size ~live_offset ~raise_frame debuginfo =
+  frame_descriptors :=
+    { fd_lbl = label;
+      fd_frame_size = frame_size;
+      fd_live_offset = List.sort_uniq (-) live_offset;
+      fd_raise = raise_frame;
+      fd_debuginfo = debuginfo } :: !frame_descriptors
+
+type emit_frame_actions =
+  { efa_code_label: int -> unit;
+    efa_data_label: int -> unit;
+    efa_16: int -> unit;
+    efa_32: int32 -> unit;
+    efa_word: int -> unit;
+    efa_align: int -> unit;
+    efa_label_rel: int -> int32 -> unit;
+    efa_def_label: int -> unit;
+    efa_string: string -> unit }
+
+let emit_frames a =
+  let filenames = Hashtbl.create 7 in
+  let label_filename name =
+    try
+      Hashtbl.find filenames name
+    with Not_found ->
+      let lbl = Cmm.new_label () in
+      Hashtbl.add filenames name lbl;
+      lbl
+  in
+  let module Label_table =
+    Hashtbl.Make (struct
+      type t = bool * Debuginfo.t
+
+      let equal ((rs1 : bool), dbg1) (rs2, dbg2) =
+        rs1 = rs2 && Debuginfo.compare dbg1 dbg2 = 0
+
+      let hash (rs, dbg) =
+        Hashtbl.hash (rs, Debuginfo.hash dbg)
+    end)
+  in
+  let debuginfos = Label_table.create 7 in
+  let rec label_debuginfos rs rdbg =
+    let key = (rs, rdbg) in
+    try fst (Label_table.find debuginfos key)
+    with Not_found ->
+      let lbl = Cmm.new_label () in
+      let next =
+        match rdbg with
+        | [] -> assert false
+        | _ :: [] -> None
+        | _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg')
+      in
+      Label_table.add debuginfos key (lbl, next);
+      lbl
+  in
+  let emit_debuginfo_label rs rdbg =
+    a.efa_data_label (label_debuginfos rs rdbg)
+  in
+  let emit_frame fd =
+    a.efa_code_label fd.fd_lbl;
+    a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo
+              then fd.fd_frame_size
+              else fd.fd_frame_size + 1);
+    a.efa_16 (List.length fd.fd_live_offset);
+    List.iter a.efa_16 fd.fd_live_offset;
+    a.efa_align Arch.size_addr;
+    match List.rev fd.fd_debuginfo with
+    | [] -> ()
+    | _ :: _ as rdbg -> emit_debuginfo_label fd.fd_raise rdbg
+  in
+  let emit_filename name lbl =
+    a.efa_def_label lbl;
+    a.efa_string name;
+    a.efa_align Arch.size_addr
+  in
+  let pack_info fd_raise d =
+    let line = min 0xFFFFF d.Debuginfo.dinfo_line
+    and char_start = min 0xFF d.Debuginfo.dinfo_char_start
+    and char_end = min 0x3FF d.Debuginfo.dinfo_char_end
+    and kind = if fd_raise then 1 else 0 in
+    Int64.(add (shift_left (of_int line) 44)
+             (add (shift_left (of_int char_start) 36)
+                (add (shift_left (of_int char_end) 26)
+                   (of_int kind))))
+  in
+  let emit_debuginfo (rs, rdbg) (lbl,next) =
+    let d = List.hd rdbg in
+    a.efa_align Arch.size_addr;
+    a.efa_def_label lbl;
+    let info = pack_info rs d in
+    a.efa_label_rel
+      (label_filename d.Debuginfo.dinfo_file)
+      (Int64.to_int32 info);
+    a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
+    begin match next with
+    | Some next -> a.efa_data_label next
+    | None -> a.efa_word 0
+    end
+  in
+  a.efa_word (List.length !frame_descriptors);
+  List.iter emit_frame !frame_descriptors;
+  Label_table.iter emit_debuginfo debuginfos;
+  Hashtbl.iter emit_filename filenames;
+  frame_descriptors := []
+
+(* Detection of functions that can be duplicated between a DLL and
+   the main program (PR#4690) *)
+
+let isprefix s1 s2 =
+  String.length s1 <= String.length s2
+  && String.sub s2 0 (String.length s1) = s1
+
+let is_generic_function name =
+  List.exists
+    (fun p -> isprefix p name)
+    ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
+
+(* CFI directives *)
+
+let is_cfi_enabled () =
+  Config.asm_cfi_supported
+
+let cfi_startproc () =
+  if is_cfi_enabled () then
+    emit_string "\t.cfi_startproc\n"
+
+let cfi_endproc () =
+  if is_cfi_enabled () then
+    emit_string "\t.cfi_endproc\n"
+
+let cfi_adjust_cfa_offset n =
+  if is_cfi_enabled () then
+  begin
+    emit_string "\t.cfi_adjust_cfa_offset\t"; emit_int n; emit_string "\n";
+  end
+
+let cfi_offset ~reg ~offset =
+  if is_cfi_enabled () then begin
+    emit_string "\t.cfi_offset ";
+    emit_int reg;
+    emit_string ", ";
+    emit_int offset;
+    emit_string "\n"
+  end
+
+(* Emit debug information *)
+
+(* This assoc list is expected to be very short *)
+let file_pos_nums =
+  (ref [] : (string * int) list ref)
+
+(* Number of files *)
+let file_pos_num_cnt = ref 1
+
+(* Reset debug state at beginning of asm file *)
+let reset_debug_info () =
+  file_pos_nums := [];
+  file_pos_num_cnt := 1
+
+(* We only diplay .file if the file has not been seen before. We
+   display .loc for every instruction. *)
+let emit_debug_info_gen dbg file_emitter loc_emitter =
+  if is_cfi_enabled () &&
+    (!Clflags.debug || Config.with_frame_pointers) then begin
+    match List.rev dbg with
+    | [] -> ()
+    | { Debuginfo.dinfo_line = line;
+        dinfo_char_start = col;
+        dinfo_file = file_name; } :: _ ->
+      if line > 0 then begin (* PR#6243 *)
+        let file_num =
+          try List.assoc file_name !file_pos_nums
+          with Not_found ->
+            let file_num = !file_pos_num_cnt in
+            incr file_pos_num_cnt;
+            file_emitter ~file_num ~file_name;
+            file_pos_nums := (file_name,file_num) :: !file_pos_nums;
+            file_num in
+        loc_emitter ~file_num ~line ~col;
+      end
+  end
+
+let emit_debug_info dbg =
+  emit_debug_info_gen dbg (fun ~file_num ~file_name ->
+      emit_string "\t.file\t";
+      emit_int file_num; emit_char '\t';
+      emit_string_literal file_name; emit_char '\n';
+    )
+    (fun ~file_num ~line ~col:_ ->
+       emit_string "\t.loc\t";
+       emit_int file_num; emit_char '\t';
+       emit_int line; emit_char '\n')
+
+let reset () =
+  reset_debug_info ();
+  frame_descriptors := []
+
+let binary_backend_available = ref false
+let create_asm_file = ref true
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
new file mode 100644
index 00000000..b2b2141c
--- /dev/null
+++ b/asmcomp/emitaux.mli
@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Common functions for emitting assembly code *)
+
+val output_channel: out_channel ref
+val emit_string: string -> unit
+val emit_int: int -> unit
+val emit_nativeint: nativeint -> unit
+val emit_int32: int32 -> unit
+val emit_symbol: char -> string -> unit
+val emit_printf: ('a, out_channel, unit) format -> 'a
+val emit_char: char -> unit
+val emit_string_literal: string -> unit
+val emit_string_directive: string -> string -> unit
+val emit_bytes_directive: string -> string -> unit
+val emit_float64_directive: string -> int64 -> unit
+val emit_float64_split_directive: string -> int64 -> unit
+val emit_float32_directive: string -> int32 -> unit
+
+val reset : unit -> unit
+val reset_debug_info: unit -> unit
+val emit_debug_info: Debuginfo.t -> unit
+val emit_debug_info_gen :
+  Debuginfo.t ->
+  (file_num:int -> file_name:string -> unit) ->
+  (file_num:int -> line:int -> col:int -> unit) -> unit
+
+val record_frame_descr :
+  label:int ->              (* Return address *)
+  frame_size:int ->         (* Size of stack frame *)
+  live_offset:int list ->   (* Offsets/regs of live addresses *)
+  raise_frame:bool ->       (* Is frame for a raise? *)
+  Debuginfo.t ->            (* Location, if any *)
+  unit
+
+type emit_frame_actions =
+  { efa_code_label: int -> unit;
+    efa_data_label: int -> unit;
+    efa_16: int -> unit;
+    efa_32: int32 -> unit;
+    efa_word: int -> unit;
+    efa_align: int -> unit;
+    efa_label_rel: int -> int32 -> unit;
+    efa_def_label: int -> unit;
+    efa_string: string -> unit }
+
+val emit_frames: emit_frame_actions -> unit
+
+val is_generic_function: string -> bool
+
+val cfi_startproc : unit -> unit
+val cfi_endproc : unit -> unit
+val cfi_adjust_cfa_offset : int -> unit
+val cfi_offset : reg:int -> offset:int -> unit
+
+
+val binary_backend_available: bool ref
+    (** Is a binary backend available.  If yes, we don't need
+        to generate the textual assembly file (unless the user
+        request it with -S). *)
+
+val create_asm_file: bool ref
+    (** Are we actually generating the textual assembly file? *)
diff --git a/asmcomp/export_info.ml b/asmcomp/export_info.ml
new file mode 100644
index 00000000..82123a92
--- /dev/null
+++ b/asmcomp/export_info.ml
@@ -0,0 +1,360 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type value_string_contents =
+  | Contents of string
+  | Unknown_or_mutable
+
+type value_string = {
+  contents : value_string_contents;
+  size : int;
+}
+
+type value_float_array_contents =
+  | Contents of float option array
+  | Unknown_or_mutable
+
+type value_float_array = {
+  contents : value_float_array_contents;
+  size : int;
+}
+
+type descr =
+  | Value_block of Tag.t * approx array
+  | Value_mutable_block of Tag.t * int
+  | Value_int of int
+  | Value_char of char
+  | Value_constptr of int
+  | Value_float of float
+  | Value_float_array of value_float_array
+  | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
+  | Value_string of value_string
+  | Value_closure of value_closure
+  | Value_set_of_closures of value_set_of_closures
+
+and value_closure = {
+  closure_id : Closure_id.t;
+  set_of_closures : value_set_of_closures;
+}
+
+and value_set_of_closures = {
+  set_of_closures_id : Set_of_closures_id.t;
+  bound_vars : approx Var_within_closure.Map.t;
+  results : approx Closure_id.Map.t;
+  aliased_symbol : Symbol.t option;
+}
+
+and approx =
+  | Value_unknown
+  | Value_id of Export_id.t
+  | Value_symbol of Symbol.t
+
+let equal_approx (a1:approx) (a2:approx) =
+  match a1, a2 with
+  | Value_unknown, Value_unknown ->
+    true
+  | Value_id id1, Value_id id2 ->
+    Export_id.equal id1 id2
+  | Value_symbol s1, Value_symbol s2 ->
+    Symbol.equal s1 s2
+  | (Value_unknown | Value_symbol _ | Value_id _),
+    (Value_unknown | Value_symbol _ | Value_id _) ->
+    false
+
+let equal_array eq a1 a2 =
+  Array.length a1 = Array.length a2 &&
+  try
+    Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1;
+    true
+  with Exit -> false
+
+let equal_option eq o1 o2 =
+  match o1, o2 with
+  | None, None -> true
+  | Some v1, Some v2 -> eq v1 v2
+  | Some _, None | None, Some _ -> false
+
+let equal_set_of_closures (s1:value_set_of_closures)
+      (s2:value_set_of_closures) =
+  Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id &&
+  Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars &&
+  Closure_id.Map.equal equal_approx s1.results s2.results &&
+  equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol
+
+let equal_descr (d1:descr) (d2:descr) : bool =
+  match d1, d2 with
+  | Value_block (t1, f1), Value_block (t2, f2) ->
+    Tag.equal t1 t2 && equal_array equal_approx f1 f2
+  | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) ->
+    Tag.equal t1 t2 &&
+    s1 = s2
+  | Value_int i1, Value_int i2 ->
+    i1 = i2
+  | Value_char c1, Value_char c2 ->
+    c1 = c2
+  | Value_constptr i1, Value_constptr i2 ->
+    i1 = i2
+  | Value_float f1, Value_float f2 ->
+    f1 = f2
+  | Value_float_array s1, Value_float_array s2 ->
+    s1 = s2
+  | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) ->
+    Simple_value_approx.equal_boxed_int t1 v1 t2 v2
+  | Value_string s1, Value_string s2 ->
+    s1 = s2
+  | Value_closure c1, Value_closure c2 ->
+    Closure_id.equal c1.closure_id c2.closure_id &&
+    equal_set_of_closures c1.set_of_closures c2.set_of_closures
+  | Value_set_of_closures s1, Value_set_of_closures s2 ->
+    equal_set_of_closures s1 s2
+  | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
+    | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
+    | Value_boxed_int _ | Value_string _ | Value_closure _
+    | Value_set_of_closures _ ),
+    ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
+    | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
+    | Value_boxed_int _ | Value_string _ | Value_closure _
+    | Value_set_of_closures _ ) ->
+    false
+
+type t = {
+  sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
+  closures : Flambda.function_declarations Closure_id.Map.t;
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  symbol_id : Export_id.t Symbol.Map.t;
+  offset_fun : int Closure_id.Map.t;
+  offset_fv : int Var_within_closure.Map.t;
+  constant_sets_of_closures : Set_of_closures_id.Set.t;
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+}
+
+let empty : t = {
+  sets_of_closures = Set_of_closures_id.Map.empty;
+  closures = Closure_id.Map.empty;
+  values = Compilation_unit.Map.empty;
+  symbol_id = Symbol.Map.empty;
+  offset_fun = Closure_id.Map.empty;
+  offset_fv = Var_within_closure.Map.empty;
+  constant_sets_of_closures = Set_of_closures_id.Set.empty;
+  invariant_params = Set_of_closures_id.Map.empty;
+}
+
+let create ~sets_of_closures ~closures ~values ~symbol_id
+      ~offset_fun ~offset_fv ~constant_sets_of_closures
+      ~invariant_params =
+  { sets_of_closures;
+    closures;
+    values;
+    symbol_id;
+    offset_fun;
+    offset_fv;
+    constant_sets_of_closures;
+    invariant_params;
+  }
+
+let add_clambda_info t ~offset_fun ~offset_fv ~constant_sets_of_closures =
+  assert (Closure_id.Map.cardinal t.offset_fun = 0);
+  assert (Var_within_closure.Map.cardinal t.offset_fv = 0);
+  assert (Set_of_closures_id.Set.cardinal t.constant_sets_of_closures = 0);
+  { t with offset_fun; offset_fv; constant_sets_of_closures; }
+
+let merge (t1 : t) (t2 : t) : t =
+  let eidmap_disjoint_union ?eq map1 map2 =
+    Compilation_unit.Map.merge (fun _id map1 map2 ->
+        match map1, map2 with
+        | None, None -> None
+        | None, Some map
+        | Some map, None -> Some map
+        | Some map1, Some map2 ->
+          Some (Export_id.Map.disjoint_union ?eq map1 map2))
+      map1 map2
+  in
+  let int_eq (i : int) j = i = j in
+  { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values;
+    sets_of_closures =
+      Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
+        t2.sets_of_closures;
+    closures = Closure_id.Map.disjoint_union t1.closures t2.closures;
+    symbol_id = Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id t2.symbol_id;
+    offset_fun = Closure_id.Map.disjoint_union
+        ~eq:int_eq t1.offset_fun t2.offset_fun;
+    offset_fv = Var_within_closure.Map.disjoint_union
+        ~eq:int_eq t1.offset_fv t2.offset_fv;
+    constant_sets_of_closures =
+      Set_of_closures_id.Set.union t1.constant_sets_of_closures
+        t2.constant_sets_of_closures;
+    invariant_params =
+      Set_of_closures_id.Map.disjoint_union
+        ~print:(Variable.Map.print Variable.Set.print)
+        ~eq:(Variable.Map.equal Variable.Set.equal)
+        t1.invariant_params t2.invariant_params;
+  }
+
+let find_value eid map =
+  let unit_map =
+    Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map
+  in
+  Export_id.Map.find eid unit_map
+
+let find_description (t : t) eid =
+  find_value eid t.values
+
+let nest_eid_map map =
+  let add_map eid v map =
+    let unit = Export_id.get_compilation_unit eid in
+    let m =
+      try Compilation_unit.Map.find unit map
+      with Not_found -> Export_id.Map.empty
+    in
+    Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map
+  in
+  Export_id.Map.fold add_map map Compilation_unit.Map.empty
+
+let print_approx ppf ((t,root_symbols) : t * Symbol.t list) =
+  let values = t.values in
+  let fprintf = Format.fprintf in
+  let printed = ref Export_id.Set.empty in
+  let recorded_symbol = ref Symbol.Set.empty in
+  let symbols_to_print = Queue.create () in
+  let printed_set_of_closures = ref Set_of_closures_id.Set.empty in
+  let rec print_approx ppf (approx : approx) =
+    match approx with
+    | Value_unknown -> fprintf ppf "?"
+    | Value_id id ->
+      if Export_id.Set.mem id !printed then
+        fprintf ppf "(%a: _)" Export_id.print id
+      else begin
+        try
+          let descr = find_value id values in
+          printed := Export_id.Set.add id !printed;
+          fprintf ppf "@[(%a:@ %a)@]"
+            Export_id.print id print_descr descr
+        with Not_found ->
+          fprintf ppf "(%a: Not available)" Export_id.print id
+      end
+    | Value_symbol sym ->
+      if not (Symbol.Set.mem sym !recorded_symbol) then begin
+        recorded_symbol := Symbol.Set.add sym !recorded_symbol;
+        Queue.push sym symbols_to_print;
+      end;
+      Symbol.print ppf sym
+  and print_descr ppf (descr : descr) =
+    match descr with
+    | Value_int i -> Format.pp_print_int ppf i
+    | Value_char c -> fprintf ppf "%c" c
+    | Value_constptr i -> fprintf ppf "%ip" i
+    | Value_block (tag, fields) ->
+      fprintf ppf "[%a:%a]" Tag.print tag print_fields fields
+    | Value_mutable_block (tag, size) ->
+      fprintf ppf "[mutable %a:%i]" Tag.print tag size
+    | Value_closure {closure_id; set_of_closures} ->
+      fprintf ppf "(closure %a, %a)" Closure_id.print closure_id
+        print_set_of_closures set_of_closures
+    | Value_set_of_closures set_of_closures ->
+      fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures
+    | Value_string { contents; size } ->
+      begin match contents with
+      | Unknown_or_mutable -> Format.fprintf ppf "string %i" size
+      | Contents s ->
+        let s =
+          if size > 10
+          then String.sub s 0 8 ^ "..."
+          else s
+        in
+        Format.fprintf ppf "string %i %S" size s
+      end
+    | Value_float f -> Format.pp_print_float ppf f
+    | Value_float_array float_array ->
+      Format.fprintf ppf "float_array%s %i"
+        (match float_array.contents with
+          | Unknown_or_mutable -> ""
+          | Contents _ -> "_imm")
+        float_array.size
+    | Value_boxed_int (t, i) ->
+      let module A = Simple_value_approx in
+      match t with
+      | A.Int32 -> Format.fprintf ppf "%li" i
+      | A.Int64 -> Format.fprintf ppf "%Li" i
+      | A.Nativeint -> Format.fprintf ppf "%ni" i
+  and print_fields ppf fields =
+    Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields
+  and print_set_of_closures ppf
+      { set_of_closures_id; bound_vars; aliased_symbol; results } =
+    if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures
+    then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id
+    else begin
+      printed_set_of_closures :=
+        Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures;
+      let print_alias ppf = function
+        | None -> ()
+        | Some symbol ->
+          Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol
+      in
+      fprintf ppf "{%a: %a%a => %a}"
+        Set_of_closures_id.print set_of_closures_id
+        print_binding bound_vars
+        print_alias aliased_symbol
+        (Closure_id.Map.print print_approx) results
+    end
+  and print_binding ppf bound_vars =
+    Var_within_closure.Map.iter (fun clos_id approx ->
+        fprintf ppf "%a -> %a,@ "
+          Var_within_closure.print clos_id
+          print_approx approx)
+      bound_vars
+  in
+  let rec print_recorded_symbols () =
+    if not (Queue.is_empty symbols_to_print) then begin
+      let sym = Queue.pop symbols_to_print in
+      begin match Symbol.Map.find sym t.symbol_id with
+      | exception Not_found -> ()
+      | id ->
+        fprintf ppf "@[%a:@ %a@];@ "
+          Symbol.print sym
+          print_approx (Value_id id)
+      end;
+      print_recorded_symbols ();
+    end
+  in
+  List.iter (fun s -> Queue.push s symbols_to_print) root_symbols;
+  fprintf ppf "@[Globals:@ ";
+  fprintf ppf "@]@ @[Symbols:@ ";
+  print_recorded_symbols ();
+  fprintf ppf "@]"
+
+let print_offsets ppf (t : t) =
+  Format.fprintf ppf "@[offset_fun:@ ";
+  Closure_id.Map.iter (fun cid off ->
+      Format.fprintf ppf "%a -> %i@ "
+        Closure_id.print cid off) t.offset_fun;
+  Format.fprintf ppf "@]@ @[offset_fv:@ ";
+  Var_within_closure.Map.iter (fun vid off ->
+      Format.fprintf ppf "%a -> %i@ "
+        Var_within_closure.print vid off) t.offset_fv;
+  Format.fprintf ppf "@]@ "
+
+let print_functions ppf (t : t) =
+  Set_of_closures_id.Map.print Flambda.print_function_declarations ppf
+    t.sets_of_closures
+
+let print_all ppf ((t, root_symbols) : t * Symbol.t list) =
+  let fprintf = Format.fprintf in
+  fprintf ppf "approxs@ %a@.@."
+    print_approx (t, root_symbols);
+  fprintf ppf "functions@ %a@.@."
+    print_functions t
diff --git a/asmcomp/export_info.mli b/asmcomp/export_info.mli
new file mode 100644
index 00000000..d6fbd7ae
--- /dev/null
+++ b/asmcomp/export_info.mli
@@ -0,0 +1,149 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Exported information (that is to say, information written into a .cmx
+    file) about a compilation unit. *)
+
+type value_string_contents =
+  | Contents of string
+  | Unknown_or_mutable
+
+type value_string = {
+  contents : value_string_contents;
+  size : int;
+}
+
+type value_float_array_contents =
+  | Contents of float option array
+  | Unknown_or_mutable
+
+type value_float_array = {
+  contents : value_float_array_contents;
+  size : int;
+}
+
+type descr =
+  | Value_block of Tag.t * approx array
+  | Value_mutable_block of Tag.t * int
+  | Value_int of int
+  | Value_char of char
+  | Value_constptr of int
+  | Value_float of float
+  | Value_float_array of value_float_array
+  | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
+  | Value_string of value_string
+  | Value_closure of value_closure
+  | Value_set_of_closures of value_set_of_closures
+
+and value_closure = {
+  closure_id : Closure_id.t;
+  set_of_closures : value_set_of_closures;
+}
+
+and value_set_of_closures = {
+  set_of_closures_id : Set_of_closures_id.t;
+  bound_vars : approx Var_within_closure.Map.t;
+  results : approx Closure_id.Map.t;
+  aliased_symbol : Symbol.t option;
+}
+
+(* CR-soon mshinwell: Fix the export information so we can correctly
+   propagate "unresolved due to..." in the manner of [Simple_value_approx].
+   Unfortunately this seems to be complicated by the fact that, during
+   [Import_approx], resolution can fail not only due to missing symbols but
+   also due to missing export IDs.  The argument type of
+   [Simple_value_approx.t] may need updating to reflect this (make the
+   symbol optional?  It's only for debugging anyway.) *)
+and approx =
+  | Value_unknown
+  | Value_id of Export_id.t
+  | Value_symbol of Symbol.t
+
+(** A structure that describes what a single compilation unit exports. *)
+type t = private {
+  sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
+  (** Code of exported functions indexed by set of closures IDs. *)
+  closures : Flambda.function_declarations Closure_id.Map.t;
+  (** Code of exported functions indexed by closure IDs. *)
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  (** Structure of exported values. *)
+  symbol_id : Export_id.t Symbol.Map.t;
+  (** Associates symbols and values. *)
+  offset_fun : int Closure_id.Map.t;
+  (** Positions of function pointers in their closures. *)
+  offset_fv : int Var_within_closure.Map.t;
+  (** Positions of value pointers in their closures. *)
+  constant_sets_of_closures : Set_of_closures_id.Set.t;
+  (* CR-soon mshinwell for pchambart: Add comment *)
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+  (* Function parameters known to be invariant (see [Invariant_params])
+     indexed by set of closures ID. *)
+}
+
+(** Export information for a compilation unit that exports nothing. *)
+val empty : t
+
+(** Create a new export information structure. *)
+val create
+   : sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t
+  -> closures:Flambda.function_declarations Closure_id.Map.t
+  -> values:descr Export_id.Map.t Compilation_unit.Map.t
+  -> symbol_id:Export_id.t Symbol.Map.t
+  -> offset_fun:int Closure_id.Map.t
+  -> offset_fv:int Var_within_closure.Map.t
+  -> constant_sets_of_closures:Set_of_closures_id.Set.t
+  -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
+  -> t
+
+(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the
+   current [create] function, returned by [Build_export_info]. And
+   another built using t and offset_informations returned by
+   [flambda_to_clambda] ?
+   mshinwell: I think we should, but after we've done the first release.
+*)
+(** Record information about the layout of closures and which sets of
+    closures are constant.  These are all worked out during the
+    [Flambda_to_clambda] pass. *)
+val add_clambda_info
+   : t
+  -> offset_fun:int Closure_id.Map.t
+  -> offset_fv:int Var_within_closure.Map.t
+  -> constant_sets_of_closures:Set_of_closures_id.Set.t
+  -> t
+
+(** Union of export information.  Verifies that there are no identifier
+    clashes. *)
+val merge : t -> t -> t
+
+(** Look up the description of an exported value given its export ID. *)
+val find_description
+   : t
+  -> Export_id.t
+  -> descr
+
+(** Partition a mapping from export IDs by compilation unit. *)
+val nest_eid_map
+   : 'a Export_id.Map.t
+  -> 'a Export_id.Map.t Compilation_unit.Map.t
+
+(**/**)
+(* Debug printing functions. *)
+val print_approx : Format.formatter -> t * Symbol.t list -> unit
+val print_functions : Format.formatter -> t -> unit
+val print_offsets : Format.formatter -> t -> unit
+val print_all : Format.formatter -> t * Symbol.t list -> unit
diff --git a/asmcomp/export_info_for_pack.ml b/asmcomp/export_info_for_pack.ml
new file mode 100644
index 00000000..da413408
--- /dev/null
+++ b/asmcomp/export_info_for_pack.ml
@@ -0,0 +1,211 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+let rename_id_state = Export_id.Tbl.create 100
+let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10
+let imported_function_declarations_table =
+  (Set_of_closures_id.Tbl.create 10
+   : Flambda.function_declarations Set_of_closures_id.Tbl.t)
+
+(* Rename export identifiers' compilation units to denote that they now
+   live within a pack. *)
+let import_eid_for_pack units pack id =
+  try Export_id.Tbl.find rename_id_state id
+  with Not_found ->
+    let unit_id = Export_id.get_compilation_unit id in
+    let id' =
+      if Compilation_unit.Set.mem unit_id units
+      then Export_id.create ?name:(Export_id.name id) pack
+      else id
+    in
+    Export_id.Tbl.add rename_id_state id id';
+    id'
+
+(* Similar to [import_eid_for_pack], but for symbols. *)
+let import_symbol_for_pack units pack symbol =
+  let compilation_unit = Symbol.compilation_unit symbol in
+  if Compilation_unit.Set.mem compilation_unit units
+  then Symbol.import_for_pack ~pack symbol
+  else symbol
+
+let import_approx_for_pack units pack (approx : Export_info.approx)
+      : Export_info.approx =
+  match approx with
+  | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym)
+  | Value_id eid -> Value_id (import_eid_for_pack units pack eid)
+  | Value_unknown -> Value_unknown
+
+let import_set_of_closures_id_for_pack units pack
+    (set_of_closures_id : Set_of_closures_id.t)
+      : Set_of_closures_id.t =
+  let compilation_unit =
+    Set_of_closures_id.get_compilation_unit set_of_closures_id
+  in
+  if Compilation_unit.Set.mem compilation_unit units then
+    Set_of_closures_id.Tbl.memoize
+      rename_set_of_closures_id_state
+      (fun _ ->
+         Set_of_closures_id.create
+           ?name:(Set_of_closures_id.name set_of_closures_id)
+           pack)
+      set_of_closures_id
+  else set_of_closures_id
+
+let import_set_of_closures_origin_for_pack units pack
+    (set_of_closures_origin : Set_of_closures_origin.t)
+    : Set_of_closures_origin.t =
+  Set_of_closures_origin.rename
+    (import_set_of_closures_id_for_pack units pack)
+    set_of_closures_origin
+
+let import_set_of_closures units pack
+      (set_of_closures : Export_info.value_set_of_closures)
+      : Export_info.value_set_of_closures =
+  { set_of_closures_id =
+      import_set_of_closures_id_for_pack units pack
+        set_of_closures.set_of_closures_id;
+    bound_vars =
+      Var_within_closure.Map.map (import_approx_for_pack units pack)
+        set_of_closures.bound_vars;
+    results =
+      Closure_id.Map.map (import_approx_for_pack units pack)
+        set_of_closures.results;
+    aliased_symbol =
+      Misc.may_map
+        (import_symbol_for_pack units pack)
+        set_of_closures.aliased_symbol;
+  }
+
+let import_descr_for_pack units pack (descr : Export_info.descr)
+      : Export_info.descr =
+  match descr with
+  | Value_int _
+  | Value_char _
+  | Value_constptr _
+  | Value_string _
+  | Value_float _
+  | Value_float_array _
+  | Export_info.Value_boxed_int _
+  | Value_mutable_block _ as desc -> desc
+  | Value_block (tag, fields) ->
+    Value_block (tag, Array.map (import_approx_for_pack units pack) fields)
+  | Value_closure { closure_id; set_of_closures } ->
+    Value_closure {
+      closure_id;
+      set_of_closures = import_set_of_closures units pack set_of_closures;
+    }
+  | Value_set_of_closures set_of_closures ->
+    Value_set_of_closures (import_set_of_closures units pack set_of_closures)
+
+let rec import_code_for_pack units pack expr =
+  Flambda_iterators.map_named (function
+      | Symbol sym -> Symbol (import_symbol_for_pack units pack sym)
+      | Read_symbol_field (sym, field) ->
+        Read_symbol_field (import_symbol_for_pack units pack sym, field)
+      | Set_of_closures set_of_closures ->
+        let set_of_closures =
+          Flambda.create_set_of_closures
+            ~free_vars:set_of_closures.free_vars
+            ~specialised_args:set_of_closures.specialised_args
+            ~direct_call_surrogates:set_of_closures.direct_call_surrogates
+            ~function_decls:
+              (import_function_declarations_for_pack units pack
+                 set_of_closures.function_decls)
+        in
+        Set_of_closures set_of_closures
+      | e -> e)
+    expr
+
+and import_function_declarations_for_pack_aux units pack
+      (function_decls : Flambda.function_declarations) =
+  let funs =
+    Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+        Flambda.create_function_declaration ~params:function_decl.params
+          ~body:(import_code_for_pack units pack function_decl.body)
+          ~stub:function_decl.stub ~dbg:function_decl.dbg
+          ~inline:function_decl.inline
+          ~specialise:function_decl.specialise
+          ~is_a_functor:function_decl.is_a_functor)
+      function_decls.funs
+  in
+  Flambda.import_function_declarations_for_pack
+    (Flambda.update_function_declarations function_decls ~funs)
+    (import_set_of_closures_id_for_pack units pack)
+    (import_set_of_closures_origin_for_pack units pack)
+
+and import_function_declarations_for_pack units pack
+    (function_decls:Flambda.function_declarations) =
+  let original_set_of_closures_id = function_decls.set_of_closures_id in
+  try
+    Set_of_closures_id.Tbl.find imported_function_declarations_table
+      original_set_of_closures_id
+  with Not_found ->
+    let function_decls =
+      import_function_declarations_for_pack_aux units pack function_decls
+    in
+    Set_of_closures_id.Tbl.add
+      imported_function_declarations_table
+      original_set_of_closures_id
+      function_decls;
+    function_decls
+
+let import_eidmap_for_pack units pack f map =
+  Export_info.nest_eid_map
+    (Compilation_unit.Map.fold
+      (fun _ map acc -> Export_id.Map.disjoint_union map acc)
+      (Compilation_unit.Map.map (fun map ->
+          Export_id.Map.map_keys (import_eid_for_pack units pack)
+            (Export_id.Map.map f map))
+        map)
+      Export_id.Map.empty)
+
+let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
+  let import_sym = import_symbol_for_pack pack_units pack in
+  let import_descr = import_descr_for_pack pack_units pack in
+  let import_eid = import_eid_for_pack pack_units pack in
+  let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in
+  let import_set_of_closures_id =
+    import_set_of_closures_id_for_pack pack_units pack
+  in
+  let import_function_declarations =
+    import_function_declarations_for_pack pack_units pack
+  in
+  let sets_of_closures =
+    Set_of_closures_id.Map.map_keys import_set_of_closures_id
+      (Set_of_closures_id.Map.map
+         import_function_declarations
+         exp.sets_of_closures)
+  in
+  Export_info.create ~sets_of_closures
+    ~closures:(Flambda_utils.make_closure_map' sets_of_closures)
+    ~offset_fun:exp.offset_fun
+    ~offset_fv:exp.offset_fv
+    ~values:(import_eidmap import_descr exp.values)
+    ~symbol_id:(Symbol.Map.map_keys import_sym
+      (Symbol.Map.map import_eid exp.symbol_id))
+    ~constant_sets_of_closures:
+      (Set_of_closures_id.Set.map import_set_of_closures_id
+         exp.constant_sets_of_closures)
+    ~invariant_params:
+      (Set_of_closures_id.Map.map_keys import_set_of_closures_id
+         exp.invariant_params)
+
+let clear_import_state () =
+  Set_of_closures_id.Tbl.clear imported_function_declarations_table;
+  Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state;
+  Export_id.Tbl.clear rename_id_state
diff --git a/asmcomp/export_info_for_pack.mli b/asmcomp/export_info_for_pack.mli
new file mode 100644
index 00000000..2ba3a35d
--- /dev/null
+++ b/asmcomp/export_info_for_pack.mli
@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Transformations on export information that are only used for the
+    building of packs. *)
+
+(** Transform the information from [exported] to be
+    suitable to be reexported as the information for a pack named [pack]
+    containing units [pack_units].
+    It mainly changes symbols of units [pack_units] to refer to
+    [pack] instead. *)
+val import_for_pack
+   : pack_units:Compilation_unit.Set.t
+  -> pack:Compilation_unit.t
+  -> Export_info.t
+  -> Export_info.t
+
+(** Drops the state after importing several units in the same pack. *)
+val clear_import_state : unit -> unit
diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml
new file mode 100644
index 00000000..01a6be7d
--- /dev/null
+++ b/asmcomp/flambda_to_clambda.ml
@@ -0,0 +1,694 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type for_one_or_more_units = {
+  fun_offset_table : int Closure_id.Map.t;
+  fv_offset_table : int Var_within_closure.Map.t;
+  closures : Flambda.function_declarations Closure_id.Map.t;
+  constant_sets_of_closures : Set_of_closures_id.Set.t;
+}
+
+type t = {
+  current_unit : for_one_or_more_units;
+  imported_units : for_one_or_more_units;
+}
+
+type ('a, 'b) declaration_position =
+  | Current_unit of 'a
+  | Imported_unit of 'b
+  | Not_declared
+
+let get_fun_offset t closure_id =
+  let fun_offset_table =
+    if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ())
+    then t.current_unit.fun_offset_table
+    else t.imported_units.fun_offset_table
+  in
+  try Closure_id.Map.find closure_id fun_offset_table
+  with Not_found ->
+    Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a"
+      Closure_id.print closure_id
+
+let get_fv_offset t var_within_closure =
+  let fv_offset_table =
+    if Var_within_closure.in_compilation_unit var_within_closure
+        (Compilenv.current_unit ())
+    then t.current_unit.fv_offset_table
+    else t.imported_units.fv_offset_table
+  in
+  try Var_within_closure.Map.find var_within_closure fv_offset_table
+  with Not_found ->
+    Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a"
+      Var_within_closure.print var_within_closure
+
+let function_declaration_position t closure_id =
+  try
+    Current_unit (Closure_id.Map.find closure_id t.current_unit.closures)
+  with Not_found ->
+    try
+      Imported_unit (Closure_id.Map.find closure_id t.imported_units.closures)
+    with Not_found -> Not_declared
+
+let is_function_constant t closure_id =
+  match function_declaration_position t closure_id with
+  | Current_unit { set_of_closures_id } ->
+    Set_of_closures_id.Set.mem set_of_closures_id
+      t.current_unit.constant_sets_of_closures
+  | Imported_unit { set_of_closures_id } ->
+    Set_of_closures_id.Set.mem set_of_closures_id
+      t.imported_units.constant_sets_of_closures
+  | Not_declared ->
+    Misc.fatal_errorf "Flambda_to_clambda: missing closure %a"
+      Closure_id.print closure_id
+
+(* Instrumentation of closure and field accesses to try to catch compiler
+   bugs. *)
+
+let check_closure ulam named : Clambda.ulambda =
+  if not !Clflags.clambda_checks then ulam
+  else
+    let desc =
+      Primitive.simple ~name:"caml_check_value_is_closure"
+        ~arity:2 ~alloc:false
+    in
+    let str = Format.asprintf "%a" Flambda.print_named named in
+    let str_const =
+      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    in
+    Uprim (Pccall desc,
+           [ulam; Clambda.Uconst (Uconst_ref (str_const, None))],
+           Debuginfo.none)
+
+let check_field ulam pos named_opt : Clambda.ulambda =
+  if not !Clflags.clambda_checks then ulam
+  else
+    let desc =
+      Primitive.simple ~name:"caml_check_field_access"
+        ~arity:3 ~alloc:false
+    in
+    let str =
+      match named_opt with
+      | None -> ""
+      | Some named -> Format.asprintf "%a" Flambda.print_named named
+    in
+    let str_const =
+      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    in
+    Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos);
+        Clambda.Uconst (Uconst_ref (str_const, None))],
+      Debuginfo.none)
+
+module Env : sig
+  type t
+
+  val empty : t
+
+  val add_subst : t -> Variable.t -> Clambda.ulambda -> t
+  val find_subst_exn : t -> Variable.t -> Clambda.ulambda
+
+  val add_fresh_ident : t -> Variable.t -> Ident.t * t
+  val ident_for_var_exn : t -> Variable.t -> Ident.t
+
+  val add_fresh_mutable_ident : t -> Mutable_variable.t -> Ident.t * t
+  val ident_for_mutable_var_exn : t -> Mutable_variable.t -> Ident.t
+
+  val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t
+  val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option
+
+  val keep_only_symbols : t -> t
+end = struct
+  type t =
+    { subst : Clambda.ulambda Variable.Map.t;
+      var : Ident.t Variable.Map.t;
+      mutable_var : Ident.t Mutable_variable.Map.t;
+      toplevel : bool;
+      allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t;
+    }
+
+  let empty =
+    { subst = Variable.Map.empty;
+      var = Variable.Map.empty;
+      mutable_var = Mutable_variable.Map.empty;
+      toplevel = false;
+      allocated_constant_for_symbol = Symbol.Map.empty;
+    }
+
+  let add_subst t id subst =
+    { t with subst = Variable.Map.add id subst t.subst }
+
+  let find_subst_exn t id = Variable.Map.find id t.subst
+
+  let ident_for_var_exn t id = Variable.Map.find id t.var
+
+  let add_fresh_ident t var =
+    let id = Ident.create (Variable.unique_name var) in
+    id, { t with var = Variable.Map.add var id t.var }
+
+  let ident_for_mutable_var_exn t mut_var =
+    Mutable_variable.Map.find mut_var t.mutable_var
+
+  let add_fresh_mutable_ident t mut_var =
+    let id = Mutable_variable.unique_ident mut_var in
+    let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in
+    id, { t with mutable_var; }
+
+  let add_allocated_const t sym cons =
+    { t with
+      allocated_constant_for_symbol =
+        Symbol.Map.add sym cons t.allocated_constant_for_symbol;
+    }
+
+  let allocated_const_for_symbol t sym =
+    try
+      Some (Symbol.Map.find sym t.allocated_constant_for_symbol)
+    with Not_found -> None
+
+  let keep_only_symbols t =
+    { empty with
+      allocated_constant_for_symbol = t.allocated_constant_for_symbol;
+    }
+end
+
+let subst_var env var : Clambda.ulambda =
+  try Env.find_subst_exn env var
+  with Not_found ->
+    try Uvar (Env.ident_for_var_exn env var)
+    with Not_found ->
+      Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@."
+        Variable.print var
+
+let subst_vars env vars = List.map (subst_var env) vars
+
+let build_uoffset ulam offset : Clambda.ulambda =
+  if offset = 0 then ulam
+  else Uoffset (ulam, offset)
+
+let to_clambda_allocated_constant (const : Allocated_const.t)
+      : Clambda.ustructured_constant =
+  match const with
+  | Float f -> Uconst_float f
+  | Int32 i -> Uconst_int32 i
+  | Int64 i -> Uconst_int64 i
+  | Nativeint i -> Uconst_nativeint i
+  | Immutable_string s | String s -> Uconst_string s
+  | Immutable_float_array a | Float_array a -> Uconst_float_array a
+
+let to_uconst_symbol env symbol : Clambda.ustructured_constant option =
+  match Env.allocated_const_for_symbol env symbol with
+  | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) ->
+    Some (to_clambda_allocated_constant const)
+  | None  (* CR-soon mshinwell: Try to make this an error. *)
+  | Some _ -> None
+
+let to_clambda_symbol' env sym : Clambda.uconstant =
+  let lbl = Linkage_name.to_string (Symbol.label sym) in
+  Uconst_ref (lbl, to_uconst_symbol env sym)
+
+let to_clambda_symbol env sym : Clambda.ulambda =
+  Uconst (to_clambda_symbol' env sym)
+
+let to_clambda_const env (const : Flambda.constant_defining_value_block_field)
+      : Clambda.uconstant =
+  match const with
+  | Symbol symbol -> to_clambda_symbol' env symbol
+  | Const (Int i) -> Uconst_int i
+  | Const (Char c) -> Uconst_int (Char.code c)
+  | Const (Const_pointer i) -> Uconst_ptr i
+
+let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
+  match flam with
+  | Var var -> subst_var env var
+  | Let { var; defining_expr; body; _ } ->
+    (* TODO: synthesize proper value_kind *)
+    let id, env_body = Env.add_fresh_ident env var in
+    Ulet (Immutable, Pgenval, id, to_clambda_named t env var defining_expr,
+      to_clambda t env_body body)
+  | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } ->
+    let id, env_body = Env.add_fresh_mutable_ident env mut_var in
+    let def = subst_var env var in
+    Ulet (Mutable, contents_kind, id, def, to_clambda t env_body body)
+  | Let_rec (defs, body) ->
+    let env, defs =
+      List.fold_right (fun (var, def) (env, defs) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, (id, var, def) :: defs)
+        defs (env, [])
+    in
+    let defs =
+      List.map (fun (id, var, def) -> id, to_clambda_named t env var def) defs
+    in
+    Uletrec (defs, to_clambda t env body)
+  | Apply { func; args; kind = Direct direct_func; dbg = dbg } ->
+    (* The closure _parameter_ of the function is added by cmmgen.
+       At the call site, for a direct call, the closure argument must be
+       explicitly added (by [to_clambda_direct_apply]); there is no special
+       handling of such in the direct call primitive.
+       For an indirect call, we do not need to do anything here; Cmmgen will
+       do the equivalent of the previous paragraph when it generates a direct
+       call to [caml_apply]. *)
+    to_clambda_direct_apply t func args direct_func dbg env
+  | Apply { func; args; kind = Indirect; dbg = dbg } ->
+    let callee = subst_var env func in
+    Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)),
+      subst_vars env args, dbg)
+  | Switch (arg, sw) ->
+    let aux () : Clambda.ulambda =
+      let const_index, const_actions =
+        to_clambda_switch t env sw.consts sw.numconsts sw.failaction
+      in
+      let block_index, block_actions =
+        to_clambda_switch t env sw.blocks sw.numblocks sw.failaction
+      in
+      Uswitch (subst_var env arg,
+        { us_index_consts = const_index;
+          us_actions_consts = const_actions;
+          us_index_blocks = block_index;
+          us_actions_blocks = block_actions;
+        })
+    in
+    (* Check that the [failaction] may be duplicated.  If this is not the
+       case, share it through a static raise / static catch. *)
+    (* CR-someday pchambart for pchambart: This is overly simplified.
+       We should verify that this does not generates too bad code.
+       If it the case, handle some let cases.
+    *)
+    begin match sw.failaction with
+    | None -> aux ()
+    | Some (Static_raise _) -> aux ()
+    | Some failaction ->
+      let exn = Static_exception.create () in
+      let sw =
+        { sw with
+          failaction = Some (Flambda.Static_raise (exn, []));
+        }
+      in
+      let expr : Flambda.t =
+        Static_catch (exn, [], Switch (arg, sw), failaction)
+      in
+      to_clambda t env expr
+    end
+  | String_switch (arg, sw, def) ->
+    let arg = subst_var env arg in
+    let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in
+    let def = Misc.may_map (to_clambda t env) def in
+    Ustringswitch (arg, sw, def)
+  | Static_raise (static_exn, args) ->
+    Ustaticfail (Static_exception.to_int static_exn,
+      List.map (subst_var env) args)
+  | Static_catch (static_exn, vars, body, handler) ->
+    let env_handler, ids =
+      List.fold_right (fun var (env, ids) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, id :: ids)
+        vars (env, [])
+    in
+    Ucatch (Static_exception.to_int static_exn, ids,
+      to_clambda t env body, to_clambda t env_handler handler)
+  | Try_with (body, var, handler) ->
+    let id, env_handler = Env.add_fresh_ident env var in
+    Utrywith (to_clambda t env body, id, to_clambda t env_handler handler)
+  | If_then_else (arg, ifso, ifnot) ->
+    Uifthenelse (subst_var env arg, to_clambda t env ifso,
+      to_clambda t env ifnot)
+  | While (cond, body) ->
+    Uwhile (to_clambda t env cond, to_clambda t env body)
+  | For { bound_var; from_value; to_value; direction; body } ->
+    let id, env_body = Env.add_fresh_ident env bound_var in
+    Ufor (id, subst_var env from_value, subst_var env to_value,
+      direction, to_clambda t env_body body)
+  | Assign { being_assigned; new_value } ->
+    let id =
+      try Env.ident_for_mutable_var_exn env being_assigned
+      with Not_found ->
+        Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a"
+          Mutable_variable.print being_assigned
+          Flambda.print flam
+    in
+    Uassign (id, subst_var env new_value)
+  | Send { kind; meth; obj; args; dbg } ->
+    Usend (kind, subst_var env meth, subst_var env obj,
+      subst_vars env args, dbg)
+  | Proved_unreachable -> Uunreachable
+
+and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
+  match named with
+  | Symbol sym -> to_clambda_symbol env sym
+  | Const (Const_pointer n) -> Uconst (Uconst_ptr n)
+  | Const (Int n) -> Uconst (Uconst_int n)
+  | Const (Char c) -> Uconst (Uconst_int (Char.code c))
+  | Allocated_const _ ->
+    Misc.fatal_errorf "[Allocated_const] should have been lifted to a \
+        [Let_symbol] construction before [Flambda_to_clambda]: %a = %a"
+      Variable.print var
+      Flambda.print_named named
+  | Read_mutable mut_var ->
+    begin try Uvar (Env.ident_for_mutable_var_exn env mut_var)
+    with Not_found ->
+      Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a"
+        Mutable_variable.print mut_var
+        Flambda.print_named named
+    end
+  | Read_symbol_field (symbol, field) ->
+    Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none)
+  | Set_of_closures set_of_closures ->
+    to_clambda_set_of_closures t env set_of_closures
+  | Project_closure { set_of_closures; closure_id } ->
+    (* Note that we must use [build_uoffset] to ensure that we do not generate
+       a [Uoffset] construction in the event that the offset is zero, otherwise
+       we might break pattern matches in Cmmgen (in particular for the
+       compilation of "let rec"). *)
+    check_closure (
+      build_uoffset
+        (check_closure (subst_var env set_of_closures)
+           (Flambda.Expr (Var set_of_closures)))
+        (get_fun_offset t closure_id))
+      named
+  | Move_within_set_of_closures { closure; start_from; move_to } ->
+    check_closure (build_uoffset
+      (check_closure (subst_var env closure)
+         (Flambda.Expr (Var closure)))
+      ((get_fun_offset t move_to) - (get_fun_offset t start_from)))
+      named
+  | Project_var { closure; var; closure_id } ->
+    let ulam = subst_var env closure in
+    let fun_offset = get_fun_offset t closure_id in
+    let var_offset = get_fv_offset t var in
+    let pos = var_offset - fun_offset in
+    Uprim (Pfield pos,
+      [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
+      Debuginfo.none)
+  | Prim (Pfield index, [block], dbg) ->
+    Uprim (Pfield index, [check_field (subst_var env block) index None], dbg)
+  | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
+    Uprim (Psetfield (index, maybe_ptr, init), [
+        check_field (subst_var env block) index None;
+        subst_var env new_value;
+      ], dbg)
+  | Prim (Popaque, args, dbg) ->
+    Uprim (Pidentity, subst_vars env args, dbg)
+  | Prim (p, args, dbg) ->
+    Uprim (p, subst_vars env args, dbg)
+  | Expr expr -> to_clambda t env expr
+
+and to_clambda_switch t env cases num_keys default =
+  let num_keys =
+    if Numbers.Int.Set.cardinal num_keys = 0 then 0
+    else Numbers.Int.Set.max_elt num_keys + 1
+  in
+  let index = Array.make num_keys 0 in
+  let store = Flambda_utils.Switch_storer.mk_store () in
+  begin match default with
+  | Some def when List.length cases < num_keys -> ignore (store.act_store def)
+  | _ -> ()
+  end;
+  List.iter (fun (key, lam) -> index.(key) <- store.act_store lam) cases;
+  let actions = Array.map (to_clambda t env) (store.act_get ()) in
+  match actions with
+  | [| |] -> [| |], [| |]  (* May happen when [default] is [None]. *)
+  | _ -> index, actions
+
+and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda =
+  let closed = is_function_constant t direct_func in
+  let label = Compilenv.function_label direct_func in
+  let uargs =
+    let uargs = subst_vars env args in
+    (* Remove the closure argument if the closure is closed.  (Note that the
+       closure argument is always a variable, so we can be sure we are not
+       dropping any side effects.) *)
+    if closed then uargs else uargs @ [subst_var env func]
+  in
+  Udirect_apply (label, uargs, dbg)
+
+(* Describe how to build a runtime closure block that corresponds to the
+   given Flambda set of closures.
+
+   For instance the closure for the following set of closures:
+
+     let rec fun_a x =
+       if x <= 0 then 0 else fun_b (x-1) v1
+     and fun_b x y =
+       if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1)
+
+   will be represented in memory as:
+
+     [ closure header; fun_a;
+       1; infix header; fun caml_curry_2;
+       2; fun_b; v1; v2 ]
+
+   fun_a and fun_b will take an additional parameter 'env' to
+   access their closure.  It will be arranged such that in the body
+   of each function the env parameter points to its own code
+   pointer.  For example, in fun_b it will be shifted by 3 words.
+
+   Hence accessing v1 in the body of fun_a is accessing the
+   6th field of 'env' and in the body of fun_b the 1st field.
+*)
+and to_clambda_set_of_closures t env
+      (({ function_decls; free_vars } : Flambda.set_of_closures)
+        as set_of_closures) : Clambda.ulambda =
+  let all_functions = Variable.Map.bindings function_decls.funs in
+  let env_var = Ident.create "env" in
+  let to_clambda_function
+        (closure_id, (function_decl : Flambda.function_declaration))
+        : Clambda.ufunction =
+    let closure_id = Closure_id.wrap closure_id in
+    let fun_offset =
+      Closure_id.Map.find closure_id t.current_unit.fun_offset_table
+    in
+    let env =
+      (* Inside the body of the function, we cannot access variables
+         declared outside, so start with a suitably clean environment.
+         Note that we must not forget the information about which allocated
+         constants contain which unboxed values. *)
+      let env = Env.keep_only_symbols env in
+      (* Add the Clambda expressions for the free variables of the function
+         to the environment. *)
+      let add_env_free_variable id _ env =
+        let var_offset =
+          try
+            Var_within_closure.Map.find
+              (Var_within_closure.wrap id) t.current_unit.fv_offset_table
+          with Not_found ->
+            Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \
+                free variable %a is unknown.  Set of closures: %a"
+              Variable.print id
+              Flambda.print_set_of_closures set_of_closures
+        in
+        let pos = var_offset - fun_offset in
+        Env.add_subst env id
+          (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none))
+      in
+      let env = Variable.Map.fold add_env_free_variable free_vars env in
+      (* Add the Clambda expressions for all functions defined in the current
+         set of closures to the environment.  The various functions may be
+         retrieved by moving within the runtime closure, starting from the
+         current function's closure. *)
+      let add_env_function pos env (id, _) =
+        let offset =
+          Closure_id.Map.find (Closure_id.wrap id)
+            t.current_unit.fun_offset_table
+        in
+        let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in
+        Env.add_subst env id exp
+      in
+      List.fold_left (add_env_function fun_offset) env all_functions
+    in
+    let env_body, params =
+      List.fold_right (fun var (env, params) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, id :: params)
+        function_decl.params (env, [])
+    in
+    { label = Compilenv.function_label closure_id;
+      arity = Flambda_utils.function_arity function_decl;
+      params = params @ [env_var];
+      body = to_clambda t env_body function_decl.body;
+      dbg = function_decl.dbg;
+      env = Some env_var;
+    }
+  in
+  let funs = List.map to_clambda_function all_functions in
+  let free_vars =
+    Variable.Map.bindings (Variable.Map.map (
+      fun (free_var : Flambda.specialised_to) ->
+        subst_var env free_var.var) free_vars)
+  in
+  Uclosure (funs, List.map snd free_vars)
+
+and to_clambda_closed_set_of_closures t env symbol
+      ({ function_decls; } : Flambda.set_of_closures)
+      : Clambda.ustructured_constant =
+  let functions = Variable.Map.bindings function_decls.funs in
+  let to_clambda_function (id, (function_decl : Flambda.function_declaration))
+        : Clambda.ufunction =
+    (* All that we need in the environment, for translating one closure from
+       a closed set of closures, is the substitutions for variables bound to
+       the various closures in the set.  Such closures will always be
+       referenced via symbols. *)
+    let env =
+      List.fold_left (fun env (var, _) ->
+          let closure_id = Closure_id.wrap var in
+          let symbol = Compilenv.closure_symbol closure_id in
+          Env.add_subst env var (to_clambda_symbol env symbol))
+        (Env.keep_only_symbols env)
+        functions
+    in
+    let env_body, params =
+      List.fold_right (fun var (env, params) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, id :: params)
+        function_decl.params (env, [])
+    in
+    { label = Compilenv.function_label (Closure_id.wrap id);
+      arity = Flambda_utils.function_arity function_decl;
+      params;
+      body = to_clambda t env_body function_decl.body;
+      dbg = function_decl.dbg;
+      env = None;
+    }
+  in
+  let ufunct = List.map to_clambda_function functions in
+  let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in
+  Uconst_closure (ufunct, closure_lbl, [])
+
+let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda =
+  let fields =
+    List.mapi (fun index expr -> index, to_clambda t env expr) fields
+  in
+  let build_setfield (index, field) : Clambda.ulambda =
+    (* Note that this will never cause a write barrier hit, owing to
+       the [Initialization]. *)
+    Uprim (Psetfield (index, Pointer, Root_initialization),
+      [to_clambda_symbol env symbol; field],
+      Debuginfo.none)
+  in
+  match fields with
+  | [] -> Uconst (Uconst_ptr 0)
+  | h :: t ->
+    List.fold_left (fun acc (p, field) ->
+        Clambda.Usequence (build_setfield (p, field), acc))
+      (build_setfield h) t
+
+let accumulate_structured_constants t env symbol
+      (c : Flambda.constant_defining_value) acc =
+  match c with
+  | Allocated_const c ->
+    Symbol.Map.add symbol (to_clambda_allocated_constant c) acc
+  | Block (tag, fields) ->
+    let fields = List.map (to_clambda_const env) fields in
+    Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc
+  | Set_of_closures set_of_closures ->
+    let to_clambda_set_of_closures =
+      to_clambda_closed_set_of_closures t env symbol set_of_closures
+    in
+    Symbol.Map.add symbol to_clambda_set_of_closures acc
+  | Project_closure _ -> acc
+
+let to_clambda_program t env constants (program : Flambda.program) =
+  let rec loop env constants (program : Flambda.program_body)
+        : Clambda.ulambda * Clambda.ustructured_constant Symbol.Map.t =
+    match program with
+    | Let_symbol (symbol, alloc, program) ->
+      (* Useful only for unboxing. Since floats and boxed integers will
+         never be part of a Let_rec_symbol, handling only the Let_symbol
+         is sufficient. *)
+      let env =
+        match alloc with
+        | Allocated_const const -> Env.add_allocated_const env symbol const
+        | _ -> env
+      in
+      let constants =
+        accumulate_structured_constants t env symbol alloc constants
+      in
+      loop env constants program
+    | Let_rec_symbol (defs, program) ->
+      let constants =
+        List.fold_left (fun constants (symbol, alloc) ->
+            accumulate_structured_constants t env symbol alloc constants)
+          constants defs
+      in
+      loop env constants program
+    | Initialize_symbol (symbol, _tag, fields, program) ->
+      (* The tag is ignored here: It is used separately to generate the
+         preallocated block. Only the initialisation code is generated
+         here. *)
+      let e1 = to_clambda_initialize_symbol t env symbol fields in
+      let e2, constants = loop env constants program in
+      Usequence (e1, e2), constants
+    | Effect (expr, program) ->
+      let e1 = to_clambda t env expr in
+      let e2, constants = loop env constants program in
+      Usequence (e1, e2), constants
+    | End _ ->
+      Uconst (Uconst_ptr 0), constants
+  in
+  loop env constants program.program_body
+
+type result = {
+  expr : Clambda.ulambda;
+  preallocated_blocks : Clambda.preallocated_block list;
+  structured_constants : Clambda.ustructured_constant Symbol.Map.t;
+  exported : Export_info.t;
+}
+
+let convert (program, exported) : result =
+  let current_unit =
+    let offsets = Closure_offsets.compute program in
+    { fun_offset_table = offsets.function_offsets;
+      fv_offset_table = offsets.free_variable_offsets;
+      closures = Flambda_utils.make_closure_map program;
+      constant_sets_of_closures =
+        Flambda_utils.all_lifted_constant_sets_of_closures program;
+    }
+  in
+  let imported_units =
+    let imported = Compilenv.approx_env () in
+    { fun_offset_table = imported.offset_fun;
+      fv_offset_table = imported.offset_fv;
+      closures = imported.closures;
+      constant_sets_of_closures = imported.constant_sets_of_closures;
+    }
+  in
+  let t = { current_unit; imported_units; } in
+  let preallocated_blocks =
+    List.map (fun (symbol, tag, fields) ->
+        { Clambda.
+          symbol = Linkage_name.to_string (Symbol.label symbol);
+          exported = true;
+          tag = Tag.to_int tag;
+          size = List.length fields;
+        })
+      (Flambda_utils.initialize_symbols program)
+  in
+  let expr, structured_constants =
+    to_clambda_program t Env.empty Symbol.Map.empty program
+  in
+  let offset_fun, offset_fv =
+    Closure_offsets.compute_reexported_offsets program
+      ~current_unit_offset_fun:current_unit.fun_offset_table
+      ~current_unit_offset_fv:current_unit.fv_offset_table
+      ~imported_units_offset_fun:imported_units.fun_offset_table
+      ~imported_units_offset_fv:imported_units.fv_offset_table
+  in
+  let exported =
+    Export_info.add_clambda_info exported
+      ~offset_fun
+      ~offset_fv
+      ~constant_sets_of_closures:current_unit.constant_sets_of_closures
+  in
+  { expr; preallocated_blocks; structured_constants; exported; }
diff --git a/asmcomp/flambda_to_clambda.mli b/asmcomp/flambda_to_clambda.mli
new file mode 100644
index 00000000..39cbc40f
--- /dev/null
+++ b/asmcomp/flambda_to_clambda.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type result = {
+  expr : Clambda.ulambda;
+  preallocated_blocks : Clambda.preallocated_block list;
+  structured_constants : Clambda.ustructured_constant Symbol.Map.t;
+  exported : Export_info.t;
+}
+
+(** Convert an Flambda program, with associated proto-export information,
+    to Clambda.
+    This yields a Clambda expression together with augmented export
+    information and details about required statically-allocated values
+    (preallocated blocks, for [Initialize_symbol], and structured
+    constants).
+
+    It is during this process that accesses to variables within
+    closures are transformed to field accesses within closure values.
+    For direct calls, the hidden closure parameter is added.  Switch
+    tables are also built.
+*)
+val convert : Flambda.program * Export_info.t -> result
diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml
new file mode 100644
index 00000000..6ef8fec6
--- /dev/null
+++ b/asmcomp/i386/CSE.ml
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for the i386 *)
+
+open Cmm
+open Arch
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+  match op with
+  (* Operations that affect the floating-point stack cannot be factored *)
+  | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+  | Iintoffloat | Ifloatofint
+  | Iload((Single | Double | Double_u), _) -> Op_other
+  (* Specific ops *)
+  | Ispecific(Ilea _) -> Op_pure
+  | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg
+  | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg
+  | Ispecific(Ioffset_loc(_, _)) -> Op_store true
+  | Ispecific _ -> Op_other
+  | _ -> super#class_of_operation op
+
+method! is_cheap_operation op =
+  match op with
+  | Iconst_int _ -> true
+  | Iconst_symbol _ -> true
+  | _ -> false
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/i386/NOTES.md b/asmcomp/i386/NOTES.md
new file mode 100644
index 00000000..6f1e1839
--- /dev/null
+++ b/asmcomp/i386/NOTES.md
@@ -0,0 +1,22 @@
+# Supported platforms
+
+Intel and AMD x86 processors in 32-bit mode.
+The baseline is the 80486, also known as `i486`.
+(Debian's baseline is now the Pentium 1.)
+
+Floating-point architecture: x87.
+(SSE2 not available in Debian's baseline.)
+
+Operating systems: Linux, BSD, MacOS X, MS Windows.
+
+Debian architecture name: `i386`
+
+# Reference documents
+
+* Instruction set architecture:
+  any Intel or AMD manual of the last 20 years.
+* ELF application binary interface:
+  _System V Application Binary Interface,
+   Intel386 Architecture Processor Supplement_
+* MacOS X application binary interface:
+  _OS X ABI Function Call Guide: IA-32 Function Calling Conventions_
diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml
new file mode 100644
index 00000000..23f54232
--- /dev/null
+++ b/asmcomp/i386/arch.ml
@@ -0,0 +1,167 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Machine-specific command-line options *)
+
+let fast_math = ref false
+
+let command_line_options =
+  [ "-ffast-math", Arg.Set fast_math,
+      " Inline trigonometric and exponential functions" ]
+
+(* Specific operations for the Intel 386 processor *)
+
+open Format
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+  | Iindexed2 of int                    (* reg + reg + displ *)
+  | Iscaled of int * int                (* reg * scale + displ *)
+  | Iindexed2scaled of int * int        (* reg + reg * scale + displ *)
+
+type specific_operation =
+    Ilea of addressing_mode             (* Lea gives scaled adds *)
+  | Istore_int of nativeint * addressing_mode * bool
+                                        (* Store an integer constant *)
+  | Istore_symbol of string * addressing_mode * bool (* Store a symbol *)
+  | Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
+  | Ipush                               (* Push regs on stack *)
+  | Ipush_int of nativeint              (* Push an integer constant *)
+  | Ipush_symbol of string              (* Push a symbol *)
+  | Ipush_load of addressing_mode       (* Load a scalar and push *)
+  | Ipush_load_float of addressing_mode (* Load a float and push *)
+  | Isubfrev | Idivfrev                 (* Reversed float sub and div *)
+  | Ifloatarithmem of bool * float_operation * addressing_mode
+                                        (* Float arith operation with memory *)
+                                        (* bool: true=64 bits, false=32 *)
+  | Ifloatspecial of string
+
+and float_operation =
+    Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev
+
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
+(* Sizes, endianness *)
+
+let big_endian = false
+
+let size_addr = 4
+let size_int = 4
+let size_float = 8
+
+let allow_unaligned_access = true
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = true
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+  | Iindexed2 n -> Iindexed2(n + delta)
+  | Iscaled(scale, n) -> Iscaled(scale, n + delta)
+  | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
+
+let num_args_addressing = function
+    Ibased _ -> 0
+  | Iindexed _ -> 1
+  | Iindexed2 _ -> 2
+  | Iscaled _ -> 1
+  | Iindexed2scaled _ -> 2
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Ibased(s, 0) ->
+      fprintf ppf "\"%s\"" s
+  | Ibased(s, n) ->
+      fprintf ppf "\"%s\" + %i" s n
+  | Iindexed n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a%s" printreg arg.(0) idx
+  | Iindexed2 n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx
+  | Iscaled(scale, n) ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a  * %i%s" printreg arg.(0) scale idx
+  | Iindexed2scaled(scale, n) ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx
+
+let print_specific_operation printreg op ppf arg =
+  match op with
+  | Ilea addr -> print_addressing printreg addr ppf arg
+  | Istore_int(n, addr, is_assign) ->
+      fprintf ppf "[%a] := %nd %s"
+         (print_addressing printreg addr) arg n
+         (if is_assign then "(assign)" else "(init)")
+  | Istore_symbol(lbl, addr, is_assign) ->
+      fprintf ppf "[%a] := \"%s\" %s"
+         (print_addressing printreg addr) arg lbl
+         (if is_assign then "(assign)" else "(init)")
+  | Ioffset_loc(n, addr) ->
+      fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n
+  | Ipush ->
+      fprintf ppf "push ";
+      for i = 0 to Array.length arg - 1 do
+        if i > 0 then fprintf ppf ", ";
+        printreg ppf arg.(i)
+      done
+  | Ipush_int n ->
+      fprintf ppf "push %s" (Nativeint.to_string n)
+  | Ipush_symbol s ->
+      fprintf ppf "push \"%s\"" s
+  | Ipush_load addr ->
+      fprintf ppf "push [%a]" (print_addressing printreg addr) arg
+  | Ipush_load_float addr ->
+      fprintf ppf "pushfloat [%a]" (print_addressing printreg addr) arg
+  | Isubfrev ->
+      fprintf ppf "%a -f(rev) %a" printreg arg.(0) printreg arg.(1)
+  | Idivfrev ->
+      fprintf ppf "%a /f(rev) %a" printreg arg.(0) printreg arg.(1)
+  | Ifloatarithmem(double, op, addr) ->
+      let op_name = function
+      | Ifloatadd -> "+f"
+      | Ifloatsub -> "-f"
+      | Ifloatsubrev -> "-f(rev)"
+      | Ifloatmul -> "*f"
+      | Ifloatdiv -> "/f"
+      | Ifloatdivrev -> "/f(rev)" in
+      let long = if double then "float64" else "float32" in
+      fprintf ppf "%a %s %s[%a]" printreg arg.(0) (op_name op) long
+       (print_addressing printreg addr) (Array.sub arg 1 (Array.length arg - 1))
+  | Ifloatspecial name ->
+      fprintf ppf "%s " name;
+      for i = 0 to Array.length arg - 1 do
+        if i > 0 then fprintf ppf ", ";
+        printreg ppf arg.(i)
+      done
+
+(* Stack alignment constraints *)
+
+let stack_alignment =
+  match Config.system with
+  | "win32" -> 4     (* MSVC *)
+  | _ -> 16
+(* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays,
+   even if only MacOS X's ABI formally requires it *)
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
new file mode 100644
index 00000000..94c3d035
--- /dev/null
+++ b/asmcomp/i386/emit.mlp
@@ -0,0 +1,1096 @@
+#2 "asmcomp/i386/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of Intel 386 assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+open X86_ast
+open X86_proc
+open X86_dsl
+
+let _label s = D.label ~typ:DWORD s
+
+let mem_sym typ ?(ofs = 0) sym =
+  mem32 typ ~scale:0 ?base:None ~sym ofs RAX (*ignored since scale=0*)
+
+(* CFI directives *)
+
+let cfi_startproc () =
+  if Config.asm_cfi_supported then D.cfi_startproc ()
+
+let cfi_endproc () =
+  if Config.asm_cfi_supported then D.cfi_endproc ()
+
+let cfi_adjust_cfa_offset n =
+  if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n
+
+let emit_debug_info dbg =
+  emit_debug_info_gen dbg D.file D.loc
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+let stack_offset = ref 0
+
+(* Layout of the stack frame *)
+
+let frame_size () =                     (* includes return address *)
+  let sz =
+    !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4
+  in Misc.align sz stack_alignment
+
+let slot_offset loc cl =
+  match loc with
+  | Incoming n ->
+      assert (n >= 0);
+      frame_size() + n
+  | Local n ->
+      if cl = 0
+      then !stack_offset + n * 4
+      else !stack_offset + num_stack_slots.(0) * 4 + n * 8
+  | Outgoing n ->
+      assert (n >= 0);
+      n
+
+(* Record symbols used and defined - at the end generate extern for those
+   used but not defined *)
+
+let symbols_defined = ref StringSet.empty
+let symbols_used = ref StringSet.empty
+
+let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined
+let add_used_symbol s = symbols_used := StringSet.add s !symbols_used
+
+let trap_frame_size = Misc.align 8 stack_alignment
+
+(* Prefixing of symbols with "_" *)
+
+let symbol_prefix =
+  match system with
+  | S_linux_elf -> ""
+  | S_bsd_elf -> ""
+  | S_solaris -> ""
+  | S_beos -> ""
+  | S_gnu -> ""
+  | _ -> "_" (* win32 & others *)
+
+let emit_symbol s = string_of_symbol symbol_prefix s
+
+let immsym s = sym (emit_symbol s)
+
+let emit_call s = I.call (immsym s)
+
+(* Output a label *)
+
+let label_prefix =
+  match system with
+  | S_linux_elf -> ".L"
+  | S_bsd_elf -> ".L"
+  | S_solaris -> ".L"
+  | S_beos -> ".L"
+  | S_gnu -> ".L"
+  | _ -> "L"
+
+let emit_label lbl =
+  Printf.sprintf "%s%d" label_prefix lbl
+
+let label s = sym (emit_label s)
+
+let def_label s = D.label (emit_label s)
+
+let emit_Llabel fallthrough lbl =
+  if not fallthrough && !fastcode_flag then D.align 16 ;
+  def_label lbl
+
+(* Output a pseudo-register *)
+
+let int_reg_name =  [| RAX; RBX; RCX; RDX; RSI; RDI; RBP  |]
+
+let float_reg_name = [| TOS |]
+
+let register_name r =
+  if r < 100 then Reg32 (int_reg_name.(r))
+  else Regf (float_reg_name.(r - 100))
+
+let sym32 ?ofs s = mem_sym ?ofs DWORD (emit_symbol s)
+
+let reg = function
+  | { loc = Reg r } -> register_name r
+  | { loc = Stack(Incoming n | Outgoing n) } when n < 0 ->
+      sym32 "caml_extra_params" ~ofs:(n + 64)
+  | { loc = Stack s; typ = Float } as r ->
+      let ofs = slot_offset s (register_class r) in
+      mem32 REAL8 ofs RSP
+  | { loc = Stack s } as r ->
+      let ofs = slot_offset s (register_class r) in
+      mem32 DWORD ofs RSP
+  | { loc = Unknown } ->
+      fatal_error "Emit_i386.reg"
+
+(* Output a reference to the lower 8 bits or lower 16 bits of a register *)
+
+let reg_low_8_name  = Array.map (fun r -> Reg8L r) int_reg_name
+let reg_low_16_name = Array.map (fun r -> Reg16 r) int_reg_name
+
+let reg8 r =
+  match r.loc with
+  | Reg r when r < 4 -> reg_low_8_name.(r)
+  | _ -> fatal_error "Emit_i386.reg8"
+
+let reg16 r =
+  match r.loc with
+  | Reg r when r < 7 -> reg_low_16_name.(r)
+  | _ -> fatal_error "Emit_i386.reg16"
+
+let reg32 = function
+  | { loc = Reg.Reg r } -> int_reg_name.(r)
+  | _ -> assert false
+
+let arg32 i n = reg32 i.arg.(n)
+
+(* Output an addressing mode *)
+
+let addressing addr typ i n =
+  match addr with
+  | Ibased(s, ofs) ->
+      add_used_symbol s;
+      mem_sym typ (emit_symbol s) ~ofs
+  | Iindexed d ->
+      mem32 typ d (arg32 i n)
+  | Iindexed2 d ->
+      mem32 typ ~base:(arg32 i n) d (arg32 i (n+1))
+  | Iscaled(2, d) ->
+      mem32 typ ~base:(arg32 i n) d (arg32 i n)
+  | Iscaled(scale, d) ->
+      mem32 typ ~scale d (arg32 i n)
+  | Iindexed2scaled(scale, d) ->
+      mem32 typ ~scale ~base:(arg32 i n) d (arg32 i (n+1))
+
+(* Record live pointers at call points *)
+
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := ((r lsl 1) + 1) :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ())
+    live;
+  record_frame_descr ~label:lbl ~frame_size:(frame_size())
+    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+  lbl
+
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in
+  def_label lbl
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_frame: label }                   (* Label of frame descriptor *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  def_label gc.gc_lbl;
+  emit_call "caml_call_gc";
+  def_label gc.gc_frame;
+  I.jmp (label gc.gc_return_lbl)
+
+(* Record calls to caml_ml_array_bound_error.
+   In -g mode, we maintain one call to caml_ml_array_bound_error
+   per bound check site.  Without -g, we can share a single call. *)
+
+type bound_error_call =
+  { bd_lbl: label;                      (* Entry label *)
+    bd_frame: label }                   (* Label of frame descriptor *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+let bound_error_call = ref 0
+
+let bound_error_label ?label dbg =
+  if !Clflags.debug then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    bound_error_sites :=
+      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
+    lbl_bound_error
+  end else begin
+    if !bound_error_call = 0 then bound_error_call := new_label();
+    !bound_error_call
+  end
+
+let emit_call_bound_error bd =
+  def_label bd.bd_lbl;
+  emit_call "caml_ml_array_bound_error";
+  def_label bd.bd_frame
+
+let emit_call_bound_errors () =
+  List.iter emit_call_bound_error !bound_error_sites;
+  if !bound_error_call > 0 then begin
+    def_label !bound_error_call;
+    emit_call "caml_ml_array_bound_error"
+  end
+
+(* Names for instructions *)
+
+let instr_for_intop = function
+  | Iadd -> I.add
+  | Isub -> I.sub
+  | Imul -> (fun arg1 arg2 ->  I.imul arg1 (Some arg2))
+  | Iand -> I.and_
+  | Ior -> I.or_
+  | Ixor -> I.xor
+  | Ilsl -> I.sal
+  | Ilsr -> I.shr
+  | Iasr -> I.sar
+  | _ -> fatal_error "Emit_i386: instr_for_intop"
+
+let unary_instr_for_floatop = function
+  | Inegf -> I.fchs ()
+  | Iabsf -> I.fabs ()
+  | _ -> fatal_error "Emit_i386: unary_instr_for_floatop"
+
+let instr_for_floatop = function
+  | Iaddf -> I.fadd
+  | Isubf -> I.fsub
+  | Imulf -> I.fmul
+  | Idivf -> I.fdiv
+  | Ispecific Isubfrev -> I.fsubr
+  | Ispecific Idivfrev -> I.fdivr
+  | _ -> fatal_error "Emit_i386: instr_for_floatop"
+
+let instr_for_floatop_reversed = function
+  | Iaddf -> I.fadd
+  | Isubf -> I.fsubr
+  | Imulf -> I.fmul
+  | Idivf -> I.fdivr
+  | Ispecific Isubfrev -> I.fsub
+  | Ispecific Idivfrev -> I.fdiv
+  | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed"
+
+
+let instr_for_floatop_reversed_pop = function
+  | Iaddf -> I.faddp
+  | Isubf -> I.fsubrp
+  | Imulf -> I.fmulp
+  | Idivf -> I.fdivrp
+  | Ispecific Isubfrev -> I.fsubp
+  | Ispecific Idivfrev -> I.fdivp
+  | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed_pop"
+
+let instr_for_floatarithmem = function
+  | Ifloatadd -> I.fadd
+  | Ifloatsub -> I.fsub
+  | Ifloatsubrev -> I.fsubr
+  | Ifloatmul -> I.fmul
+  | Ifloatdiv -> I.fdiv
+  | Ifloatdivrev -> I.fdivr
+
+let cond = function
+  | Isigned Ceq   -> E   | Isigned Cne   -> NE
+  | Isigned Cle   -> LE  | Isigned Cgt   -> G
+  | Isigned Clt   -> L   | Isigned Cge   -> GE
+  | Iunsigned Ceq -> E   | Iunsigned Cne -> NE
+  | Iunsigned Cle -> BE  | Iunsigned Cgt -> A
+  | Iunsigned Clt -> B   | Iunsigned Cge -> AE
+
+(* Output an = 0 or <> 0 test. *)
+
+let output_test_zero arg =
+  match arg.loc with
+  | Reg.Reg _ -> I.test (reg arg) (reg arg)
+  | _  -> I.cmp (int 0) (reg arg)
+
+(* Deallocate the stack frame before a return or tail call *)
+
+let output_epilogue f =
+  let n = frame_size() - 4 in
+  if n > 0 then
+    begin
+      I.add (int n) esp;
+      cfi_adjust_cfa_offset (-n);
+      f ();
+      (* reset CFA back cause function body may continue *)
+      cfi_adjust_cfa_offset n
+    end
+  else
+    f ()
+
+(* Determine if the given register is the top of the floating-point stack *)
+
+let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false
+
+(* Emit the code for a floating-point comparison *)
+
+let emit_float_test cmp neg arg lbl =
+  let actual_cmp =
+    match (is_tos arg.(0), is_tos arg.(1)) with
+    | (true, true) ->
+        (* both args on top of FP stack *)
+        I.fcompp ();
+        cmp
+    | (true, false) ->
+        (* first arg on top of FP stack *)
+        I.fcomp (reg arg.(1));
+        cmp
+    | (false, true) ->
+        (* second arg on top of FP stack *)
+        I.fcomp (reg arg.(0));
+        Cmm.swap_comparison cmp
+    | (false, false) ->
+        I.fld     (reg arg.(0));
+        I.fcomp   (reg arg.(1));
+        cmp
+  in
+  I.fnstsw ax;
+  match actual_cmp with
+  | Ceq ->
+      if neg then begin
+        I.and_ (int 68) ah;
+        I.xor (int 64) ah;
+        I.jne lbl
+      end else begin
+        I.and_ (int 69) ah;
+        I.cmp (int 64) ah;
+        I.je lbl
+      end
+  | Cne ->
+      if neg then begin
+        I.and_ (int 69) ah;
+        I.cmp (int 64) ah;
+        I.je lbl
+      end else begin
+        I.and_ (int 68) ah;
+        I.xor (int 64) ah;
+        I.jne lbl
+      end
+  | Cle ->
+      I.and_ (int 69) ah;
+      I.dec ah;
+      I.cmp (int 64) ah;
+      if neg
+      then I.jae lbl
+      else I.jb lbl
+  | Cge ->
+      I.and_ (int 5) ah;
+      if neg
+      then I.jne lbl
+      else I.je lbl
+  | Clt ->
+      I.and_ (int 69) ah;
+      I.cmp (int 1) ah;
+      if neg
+      then I.jne lbl
+      else I.je lbl
+  | Cgt ->
+      I.and_ (int 69) ah;
+      if neg
+      then I.jne lbl
+      else I.je lbl
+
+(* Emit a Ifloatspecial instruction *)
+
+let emit_floatspecial = function
+  | "atan"  -> I.fld1 (); I.fpatan ()
+  | "atan2" -> I.fpatan ()
+  | "cos"   -> I.fcos ()
+  | "log"   -> I.fldln2 (); I.fxch st1; I.fyl2x ()
+  | "log10" -> I.fldlg2 (); I.fxch st1; I.fyl2x ()
+  | "sin"   -> I.fsin ()
+  | "sqrt"  -> I.fsqrt ()
+  | "tan"   -> I.fptan (); I.fstp st0
+  | _ -> assert false
+
+(* Floating-point constants *)
+
+let float_constants = ref ([] : (int64 * int) list)
+
+let add_float_constant cst =
+  try
+    List.assoc cst !float_constants
+  with
+    Not_found ->
+      let lbl = new_label() in
+      float_constants := (cst, lbl) :: !float_constants;
+      lbl
+
+let emit_float64_split_directive x =
+  let lo = Int64.logand x 0xFFFF_FFFFL
+  and hi = Int64.shift_right_logical x 32 in
+  D.long (Const (if Arch.big_endian then hi else lo));
+  D.long (Const (if Arch.big_endian then lo else hi))
+
+let emit_float_constant cst lbl =
+  _label (emit_label lbl);
+  emit_float64_split_directive cst
+
+let emit_global_label s =
+  let lbl = Compilenv.make_symbol (Some s) in
+  add_def_symbol lbl;
+  let lbl = emit_symbol lbl in
+  D.global lbl;
+  _label lbl
+
+(* Output the assembly code for an instruction *)
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+(* Record references to external C functions (for MacOSX) *)
+let external_symbols_direct = ref StringSet.empty
+let external_symbols_indirect = ref StringSet.empty
+
+let emit_instr fallthrough i =
+  emit_debug_info i.dbg;
+  match i.desc with
+  | Lend -> ()
+  | Lop(Imove | Ispill | Ireload) ->
+      let src = i.arg.(0) and dst = i.res.(0) in
+      if src.loc <> dst.loc then begin
+        if src.typ = Float then
+          if is_tos src then
+            I.fstp (reg dst)
+          else if is_tos dst then
+            I.fld (reg src)
+          else begin
+            I.fld (reg src);
+            I.fstp (reg dst)
+          end
+        else
+          I.mov (reg src) (reg dst)
+      end
+  | Lop(Iconst_int n) ->
+      if n = 0n then begin
+        match i.res.(0).loc with
+        | Reg _ -> I.xor (reg i.res.(0)) (reg i.res.(0))
+        | _     -> I.mov (int 0) (reg i.res.(0))
+      end else
+        I.mov (nat n) (reg i.res.(0))
+  | Lop(Iconst_float f) ->
+      begin match f with
+      | 0x0000_0000_0000_0000L ->       (* +0.0 *)
+          I.fldz ()
+      | 0x8000_0000_0000_0000L ->       (* -0.0 *)
+          I.fldz (); I.fchs ()
+      | 0x3FF0_0000_0000_0000L ->       (*  1.0 *)
+          I.fld1 ()
+      | 0xBFF0_0000_0000_0000L ->       (* -1.0 *)
+          I.fld1 (); I.fchs ()
+      | _ ->
+          let lbl = add_float_constant f in
+          I.fld (mem_sym REAL8 (emit_label lbl))
+      end
+  | Lop(Iconst_symbol s) ->
+      add_used_symbol s;
+      I.mov (immsym s) (reg i.res.(0))
+  | Lop(Icall_ind { label_after; }) ->
+      I.call (reg i.arg.(0));
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Icall_imm { func; label_after; }) ->
+      add_used_symbol func;
+      emit_call func;
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Itailcall_ind { label_after = _; }) ->
+      output_epilogue begin fun () ->
+        I.jmp (reg i.arg.(0))
+      end
+  | Lop(Itailcall_imm { func; label_after = _; }) ->
+      if func = !function_name then
+        I.jmp (label !tailrec_entry_point)
+      else begin
+        output_epilogue begin fun () ->
+          add_used_symbol func;
+          I.jmp (immsym func)
+        end
+      end
+  | Lop(Iextcall { func; alloc; label_after; }) ->
+      add_used_symbol func;
+      if alloc then begin
+        if system <> S_macosx then
+          I.mov (immsym func) eax
+        else begin
+          external_symbols_indirect :=
+            StringSet.add func !external_symbols_indirect;
+          I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr"
+                              (emit_symbol func))) eax
+        end;
+        emit_call "caml_c_call";
+        record_frame i.live false i.dbg ~label:label_after
+      end else begin
+        if system <> S_macosx then
+          emit_call func
+        else begin
+          external_symbols_direct :=
+            StringSet.add func !external_symbols_direct;
+          I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol func)))
+        end
+      end
+  | Lop(Istackoffset n) ->
+      if n < 0
+      then I.add (int (-n)) esp
+      else I.sub (int n) esp;
+      cfi_adjust_cfa_offset n;
+      stack_offset := !stack_offset + n
+  | Lop(Iload(chunk, addr)) ->
+      let dest = i.res.(0) in
+      begin match chunk with
+      | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned ->
+          I.mov (addressing addr DWORD i 0) (reg dest)
+      | Byte_unsigned ->
+          I.movzx (addressing addr BYTE i 0) (reg dest)
+      | Byte_signed ->
+          I.movsx (addressing addr BYTE i 0) (reg dest)
+      | Sixteen_unsigned ->
+          I.movzx (addressing addr WORD i 0) (reg dest)
+      | Sixteen_signed ->
+          I.movsx (addressing addr WORD i 0) (reg dest)
+      | Single ->
+          I.fld (addressing addr REAL4 i 0)
+      | Double | Double_u ->
+          I.fld (addressing addr REAL8 i 0)
+      end
+  | Lop(Istore(chunk, addr, _)) ->
+      begin match chunk with
+      | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned ->
+          I.mov (reg i.arg.(0)) (addressing addr DWORD i 1)
+      | Byte_unsigned | Byte_signed ->
+          I.mov (reg8 i.arg.(0)) (addressing addr BYTE i 1)
+      | Sixteen_unsigned | Sixteen_signed ->
+          I.mov (reg16 i.arg.(0)) (addressing addr WORD i 1)
+      | Single ->
+          if is_tos i.arg.(0) then
+            I.fstp (addressing addr REAL4 i 1)
+          else begin
+            I.fld (reg i.arg.(0));
+            I.fstp (addressing addr REAL4 i 1)
+          end
+      | Double | Double_u ->
+          if is_tos i.arg.(0) then
+            I.fstp (addressing addr REAL8 i 1)
+          else begin
+            I.fld (reg i.arg.(0));
+            I.fstp (addressing addr REAL8 i 1)
+          end
+      end
+  | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+      if !fastcode_flag then begin
+        let lbl_redo = new_label() in
+        def_label lbl_redo;
+        I.mov (sym32 "caml_young_ptr") eax;
+        I.sub (int n) eax;
+        I.mov eax (sym32 "caml_young_ptr");
+        I.cmp (sym32 "caml_young_limit") eax;
+        let lbl_call_gc = new_label() in
+        let lbl_frame = record_frame_label i.live false Debuginfo.none in
+        I.jb (label lbl_call_gc);
+        I.lea (mem32 NONE 4 RAX) (reg i.res.(0));
+        call_gc_sites :=
+          { gc_lbl = lbl_call_gc;
+            gc_return_lbl = lbl_redo;
+            gc_frame = lbl_frame } :: !call_gc_sites
+      end else begin
+        begin match n with
+          8  -> emit_call "caml_alloc1"
+        | 12 -> emit_call "caml_alloc2"
+        | 16 -> emit_call "caml_alloc3"
+        | _  ->
+            I.mov (int n) eax;
+            emit_call "caml_allocN"
+        end;
+        let label =
+          record_frame_label ?label:label_after_call_gc i.live false
+            Debuginfo.none
+        in
+        def_label label;
+        I.lea (mem32 NONE 4 RAX) (reg i.res.(0))
+      end
+  | Lop(Iintop(Icomp cmp)) ->
+      I.cmp (reg i.arg.(1)) (reg i.arg.(0));
+      I.set (cond cmp) al;
+      I.movzx al (reg i.res.(0));
+  | Lop(Iintop_imm(Icomp cmp, n)) ->
+      I.cmp (int n) (reg i.arg.(0));
+      I.set (cond cmp) al;
+      I.movzx al (reg i.res.(0))
+  | Lop(Iintop (Icheckbound { label_after_error; } )) ->
+      let lbl = bound_error_label ?label:label_after_error i.dbg in
+      I.cmp (reg i.arg.(1)) (reg i.arg.(0));
+      I.jbe (label lbl)
+  | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+      let lbl = bound_error_label ?label:label_after_error i.dbg in
+      I.cmp (int n) (reg i.arg.(0));
+      I.jbe (label lbl)
+  | Lop(Iintop(Idiv | Imod)) ->
+      I.cdq ();
+      I.idiv (reg i.arg.(1))
+  | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
+      (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *)
+      instr_for_intop op cl (reg i.res.(0))
+  | Lop(Iintop Imulh) ->
+      I.imul (reg i.arg.(1)) None
+  | Lop(Iintop op) ->
+      (* We have i.arg.(0) = i.res.(0) *)
+      instr_for_intop op (reg i.arg.(1)) (reg i.res.(0))
+  | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc ->
+      I.lea (mem32 NONE n (reg32 i.arg.(0))) (reg i.res.(0))
+  | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) ->
+      I.inc (reg i.res.(0))
+  | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) ->
+      I.dec (reg i.res.(0))
+  | Lop(Iintop_imm(op, n)) ->
+      (* We have i.arg.(0) = i.res.(0) *)
+      instr_for_intop op (int n) (reg i.res.(0))
+  | Lop(Inegf | Iabsf as floatop) ->
+      if not (is_tos i.arg.(0)) then
+        I.fld (reg i.arg.(0));
+      unary_instr_for_floatop floatop
+  | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev)
+        as floatop) ->
+      begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with
+        (true, true) ->
+          (* both operands on top of FP stack *)
+          instr_for_floatop_reversed_pop floatop st0 st1
+      | (true, false) ->
+          (* first operand on stack *)
+          instr_for_floatop floatop (reg i.arg.(1))
+      | (false, true) ->
+          (* second operand on stack *)
+          instr_for_floatop_reversed floatop (reg i.arg.(0))
+      | (false, false) ->
+          (* both operands in memory *)
+          I.fld (reg i.arg.(0));
+          instr_for_floatop floatop (reg i.arg.(1))
+      end
+  | Lop(Ifloatofint) ->
+      begin match i.arg.(0).loc with
+      | Stack _ ->
+          I.fild (reg i.arg.(0))
+      | _ ->
+          I.push (reg i.arg.(0));
+          I.fild (mem32 DWORD 0 RSP);
+          I.add (int 4) esp
+      end
+  | Lop(Iintoffloat) ->
+      if not (is_tos i.arg.(0)) then
+        I.fld (reg i.arg.(0));
+      stack_offset := !stack_offset - 8;
+      I.sub (int 8) esp;
+      cfi_adjust_cfa_offset 8;
+      I.fnstcw (mem32 NONE 4 RSP);
+      I.mov (mem32 WORD 4 RSP) ax;
+      I.mov (int 12) ah;
+      I.mov ax (mem32 WORD 0 RSP);
+      I.fldcw (mem32 NONE 0 RSP);
+      begin match i.res.(0).loc with
+      | Stack _ ->
+          I.fistp (reg i.res.(0))
+      | _ ->
+          I.fistp (mem32 DWORD 0 RSP);
+          I.mov (mem32 DWORD 0 RSP) (reg i.res.(0))
+      end;
+      I.fldcw (mem32 NONE 4 RSP);
+      I.add (int 8) esp;
+      cfi_adjust_cfa_offset (-8);
+      stack_offset := !stack_offset + 8
+  | Lop(Ispecific(Ilea addr)) ->
+      I.lea (addressing addr DWORD i 0) (reg i.res.(0))
+  | Lop(Ispecific(Istore_int(n, addr, _))) ->
+      I.mov (nat n) (addressing addr DWORD i 0)
+  | Lop(Ispecific(Istore_symbol(s, addr, _))) ->
+      add_used_symbol s;
+      I.mov (immsym s) (addressing addr DWORD i 0)
+  | Lop(Ispecific(Ioffset_loc(n, addr))) ->
+      I.add (int n) (addressing addr DWORD i 0)
+  | Lop(Ispecific(Ipush)) ->
+      (* Push arguments in reverse order *)
+      for n = Array.length i.arg - 1 downto 0 do
+        let r = i.arg.(n) in
+        match r with
+          {loc = Reg _; typ = Float} ->
+            I.sub (int 8) esp;
+            cfi_adjust_cfa_offset 8;
+            I.fstp (mem32 REAL8 0 RSP);
+            stack_offset := !stack_offset + 8
+        | {loc = Stack sl; typ = Float} ->
+            let ofs = slot_offset sl 1 in
+            (* Use x87 stack to move from stack to stack,
+               instead of two 32-bit push instructions,
+               which could kill performance on modern CPUs (see #6979).
+            *)
+            I.fld (mem32 REAL8 ofs RSP);
+            I.sub (int 8) esp;
+            cfi_adjust_cfa_offset 8;
+            I.fstp (mem32 REAL8 0 RSP);
+            stack_offset := !stack_offset + 8
+        | _ ->
+            I.push (reg r);
+            cfi_adjust_cfa_offset 4;
+            stack_offset := !stack_offset + 4
+      done
+  | Lop(Ispecific(Ipush_int n)) ->
+      I.push (nat n);
+      cfi_adjust_cfa_offset 4;
+      stack_offset := !stack_offset + 4
+  | Lop(Ispecific(Ipush_symbol s)) ->
+      add_used_symbol s;
+      I.push (immsym s);
+      cfi_adjust_cfa_offset 4;
+      stack_offset := !stack_offset + 4
+  | Lop(Ispecific(Ipush_load addr)) ->
+      I.push (addressing addr DWORD i 0);
+      cfi_adjust_cfa_offset 4;
+      stack_offset := !stack_offset + 4
+  | Lop(Ispecific(Ipush_load_float addr)) ->
+      I.push (addressing (offset_addressing addr 4) DWORD i 0);
+      I.push (addressing addr DWORD i 0);
+      cfi_adjust_cfa_offset 8;
+      stack_offset := !stack_offset + 8
+  | Lop(Ispecific(Ifloatarithmem(double, op, addr))) ->
+      if not (is_tos i.arg.(0)) then
+        I.fld (reg i.arg.(0));
+      instr_for_floatarithmem op
+          (addressing addr
+             (if double then REAL8 else REAL4) i 1)
+  | Lop(Ispecific(Ifloatspecial s)) ->
+      (* Push args on float stack if necessary *)
+      for k = 0 to Array.length i.arg - 1 do
+        if not (is_tos i.arg.(k)) then I.fld (reg i.arg.(k))
+      done;
+      (* Fix-up for binary instrs whose args were swapped *)
+      if Array.length i.arg = 2 && is_tos i.arg.(1) then
+        I.fxch st1;
+      emit_floatspecial s
+  | Lreloadretaddr ->
+      ()
+  | Lreturn ->
+      output_epilogue begin fun () ->
+        I.ret ()
+      end
+  | Llabel lbl ->
+      emit_Llabel fallthrough lbl
+  | Lbranch lbl ->
+      I.jmp (label lbl)
+  | Lcondbranch(tst, lbl) ->
+      let lbl = label lbl in
+      begin match tst with
+      | Itruetest ->
+          output_test_zero i.arg.(0);
+          I.jne lbl;
+      | Ifalsetest ->
+          output_test_zero i.arg.(0);
+          I.je lbl
+      | Iinttest cmp ->
+          I.cmp (reg i.arg.(1)) (reg i.arg.(0));
+          I.j (cond cmp) lbl
+      | Iinttest_imm((Isigned Ceq | Isigned Cne |
+                      Iunsigned Ceq | Iunsigned Cne) as cmp, 0) ->
+          output_test_zero i.arg.(0);
+          I.j (cond cmp) lbl
+      | Iinttest_imm(cmp, n) ->
+          I.cmp (int n) (reg i.arg.(0));
+          I.j (cond cmp) lbl
+      | Ifloattest(cmp, neg) ->
+          emit_float_test cmp neg i.arg lbl
+      | Ioddtest ->
+          I.test (int 1) (reg i.arg.(0));
+          I.jne lbl
+      | Ieventest ->
+          I.test (int 1) (reg i.arg.(0));
+          I.je lbl
+      end
+  | Lcondbranch3(lbl0, lbl1, lbl2) ->
+      I.cmp (int 1) (reg i.arg.(0));
+      begin match lbl0 with
+        None -> ()
+      | Some lbl -> I.jb (label lbl)
+      end;
+      begin match lbl1 with
+        None -> ()
+      | Some lbl -> I.je (label lbl)
+      end;
+      begin match lbl2 with
+        None -> ()
+      | Some lbl -> I.jg (label lbl)
+      end
+  | Lswitch jumptbl ->
+      let lbl = new_label() in
+      I.jmp (mem32 NONE 0 (reg32 i.arg.(0)) ~scale:4 ~sym:(emit_label lbl));
+      D.data ();
+      _label (emit_label lbl);
+      for i = 0 to Array.length jumptbl - 1 do
+        D.long (ConstLabel (emit_label jumptbl.(i)))
+      done;
+      D.text ()
+  | Lsetuptrap lbl ->
+      I.call (label lbl)
+  | Lpushtrap ->
+      if trap_frame_size > 8 then
+        I.sub (int (trap_frame_size - 8)) esp;
+      I.push (sym32 "caml_exception_pointer");
+      cfi_adjust_cfa_offset trap_frame_size;
+      I.mov esp (sym32 "caml_exception_pointer");
+      stack_offset := !stack_offset + trap_frame_size
+  | Lpoptrap ->
+      I.pop (sym32 "caml_exception_pointer");
+      I.add (int (trap_frame_size - 4)) esp;
+      cfi_adjust_cfa_offset (-trap_frame_size);
+      stack_offset := !stack_offset - trap_frame_size
+  | Lraise k  ->
+      begin match k with
+      | Cmm.Raise_withtrace ->
+          emit_call "caml_raise_exn";
+          record_frame Reg.Set.empty true i.dbg
+      | Cmm.Raise_notrace ->
+          I.mov (sym32 "caml_exception_pointer") esp;
+          I.pop (sym32 "caml_exception_pointer");
+          if trap_frame_size > 8 then
+            I.add (int (trap_frame_size - 8)) esp;
+          I.ret ()
+      end
+
+let rec emit_all fallthrough i =
+  match i.desc with
+  |  Lend -> ()
+  | _ ->
+      emit_instr fallthrough i;
+      emit_all
+        (system = S_win32 || Linearize.has_fallthrough i.desc)
+        i.next
+
+(* Emission of external symbol references (for MacOSX) *)
+
+let emit_external_symbol_direct s =
+  _label (Printf.sprintf "L%s$stub" (emit_symbol s));
+  D.indirect_symbol (emit_symbol s);
+  I.hlt (); I.hlt (); I.hlt (); I.hlt () ; I.hlt ()
+
+let emit_external_symbol_indirect s =
+  _label (Printf.sprintf "L%s$non_lazy_ptr" (emit_symbol s));
+  D.indirect_symbol (emit_symbol s);
+  D.long (const 0)
+
+let emit_external_symbols () =
+  D.section [ "__IMPORT"; "__pointers"] None ["non_lazy_symbol_pointers" ];
+  StringSet.iter emit_external_symbol_indirect !external_symbols_indirect;
+  external_symbols_indirect := StringSet.empty;
+  D.section [ "__IMPORT"; "__jump_table"] None
+    [ "symbol_stubs"; "self_modifying_code+pure_instructions"; "5" ];
+  StringSet.iter emit_external_symbol_direct !external_symbols_direct;
+  external_symbols_direct := StringSet.empty;
+  if !Clflags.gprofile then begin
+    _label "Lmcount$stub";
+    D.indirect_symbol "mcount";
+    I.hlt (); I.hlt (); I.hlt () ; I.hlt () ; I.hlt ()
+  end
+
+(* Emission of the profiling prelude *)
+
+let call_mcount mcount =
+  I.push eax;
+  I.mov esp ebp;
+  I.push ecx;
+  I.push edx;
+  I.call (sym mcount);
+  I.pop edx;
+  I.pop ecx;
+  I.pop eax
+
+let emit_profile () =
+  match system with
+  | S_linux_elf | S_gnu -> call_mcount "mcount"
+  | S_bsd_elf -> call_mcount ".mcount"
+  | S_macosx -> call_mcount "Lmcount$stub"
+  | _ -> () (*unsupported yet*)
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  fastcode_flag := fundecl.fun_fast;
+  tailrec_entry_point := new_label();
+  stack_offset := 0;
+  call_gc_sites := [];
+  bound_error_sites := [];
+  bound_error_call := 0;
+  D.text ();
+  add_def_symbol fundecl.fun_name;
+  D.align (if system = S_win32 then 4 else 16);
+  if system = S_macosx
+  && not !Clflags.output_c_object
+  && is_generic_function fundecl.fun_name
+  then (* PR#4690 *)
+    D.private_extern (emit_symbol fundecl.fun_name)
+  else
+    D.global (emit_symbol fundecl.fun_name);
+  D.label (emit_symbol fundecl.fun_name);
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc ();
+  if !Clflags.gprofile then emit_profile();
+  let n = frame_size() - 4 in
+  if n > 0 then  begin
+    I.sub (int n) esp;
+    cfi_adjust_cfa_offset n;
+  end;
+  def_label !tailrec_entry_point;
+  emit_all true fundecl.fun_body;
+  List.iter emit_call_gc !call_gc_sites;
+  emit_call_bound_errors ();
+  cfi_endproc ();
+  begin match system with
+  | S_linux_elf | S_bsd_elf | S_gnu ->
+      D.type_ (emit_symbol fundecl.fun_name) "@function";
+      D.size (emit_symbol fundecl.fun_name)
+        (ConstSub (
+            ConstThis,
+            ConstLabel (emit_symbol fundecl.fun_name)))
+  | _ -> ()
+  end
+
+
+(* Emission of data *)
+
+let emit_item = function
+  | Cglobal_symbol s -> D.global (emit_symbol s)
+  | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s)
+  | Cint8 n -> D.byte (const n)
+  | Cint16 n -> D.word (const n)
+  | Cint32 n -> D.long (const_nat n)
+  | Cint n -> D.long (const_nat n)
+  | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f)))
+  | Cdouble f -> emit_float64_split_directive (Int64.bits_of_float f)
+  | Csymbol_address s -> add_used_symbol s; D.long (ConstLabel (emit_symbol s))
+  | Cstring s -> D.bytes s
+  | Cskip n -> if n > 0 then D.space n
+  | Calign n -> D.align n
+
+let data l =
+  D.data ();
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  X86_proc.reset_asm_code ();
+  reset_debug_info();                   (* PR#5603 *)
+  float_constants := [];
+  if system = S_win32 then begin
+    D.mode386 ();
+    D.model "FLAT";
+    D.extrn "_caml_young_ptr" DWORD;
+    D.extrn "_caml_young_limit" DWORD;
+    D.extrn "_caml_exception_pointer" DWORD;
+    D.extrn "_caml_extra_params" DWORD;
+    D.extrn "_caml_call_gc" PROC;
+    D.extrn "_caml_c_call" PROC;
+    D.extrn "_caml_allocN" PROC;
+    D.extrn "_caml_alloc1" PROC;
+    D.extrn "_caml_alloc2" PROC;
+    D.extrn "_caml_alloc3" PROC;
+    D.extrn "_caml_ml_array_bound_error" PROC;
+    D.extrn "_caml_raise_exn" PROC;
+  end;
+
+  D.data ();
+  emit_global_label "data_begin";
+
+  D.text ();
+  emit_global_label "code_begin";
+  if system = S_macosx then I.nop (); (* PR#4690 *)
+  ()
+
+let end_assembly() =
+  if !float_constants <> [] then begin
+    D.data ();
+    List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants
+  end;
+
+  D.text ();
+  if system = S_macosx then I.nop ();
+  (* suppress "ld warning: atom sorting error" *)
+
+  emit_global_label "code_end";
+
+  D.data ();
+  emit_global_label "data_end";
+  D.long (const 0);
+
+  emit_global_label "frametable";
+
+  emit_frames
+    { efa_code_label = (fun l -> D.long (ConstLabel (emit_label l)));
+      efa_data_label = (fun l -> D.long (ConstLabel (emit_label l)));
+      efa_16 = (fun n -> D.word (const n));
+      efa_32 = (fun n -> D.long (const_32 n));
+      efa_word = (fun n -> D.long (const n));
+      efa_align = D.align;
+      efa_label_rel = (fun lbl ofs ->
+          D.long (ConstAdd (
+              ConstSub(ConstLabel(emit_label lbl),
+                       ConstThis),
+              const_32 ofs)));
+      efa_def_label = (fun l -> _label (emit_label l));
+      efa_string = (fun s -> D.bytes (s ^ "\000"))
+    };
+
+  if system = S_macosx then emit_external_symbols ();
+  if system = S_linux_elf then
+    (* Mark stack as non-executable, PR#4564 *)
+    D.section [".note.GNU-stack"] (Some "") ["%progbits"];
+
+  if system = S_win32 then begin
+    D.comment "External functions";
+    StringSet.iter
+      (fun s ->
+         if not (StringSet.mem s !symbols_defined) then
+           D.extrn (emit_symbol s) PROC)
+      !symbols_used;
+    symbols_used := StringSet.empty;
+    symbols_defined := StringSet.empty;
+  end;
+
+  let asm =
+    if !Emitaux.create_asm_file then
+      Some
+        (
+         (if X86_proc.masm then X86_masm.generate_asm
+          else X86_gas.generate_asm) !Emitaux.output_channel
+        )
+    else
+      None
+  in
+  X86_proc.generate_code asm
diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml
new file mode 100644
index 00000000..9350fc96
--- /dev/null
+++ b/asmcomp/i386/proc.ml
@@ -0,0 +1,231 @@
+# 2 "asmcomp/i386/proc.ml"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the Intel 386 processor *)
+
+open Misc
+open Arch
+open Cmm
+open Reg
+open Mach
+
+(* Which asm conventions to use *)
+let masm =
+  match Config.ccomp_type with
+  | "msvc" -> true
+  | _      -> false
+
+(* Registers available for register allocation *)
+
+(* Register map:
+    eax         0               eax - edi: function arguments and results
+    ebx         1               eax: C function results
+    ecx         2               ebx, esi, edi, ebp: preserved by C
+    edx         3
+    esi         4
+    edi         5
+    ebp         6
+
+    tos         100             top of floating-point stack. *)
+
+let int_reg_name =
+  if masm then
+    [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |]
+  else
+    [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |]
+
+let float_reg_name =
+  if masm then
+    [| "tos" |]
+  else
+    [| "%tos" |]
+
+let num_register_classes = 2
+
+let register_class r =
+  match r.typ with
+  | Val | Int | Addr -> 0
+  | Float -> 1
+
+let num_available_registers = [| 7; 0 |]
+
+let first_available_register = [| 0; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+(* There is little scheduling, and some operations are more compact
+   when their argument is %eax. *)
+
+let rotate_registers = false
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 7 Reg.dummy in
+  for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
+  v
+
+let hard_float_reg = [| Reg.at_location Float (Reg 100) |]
+
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let eax = phys_reg 0
+let ecx = phys_reg 2
+let edx = phys_reg 3
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Calling conventions *)
+
+(* To supplement the processor's meagre supply of registers, we also
+   use some global memory locations to pass arguments beyond the 6th.
+   These globals are denoted by Incoming and Outgoing stack locations
+   with negative offsets, starting at -64.
+   Unlike arguments passed on stack, arguments passed in globals
+   do not prevent tail-call elimination.  The caller stores arguments
+   in these globals immediately before the call, and the first thing the
+   callee does is copy them to registers or stack locations.
+   Neither GC nor thread context switches can occur between these two
+   times. *)
+
+let calling_conventions first_int last_int first_float last_float make_stack
+                        arg =
+  let loc = Array.make (Array.length arg) Reg.dummy in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref (-64) in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+      Val | Int | Addr as ty ->
+        if !int <= last_int then begin
+          loc.(i) <- phys_reg !int;
+          incr int
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !float <= last_float then begin
+          loc.(i) <- phys_reg !float;
+          incr float
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align (max 0 !ofs) stack_alignment)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+(* Six arguments in integer registers plus eight in global memory. *)
+let max_arguments_for_tailcalls = 14
+
+let loc_arguments arg =
+  calling_conventions 0 5 100 99 outgoing arg
+let loc_parameters arg =
+  let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc
+let loc_results res =
+  let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc
+let loc_external_arguments _arg =
+  fatal_error "Proc.loc_external_arguments"
+let loc_external_results res =
+  match res with
+  | [|{typ=Int};{typ=Int}|] -> [|eax; edx|]
+  | _ ->
+      let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+
+let loc_exn_bucket = eax
+
+(* Volatile registers: the x87 top of FP stack is *)
+
+let reg_is_volatile = function
+  | { typ = Float; loc = Reg _ } -> true
+  | _ -> false
+
+let regs_are_volatile rs =
+  try
+    for i = 0 to Array.length rs - 1 do
+      if reg_is_volatile rs.(i) then raise Exit
+    done;
+    false
+  with Exit ->
+    true
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call =               (* ebx, esi, edi, ebp preserved *)
+  [|eax; ecx; edx|]
+
+let destroyed_at_oper = function
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _}) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
+  | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
+  | Iop(Ialloc _ | Iintop Imulh) -> [| eax |]
+  | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
+  | Iop(Iintoffloat) -> [| eax |]
+  | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
+  | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure _op = 4
+
+let max_register_pressure = function
+    Iextcall _ -> [| 4; max_int |]
+  | Iintop(Idiv | Imod) -> [| 5; max_int |]
+  | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
+    Iintoffloat -> [| 6; max_int |]
+  | _ -> [|7; max_int |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers).  *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
+  | Ispecific(Ilea _) -> true
+  | Ispecific _ -> false
+  | _ -> true
+
+(* Layout of the stack frame *)
+
+let num_stack_slots = [| 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler *)
+
+let assemble_file infile outfile =
+  X86_proc.assemble_file infile outfile
+
+let init () = ()
diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml
new file mode 100644
index 00000000..511b7f1b
--- /dev/null
+++ b/asmcomp/i386/reload.ml
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmm
+open Arch
+open Reg
+open Mach
+
+(* Reloading for the Intel x86 *)
+
+let stackp r =
+  match r.loc with
+    Stack _ -> true
+  | _ -> false
+
+class reload = object (self)
+
+inherit Reloadgen.reload_generic as super
+
+method! makereg r =
+  match r.typ with
+    Float -> r
+  | _ -> super#makereg r
+
+(* By overriding makereg, we make sure that pseudoregs of type float
+   will never be reloaded. Hence there is no need to make special cases for
+   floating-point operations. *)
+
+method! reload_operation op arg res =
+  match op with
+    Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) ->
+      (* One of the two arguments can reside in the stack *)
+      if stackp arg.(0) && stackp arg.(1)
+      then ([|arg.(0); self#makereg arg.(1)|], res)
+      else (arg, res)
+  | Iintop(Imul) ->
+      (* First argument (and destination) must be in register,
+         second arg can reside in stack *)
+      if stackp arg.(0)
+      then let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|])
+      else (arg, res)
+  | Iintop_imm(Iadd, _) when arg.(0).loc <> res.(0).loc ->
+      (* This add will be turned into a lea; args and results must be
+         in registers *)
+      super#reload_operation op arg res
+  | Iintop_imm(Imul, _) ->
+      (* First argument and destination must be in register *)
+      if stackp arg.(0)
+      then let r = self#makereg arg.(0) in ([|r|], [|r|])
+      else (arg, res)
+  | Iintop(Imulh | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _)
+  | Ifloatofint | Iintoffloat | Ispecific(Ipush) ->
+      (* The argument(s) can be either in register or on stack *)
+      (* Note: Imulh: arg(0 and res(0) already forced in regs
+               Ilsl, Ilsr, Iasr: arg(1) already forced in regs *)
+      (arg, res)
+  | _ -> (* Other operations: all args and results in registers *)
+      super#reload_operation op arg res
+
+method! reload_test tst arg =
+  match tst with
+    Iinttest _ ->
+      (* One of the two arguments can reside on stack *)
+      if stackp arg.(0) && stackp arg.(1)
+      then [| self#makereg arg.(0); arg.(1) |]
+      else arg
+  | _ ->
+      (* The argument(s) can be either in register or on stack *)
+      arg
+
+end
+
+let fundecl f =
+  (new reload)#fundecl f
diff --git a/asmcomp/i386/scheduling.ml b/asmcomp/i386/scheduling.ml
new file mode 100644
index 00000000..05627b04
--- /dev/null
+++ b/asmcomp/i386/scheduling.ml
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let () = let module M = Schedgen in () (* to create a dependency *)
+
+(* Scheduling is turned off because our model does not fit the 486
+   nor the Pentium very well. In particular, it messes up with the
+   float reg stack. The Pentiums Pro / II / III / etc schedule
+   at run-time much better than what we could do. *)
+
+let fundecl f = f
diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml
new file mode 100644
index 00000000..efde628d
--- /dev/null
+++ b/asmcomp/i386/selection.ml
@@ -0,0 +1,327 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the Intel x86 *)
+
+open Misc
+open Arch
+open Proc
+open Cmm
+open Mach
+
+(* Auxiliary for recognizing addressing modes *)
+
+type addressing_expr =
+    Asymbol of string
+  | Alinear of expression
+  | Aadd of expression * expression
+  | Ascale of expression * int
+  | Ascaledadd of expression * expression * int
+
+let rec select_addr exp =
+  match exp with
+    Cconst_symbol s ->
+      (Asymbol s, 0)
+  | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) ->
+      let (a, n) = select_addr arg in (a, n + m)
+  | Cop(Csubi, [arg; Cconst_int m], _) ->
+      let (a, n) = select_addr arg in (a, n - m)
+  | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) ->
+      let (a, n) = select_addr arg in (a, n + m)
+  | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) ->
+      begin match select_addr arg with
+        (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
+      | _ -> (Alinear exp, 0)
+      end
+  | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) ->
+      begin match select_addr arg with
+        (Alinear e, n) -> (Ascale(e, mult), n * mult)
+      | _ -> (Alinear exp, 0)
+      end
+  | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) ->
+      begin match select_addr arg with
+        (Alinear e, n) -> (Ascale(e, mult), n * mult)
+      | _ -> (Alinear exp, 0)
+      end
+  | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) ->
+      begin match (select_addr arg1, select_addr arg2) with
+          ((Alinear e1, n1), (Alinear e2, n2)) ->
+              (Aadd(e1, e2), n1 + n2)
+        | ((Alinear e1, n1), (Ascale(e2, scale), n2)) ->
+              (Ascaledadd(e1, e2, scale), n1 + n2)
+        | ((Ascale(e1, scale), n1), (Alinear e2, n2)) ->
+              (Ascaledadd(e2, e1, scale), n1 + n2)
+        | (_, (Ascale(e2, scale), n2)) ->
+              (Ascaledadd(arg1, e2, scale), n2)
+        | ((Ascale(e1, scale), n1), _) ->
+              (Ascaledadd(arg2, e1, scale), n1)
+        | _ ->
+              (Aadd(arg1, arg2), 0)
+      end
+  | arg ->
+      (Alinear arg, 0)
+
+(* C functions to be turned into Ifloatspecial instructions if -ffast-math.
+   If you update this list, you may need to update [is_simple_expr] and/or
+   [effects_of], below. *)
+let inline_float_ops =
+  ["atan"; "atan2"; "cos"; "log"; "log10"; "sin"; "sqrt"; "tan"]
+
+(* Estimate number of float temporaries needed to evaluate expression
+   (Ershov's algorithm) *)
+
+let rec float_needs = function
+    Cop((Cnegf | Cabsf), [arg], _) ->
+      float_needs arg
+  | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2], _) ->
+      let n1 = float_needs arg1 in
+      let n2 = float_needs arg2 in
+      if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
+  | Cop(Cextcall(fn, _ty_res, _alloc, _label), args, _dbg)
+    when !fast_math && List.mem fn inline_float_ops ->
+      begin match args with
+        [arg] -> float_needs arg
+      | [arg1; arg2] -> max (float_needs arg2 + 1) (float_needs arg1)
+      | _ -> assert false
+      end
+  | _ ->
+      1
+
+(* Special constraints on operand and result registers *)
+
+exception Use_default
+
+let eax = phys_reg 0
+let ecx = phys_reg 2
+let edx = phys_reg 3
+let tos = phys_reg 100
+
+let pseudoregs_for_operation op arg res =
+  match op with
+  (* Two-address binary operations *)
+    Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) ->
+      ([|res.(0); arg.(1)|], res, false)
+  (* Two-address unary operations *)
+  | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) ->
+      (res, res, false)
+  (* For imull, first arg must be in eax, eax is clobbered, and result is in
+     edx. *)
+  | Iintop(Imulh) ->
+      ([| eax; arg.(1) |], [| edx |], true)
+  (* For shifts with variable shift count, second arg must be in ecx *)
+  | Iintop(Ilsl|Ilsr|Iasr) ->
+      ([|res.(0); ecx|], res, false)
+  (* For div and mod, first arg must be in eax, edx is clobbered,
+     and result is in eax or edx respectively.
+     Keep it simple, just force second argument in ecx. *)
+  | Iintop(Idiv) ->
+      ([| eax; ecx |], [| eax |], true)
+  | Iintop(Imod) ->
+      ([| eax; ecx |], [| edx |], true)
+  (* For floating-point operations and floating-point loads,
+     the result is always left at the top of the floating-point stack *)
+  | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+  | Ifloatofint | Iload((Single | Double | Double_u), _)
+  | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem _ | Ifloatspecial _) ->
+      (arg, [| tos |], false)           (* don't move it immediately *)
+  (* For storing a byte, the argument must be in eax...edx.
+     (But for a short, any reg will do!)
+     Keep it simple, just force the argument to be in edx. *)
+  | Istore((Byte_unsigned | Byte_signed), _, _) ->
+      let newarg = Array.copy arg in
+      newarg.(0) <- edx;
+      (newarg, res, false)
+  (* Other instructions are regular *)
+  | _ -> raise Use_default
+
+let chunk_double = function
+    Single -> false
+  | Double -> true
+  | Double_u -> true
+  | _ -> assert false
+
+(* The selector class *)
+
+class selector = object (self)
+
+inherit Selectgen.selector_generic as super
+
+method is_immediate (_n : int) = true
+
+method! is_simple_expr e =
+  match e with
+  | Cop(Cextcall(fn, _, _alloc, _), args, _)
+    when !fast_math && List.mem fn inline_float_ops ->
+      (* inlined float ops are simple if their arguments are *)
+      List.for_all self#is_simple_expr args
+  | _ ->
+      super#is_simple_expr e
+
+method! effects_of e =
+  match e with
+  | Cop(Cextcall(fn, _, _, _), args, _)
+    when !fast_math && List.mem fn inline_float_ops ->
+      Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+  | _ ->
+      super#effects_of e
+
+method select_addressing _chunk exp =
+  match select_addr exp with
+    (Asymbol s, d) ->
+      (Ibased(s, d), Ctuple [])
+  | (Alinear e, d) ->
+      (Iindexed d, e)
+  | (Aadd(e1, e2), d) ->
+      (Iindexed2 d, Ctuple[e1; e2])
+  | (Ascale(e, scale), d) ->
+      (Iscaled(scale, d), e)
+  | (Ascaledadd(e1, e2, scale), d) ->
+      (Iindexed2scaled(scale, d), Ctuple[e1; e2])
+
+method! select_store is_assign addr exp =
+  match exp with
+    Cconst_int n ->
+      (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
+  | (Cconst_natint n | Cblockheader (n, _)) ->
+      (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
+  | Cconst_pointer n ->
+      (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
+  | Cconst_natpointer n ->
+      (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
+  | Cconst_symbol s ->
+      (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple [])
+  | _ ->
+      super#select_store is_assign addr exp
+
+method! select_operation op args dbg =
+  match op with
+  (* Recognize the LEA instruction *)
+    Caddi | Caddv | Cadda | Csubi ->
+      begin match self#select_addressing Word_int (Cop(op, args, dbg)) with
+        (Iindexed _, _)
+      | (Iindexed2 0, _) -> super#select_operation op args dbg
+      | (addr, arg) -> (Ispecific(Ilea addr), [arg])
+      end
+  (* Recognize float arithmetic with memory.
+     In passing, apply Ershov's algorithm to reduce stack usage *)
+  | Caddf ->
+      self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args
+  | Csubf ->
+      self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev
+                             args
+  | Cmulf ->
+      self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args
+  | Cdivf ->
+      self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev
+                             args
+  (* Recognize store instructions *)
+  | Cstore ((Word_int | Word_val) as chunk, _) ->
+      begin match args with
+        [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)]
+        when loc = loc' ->
+          let (addr, arg) = self#select_addressing chunk loc in
+          (Ispecific(Ioffset_loc(n, addr)), [arg])
+      | _ ->
+          super#select_operation op args dbg
+      end
+  (* Recognize inlined floating point operations *)
+  | Cextcall(fn, _ty_res, false, _label)
+    when !fast_math && List.mem fn inline_float_ops ->
+      (Ispecific(Ifloatspecial fn), args)
+  (* i386 does not support immediate operands for multiply high signed *)
+  | Cmulhi ->
+      (Iintop Imulh, args)
+  (* Default *)
+  | _ -> super#select_operation op args dbg
+
+(* Recognize float arithmetic with mem *)
+
+method select_floatarith regular_op reversed_op mem_op mem_rev_op args =
+  match args with
+    [arg1; Cop(Cload (chunk, _), [loc2], _)] ->
+      let (addr, arg2) = self#select_addressing chunk loc2 in
+      (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)),
+                 [arg1; arg2])
+  | [Cop(Cload (chunk, _), [loc1], _); arg2] ->
+      let (addr, arg1) = self#select_addressing chunk loc1 in
+      (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)),
+                 [arg2; arg1])
+  | [arg1; arg2] ->
+      (* Evaluate bigger subexpression first to minimize stack usage.
+         Because of right-to-left evaluation, rightmost arg is evaluated
+         first *)
+      if float_needs arg1 <= float_needs arg2
+      then (regular_op, [arg1; arg2])
+      else (reversed_op, [arg2; arg1])
+  | _ ->
+      fatal_error "Proc_i386: select_floatarith"
+
+(* Deal with register constraints *)
+
+method! insert_op_debug op dbg rs rd =
+  try
+    let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in
+    self#insert_moves rs rsrc;
+    self#insert_debug (Iop op) dbg rsrc rdst;
+    if move_res then begin
+      self#insert_moves rdst rd;
+      rd
+    end else
+      rdst
+  with Use_default ->
+    super#insert_op_debug op dbg rs rd
+
+(* Selection of push instructions for external calls *)
+
+method select_push exp =
+  match exp with
+    Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
+  | Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple [])
+  | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
+  | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
+  | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
+  | Cop(Cload ((Word_int | Word_val as chunk), _), [loc], _) ->
+      let (addr, arg) = self#select_addressing chunk loc in
+      (Ispecific(Ipush_load addr), arg)
+  | Cop(Cload (Double_u, _), [loc], _) ->
+      let (addr, arg) = self#select_addressing Double_u loc in
+      (Ispecific(Ipush_load_float addr), arg)
+  | _ -> (Ispecific(Ipush), exp)
+
+method! mark_c_tailcall =
+  Proc.contains_calls := true
+
+method! emit_extcall_args env args =
+  let rec size_pushes = function
+  | [] -> 0
+  | e :: el -> Selectgen.size_expr env e + size_pushes el in
+  let sz1 = size_pushes args in
+  let sz2 = Misc.align sz1 stack_alignment in
+  let rec emit_pushes = function
+  | [] ->
+      if sz2 > sz1 then
+        self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||]
+  | e :: el ->
+      emit_pushes el;
+      let (op, arg) = self#select_push e in
+      match self#emit_expr env arg with
+      | None -> ()
+      | Some r -> self#insert (Iop op) r [||] in
+  emit_pushes args;
+  ([||], sz2)
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/import_approx.ml b/asmcomp/import_approx.ml
new file mode 100644
index 00000000..0ab09ca0
--- /dev/null
+++ b/asmcomp/import_approx.ml
@@ -0,0 +1,192 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module A = Simple_value_approx
+
+let import_set_of_closures =
+  let import_function_declarations (clos : Flambda.function_declarations)
+        : Flambda.function_declarations =
+    (* CR-soon mshinwell for pchambart: Do we still need to do this
+       rewriting?  I'm wondering if maybe we don't have to any more. *)
+    let sym_to_fun_var_map (clos : Flambda.function_declarations) =
+      Variable.Map.fold (fun fun_var _ acc ->
+           let closure_id = Closure_id.wrap fun_var in
+           let sym = Compilenv.closure_symbol closure_id in
+           Symbol.Map.add sym fun_var acc)
+        clos.funs Symbol.Map.empty
+    in
+    let sym_map = sym_to_fun_var_map clos in
+    let f_named (named : Flambda.named) =
+      match named with
+      | Symbol sym ->
+        begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with
+        | Not_found -> named
+        end
+      | named -> named
+    in
+    let funs =
+      Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+          let body =
+            Flambda_iterators.map_toplevel_named f_named function_decl.body
+          in
+          Flambda.create_function_declaration ~params:function_decl.params
+            ~body ~stub:function_decl.stub ~dbg:function_decl.dbg
+            ~inline:function_decl.inline
+            ~specialise:function_decl.specialise
+            ~is_a_functor:function_decl.is_a_functor)
+        clos.funs
+    in
+    Flambda.update_function_declarations clos ~funs
+  in
+  let aux set_of_closures_id =
+    ignore (Compilenv.approx_for_global
+      (Set_of_closures_id.get_compilation_unit set_of_closures_id));
+    let ex_info = Compilenv.approx_env () in
+    let function_declarations =
+      try
+        Some (Set_of_closures_id.Map.find set_of_closures_id
+          ex_info.sets_of_closures)
+      with Not_found ->
+        None
+    in
+    match function_declarations with
+    | None -> None
+    | Some function_declarations ->
+      Some (import_function_declarations function_declarations)
+  in
+  Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
+
+let rec import_ex ex =
+  ignore (Compilenv.approx_for_global (Export_id.get_compilation_unit ex));
+  let ex_info = Compilenv.approx_env () in
+  let import_value_set_of_closures ~set_of_closures_id ~bound_vars
+        ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option =
+    let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
+    match
+      Set_of_closures_id.Map.find set_of_closures_id ex_info.invariant_params
+    with
+    | exception Not_found ->
+      Misc.fatal_errorf "Set of closures ID %a not found in invariant_params \
+          (when importing [%a: %s])"
+        Set_of_closures_id.print set_of_closures_id
+        Export_id.print ex
+        what
+    | invariant_params ->
+      match import_set_of_closures set_of_closures_id with
+      | None -> None
+      | Some function_decls ->
+        Some (A.create_value_set_of_closures
+          ~function_decls
+          ~bound_vars
+          ~invariant_params:(lazy invariant_params)
+          ~specialised_args:Variable.Map.empty
+          ~freshening:Freshening.Project_var.empty
+          ~direct_call_surrogates:Closure_id.Map.empty)
+  in
+  match Export_info.find_description ex_info ex with
+  | exception Not_found -> A.value_unknown Other
+  | Value_int i -> A.value_int i
+  | Value_char c -> A.value_char c
+  | Value_constptr i -> A.value_constptr i
+  | Value_float f -> A.value_float f
+  | Value_float_array float_array ->
+    begin match float_array.contents with
+    | Unknown_or_mutable ->
+      A.value_mutable_float_array ~size:float_array.size
+    | Contents contents ->
+      A.value_immutable_float_array
+        (Array.map (function
+           | None -> A.value_any_float
+           | Some f -> A.value_float f)
+           contents)
+    end
+  | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
+  | Value_string { size; contents } ->
+    let contents =
+      match contents with
+      | Unknown_or_mutable -> None
+      | Contents contents -> Some contents
+    in
+    A.value_string size contents
+  | Value_mutable_block _ -> A.value_unknown Other
+  | Value_block (tag, fields) ->
+    A.value_block tag (Array.map import_approx fields)
+  | Value_closure { closure_id;
+        set_of_closures =
+          { set_of_closures_id; bound_vars; aliased_symbol } } ->
+    let value_set_of_closures =
+      import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
+        ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
+    in
+    begin match value_set_of_closures with
+    | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id)
+    | Some value_set_of_closures ->
+      A.value_closure ?set_of_closures_symbol:aliased_symbol
+        value_set_of_closures closure_id
+    end
+  | Value_set_of_closures { set_of_closures_id; bound_vars; aliased_symbol } ->
+    let value_set_of_closures =
+      import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
+        ~what:"Value_set_of_closures"
+    in
+    match value_set_of_closures with
+    | None ->
+      A.value_unresolved (Set_of_closures_id set_of_closures_id)
+    | Some value_set_of_closures ->
+      let approx = A.value_set_of_closures value_set_of_closures in
+      match aliased_symbol with
+      | None -> approx
+      | Some symbol -> A.augment_with_symbol approx symbol
+
+and import_approx (ap : Export_info.approx) =
+  match ap with
+  | Value_unknown -> A.value_unknown Other
+  | Value_id ex -> A.value_extern ex
+  | Value_symbol sym -> A.value_symbol sym
+
+let import_symbol sym =
+  if Compilenv.is_predefined_exception sym then
+    A.value_unknown Other
+  else
+    let symbol_id_map =
+      let global = Symbol.compilation_unit sym in
+      (Compilenv.approx_for_global global).symbol_id
+    in
+    match Symbol.Map.find sym symbol_id_map with
+    | approx -> A.augment_with_symbol (import_ex approx) sym
+    | exception Not_found ->
+      A.value_unresolved (Symbol sym)
+
+(* Note for code reviewers: Observe that [really_import] iterates until
+   the approximation description is fully resolved (or a necessary .cmx
+   file is missing). *)
+
+let rec really_import (approx : A.descr) =
+  match approx with
+  | Value_extern ex -> really_import_ex ex
+  | Value_symbol sym -> really_import_symbol sym
+  | r -> r
+
+and really_import_ex ex =
+  really_import (import_ex ex).descr
+
+and really_import_symbol sym =
+  really_import (import_symbol sym).descr
+
+let really_import_approx (approx : Simple_value_approx.t) =
+  A.replace_description approx (really_import approx.descr)
diff --git a/asmcomp/import_approx.mli b/asmcomp/import_approx.mli
new file mode 100644
index 00000000..23d9d294
--- /dev/null
+++ b/asmcomp/import_approx.mli
@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Create simple value approximations from the export information in
+    .cmx files. *)
+
+(** Given an approximation description, load .cmx files (possibly more
+    than one) until the description is fully resolved.  If a necessary .cmx
+    file cannot be found, "unresolved" will be returned. *)
+val really_import : Simple_value_approx.descr -> Simple_value_approx.descr
+
+(** Maps the description of the given approximation through [really_import]. *)
+val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t
+
+(** Read and convert the approximation of a given symbol from the
+    relevant .cmx file.  Unlike the "really_" functions, this does not
+    continue to load .cmx files until the approximation is fully
+    resolved. *)
+val import_symbol : Symbol.t -> Simple_value_approx.t
diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml
new file mode 100644
index 00000000..7d569c5b
--- /dev/null
+++ b/asmcomp/interf.ml
@@ -0,0 +1,203 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Construction of the interference graph.
+   Annotate pseudoregs with interference lists and preference lists. *)
+
+module IntPairSet =
+  Set.Make(struct
+    type t = int * int
+    let compare ((a1,b1) : t) (a2,b2) =
+      match compare a1 a2 with
+        | 0 -> compare b1 b2
+        | c -> c
+  end)
+
+open Reg
+open Mach
+
+let build_graph fundecl =
+
+  (* The interference graph is represented in two ways:
+     - by adjacency lists for each register
+     - by a sparse bit matrix (a set of pairs of register stamps) *)
+
+  let mat = ref IntPairSet.empty in
+
+  (* Record an interference between two registers *)
+  let add_interf ri rj =
+    if Proc.register_class ri = Proc.register_class rj then begin
+      let i = ri.stamp and j = rj.stamp in
+      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 begin
+            ri.interf <- rj :: ri.interf;
+            if not rj.spill then ri.degree <- ri.degree + 1
+          end;
+          if rj.loc = Unknown then begin
+            rj.interf <- ri :: rj.interf;
+            if not ri.spill then rj.degree <- rj.degree + 1
+          end
+        end
+      end
+    end in
+
+  (* Record interferences between a register array and a set of registers *)
+  let add_interf_set v s =
+    for i = 0 to Array.length v - 1 do
+      let r1 = v.(i) in
+      Reg.Set.iter (add_interf r1) s
+    done in
+
+  (* Record interferences between elements of an array *)
+  let add_interf_self v =
+    for i = 0 to Array.length v - 2 do
+      let ri = v.(i) in
+      for j = i+1 to Array.length v - 1 do
+        add_interf ri v.(j)
+      done
+    done in
+
+  (* Record interferences between the destination of a move and a set
+     of live registers. Since the destination is equal to the source,
+     do not add an interference between them if the source is still live
+     afterwards. *)
+  let add_interf_move src dst s =
+    Reg.Set.iter (fun r -> if r.stamp <> src.stamp then add_interf dst r) s in
+
+  (* Compute interferences *)
+
+  let rec interf i =
+    let destroyed = Proc.destroyed_at_oper i.desc in
+    if Array.length destroyed > 0 then add_interf_set destroyed i.live;
+    match i.desc with
+      Iend -> ()
+    | Ireturn -> ()
+    | Iop(Imove | Ispill | Ireload) ->
+        add_interf_move i.arg.(0) i.res.(0) i.live;
+        interf i.next
+    | Iop(Itailcall_ind _) -> ()
+    | Iop(Itailcall_imm _) -> ()
+    | Iop _ ->
+        add_interf_set i.res i.live;
+        add_interf_self i.res;
+        interf i.next
+    | Iifthenelse(_tst, ifso, ifnot) ->
+        interf ifso;
+        interf ifnot;
+        interf i.next
+    | Iswitch(_index, cases) ->
+        for i = 0 to Array.length cases - 1 do
+          interf cases.(i)
+        done;
+        interf i.next
+    | Iloop body ->
+        interf body; interf i.next
+    | Icatch(_rec_flag, handlers, body) ->
+        interf body;
+        List.iter (fun (_, handler) -> interf handler) handlers;
+        interf i.next
+    | Iexit _ ->
+        ()
+    | Itrywith(body, handler) ->
+        add_interf_set Proc.destroyed_at_raise handler.live;
+        interf body; interf handler; interf i.next
+    | Iraise _ -> () in
+
+  (* Add a preference from one reg to another.
+     Do not add anything if the two registers conflict,
+     or if the source register already has a location,
+     or if the two registers belong to different classes.
+     (The last case can occur e.g. on Sparc when passing
+      float arguments in integer registers, PR#6227.) *)
+
+  let add_pref weight r1 r2 =
+    if weight > 0 then begin
+      let i = r1.stamp and j = r2.stamp in
+      if i <> j
+      && r1.loc = Unknown
+      && Proc.register_class r1 = Proc.register_class r2
+      && (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
+
+  (* Add a mutual preference between two regs *)
+  let add_mutual_pref weight r1 r2 =
+    add_pref weight r1 r2; add_pref weight r2 r1 in
+
+  (* Update the spill cost of the registers involved in an operation *)
+
+  let add_spill_cost cost arg =
+    for i = 0 to Array.length arg - 1 do
+      let r = arg.(i) in r.spill_cost <- r.spill_cost + cost
+    done in
+
+  (* Compute preferences and spill costs *)
+
+  let rec prefer weight i =
+    add_spill_cost weight i.arg;
+    add_spill_cost weight i.res;
+    match i.desc with
+      Iend -> ()
+    | Ireturn -> ()
+    | Iop(Imove) ->
+        add_mutual_pref weight i.arg.(0) i.res.(0);
+        prefer weight i.next
+    | Iop(Ispill) ->
+        add_pref (weight / 4) i.arg.(0) i.res.(0);
+        prefer weight i.next
+    | Iop(Ireload) ->
+        add_pref (weight / 4) i.res.(0) i.arg.(0);
+        prefer weight i.next
+    | Iop(Itailcall_ind _) -> ()
+    | Iop(Itailcall_imm _) -> ()
+    | Iop _ ->
+        prefer weight i.next
+    | Iifthenelse(_tst, ifso, ifnot) ->
+        prefer (weight / 2) ifso;
+        prefer (weight / 2) ifnot;
+        prefer weight i.next
+    | Iswitch(_index, cases) ->
+        for i = 0 to Array.length cases - 1 do
+          prefer (weight / 2) cases.(i)
+        done;
+        prefer weight i.next
+    | Iloop body ->
+        (* Avoid overflow of weight and spill_cost *)
+        prefer (if weight < 1000 then 8 * weight else weight) body;
+        prefer weight i.next
+    | Icatch(rec_flag, handlers, body) ->
+        prefer weight body;
+        List.iter (fun (_nfail, handler) ->
+            let weight =
+              match rec_flag with
+              | Cmm.Recursive ->
+                  (* Avoid overflow of weight and spill_cost *)
+                  if weight < 1000 then 8 * weight else weight
+              | Cmm.Nonrecursive ->
+                  weight in
+            prefer weight handler) handlers;
+        prefer weight i.next
+    | Iexit _ ->
+        ()
+    | Itrywith(body, handler) ->
+        prefer weight body; prefer weight handler; prefer weight i.next
+    | Iraise _ -> ()
+  in
+
+  interf fundecl.fun_body; prefer 8 fundecl.fun_body
diff --git a/asmcomp/interf.mli b/asmcomp/interf.mli
new file mode 100644
index 00000000..13549a1d
--- /dev/null
+++ b/asmcomp/interf.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Construction of the interference graph.
+   Annotate pseudoregs with interference lists and preference lists. *)
+
+val build_graph: Mach.fundecl -> unit
diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
new file mode 100644
index 00000000..1aa5d90f
--- /dev/null
+++ b/asmcomp/linearize.ml
@@ -0,0 +1,317 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Transformation of Mach code into a list of pseudo-instructions. *)
+
+open Reg
+open Mach
+
+type label = Cmm.label
+
+type instruction =
+  { mutable desc: instruction_desc;
+    mutable next: instruction;
+    arg: Reg.t array;
+    res: Reg.t array;
+    dbg: Debuginfo.t;
+    live: Reg.Set.t }
+
+and instruction_desc =
+    Lend
+  | Lop of operation
+  | Lreloadretaddr
+  | Lreturn
+  | Llabel of label
+  | Lbranch of label
+  | Lcondbranch of test * label
+  | Lcondbranch3 of label option * label option * label option
+  | Lswitch of label array
+  | Lsetuptrap of label
+  | Lpushtrap
+  | Lpoptrap
+  | Lraise of Cmm.raise_kind
+
+let has_fallthrough = function
+  | Lreturn | Lbranch _ | Lswitch _ | Lraise _
+  | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false
+  | _ -> true
+
+type fundecl =
+  { fun_name: string;
+    fun_body: instruction;
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : Mach.spacetime_shape option;
+  }
+
+(* Invert a test *)
+
+let invert_integer_test = function
+    Isigned cmp -> Isigned(Cmm.negate_comparison cmp)
+  | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp)
+
+let invert_test = function
+    Itruetest -> Ifalsetest
+  | Ifalsetest -> Itruetest
+  | Iinttest(cmp) -> Iinttest(invert_integer_test cmp)
+  | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n)
+  | Ifloattest(cmp, neg) -> Ifloattest(cmp, not neg)
+  | Ieventest -> Ioddtest
+  | Ioddtest -> Ieventest
+
+(* The "end" instruction *)
+
+let rec end_instr =
+  { desc = Lend;
+    next = end_instr;
+    arg = [||];
+    res = [||];
+    dbg = Debuginfo.none;
+    live = Reg.Set.empty }
+
+(* Cons an instruction (live, debug empty) *)
+
+let instr_cons d a r n =
+  { desc = d; next = n; arg = a; res = r;
+    dbg = Debuginfo.none; live = Reg.Set.empty }
+
+(* Cons a simple instruction (arg, res, live empty) *)
+
+let cons_instr d n =
+  { desc = d; next = n; arg = [||]; res = [||];
+    dbg = Debuginfo.none; live = Reg.Set.empty }
+
+(* Build an instruction with arg, res, dbg, live taken from
+   the given Mach.instruction *)
+
+let copy_instr d i n =
+  { desc = d; next = n;
+    arg = i.Mach.arg; res = i.Mach.res;
+    dbg = i.Mach.dbg; live = i.Mach.live }
+
+(*
+   Label the beginning of the given instruction sequence.
+   - If the sequence starts with a branch, jump over it.
+   - If the sequence is the end, (tail call position), just do nothing
+*)
+
+let get_label n = match n.desc with
+    Lbranch lbl -> (lbl, n)
+  | Llabel lbl -> (lbl, n)
+  | Lend -> (-1, n)
+  | _ -> let lbl = Cmm.new_label() in (lbl, cons_instr (Llabel lbl) n)
+
+(* Check the fallthrough label *)
+let check_label n = match n.desc with
+  | Lbranch lbl -> lbl
+  | Llabel lbl -> lbl
+  | _ -> -1
+
+(* Discard all instructions up to the next label.
+   This function is to be called before adding a non-terminating
+   instruction. *)
+
+let rec discard_dead_code n =
+  match n.desc with
+    Lend -> n
+  | Llabel _ -> n
+(* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions,
+   as this may cause a stack imbalance later during assembler generation. *)
+  | Lpoptrap | Lpushtrap -> n
+  | Lop(Istackoffset _) -> n
+  | _ -> discard_dead_code n.next
+
+(*
+   Add a branch in front of a continuation.
+   Discard dead code in the continuation.
+   Does not insert anything if we're just falling through
+   or if we jump to dead code after the end of function (lbl=-1)
+*)
+
+let add_branch lbl n =
+  if lbl >= 0 then
+    let n1 = discard_dead_code n in
+    match n1.desc with
+    | Llabel lbl1 when lbl1 = lbl -> n1
+    | _ -> cons_instr (Lbranch lbl) n1
+  else
+    discard_dead_code n
+
+let try_depth = ref 0
+
+(* Association list: exit handler -> (handler label, try-nesting factor) *)
+
+let exit_label = ref []
+
+let find_exit_label_try_depth k =
+  try
+    List.assoc k !exit_label
+  with
+  | Not_found -> Misc.fatal_error "Linearize.find_exit_label"
+
+let find_exit_label k =
+  let (label, t) = find_exit_label_try_depth k in
+  assert(t = !try_depth);
+  label
+
+let is_next_catch n = match !exit_label with
+| (n0,(_,t))::_  when n0=n && t = !try_depth -> true
+| _ -> false
+
+let local_exit k =
+  snd (find_exit_label_try_depth k) = !try_depth
+
+(* Linearize an instruction [i]: add it in front of the continuation [n] *)
+
+let rec linear i n =
+  match i.Mach.desc with
+    Iend -> n
+  | Iop(Itailcall_ind _ | Itailcall_imm _ as op) ->
+      if not Config.spacetime then
+        copy_instr (Lop op) i (discard_dead_code n)
+      else
+        copy_instr (Lop op) i (linear i.Mach.next n)
+  | Iop(Imove | Ireload | Ispill)
+    when i.Mach.arg.(0).loc = i.Mach.res.(0).loc ->
+      linear i.Mach.next n
+  | Iop op ->
+      copy_instr (Lop op) i (linear i.Mach.next n)
+  | Ireturn ->
+      let n1 = copy_instr Lreturn i (discard_dead_code n) in
+      if !Proc.contains_calls
+      then cons_instr Lreloadretaddr n1
+      else n1
+  | Iifthenelse(test, ifso, ifnot) ->
+      let n1 = linear i.Mach.next n in
+      begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with
+        Iend, _, Lbranch lbl ->
+          copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1)
+      | _, Iend, Lbranch lbl ->
+          copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
+      | Iexit nfail1, Iexit nfail2, _
+            when is_next_catch nfail1 && local_exit nfail2 ->
+          let lbl2 = find_exit_label nfail2 in
+          copy_instr
+            (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1)
+      | Iexit nfail, _, _ when local_exit nfail ->
+          let n2 = linear ifnot n1
+          and lbl = find_exit_label nfail in
+          copy_instr (Lcondbranch(test, lbl)) i n2
+      | _,  Iexit nfail, _ when local_exit nfail ->
+          let n2 = linear ifso n1 in
+          let lbl = find_exit_label nfail in
+          copy_instr (Lcondbranch(invert_test test, lbl)) i n2
+      | Iend, _, _ ->
+          let (lbl_end, n2) = get_label n1 in
+          copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2)
+      | _,  Iend, _ ->
+          let (lbl_end, n2) = get_label n1 in
+          copy_instr (Lcondbranch(invert_test test, lbl_end)) i
+                     (linear ifso n2)
+      | _, _, _ ->
+        (* Should attempt branch prediction here *)
+          let (lbl_end, n2) = get_label n1 in
+          let (lbl_else, nelse) = get_label (linear ifnot n2) in
+          copy_instr (Lcondbranch(invert_test test, lbl_else)) i
+            (linear ifso (add_branch lbl_end nelse))
+      end
+  | Iswitch(index, cases) ->
+      let lbl_cases = Array.make (Array.length cases) 0 in
+      let (lbl_end, n1) = get_label(linear i.Mach.next n) in
+      let n2 = ref (discard_dead_code n1) in
+      for i = Array.length cases - 1 downto 0 do
+        let (lbl_case, ncase) =
+                get_label(linear cases.(i) (add_branch lbl_end !n2)) in
+        lbl_cases.(i) <- lbl_case;
+        n2 := discard_dead_code ncase
+      done;
+      (* Switches with 1 and 2 branches have been eliminated earlier.
+         Here, we do something for switches with 3 branches. *)
+      if Array.length index = 3 then begin
+        let fallthrough_lbl = check_label !n2 in
+        let find_label n =
+          let lbl = lbl_cases.(index.(n)) in
+          if lbl = fallthrough_lbl then None else Some lbl in
+        copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2))
+                   i !n2
+      end else
+        copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2
+  | Iloop body ->
+      let lbl_head = Cmm.new_label() in
+      let n1 = linear i.Mach.next n in
+      let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in
+      cons_instr (Llabel lbl_head) n2
+  | Icatch(_rec_flag, handlers, body) ->
+      let (lbl_end, n1) = get_label(linear i.Mach.next n) in
+      (* CR mshinwell for pchambart:
+         1. rename "io"
+         2. Make sure the test cases cover the "Iend" cases too *)
+      let labels_at_entry_to_handlers = List.map (fun (_nfail, handler) ->
+          match handler.Mach.desc with
+          | Iend -> lbl_end
+          | _ -> Cmm.new_label ())
+          handlers in
+      let exit_label_add = List.map2
+          (fun (nfail, _) lbl -> (nfail, (lbl, !try_depth)))
+          handlers labels_at_entry_to_handlers in
+      let previous_exit_label = !exit_label in
+      exit_label := exit_label_add @ !exit_label;
+      let n2 = List.fold_left2 (fun n (_nfail, handler) lbl_handler ->
+          match handler.Mach.desc with
+          | Iend -> n
+          | _ -> cons_instr (Llabel lbl_handler) (linear handler n))
+          n1 handlers labels_at_entry_to_handlers
+      in
+      let n3 = linear body (add_branch lbl_end n2) in
+      exit_label := previous_exit_label;
+      n3
+  | Iexit nfail ->
+      let lbl, t = find_exit_label_try_depth nfail in
+      (* We need to re-insert dummy pushtrap (which won't be executed),
+         so as to preserve stack offset during assembler generation.
+         It would make sense to have a special pseudo-instruction
+         only to inform the later pass about this stack offset
+         (corresponding to N traps).
+       *)
+      let rec loop i tt =
+        if t = tt then i
+        else loop (cons_instr Lpushtrap i) (tt - 1)
+      in
+      let n1 = loop (linear i.Mach.next n) !try_depth in
+      let rec loop i tt =
+        if t = tt then i
+        else loop (cons_instr Lpoptrap i) (tt - 1)
+      in
+      loop (add_branch lbl n1) !try_depth
+  | Itrywith(body, handler) ->
+      let (lbl_join, n1) = get_label (linear i.Mach.next n) in
+      incr try_depth;
+      assert (i.Mach.arg = [| |] || Config.spacetime);
+      let (lbl_body, n2) =
+        get_label (instr_cons Lpushtrap i.Mach.arg [| |]
+                    (linear body (cons_instr Lpoptrap n1))) in
+      decr try_depth;
+      instr_cons (Lsetuptrap lbl_body) i.Mach.arg [| |]
+        (linear handler (add_branch lbl_join n2))
+  | Iraise k ->
+      copy_instr (Lraise k) i (discard_dead_code n)
+
+let fundecl f =
+  { fun_name = f.Mach.fun_name;
+    fun_body = linear f.Mach.fun_body end_instr;
+    fun_fast = f.Mach.fun_fast;
+    fun_dbg  = f.Mach.fun_dbg;
+    fun_spacetime_shape = f.Mach.fun_spacetime_shape;
+  }
diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli
new file mode 100644
index 00000000..850fbd89
--- /dev/null
+++ b/asmcomp/linearize.mli
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Transformation of Mach code into a list of pseudo-instructions. *)
+
+type label = Cmm.label
+
+type instruction =
+  { mutable desc: instruction_desc;
+    mutable next: instruction;
+    arg: Reg.t array;
+    res: Reg.t array;
+    dbg: Debuginfo.t;
+    live: Reg.Set.t }
+
+and instruction_desc =
+    Lend
+  | Lop of Mach.operation
+  | Lreloadretaddr
+  | Lreturn
+  | Llabel of label
+  | Lbranch of label
+  | Lcondbranch of Mach.test * label
+  | Lcondbranch3 of label option * label option * label option
+  | Lswitch of label array
+  | Lsetuptrap of label
+  | Lpushtrap
+  | Lpoptrap
+  | Lraise of Cmm.raise_kind
+
+val has_fallthrough :  instruction_desc -> bool
+val end_instr: instruction
+val instr_cons:
+  instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction
+val invert_test: Mach.test -> Mach.test
+
+type fundecl =
+  { fun_name: string;
+    fun_body: instruction;
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : Mach.spacetime_shape option;
+  }
+
+val fundecl: Mach.fundecl -> fundecl
diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml
new file mode 100644
index 00000000..e289b464
--- /dev/null
+++ b/asmcomp/liveness.ml
@@ -0,0 +1,179 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Liveness analysis.
+   Annotate mach code with the set of regs live at each point. *)
+
+open Mach
+
+let live_at_exit = ref []
+
+let find_live_at_exit k =
+  try
+    List.assoc k !live_at_exit
+  with
+  | Not_found -> Misc.fatal_error "Liveness.find_live_at_exit"
+
+let live_at_raise = ref Reg.Set.empty
+
+let rec live i finally =
+  (* finally is the set of registers live after execution of the
+     instruction sequence.
+     The result of the function is the set of registers live just
+     before the instruction sequence.
+     The instruction i is annotated by the set of registers live across
+     the instruction. *)
+  let arg =
+    if Config.spacetime
+      && Mach.spacetime_node_hole_pointer_is_live_before i
+    then Array.append i.arg [| Proc.loc_spacetime_node_hole |]
+    else i.arg
+  in
+  match i.desc with
+    Iend ->
+      i.live <- finally;
+      finally
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
+      i.live <- Reg.Set.empty; (* no regs are live across *)
+      Reg.set_of_array arg
+  | Iop op ->
+      let after = live i.next finally in
+      if Proc.op_is_pure op                    (* no side effects *)
+      && Reg.disjoint_set_array after i.res    (* results are not used after *)
+      && not (Proc.regs_are_volatile arg)      (* no stack-like hard reg *)
+      && not (Proc.regs_are_volatile i.res)    (*            is involved *)
+      then begin
+        (* This operation is dead code.  Ignore its arguments. *)
+        i.live <- after;
+        after
+      end else begin
+        let across_after = Reg.diff_set_array after i.res in
+        let across =
+          match op with
+          | Icall_ind _ | Icall_imm _ | Iextcall _
+          | Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) ->
+              (* The function call may raise an exception, branching to the
+                 nearest enclosing try ... with. Similarly for bounds checks.
+                 Hence, everything that must be live at the beginning of
+                 the exception handler must also be live across this instr. *)
+               Reg.Set.union across_after !live_at_raise
+           | _ ->
+               across_after in
+        i.live <- across;
+        Reg.add_set_array across arg
+      end
+  | Iifthenelse(_test, ifso, ifnot) ->
+      let at_join = live i.next finally in
+      let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in
+      i.live <- at_fork;
+      Reg.add_set_array at_fork arg
+  | Iswitch(_index, cases) ->
+      let at_join = live i.next finally in
+      let at_fork = ref Reg.Set.empty in
+      for i = 0 to Array.length cases - 1 do
+        at_fork := Reg.Set.union !at_fork (live cases.(i) at_join)
+      done;
+      i.live <- !at_fork;
+      Reg.add_set_array !at_fork arg
+  | Iloop(body) ->
+      let at_top = ref Reg.Set.empty in
+      (* Yes, there are better algorithms, but we'll just iterate till
+         reaching a fixpoint. *)
+      begin try
+        while true do
+          let new_at_top = Reg.Set.union !at_top (live body !at_top) in
+          if Reg.Set.equal !at_top new_at_top then raise Exit;
+          at_top := new_at_top
+        done
+      with Exit -> ()
+      end;
+      i.live <- !at_top;
+      !at_top
+  | Icatch(rec_flag, handlers, body) ->
+      let at_join = live i.next finally in
+      let aux (nfail,handler) (nfail', before_handler) =
+        assert(nfail = nfail');
+        let before_handler' = live handler at_join in
+        nfail, Reg.Set.union before_handler before_handler'
+      in
+      let aux_equal (nfail, before_handler) (nfail', before_handler') =
+        assert(nfail = nfail');
+        Reg.Set.equal before_handler before_handler'
+      in
+      let live_at_exit_before = !live_at_exit in
+      let live_at_exit_add before_handlers =
+        List.map (fun (nfail, before_handler) ->
+            (nfail, before_handler))
+          before_handlers
+      in
+      let rec fixpoint before_handlers =
+        let live_at_exit_add = live_at_exit_add before_handlers in
+        live_at_exit := live_at_exit_add @ !live_at_exit;
+        let before_handlers' = List.map2 aux handlers before_handlers in
+        live_at_exit := live_at_exit_before;
+        match rec_flag with
+        | Cmm.Nonrecursive ->
+            before_handlers'
+        | Cmm.Recursive ->
+            if List.for_all2 aux_equal before_handlers before_handlers'
+            then before_handlers'
+            else fixpoint before_handlers'
+      in
+      let init_state =
+        List.map (fun (nfail, _handler) -> nfail, Reg.Set.empty) handlers
+      in
+      let before_handler = fixpoint init_state in
+      (* We could use handler.live instead of Reg.Set.empty as the initial
+         value but we would need to clean the live field before doing the
+         analysis (to remove remnants of previous passes). *)
+      live_at_exit := (live_at_exit_add before_handler) @ !live_at_exit;
+      let before_body = live body at_join in
+      live_at_exit := live_at_exit_before;
+      i.live <- before_body;
+      before_body
+  | Iexit nfail ->
+      let this_live = find_live_at_exit nfail in
+      i.live <- this_live ;
+      this_live
+  | Itrywith(body, handler) ->
+      let at_join = live i.next finally in
+      let before_handler = live handler at_join in
+      let saved_live_at_raise = !live_at_raise in
+      live_at_raise := Reg.Set.remove Proc.loc_exn_bucket before_handler;
+      let before_body = live body at_join in
+      live_at_raise := saved_live_at_raise;
+      i.live <- before_body;
+      before_body
+  | Iraise _ ->
+      i.live <- !live_at_raise;
+      Reg.add_set_array !live_at_raise arg
+
+let reset () =
+  live_at_raise := Reg.Set.empty;
+  live_at_exit := []
+
+let fundecl ppf f =
+  let initially_live = live f.fun_body Reg.Set.empty in
+  (* Sanity check: only function parameters (and the Spacetime node hole
+     register, if profiling) can be live at entrypoint *)
+  let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in
+  let wrong_live =
+    if not Config.spacetime then wrong_live
+    else Reg.Set.remove Proc.loc_spacetime_node_hole wrong_live
+  in
+  if not (Reg.Set.is_empty wrong_live) then begin
+    Format.fprintf ppf "%a@." Printmach.regset wrong_live;
+    Misc.fatal_error "Liveness.fundecl"
+  end
diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli
new file mode 100644
index 00000000..7a8fae62
--- /dev/null
+++ b/asmcomp/liveness.mli
@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Liveness analysis.
+   Annotate mach code with the set of regs live at each point. *)
+
+open Format
+
+val reset : unit -> unit
+val fundecl: formatter -> Mach.fundecl -> unit
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
new file mode 100644
index 00000000..2808448b
--- /dev/null
+++ b/asmcomp/mach.ml
@@ -0,0 +1,181 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of machine code by sequences of pseudoinstructions *)
+
+type label = Cmm.label
+
+type integer_comparison =
+    Isigned of Cmm.comparison
+  | Iunsigned of Cmm.comparison
+
+type integer_operation =
+    Iadd | Isub | Imul | Imulh | Idiv | Imod
+  | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
+  | Icomp of integer_comparison
+  | Icheckbound of { label_after_error : label option;
+        spacetime_index : int; }
+
+type test =
+    Itruetest
+  | Ifalsetest
+  | Iinttest of integer_comparison
+  | Iinttest_imm of integer_comparison * int
+  | Ifloattest of Cmm.comparison * bool
+  | Ioddtest
+  | Ieventest
+
+type operation =
+    Imove
+  | Ispill
+  | Ireload
+  | Iconst_int of nativeint
+  | Iconst_float of int64
+  | Iconst_symbol of string
+  | Icall_ind of { label_after : label; }
+  | Icall_imm of { func : string; label_after : label; }
+  | Itailcall_ind of { label_after : label; }
+  | Itailcall_imm of { func : string; label_after : label; }
+  | Iextcall of { func : string; alloc : bool; label_after : label; }
+  | Istackoffset of int
+  | Iload of Cmm.memory_chunk * Arch.addressing_mode
+  | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
+  | Ialloc of { words : int; label_after_call_gc : label option;
+        spacetime_index : int; }
+  | Iintop of integer_operation
+  | Iintop_imm of integer_operation * int
+  | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+  | Ifloatofint | Iintoffloat
+  | Ispecific of Arch.specific_operation
+
+type instruction =
+  { desc: instruction_desc;
+    next: instruction;
+    arg: Reg.t array;
+    res: Reg.t array;
+    dbg: Debuginfo.t;
+    mutable live: Reg.Set.t }
+
+and instruction_desc =
+    Iend
+  | Iop of operation
+  | Ireturn
+  | Iifthenelse of test * instruction * instruction
+  | Iswitch of int array * instruction array
+  | Iloop of instruction
+  | Icatch of Cmm.rec_flag * (int * instruction) list * instruction
+  | Iexit of int
+  | Itrywith of instruction * instruction
+  | Iraise of Cmm.raise_kind
+
+type spacetime_part_of_shape =
+  | Direct_call_point of { callee : string; }
+  | Indirect_call_point
+  | Allocation_point
+
+type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list
+
+type fundecl =
+  { fun_name: string;
+    fun_args: Reg.t array;
+    fun_body: instruction;
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : spacetime_shape option;
+  }
+
+let rec dummy_instr =
+  { desc = Iend;
+    next = dummy_instr;
+    arg = [||];
+    res = [||];
+    dbg = Debuginfo.none;
+    live = Reg.Set.empty }
+
+let end_instr () =
+  { desc = Iend;
+    next = dummy_instr;
+    arg = [||];
+    res = [||];
+    dbg = Debuginfo.none;
+    live = Reg.Set.empty }
+
+let instr_cons d a r n =
+  { desc = d; next = n; arg = a; res = r;
+    dbg = Debuginfo.none; live = Reg.Set.empty }
+
+let instr_cons_debug d a r dbg n =
+  { desc = d; next = n; arg = a; res = r; dbg = dbg; live = Reg.Set.empty }
+
+let rec instr_iter f i =
+  match i.desc with
+    Iend -> ()
+  | _ ->
+      f i;
+      match i.desc with
+        Iend -> ()
+      | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> ()
+      | Iifthenelse(_tst, ifso, ifnot) ->
+          instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next
+      | Iswitch(_index, cases) ->
+          for i = 0 to Array.length cases - 1 do
+            instr_iter f cases.(i)
+          done;
+          instr_iter f i.next
+      | Iloop(body) ->
+          instr_iter f body; instr_iter f i.next
+      | Icatch(_, handlers, body) ->
+          instr_iter f body;
+          List.iter (fun (_n, handler) -> instr_iter f handler) handlers;
+          instr_iter f i.next
+      | Iexit _ -> ()
+      | Itrywith(body, handler) ->
+          instr_iter f body; instr_iter f handler; instr_iter f i.next
+      | Iraise _ -> ()
+      | _ ->
+          instr_iter f i.next
+
+let spacetime_node_hole_pointer_is_live_before insn =
+  match insn.desc with
+  | Iop op ->
+    begin match op with
+    | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ -> true
+    | Iextcall { alloc; } -> alloc
+    | Ialloc _ ->
+      (* Allocations are special: the call to [caml_call_gc] requires some
+         instrumentation code immediately prior, but this is not inserted until
+         the emitter (since the call is not visible prior to that in any IR).
+         As such, none of the Mach / Linearize analyses will ever see that
+         we use the node hole pointer for these, and we do not need to say
+         that it is live at such points. *)
+      false
+    | Iintop op | Iintop_imm (op, _) ->
+      begin match op with
+      | Icheckbound _
+        (* [Icheckbound] doesn't need to return [true] for the same reason as
+           [Ialloc]. *)
+      | Iadd | Isub | Imul | Imulh | Idiv | Imod
+      | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
+      | Icomp _ -> false
+      end
+    | Ispecific specific_op ->
+      Arch.spacetime_node_hole_pointer_is_live_before specific_op
+    | Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _
+    | Iconst_symbol _ | Istackoffset _ | Iload _ | Istore _
+    | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+    | Ifloatofint | Iintoffloat -> false
+    end
+  | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Iloop _ | Icatch _
+  | Iexit _ | Itrywith _ | Iraise _ -> false
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
new file mode 100644
index 00000000..f97834d7
--- /dev/null
+++ b/asmcomp/mach.mli
@@ -0,0 +1,125 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of machine code by sequences of pseudoinstructions *)
+
+(** N.B. Backends vary in their treatment of call gc and checkbound
+    points.  If the positioning of any labels associated with these is
+    important for some new feature in the compiler, the relevant backends'
+    behaviour should be checked. *)
+type label = Cmm.label
+
+type integer_comparison =
+    Isigned of Cmm.comparison
+  | Iunsigned of Cmm.comparison
+
+type integer_operation =
+    Iadd | Isub | Imul | Imulh | Idiv | Imod
+  | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
+  | Icomp of integer_comparison
+  | Icheckbound of { label_after_error : label option;
+        spacetime_index : int; }
+    (** For Spacetime only, [Icheckbound] operations take two arguments, the
+        second being the pointer to the trie node for the current function
+        (and the first being as per non-Spacetime mode). *)
+
+type test =
+    Itruetest
+  | Ifalsetest
+  | Iinttest of integer_comparison
+  | Iinttest_imm of integer_comparison * int
+  | Ifloattest of Cmm.comparison * bool
+  | Ioddtest
+  | Ieventest
+
+type operation =
+    Imove
+  | Ispill
+  | Ireload
+  | Iconst_int of nativeint
+  | Iconst_float of int64
+  | Iconst_symbol of string
+  | Icall_ind of { label_after : label; }
+  | Icall_imm of { func : string; label_after : label; }
+  | Itailcall_ind of { label_after : label; }
+  | Itailcall_imm of { func : string; label_after : label; }
+  | Iextcall of { func : string; alloc : bool; label_after : label; }
+  | Istackoffset of int
+  | Iload of Cmm.memory_chunk * Arch.addressing_mode
+  | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
+                                 (* false = initialization, true = assignment *)
+  | Ialloc of { words : int; label_after_call_gc : label option;
+      spacetime_index : int; }
+    (** For Spacetime only, Ialloc instructions take one argument, being the
+        pointer to the trie node for the current function. *)
+  | Iintop of integer_operation
+  | Iintop_imm of integer_operation * int
+  | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+  | Ifloatofint | Iintoffloat
+  | Ispecific of Arch.specific_operation
+
+type instruction =
+  { desc: instruction_desc;
+    next: instruction;
+    arg: Reg.t array;
+    res: Reg.t array;
+    dbg: Debuginfo.t;
+    mutable live: Reg.Set.t }
+
+and instruction_desc =
+    Iend
+  | Iop of operation
+  | Ireturn
+  | Iifthenelse of test * instruction * instruction
+  | Iswitch of int array * instruction array
+  | Iloop of instruction
+  | Icatch of Cmm.rec_flag * (int * instruction) list * instruction
+  | Iexit of int
+  | Itrywith of instruction * instruction
+  | Iraise of Cmm.raise_kind
+
+type spacetime_part_of_shape =
+  | Direct_call_point of { callee : string; (* the symbol *) }
+  | Indirect_call_point
+  | Allocation_point
+
+(** A description of the layout of a Spacetime profiling node associated with
+    a given function.  Each call and allocation point instrumented within
+    the function is marked with a label in the code and assigned a place
+    within the node.  This information is stored within the executable and
+    extracted when the user saves a profile.  The aim is to minimise runtime
+    memory usage within the nodes and increase performance. *)
+type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list
+
+type fundecl =
+  { fun_name: string;
+    fun_args: Reg.t array;
+    fun_body: instruction;
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : spacetime_shape option;
+  }
+
+val dummy_instr: instruction
+val end_instr: unit -> instruction
+val instr_cons:
+      instruction_desc -> Reg.t array -> Reg.t array -> instruction ->
+        instruction
+val instr_cons_debug:
+      instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t ->
+        instruction -> instruction
+val instr_iter: (instruction -> unit) -> instruction -> unit
+
+val spacetime_node_hole_pointer_is_live_before : instruction -> bool
diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml
new file mode 100644
index 00000000..b8454ffd
--- /dev/null
+++ b/asmcomp/power/CSE.ml
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for the PowerPC *)
+
+open Arch
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+  match op with
+  | Ispecific(Imultaddf | Imultsubf) -> Op_pure
+  | Ispecific(Ialloc_far _) -> Op_other
+  | _ -> super#class_of_operation op
+
+method! is_cheap_operation op =
+  match op with
+  | Iconst_int n -> n <= 32767n && n >= -32768n
+  | _ -> false
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/power/NOTES.md b/asmcomp/power/NOTES.md
new file mode 100644
index 00000000..d54c0869
--- /dev/null
+++ b/asmcomp/power/NOTES.md
@@ -0,0 +1,26 @@
+# Supported platforms
+
+IBM POWER and Freescale (nee Motorola) PowerPC processors, in three flavors:
+* 32 bits, ELF ABI: Debian's `powerpc`
+* 64 bits big-endian, ELF ABI v1: Debian's `powerpc`
+* 64 bits little-endian, ELF ABI v2: Debian's `ppc64el`
+
+No longer supported: AIX and MacOS X.
+
+# Reference documents
+
+* Instruction set architecture:
+  _PowerPC User Instruction Set Architecture_,
+  book 1 of _PowerPC Architecture Book_
+  (http://www.ibm.com/developerworks/systems/library/es-archguide-v2.html).
+* ELF ABI 32 bits:
+  _System V Application Binary Interface, PowerPC Processor Supplement_
+* ELF ABI 64 bits version 1:
+  _64-bit PowerPC ELF Application Binary Interface Supplement_
+  (http://refspecs.linuxfoundation.org/ELF/ppc64/PPC-elf64abi.html)
+* ELF ABI 64 bits version 2:
+   _Power Architecture 64-bit ELF V2 ABI Specification,
+    OpenPOWER ABI for Linux Supplement_
+  (http://openpowerfoundation.org/technical/technical-resources/technical-specifications/)
+* _The PowerPC Compiler Writer's Guide_, Warthman Associates, 1996.
+  (PDF available from various sources on the Web.)
diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml
new file mode 100644
index 00000000..289f33ca
--- /dev/null
+++ b/asmcomp/power/arch.ml
@@ -0,0 +1,122 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Specific operations for the PowerPC processor *)
+
+open Format
+
+let ppc64 =
+  match Config.model with
+  | "ppc" -> false
+  | "ppc64" | "ppc64le" -> true
+  | _ -> assert false
+
+type abi = ELF32 | ELF64v1 | ELF64v2
+
+let abi =
+  match Config.model with
+  | "ppc" -> ELF32
+  | "ppc64" -> ELF64v1
+  | "ppc64le" -> ELF64v2
+  | _ -> assert false
+
+(* Machine-specific command-line options *)
+
+let big_toc = ref false
+
+let command_line_options = [
+  "-flarge-toc", Arg.Set big_toc,
+     " Support TOC (table of contents) greater than 64 kbytes"
+]
+
+(* Specific operations *)
+
+type specific_operation =
+    Imultaddf                           (* multiply and add *)
+  | Imultsubf                           (* multiply and subtract *)
+  | Ialloc_far of                       (* allocation in large functions *)
+      { words : int; label_after_call_gc : int (*Cmm.label*) option; }
+
+(* note: we avoid introducing a dependency to Cmm since this dep
+   is not detected when "make depend" is run under amd64 *)
+
+let spacetime_node_hole_pointer_is_live_before = function
+  | Imultaddf | Imultsubf -> false
+  | Ialloc_far _ -> true
+
+(* Addressing modes *)
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+  | Iindexed2                           (* reg + reg *)
+
+(* Sizes, endianness *)
+
+let big_endian =
+  match Config.model with
+  | "ppc" -> true
+  | "ppc64" -> true
+  | "ppc64le" -> false
+  | _ -> assert false
+
+let size_addr = if ppc64 then 8 else 4
+let size_int = size_addr
+let size_float = 8
+
+let allow_unaligned_access = true
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = true
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+  | Iindexed2 -> assert false
+
+let num_args_addressing = function
+    Ibased _ -> 0
+  | Iindexed _ -> 1
+  | Iindexed2 -> 2
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Ibased(s, n) ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "\"%s\"%s" s idx
+  | Iindexed n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a%s" printreg arg.(0) idx
+  | Iindexed2 ->
+      fprintf ppf "%a + %a" printreg arg.(0) printreg arg.(1)
+
+let print_specific_operation printreg op ppf arg =
+  match op with
+  | Imultaddf ->
+      fprintf ppf "%a *f %a +f %a"
+        printreg arg.(0) printreg arg.(1) printreg arg.(2)
+  | Imultsubf ->
+      fprintf ppf "%a *f %a -f %a"
+        printreg arg.(0) printreg arg.(1) printreg arg.(2)
+  | Ialloc_far { words; _ } ->
+      fprintf ppf "alloc_far %d" words
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
new file mode 100644
index 00000000..5abc5f85
--- /dev/null
+++ b/asmcomp/power/emit.mlp
@@ -0,0 +1,1225 @@
+#2 "asmcomp/power/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of PowerPC assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Reserved space at bottom of stack *)
+
+let reserved_stack_space =
+  match abi with
+  | ELF32 -> 0
+  | ELF64v1 -> 48
+  | ELF64v2 -> 32
+
+(* Layout of the stack.  The stack is kept 16-aligned. *)
+
+let stack_offset = ref 0
+
+let frame_size () =
+  let size =
+    reserved_stack_space +
+    !stack_offset +                     (* Trap frame, outgoing parameters *)
+    size_int * num_stack_slots.(0) +    (* Local int variables *)
+    size_float * num_stack_slots.(1) +  (* Local float variables *)
+    (if !contains_calls && abi = ELF32 then size_int else 0) in
+                                        (* The return address *)
+  Misc.align size 16
+
+let slot_offset loc cls =
+  match loc with
+    Local n ->
+      reserved_stack_space + !stack_offset +
+      (if cls = 0 then num_stack_slots.(1) * size_float + n * size_int
+                  else n * size_float)
+  | Incoming n -> frame_size() + reserved_stack_space + n
+  | Outgoing n -> reserved_stack_space + n
+
+let retaddr_offset () =
+  match abi with
+  | ELF32 -> frame_size() - size_addr
+  | ELF64v1 | ELF64v2 -> frame_size() + 16
+
+let toc_save_offset () =
+  match abi with
+  | ELF32 -> assert false
+  | ELF64v1 | ELF64v2 -> frame_size() + 8
+
+let (trap_size, trap_handler_offset, trap_previous_offset) =
+  match abi with
+  | ELF32 -> (16, 0, 4)
+  | ELF64v1 -> (32, 56, 64)
+  | ELF64v2 -> (32, 40, 48)
+
+(* Output a symbol *)
+
+let emit_symbol s = Emitaux.emit_symbol '.' s
+
+(* Output a label *)
+
+let label_prefix = ".L"
+
+let emit_label lbl =
+  emit_string label_prefix; emit_int lbl
+
+(* Section switching *)
+
+let code_space =
+  "	.section \".text\"\n"
+
+let function_descr_space =
+  match abi with
+  | ELF32 -> code_space
+  | ELF64v1 -> "	.section \".opd\",\"aw\"\n"
+  | ELF64v2 -> code_space
+
+let data_space =
+  "	.section \".data\"\n"
+
+let rodata_space =
+  "	.section \".rodata\"\n"
+
+let toc_space =
+  " .section \".toc\",\"aw\"\n"
+
+(* Names of instructions that differ in 32 and 64-bit modes *)
+
+let lg = if ppc64 then "ld" else "lwz"
+let stg = if ppc64 then "std" else "stw"
+let lwa = if ppc64 then "lwa" else "lwz"
+let cmpg = if ppc64 then "cmpd" else "cmpw"
+let cmplg = if ppc64 then "cmpld" else "cmplw"
+let datag = if ppc64 then ".quad" else ".long"
+let mullg = if ppc64 then "mulld" else "mullw"
+let divg = if ppc64 then "divd" else "divw"
+let tglle = if ppc64 then "tdlle" else "twlle"
+
+(* Output a processor register *)
+
+let emit_gpr = emit_int
+
+(* Output a pseudo-register *)
+
+let emit_reg r =
+  match r.loc with
+  | Reg r -> emit_string (register_name r)
+  | _ -> fatal_error "Emit.emit_reg"
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+  | Stack s ->
+      let ofs = slot_offset s (register_class r) in `{emit_int ofs}(1)`
+  | _ -> fatal_error "Emit.emit_stack"
+
+(* Output the name of a symbol plus an optional offset *)
+
+let emit_symbol_offset (s, d) =
+  emit_symbol s;
+  if d > 0 then `+`;
+  if d <> 0 then emit_int d
+
+(* Split a 32-bit integer constants in two 16-bit halves *)
+
+let low_high_u n = (n land 0xFFFF, n asr 16)
+  (* unsigned low half, for use with "ori" *)
+
+let native_low_high_u n =
+  (Nativeint.(to_int (logand n 0xFFFFn)),
+   Nativeint.(to_int (shift_right n 16)))
+  (* unsigned low half, for use with "ori" *)
+
+let low_high_s n =
+  let lo = ((n + 0x8000) land 0xFFFF) - 0x8000 in
+  (lo, (n - lo) asr 16)
+  (* signed low half, for use with "addi" *)
+
+let native_low_high_s n =
+  let lo = Nativeint.(sub (logand (add n 0x8000n) 0xFFFFn) 0x8000n) in
+  (Nativeint.to_int lo,
+   Nativeint.(to_int (shift_right (sub n lo) 16)))
+  (* signed low half, for use with "addi" *)
+
+let is_immediate n =
+  n <= 32767 && n >= -32768
+
+let is_native_immediate n =
+  n <= 32767n && n >= -32768n
+
+(* Record TOC entries *)
+
+type tocentry =
+  | TocSym of string
+  | TocLabel of int
+  | TocInt of nativeint
+  | TocFloat of int64
+
+let tocref_entries : (tocentry, label) Hashtbl.t = Hashtbl.create 64
+
+let emit_tocentry = function
+  | TocSym s -> emit_symbol s
+  | TocInt i -> emit_nativeint i
+  | TocFloat f -> emit_printf "0x%Lx # %.12g" f (Int64.float_of_bits f)
+  | TocLabel lbl -> emit_label lbl
+
+let label_for_tocref entry =
+  try
+    Hashtbl.find tocref_entries entry
+  with Not_found ->
+    let lbl = new_label() in
+    Hashtbl.add tocref_entries entry lbl;
+    lbl
+
+let emit_toctable () =
+  Hashtbl.iter
+    (fun entry lbl ->
+      `{emit_label lbl}:	.quad	{emit_tocentry entry}\n`)
+    tocref_entries
+
+(* Emit a load from a TOC entry *)
+
+let emit_tocload emit_dest dest entry =
+  let lbl = label_for_tocref entry in
+  if !big_toc || !Clflags.for_package <> None then begin
+    `	addis	{emit_dest dest}, 2, {emit_label lbl}@toc@ha\n`;
+    `	ld	{emit_dest dest}, {emit_label lbl}@toc@l({emit_dest dest}) # {emit_tocentry entry}\n`
+  end else begin
+    `	ld	{emit_dest dest}, {emit_label lbl}@toc(2) # {emit_tocentry entry}\n`
+  end
+
+(* Output a "upper 16 bits" or "lower 16 bits" operator. *)
+
+let emit_upper emit_fun arg =
+  emit_fun arg; emit_string "@ha"
+
+let emit_lower emit_fun arg =
+  emit_fun arg; emit_string "@l"
+
+(* Output a load or store operation *)
+
+let valid_offset instr ofs =
+  ofs land 3 = 0 || (instr <> "ld" && instr <> "std" && instr <> "lwa")
+
+let emit_load_store instr addressing_mode addr n arg =
+  match addressing_mode with
+  | Ibased(s, d) ->
+      begin match abi with
+      | ELF32 ->
+        `	addis	11, 0, {emit_upper emit_symbol_offset (s,d)}\n`;
+        `	{emit_string instr}	{emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}(11)\n`
+      | ELF64v1 | ELF64v2 ->
+        emit_tocload emit_gpr 11 (TocSym s);
+        let (lo, hi) = low_high_s d in
+        if hi <> 0 then
+          `	addis	11, 11, {emit_int hi}\n`;
+        `	{emit_string instr}	{emit_reg arg}, {emit_int lo}(11)\n`
+      end
+  | Iindexed ofs ->
+      if is_immediate ofs && valid_offset instr ofs then
+        `	{emit_string instr}	{emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
+      else begin
+        let (lo, hi) = low_high_u ofs in
+        `	addis	0, 0, {emit_int hi}\n`;
+        if lo <> 0 then
+          `	ori	0, 0, {emit_int lo}\n`;
+        `	{emit_string instr}x	{emit_reg arg}, {emit_reg addr.(n)}, 0\n`
+      end
+  | Iindexed2 ->
+      `	{emit_string instr}x	{emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n`
+
+(* After a comparison, extract the result as 0 or 1 *)
+
+let emit_set_comp cmp res =
+  `	mfcr	0\n`;
+  let bitnum =
+    match cmp with
+      Ceq | Cne -> 2
+    | Cgt | Cle -> 1
+    | Clt | Cge -> 0 in
+`	rlwinm	{emit_reg res}, 0, {emit_int(bitnum+1)}, 31, 31\n`;
+  begin match cmp with
+    Cne | Cle | Cge -> `	xori	{emit_reg res}, {emit_reg res}, 1\n`
+  | _ -> ()
+  end
+
+(* Free the stack frame *)
+
+let emit_free_frame () =
+  let n = frame_size() in
+  if n > 0 then
+    `	addi	1, 1, {emit_int n}\n`
+
+(* Emit a "bl" instruction to a given symbol *)
+
+let emit_call s =
+  match abi with
+  | ELF32 when !Clflags.dlcode || !Clflags.pic_code ->
+    `	bl	{emit_symbol s}@plt\n`
+  | _ ->
+    `	bl	{emit_symbol s}\n`
+
+(* Add a nop after a "bl" call for ELF64 *)
+
+let emit_call_nop () =
+  match abi with
+  | ELF32 -> ()
+  | ELF64v1 | ELF64v2 -> `	nop	\n`
+
+(* Reload the TOC register r2 from the value saved on the stack *)
+
+let emit_reload_toc () =
+  `	ld	2, {emit_int (toc_save_offset())}(1)\n`
+
+(* Adjust stack_offset and emit corresponding CFI directive *)
+
+let adjust_stack_offset delta =
+  stack_offset := !stack_offset + delta;
+  cfi_adjust_cfa_offset delta
+
+(* Record live pointers at call points *)
+
+let record_frame ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := ((r lsl 1) + 1) :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ())
+    live;
+  record_frame_descr ~label:lbl ~frame_size:(frame_size())
+    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+  `{emit_label lbl}:\n`
+
+(* Record floating-point literals (for PPC32) *)
+
+let float_literals = ref ([] : (int64 * int) list)
+
+(* Record jump tables (for PPC64).  In order to reduce the size of the TOC,
+   we concatenate all jumptables and emit them at the end of the compilation
+   unit. *)
+
+let jumptables = ref ([] : label list)  (* in reverse order *)
+let jumptables_lbl = ref (-1)
+
+(* Names for conditional branches after comparisons *)
+
+let branch_for_comparison = function
+    Ceq -> "beq" | Cne -> "bne"
+  | Cle -> "ble" | Cgt -> "bgt"
+  | Cge -> "bge" | Clt -> "blt"
+
+let name_for_int_comparison = function
+    Isigned cmp -> (cmpg, branch_for_comparison cmp)
+  | Iunsigned cmp -> (cmplg, branch_for_comparison cmp)
+
+(* Names for various instructions *)
+
+let name_for_intop = function
+    Iadd  -> "add"
+  | Imul  -> if ppc64 then "mulld" else "mullw"
+  | Imulh -> if ppc64 then "mulhd" else "mulhw"
+  | Idiv  -> if ppc64 then "divd" else "divw"
+  | Iand  -> "and"
+  | Ior   -> "or"
+  | Ixor  -> "xor"
+  | Ilsl  -> if ppc64 then "sld" else "slw"
+  | Ilsr  -> if ppc64 then "srd" else "srw"
+  | Iasr  -> if ppc64 then "srad" else "sraw"
+  | _ -> Misc.fatal_error "Emit.Intop"
+
+let name_for_intop_imm = function
+    Iadd -> "addi"
+  | Imul -> "mulli"
+  | Iand -> "andi."
+  | Ior  -> "ori"
+  | Ixor -> "xori"
+  | Ilsl -> if ppc64 then "sldi" else "slwi"
+  | Ilsr -> if ppc64 then "srdi" else "srwi"
+  | Iasr -> if ppc64 then "sradi" else "srawi"
+  | _ -> Misc.fatal_error "Emit.Intop_imm"
+
+let name_for_floatop1 = function
+    Inegf -> "fneg"
+  | Iabsf -> "fabs"
+  | _ -> Misc.fatal_error "Emit.Iopf1"
+
+let name_for_floatop2 = function
+    Iaddf -> "fadd"
+  | Isubf -> "fsub"
+  | Imulf -> "fmul"
+  | Idivf -> "fdiv"
+  | _ -> Misc.fatal_error "Emit.Iopf2"
+
+let name_for_specific = function
+    Imultaddf -> "fmadd"
+  | Imultsubf -> "fmsub"
+  | _ -> Misc.fatal_error "Emit.Ispecific"
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+(* Label of glue code for calling the GC *)
+let call_gc_label = ref 0
+
+(* Relaxation of branches that exceed the span of a relative branch. *)
+
+module BR = Branch_relaxation.Make (struct
+  type distance = int
+
+  module Cond_branch = struct
+    type t = Branch
+
+    let all = [Branch]
+
+    let max_displacement = function
+      (* 14-bit signed offset in words. *)
+      | Branch -> 8192
+
+    let classify_instr = function
+      | Lop (Ialloc _)
+      (* [Ialloc_far] does not need to be here, since its code sequence
+         never involves any conditional branches that might need relaxing. *)
+      | Lcondbranch _
+      | Lcondbranch3 _ -> Some Branch
+      | _ -> None
+  end
+
+  let offset_pc_at_branch = 1
+
+  let size =
+    match abi with
+    | ELF32 -> (fun a _ _ -> a)
+    | ELF64v1 -> (fun _ b _ -> b)
+    | ELF64v2 -> (fun _ _ c -> c)
+
+  let tocload_size() =
+    if !big_toc || !Clflags.for_package <> None then 2 else 1
+
+  let load_store_size = function
+    | Ibased(_s, d) ->
+        if abi = ELF32 then 2 else begin
+          let (_lo, hi) = low_high_s d in
+          tocload_size() + (if hi = 0 then 1 else 2)
+        end
+    | Iindexed ofs -> if is_immediate ofs then 1 else 3
+    | Iindexed2 -> 1
+
+  let instr_size = function
+    | Lend -> 0
+    | Lop(Imove | Ispill | Ireload) -> 1
+    | Lop(Iconst_int n) ->
+      if is_native_immediate n then 1
+      else if (let (_lo, hi) = native_low_high_s n in
+               hi >= -0x8000 && hi <= 0x7FFF) then 2
+      else if (let (_lo, hi) = native_low_high_u n in
+               hi >= -0x8000 && hi <= 0x7FFF) then 2
+      else tocload_size()
+    | Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size()
+    | Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size()
+    | Lop(Icall_ind _) -> size 2 5 4
+    | Lop(Icall_imm _) -> size 1 3 3
+    | Lop(Itailcall_ind _) -> size 5 7 6
+    | Lop(Itailcall_imm { func; _ }) ->
+        if func = !function_name
+        then 1
+        else size 4 (7 + tocload_size()) (6 + tocload_size())
+    | Lop(Iextcall { alloc = true; _ }) ->
+      size 3 (2 + tocload_size()) (2 + tocload_size())
+    | Lop(Iextcall { alloc = false; _}) -> size 1 2 2
+    | Lop(Istackoffset _) -> 1
+    | Lop(Iload(chunk, addr)) ->
+      if chunk = Byte_signed
+      then load_store_size addr + 1
+      else load_store_size addr
+    | Lop(Istore(_chunk, addr, _)) -> load_store_size addr
+    | Lop(Ialloc _) -> 4
+    | Lop(Ispecific(Ialloc_far _)) -> 5
+    | Lop(Iintop Imod) -> 3
+    | Lop(Iintop(Icomp _)) -> 4
+    | Lop(Iintop _) -> 1
+    | Lop(Iintop_imm(Icomp _, _)) -> 4
+    | Lop(Iintop_imm _) -> 1
+    | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1
+    | Lop(Ifloatofint) -> 9
+    | Lop(Iintoffloat) -> 4
+    | Lop(Ispecific _) -> 1
+    | Lreloadretaddr -> 2
+    | Lreturn -> 2
+    | Llabel _ -> 0
+    | Lbranch _ -> 1
+    | Lcondbranch _ -> 2
+    | Lcondbranch3(lbl0, lbl1, lbl2) ->
+      1 + (if lbl0 = None then 0 else 1)
+        + (if lbl1 = None then 0 else 1)
+        + (if lbl2 = None then 0 else 1)
+    | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size())
+    | Lsetuptrap _ -> size 1 2 2
+    | Lpushtrap -> size 4 5 5
+    | Lpoptrap -> 2
+    | Lraise _ -> 6
+
+  let relax_allocation ~num_words:words ~label_after_call_gc =
+    Lop (Ispecific (Ialloc_far { words; label_after_call_gc; }))
+
+  (* [classify_addr], above, never identifies these instructions as needing
+     relaxing.  As such, these functions should never be called. *)
+  let relax_specific_op _ = assert false
+  let relax_intop_checkbound ~label_after_error:_ = assert false
+  let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false
+end)
+
+(* Output the assembly code for an instruction *)
+
+let emit_instr i =
+    emit_debug_info i.dbg;
+    match i.desc with
+    | Lend -> ()
+    | Lop(Imove | Ispill | Ireload) ->
+        let src = i.arg.(0) and dst = i.res.(0) in
+        if src.loc <> dst.loc then begin
+           match (src, dst) with
+           |  {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
+                `	mr	{emit_reg dst}, {emit_reg src}\n`
+            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
+                `	fmr	{emit_reg dst}, {emit_reg src}\n`
+            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
+                `	{emit_string stg}	{emit_reg src}, {emit_stack dst}\n`
+            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
+                `	stfd	{emit_reg src}, {emit_stack dst}\n`
+            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
+                `	{emit_string lg}	{emit_reg dst}, {emit_stack src}\n`
+            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
+                `	lfd	{emit_reg dst}, {emit_stack src}\n`
+            | (_, _) ->
+                fatal_error "Emit: Imove"
+        end
+    | Lop(Iconst_int n) ->
+        if is_native_immediate n then
+          `	li	{emit_reg i.res.(0)}, {emit_nativeint n}\n`
+        else begin
+        (* Try a signed decomposition first, because the sequence
+           addis/addi is eligible for instruction fusion. *)
+        let (lo, hi) = native_low_high_s n in
+        if hi >= -0x8000 && hi <= 0x7FFF then begin
+          `	addis	{emit_reg i.res.(0)}, 0, {emit_int hi}\n`;
+          if lo <> 0 then
+          `	addi	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int lo}\n`
+        end else begin
+        (* Now try an unsigned decomposition *)
+        let (lo, hi) = native_low_high_u n in
+        if hi >= -0x8000 && hi <= 0x7FFF then begin
+          `	addis	{emit_reg i.res.(0)}, 0, {emit_int hi}\n`;
+          if lo <> 0 then
+          `	ori	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int lo}\n`
+        end else begin
+          match abi with
+          | ELF32 -> assert false
+          | ELF64v1 | ELF64v2 ->
+              emit_tocload emit_reg i.res.(0) (TocInt n)
+        end end end
+    | Lop(Iconst_float f) ->
+        begin match abi with
+        | ELF32 ->
+          let lbl = new_label() in
+          float_literals := (f, lbl) :: !float_literals;
+          `	addis	11, 0, {emit_upper emit_label lbl}\n`;
+          `	lfd	{emit_reg i.res.(0)}, {emit_lower emit_label lbl}(11)\n`
+        | ELF64v1 | ELF64v2 ->
+          let entry = TocFloat f in
+          let lbl = label_for_tocref entry in
+          if !big_toc || !Clflags.for_package <> None then begin
+            `	addis	11, 2, {emit_label lbl}@toc@ha\n`;
+            `	lfd	{emit_reg i.res.(0)}, {emit_label lbl}@toc@l(11) # {emit_tocentry entry}\n`
+          end else begin
+            `	lfd	{emit_reg i.res.(0)}, {emit_label lbl}@toc(2) # {emit_tocentry entry}\n`
+          end
+        end
+    | Lop(Iconst_symbol s) ->
+        begin match abi with
+        | ELF32 ->
+          `	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`
+        | ELF64v1 | ELF64v2 ->
+          emit_tocload emit_reg i.res.(0) (TocSym s)
+        end
+    | Lop(Icall_ind { label_after; }) ->
+        begin match abi with
+        | ELF32 ->
+          `	mtctr	{emit_reg i.arg.(0)}\n`;
+          `	bctrl\n`;
+          record_frame i.live false i.dbg ~label:label_after
+        | ELF64v1 ->
+          `	ld	0, 0({emit_reg i.arg.(0)})\n`;  (* code pointer *)
+          `	mtctr	0\n`;
+          `	ld	2, 8({emit_reg i.arg.(0)})\n`;  (* TOC for callee *)
+          `	bctrl\n`;
+          record_frame i.live false i.dbg ~label:label_after;
+          emit_reload_toc()
+        | ELF64v2 ->
+          `	mtctr	{emit_reg i.arg.(0)}\n`;
+          `	mr	12, {emit_reg i.arg.(0)}\n`;  (* addr of fn in r12 *)
+          `	bctrl\n`;
+          record_frame i.live false i.dbg ~label:label_after;
+          emit_reload_toc()
+        end
+    | Lop(Icall_imm { func; label_after; }) ->
+        begin match abi with
+        | ELF32 ->
+            emit_call func;
+            record_frame i.live false i.dbg ~label:label_after
+        | ELF64v1 | ELF64v2 ->
+        (* For PPC64, we cannot just emit a "bl s; nop" sequence, because
+           of the following scenario:
+              - current function f1 calls f2 that has the same TOC
+              - f2 tailcalls f3 that has a different TOC
+           Because f1 and f2 have the same TOC, the linker inserted no
+           code in f1 to save and restore r2 around the call to f2.
+           Because f2 tailcalls f3, r2 will not be restored to f2's TOC
+           when f3 returns.  So, we're back into f1, with the wrong TOC in r2.
+           We have two options:
+             1- Turn the call into an indirect call, like we do for
+                Itailcall_imm.  Cost: 6 instructions.
+             2- Follow the "bl" with an instruction to restore r2
+                explicitly.  If the called function has a different TOC,
+                this instruction is redundant with those inserted
+                by the linker, but this is harmless.
+                Cost: 3 instructions if same TOC, 7 if different TOC.
+           Let's try option 2. *)
+            emit_call func;
+            record_frame i.live false i.dbg ~label:label_after;
+            `	nop\n`;
+            emit_reload_toc()
+        end
+    | Lop(Itailcall_ind { label_after = _; }) ->
+        begin match abi with
+        | ELF32 ->
+          `	mtctr	{emit_reg i.arg.(0)}\n`
+        | ELF64v1 ->
+          `	ld	0, 0({emit_reg i.arg.(0)})\n`;  (* code pointer *)
+          `	mtctr	0\n`;
+          `	ld	2, 8({emit_reg i.arg.(0)})\n`   (* TOC for callee *)
+        | ELF64v2 ->
+          `	mtctr	{emit_reg i.arg.(0)}\n`;
+          `	mr	12, {emit_reg i.arg.(0)}\n`   (* addr of fn in r12 *)
+        end;
+        if !contains_calls then begin
+          `	{emit_string lg}	11, {emit_int(retaddr_offset())}(1)\n`;
+          `	mtlr	11\n`
+        end;
+        emit_free_frame();
+        `	bctr\n`
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then
+          `	b	{emit_label !tailrec_entry_point}\n`
+        else begin
+          begin match abi with
+          | ELF32 ->
+            ()
+          | ELF64v1 ->
+            emit_tocload emit_gpr 11 (TocSym func);
+            `	ld	0, 0(11)\n`;  (* code pointer *)
+            `	mtctr	0\n`;
+            `	ld	2, 8(11)\n`   (* TOC for callee *)
+          | ELF64v2 ->
+            emit_tocload emit_gpr 12 (TocSym func); (* addr of fn must be in r12 *)
+            `	mtctr	12\n`
+          end;
+          if !contains_calls then begin
+            `	{emit_string lg}	11, {emit_int(retaddr_offset())}(1)\n`;
+            `	mtlr	11\n`
+          end;
+          emit_free_frame();
+          begin match abi with
+          | ELF32 ->
+            `	b	{emit_symbol func}\n`
+          | ELF64v1 | ELF64v2 ->
+            `	bctr\n`
+          end
+        end
+    | Lop(Iextcall { func; alloc; }) ->
+        if not alloc then begin
+          emit_call func;
+          emit_call_nop()
+        end else begin
+          match abi with
+          | ELF32 ->
+            `	addis	28, 0, {emit_upper emit_symbol func}\n`;
+            `	addi	28, 28, {emit_lower emit_symbol func}\n`;
+            emit_call "caml_c_call";
+            record_frame i.live false i.dbg
+          | ELF64v1 | ELF64v2 ->
+            emit_tocload emit_gpr 28 (TocSym func);
+            emit_call "caml_c_call";
+            record_frame i.live false i.dbg;
+            `	nop\n`
+        end
+    | Lop(Istackoffset n) ->
+        `	addi	1, 1, {emit_int (-n)}\n`;
+        adjust_stack_offset n
+    | Lop(Iload(chunk, addr)) ->
+        let loadinstr =
+          match chunk with
+          | Byte_unsigned -> "lbz"
+          | Byte_signed -> "lbz"
+          | Sixteen_unsigned -> "lhz"
+          | Sixteen_signed -> "lha"
+          | Thirtytwo_unsigned -> "lwz"
+          | Thirtytwo_signed -> if ppc64 then "lwa" else "lwz"
+	  | Word_int | Word_val -> lg
+          | Single -> "lfs"
+          | Double | Double_u -> "lfd" in
+        emit_load_store loadinstr addr i.arg 0 i.res.(0);
+        if chunk = Byte_signed then
+          `	extsb	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+    | Lop(Istore(chunk, addr, _)) ->
+        let storeinstr =
+          match chunk with
+          | Byte_unsigned | Byte_signed -> "stb"
+          | Sixteen_unsigned | Sixteen_signed -> "sth"
+	  | Thirtytwo_unsigned | Thirtytwo_signed -> "stw"
+	  | Word_int | Word_val -> stg
+          | Single -> "stfs"
+          | Double | Double_u -> "stfd" in
+        emit_load_store storeinstr addr i.arg 1 i.arg.(0)
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        if !call_gc_label = 0 then begin
+          match label_after_call_gc with
+          | None -> call_gc_label := new_label ()
+          | Some label -> call_gc_label := label
+        end;
+        `	addi    31, 31, {emit_int(-n)}\n`;
+        `	{emit_string cmplg}	31, 30\n`;
+        `	addi	{emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`;
+        `	bltl	{emit_label !call_gc_label}\n`;
+        (* Exactly 4 instructions after the beginning of the alloc sequence *)
+        record_frame i.live false Debuginfo.none
+    | Lop(Ispecific(Ialloc_far { words = n; label_after_call_gc; })) ->
+        if !call_gc_label = 0 then begin
+          match label_after_call_gc with
+          | None -> call_gc_label := new_label ()
+          | Some label -> call_gc_label := label
+        end;
+        let lbl = new_label() in
+        `	addi    31, 31, {emit_int(-n)}\n`;
+        `	{emit_string cmplg}	31, 30\n`;
+        `	bge	{emit_label lbl}\n`;
+        `	bl	{emit_label !call_gc_label}\n`;
+        (* Exactly 4 instructions after the beginning of the alloc sequence *)
+        record_frame i.live false Debuginfo.none;
+        `{emit_label lbl}:	addi	{emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
+    | 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) ->
+        `	{emit_string divg}	0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	{emit_string mullg}	0, 0, {emit_reg i.arg.(1)}\n`;
+        `	subfc	{emit_reg i.res.(0)}, 0, {emit_reg i.arg.(0)}\n`
+    | Lop(Iintop(Icomp cmp)) ->
+        begin match cmp with
+          Isigned c ->
+            `	{emit_string cmpg}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            emit_set_comp c i.res.(0)
+        | Iunsigned c ->
+            `	{emit_string cmplg}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            emit_set_comp c i.res.(0)
+        end
+    | Lop(Iintop (Icheckbound { label_after_error; })) ->
+        if !Clflags.debug then
+          record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
+        `	{emit_string tglle}   {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Iintop op) ->
+        let instr = name_for_intop op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Iintop_imm(Isub, n)) ->
+        `	addi	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n`
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        begin match cmp with
+          Isigned c ->
+            `	{emit_string cmpg}i	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+            emit_set_comp c i.res.(0)
+        | Iunsigned c ->
+            `	{emit_string cmplg}i	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+            emit_set_comp c i.res.(0)
+        end
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+        if !Clflags.debug then
+          record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
+        `	{emit_string tglle}i   {emit_reg i.arg.(0)}, {emit_int n}\n`
+    | Lop(Iintop_imm(op, n)) ->
+        let instr = name_for_intop_imm op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
+    | Lop(Inegf | Iabsf as op) ->
+        let instr = name_for_floatop1 op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
+        let instr = name_for_floatop2 op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Ifloatofint) ->
+	if ppc64 then begin
+          (* Can use protected zone (288 bytes below r1 *)
+	  `	std	{emit_reg i.arg.(0)}, -16(1)\n`;
+          `	lfd	{emit_reg i.res.(0)}, -16(1)\n`;
+          `	fcfid	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+	end else begin
+          let lbl = new_label() in
+          float_literals := (0x4330000080000000L, lbl) :: !float_literals;
+          `	addis	11, 0, {emit_upper emit_label lbl}\n`;
+          `	lfd	0, {emit_lower emit_label lbl}(11)\n`;
+          `	lis	0, 0x4330\n`;
+          `	stwu	0, -16(1)\n`;
+          `	xoris	0, {emit_reg i.arg.(0)}, 0x8000\n`;
+          `	stw	0, 4(1)\n`;
+          `	lfd	{emit_reg i.res.(0)}, 0(1)\n`;
+          `	addi	1, 1, 16\n`;
+          `	fsub	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 0\n`
+	end
+    | Lop(Iintoffloat) ->
+        if ppc64 then begin
+          (* Can use protected zone (288 bytes below r1 *)
+          `	fctidz	0, {emit_reg i.arg.(0)}\n`;
+          `	stfd	0, -16(1)\n`;
+          `	ld	{emit_reg i.res.(0)}, -16(1)\n`
+        end else begin
+          `	fctiwz	0, {emit_reg i.arg.(0)}\n`;
+          `	stfdu	0, -16(1)\n`;
+          `	lwz	{emit_reg i.res.(0)}, 4(1)\n`;
+          `	addi	1, 1, 16\n`
+        end
+    | Lop(Ispecific sop) ->
+        let instr = name_for_specific sop in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
+    | Lreloadretaddr ->
+        `	{emit_string lg}	11, {emit_int(retaddr_offset())}(1)\n`;
+        `	mtlr	11\n`
+    | Lreturn ->
+        emit_free_frame();
+        `	blr\n`
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`
+    | Lbranch lbl ->
+        `	b	{emit_label lbl}\n`
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+          Itruetest ->
+            `	{emit_string cmpg}i	{emit_reg i.arg.(0)}, 0\n`;
+            `	bne	{emit_label lbl}\n`
+        | Ifalsetest ->
+            `	{emit_string cmpg}i	{emit_reg i.arg.(0)}, 0\n`;
+            `	beq	{emit_label lbl}\n`
+        | Iinttest cmp ->
+            let (comp, branch) = name_for_int_comparison cmp in
+            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `	{emit_string branch}	{emit_label lbl}\n`
+        | Iinttest_imm(cmp, n) ->
+            let (comp, branch) = name_for_int_comparison cmp in
+            `	{emit_string comp}i	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+            `	{emit_string branch}	{emit_label lbl}\n`
+        | Ifloattest(cmp, neg) ->
+            `	fcmpu	0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            (* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
+            let (bitnum, negtst) =
+              match cmp with
+                Ceq -> (2, neg)
+              | Cne -> (2, not neg)
+              | Cle -> `	cror	3, 0, 2\n`; (* lt or eq *)
+                       (3, neg)
+              | Cgt -> (1, neg)
+              | Cge -> `	cror	3, 1, 2\n`; (* gt or eq *)
+                       (3, neg)
+              | Clt -> (0, neg) in
+            if negtst
+            then `	bf	{emit_int bitnum}, {emit_label lbl}\n`
+            else `	bt	{emit_int bitnum}, {emit_label lbl}\n`
+        | Ioddtest ->
+            `	andi.	0, {emit_reg i.arg.(0)}, 1\n`;
+            `	bne	{emit_label lbl}\n`
+        | Ieventest ->
+            `	andi.	0, {emit_reg i.arg.(0)}, 1\n`;
+            `	beq	{emit_label lbl}\n`
+        end
+    | Lcondbranch3(lbl0, lbl1, lbl2) ->
+        `	{emit_string cmpg}i	{emit_reg i.arg.(0)}, 1\n`;
+        begin match lbl0 with
+          None -> ()
+        | Some lbl -> `	blt	{emit_label lbl}\n`
+        end;
+        begin match lbl1 with
+          None -> ()
+        | Some lbl -> `	beq	{emit_label lbl}\n`
+        end;
+        begin match lbl2 with
+          None -> ()
+        | Some lbl -> `	bgt	{emit_label lbl}\n`
+        end
+    | Lswitch jumptbl ->
+        let lbl = new_label() in
+        if ppc64 then begin
+          if !jumptables_lbl < 0 then jumptables_lbl := lbl;
+          let start = List.length !jumptables in
+          let (start_lo, start_hi) = low_high_s start in
+          emit_tocload emit_gpr 11 (TocLabel !jumptables_lbl);
+          `	addi	12, {emit_reg i.arg.(0)}, {emit_int start_lo}\n`;
+          if start_hi <> 0 then
+            `	addis	12, 12, {emit_int start_hi}\n`;
+          `	sldi	12, 12, 2\n`
+        end else begin
+          `	addis	11, 0, {emit_upper emit_label lbl}\n`;
+          `	addi	11, 11, {emit_lower emit_label lbl}\n`;
+          `	slwi	12, {emit_reg i.arg.(0)}, 2\n`
+        end;
+        `	{emit_string lwa}x	0, 11, 12\n`;
+        `	add	0, 11, 0\n`;
+        `	mtctr	0\n`;
+        `	bctr\n`;
+        if ppc64 then begin
+          jumptables := List.rev_append (Array.to_list jumptbl) !jumptables
+        end else begin
+          emit_string rodata_space;
+          `{emit_label lbl}:`;
+          for i = 0 to Array.length jumptbl - 1 do
+            `	.long	{emit_label jumptbl.(i)} - {emit_label lbl}\n`
+          done;
+          emit_string code_space
+        end
+    | Lsetuptrap lbl ->
+        `	bl	{emit_label lbl}\n`;
+        begin match abi with
+        | ELF32 -> ()
+        | ELF64v1 | ELF64v2 -> emit_reload_toc()
+        end
+    | Lpushtrap ->
+        begin match abi with
+        | ELF32 ->
+          `	mflr	0\n`;
+          `	stwu    0, -16(1)\n`;
+          adjust_stack_offset 16;
+          `	stw	29, 4(1)\n`;
+          `	mr	29, 1\n`
+        | ELF64v1 | ELF64v2 ->
+          `	mflr	0\n`;
+          `	addi	1, 1, -32\n`;
+          adjust_stack_offset 32;
+          `	std     0, {emit_int trap_handler_offset}(1)\n`;
+          `	std	29, {emit_int trap_previous_offset}(1)\n`;
+          `	mr	29, 1\n`
+          end
+    | Lpoptrap ->
+        `	{emit_string lg}	29, {emit_int trap_previous_offset}(1)\n`;
+        `	addi	1, 1, {emit_int trap_size}\n`;
+        adjust_stack_offset (-trap_size)
+    | Lraise k ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
+            emit_call "caml_raise_exn";
+            record_frame Reg.Set.empty true i.dbg;
+            emit_call_nop()
+        | Cmm.Raise_notrace ->
+            `	{emit_string lg}	0, {emit_int trap_handler_offset}(29)\n`;
+            `	mr	1, 29\n`;
+            `	mtctr   0\n`;
+            `	{emit_string lg}	29, {emit_int trap_previous_offset}(1)\n`;
+            `	addi	1, 1, {emit_int trap_size}\n`;
+            `	bctr\n`
+        end
+
+(* Emit a sequence of instructions *)
+
+let rec emit_all i =
+  match i.desc with
+  | Lend -> ()
+  |  _   -> emit_instr i; emit_all i.next
+
+(* Emission of the profiling prelude *)
+
+let emit_profile () =
+  match abi with
+  | ELF32 ->
+      `	mflr    0\n`;
+      `	addi	1, 1, -16\n`;
+      `	stw	0, 4(1)\n`;
+      (* _mcount preserves the registers used for parameter passing *)
+      (* when it returns, lr contains the original return address *)
+      `	bl	{emit_symbol "_mcount"}\n`;
+      `	addi	1, 1, 16\n`
+  | ELF64v1 | ELF64v2 ->
+      `	mflr	0\n`;
+      (* save the registers used for parameter passing *)
+      `	bl	{emit_symbol "caml_before_mcount"}\n`;
+      `	bl	{emit_symbol "_mcount"}\n`;
+      `	nop\n`;
+      (* restore the registers used for parameter passing *)
+      `	bl	{emit_symbol "caml_after_mcount"}\n`;
+      `	mtlr	0\n`
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  tailrec_entry_point := new_label();
+  stack_offset := 0;
+  call_gc_label := 0;
+  float_literals := [];
+  jumptables := []; jumptables_lbl := -1;
+  begin match abi with
+  | ELF32 ->
+    emit_string code_space;
+    `	.globl	{emit_symbol fundecl.fun_name}\n`;
+    `	.type	{emit_symbol fundecl.fun_name}, @function\n`;
+    `	.align	2\n`;
+    `{emit_symbol fundecl.fun_name}:\n`
+  | ELF64v1 ->
+    emit_string function_descr_space;
+    `	.align 3\n`;
+    `	.globl	{emit_symbol fundecl.fun_name}\n`;
+    `	.type   {emit_symbol fundecl.fun_name}, @function\n`;
+    `{emit_symbol fundecl.fun_name}:\n`;
+    `	.quad .L.{emit_symbol fundecl.fun_name}, .TOC.@tocbase\n`;
+    emit_string code_space;
+    `	.align  2\n`;
+    `.L.{emit_symbol fundecl.fun_name}:\n`
+  | ELF64v2 ->
+    emit_string code_space;
+    `	.globl	{emit_symbol fundecl.fun_name}\n`;
+    `	.type	{emit_symbol fundecl.fun_name}, @function\n`;
+    `	.align	2\n`;
+    `{emit_symbol fundecl.fun_name}:\n`;
+    `0:	addis	2, 12, (.TOC. - 0b)@ha\n`;
+    `	addi	2, 2, (.TOC. - 0b)@l\n`;
+    `	.localentry {emit_symbol fundecl.fun_name}, . - 0b\n`
+  end;
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc();
+  if !Clflags.gprofile then emit_profile();
+  let n = frame_size() in
+  if n > 0 then begin
+    `	addi	1, 1, {emit_int(-n)}\n`;
+    cfi_adjust_cfa_offset n
+  end;
+  if !contains_calls then begin
+    let ra = retaddr_offset() in
+    `	mflr	0\n`;
+    `	{emit_string stg}	0, {emit_int ra}(1)\n`;
+    cfi_offset ~reg: 65 (* LR *) ~offset: (ra - n);
+    match abi with
+    | ELF32 -> ()
+    | ELF64v1 | ELF64v2 ->
+      `	std	2, {emit_int(toc_save_offset())}(1)\n`
+  end;
+  `{emit_label !tailrec_entry_point}:\n`;
+  (* On this target, there is at most one "out of line" code block per
+     function: a single "call GC" point.  It comes immediately after the
+     function's body. *)
+  BR.relax fundecl.fun_body ~max_out_of_line_code_offset:0;
+  emit_all fundecl.fun_body;
+  (* Emit the glue code to call the GC *)
+  if !call_gc_label > 0 then begin
+    `{emit_label !call_gc_label}:\n`;
+    match abi with
+    | ELF32 ->
+      `	b	{emit_symbol "caml_call_gc"}\n`
+    | ELF64v1 ->
+      `	std	2, 40(1)\n`;
+             (* save our TOC, will be restored by caml_call_gc *)
+      emit_tocload emit_gpr 11 (TocSym "caml_call_gc");
+      `	ld	0, 0(11)\n`;
+      `	mtctr	0\n`;
+      `	ld	2, 8(11)\n`;
+      `	bctr\n`
+    | ELF64v2 ->
+      `	std	2, 24(1)\n`;
+             (* save our TOC, will be restored by caml_call_gc *)
+      emit_tocload emit_gpr 12 (TocSym "caml_call_gc");
+      `	mtctr	12\n`;
+      `	bctr\n`
+  end;
+  cfi_endproc();
+  begin match abi with
+  | ELF32 | ELF64v2 ->
+    `	.size	{emit_symbol fundecl.fun_name}, . - {emit_symbol fundecl.fun_name}\n`
+  | ELF64v1 ->
+    `	.size	{emit_symbol fundecl.fun_name}, . - .L.{emit_symbol fundecl.fun_name}\n`
+  end;
+  (* Emit the numeric literals *)
+  if !float_literals <> [] then begin
+    emit_string rodata_space;
+    `	.align	3\n`;
+    List.iter
+      (fun (f, lbl) ->
+        `{emit_label lbl}:`;
+        emit_float64_split_directive ".long" f)
+      !float_literals
+  end;
+  (* Emit the jump tables *)
+  if !jumptables <> [] then begin
+    emit_string rodata_space;
+    `	.align	2\n`;
+    `{emit_label !jumptables_lbl}:`;
+    List.iter
+      (fun  lbl ->
+          `	.long	{emit_label lbl} - {emit_label !jumptables_lbl}\n`)
+      (List.rev !jumptables)
+  end
+
+(* Emission of data *)
+
+let declare_global_data s =
+  `	.globl	{emit_symbol s}\n`;
+  `	.type	{emit_symbol s}, @object\n`
+
+let emit_item = function
+    Cglobal_symbol s ->
+      declare_global_data s
+  | Cdefine_symbol s ->
+      `{emit_symbol s}:\n`;
+  | Cint8 n ->
+      `	.byte	{emit_int n}\n`
+  | Cint16 n ->
+      `	.short	{emit_int n}\n`
+  | Cint32 n ->
+      `	.long	{emit_nativeint n}\n`
+  | Cint n ->
+      `	{emit_string datag}	{emit_nativeint n}\n`
+  | Csingle f ->
+      emit_float32_directive ".long" (Int32.bits_of_float f)
+  | Cdouble f ->
+      if ppc64
+      then emit_float64_directive ".quad" (Int64.bits_of_float f)
+      else emit_float64_split_directive ".long" (Int64.bits_of_float f)
+  | Csymbol_address s ->
+      `	{emit_string datag}	{emit_symbol s}\n`
+  | Cstring s ->
+      emit_bytes_directive "	.byte	" s
+  | Cskip n ->
+      if n > 0 then `	.space	{emit_int n}\n`
+  | Calign n ->
+      `	.align	{emit_int (Misc.log2 n)}\n`
+
+let data l =
+  emit_string data_space;
+  `	.align  {emit_int (if ppc64 then 3 else 2)}\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  reset_debug_info();
+  `	.file	\"\"\n`;  (* PR#7037 *)
+  begin match abi with
+  | ELF64v2 -> `	.abiversion 2\n`
+  | _ -> ()
+  end;
+  Hashtbl.clear tocref_entries;
+  (* Emit the beginning of the segments *)
+  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.make_symbol (Some "code_begin") in
+  emit_string function_descr_space;
+  (* For the ELF64v1 ABI, we must make sure that the .opd and .data
+     sections are in different pages.  .opd comes after .data,
+     so aligning .opd is enough.  To save space, we do it only
+     for the startup file, not for every OCaml compilation unit. *)
+  let c = Compilenv.current_unit_name() in
+  if abi = ELF64v1 && (c = "_startup" || c = "_shared_startup") then begin
+    `	.p2align	12\n`
+  end;
+  declare_global_data lbl_begin;
+  `{emit_symbol lbl_begin}:\n`
+
+let end_assembly() =
+  (* In profiling mode, for ELF64, emit the helper functions
+     for register saving and restoring.  We put one copy of these
+     functions in every generated file, instead of defining
+     them once in asmrun/power.S, so that we can call them
+     without risking to save r2 in the wrong place. *)
+  if ppc64 && !Clflags.gprofile then begin
+    let save_area = reserved_stack_space + (if abi = ELF64v1 then 8*8 else 0) in
+    let stacksize = save_area + 8*8 in
+    emit_string code_space;
+    `	.align	2\n`;
+    `{emit_symbol "caml_before_mcount"}:\n`;
+    `	stdu	1, {emit_int (-stacksize)}(1)\n`;
+    `	std	0, {emit_int (16 + stacksize)}(1)\n`;
+    for i = 3 to 10 do
+    `	std	{emit_gpr i}, {emit_int (save_area + (i - 3) * 8)}(1)\n`
+    done;
+    `	blr\n`;
+    `{emit_symbol "caml_after_mcount"}:\n`;
+    `	ld	0, {emit_int (16 + stacksize)}(1)\n`;
+    for i = 3 to 10 do
+    `	ld	{emit_gpr i}, {emit_int (save_area + (i - 3) * 8)}(1)\n`
+    done;
+    `	addi	1, 1, {emit_int stacksize}\n`;
+    `	blr\n`
+  end;
+  (* Emit the end of the segments *)
+  emit_string function_descr_space;
+  let lbl_end = Compilenv.make_symbol (Some "code_end") in
+  declare_global_data lbl_end;
+  `{emit_symbol lbl_end}:\n`;
+  if abi <> ELF64v1 then `	.long	0\n`;
+  emit_string data_space;
+  let lbl_end = Compilenv.make_symbol (Some "data_end") in
+  declare_global_data lbl_end;
+  `{emit_symbol lbl_end}:\n`;
+  `	{emit_string datag}	0\n`;
+  (* Emit the frame descriptors *)
+  emit_string rodata_space;
+  let lbl = Compilenv.make_symbol (Some "frametable") in
+  declare_global_data lbl;
+  `{emit_symbol lbl}:\n`;
+  emit_frames
+    { efa_code_label =
+         (fun l -> `	{emit_string datag}	{emit_label l}\n`);
+      efa_data_label =
+         (fun l -> `	{emit_string datag}	{emit_label l}\n`);
+      efa_16 = (fun n -> `	.short	{emit_int n}\n`);
+      efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
+      efa_word = (fun n -> `	{emit_string datag}	{emit_int n}\n`);
+      efa_align = (fun n -> `	.balign	{emit_int n}\n`);
+      efa_label_rel = (fun lbl ofs ->
+                           `	.long	({emit_label lbl} - .) + {emit_int32 ofs}\n`);
+      efa_def_label = (fun l -> `{emit_label l}:\n`);
+      efa_string = (fun s -> emit_bytes_directive "	.byte	" (s ^ "\000"))
+     };
+  (* Emit the TOC entries *)
+  begin match abi with
+  | ELF32 -> ()
+  | ELF64v1 | ELF64v2 ->
+      emit_string toc_space;
+      emit_toctable();
+      Hashtbl.clear tocref_entries
+  end;
+  `	.section .note.GNU-stack,\"\",%progbits\n`
diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml
new file mode 100644
index 00000000..670e8495
--- /dev/null
+++ b/asmcomp/power/proc.ml
@@ -0,0 +1,311 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the Power PC *)
+
+open Misc
+open Cmm
+open Reg
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Registers available for register allocation *)
+
+(* Integer register map:
+    0                   temporary, null register for some operations
+    1                   stack pointer
+    2                   pointer to table of contents
+    3 - 10              function arguments and results
+    11 - 12             temporaries
+    13                  pointer to small data area
+    14 - 28             general purpose, preserved by C
+    29                  trap pointer
+    30                  allocation limit
+    31                  allocation pointer
+  Floating-point register map:
+    0                   temporary
+    1 - 13              function arguments and results
+    14 - 31             general purpose, preserved by C
+*)
+
+let int_reg_name =
+  [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10";
+     "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21";
+     "22"; "23"; "24"; "25"; "26"; "27"; "28" |]
+
+let float_reg_name =
+  [| "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8";
+     "9"; "10"; "11"; "12"; "13"; "14"; "15"; "16";
+     "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24";
+     "25"; "26"; "27"; "28"; "29"; "30"; "31" |]
+
+let num_register_classes = 2
+
+let register_class r =
+  match r.typ with
+  | Val | Int | Addr -> 0
+  | Float -> 1
+
+let num_available_registers = [| 23; 31 |]
+
+let first_available_register = [| 0; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+let rotate_registers = true
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 23 Reg.dummy in
+  for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v
+
+let hard_float_reg =
+  let v = Array.make 31 Reg.dummy in
+  for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v
+
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
+(* Calling conventions *)
+
+let calling_conventions
+    first_int last_int first_float last_float
+    make_stack stack_ofs reg_use_stack arg =
+  let loc = Array.make (Array.length arg) [| Reg.dummy |] in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref stack_ofs in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i) with
+    | [| arg |] ->
+      begin match arg.typ with
+      | Val | Int | Addr as ty ->
+          if !int <= last_int then begin
+            loc.(i) <- [| phys_reg !int |];
+            incr int;
+            if reg_use_stack then ofs := !ofs + size_int
+          end else begin
+            loc.(i) <- [| stack_slot (make_stack !ofs) ty |];
+            ofs := !ofs + size_int
+          end
+      | Float ->
+          if !float <= last_float then begin
+            loc.(i) <- [| phys_reg !float |];
+            incr float;
+            (* On 64-bit platforms, passing a float in a float register
+               reserves a normal register as well *)
+            if size_int = 8 then incr int;
+            if reg_use_stack then ofs := !ofs + size_float
+          end else begin
+            ofs := Misc.align !ofs size_float;
+            loc.(i) <- [| stack_slot (make_stack !ofs) Float |];
+            ofs := !ofs + size_float
+          end
+      end
+    | [| arg1; arg2 |] ->
+      (* Passing of 64-bit quantities to external functions
+         on 32-bit platform. *)
+      assert (size_int = 4);
+      begin match arg1.typ, arg2.typ with
+      | Int, Int ->
+          (* 64-bit quantities split across two registers must either be in a
+             consecutive pair of registers where the lowest numbered is an
+             even-numbered register; or in a stack slot that is 8-byte
+             aligned. *)
+          int := Misc.align !int 2;
+          if !int <= last_int - 1 then begin
+            let reg_lower = phys_reg !int in
+            let reg_upper = phys_reg (!int + 1) in
+            loc.(i) <- [| reg_lower; reg_upper |];
+            int := !int + 2
+          end else begin
+            let size_int64 = 8 in
+            ofs := Misc.align !ofs size_int64;
+            let ofs_lower = !ofs in
+            let ofs_upper = !ofs + size_int in
+            let stack_lower = stack_slot (make_stack ofs_lower) Int in
+            let stack_upper = stack_slot (make_stack ofs_upper) Int in
+            loc.(i) <- [| stack_lower; stack_upper |];
+            ofs := !ofs + size_int64
+          end
+      | _, _ ->
+        let f = function Int -> "I" | Addr -> "A" | Val -> "V" | Float -> "F" in
+        fatal_error (Printf.sprintf "Proc.calling_conventions: bad register \
+            type(s) for multi-register argument: %s, %s"
+          (f arg1.typ) (f arg2.typ))
+      end
+    | _ ->
+      fatal_error "Proc.calling_conventions: bad number of registers for \
+                   multi-register argument"
+  done;
+  (loc, Misc.align !ofs 16)
+  (* Keep stack 16-aligned. *)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+let single_regs arg = Array.map (fun arg -> [| arg |]) arg
+let ensure_single_regs res =
+  Array.map (function
+      | [| res |] -> res
+      | _ -> failwith "Proc.ensure_single_regs")
+    res
+
+let max_arguments_for_tailcalls = 8
+
+let loc_arguments arg =
+  let (loc, ofs) =
+    calling_conventions 0 7 100 112 outgoing 0 false (single_regs arg)
+  in
+  (ensure_single_regs loc, ofs)
+let loc_parameters arg =
+  let (loc, _ofs) =
+    calling_conventions 0 7 100 112 incoming 0 false (single_regs arg)
+  in
+  ensure_single_regs loc
+let loc_results res =
+  let (loc, _ofs) =
+    calling_conventions 0 7 100 112 not_supported 0 false (single_regs res)
+  in
+  ensure_single_regs loc
+
+(* C calling conventions for ELF32:
+     use GPR 3-10 and FPR 1-8 just like ML calling conventions.
+     Using a float register does not affect the int registers.
+     Always reserve 8 bytes at bottom of stack, plus whatever is needed
+     to hold the overflow arguments.
+   C calling conventions for ELF64v1:
+     Use GPR 3-10 for the first integer arguments.
+     Use FPR 1-13 for the first float arguments.
+     Always reserve stack space for all arguments, even when passed in
+     registers.
+     Always reserve at least 8 words (64 bytes) for the arguments.
+     Always reserve 48 bytes at bottom of stack, plus whatever is needed
+     to hold the arguments.
+     The reserved 48 bytes are automatically added in emit.mlp
+     and need not appear here.
+   C calling conventions for ELF64v2:
+     Use GPR 3-10 for the first integer arguments.
+     Use FPR 1-13 for the first float arguments.
+     If all arguments fit in registers, don't reserve stack space.
+     Otherwise, reserve stack space for all arguments.
+     Always reserve 32 bytes at bottom of stack, plus whatever is needed
+     to hold the arguments.
+     The reserved 32 bytes are automatically added in emit.mlp
+     and need not appear here.
+*)
+
+let loc_external_arguments =
+  match abi with
+  | ELF32 ->
+      calling_conventions 0 7 100 107 outgoing 8 false
+  | ELF64v1 ->
+      fun args ->
+      let (loc, ofs) =
+        calling_conventions 0 7 100 112 outgoing 0 true args in
+      (loc, max ofs 64)
+  | ELF64v2 ->
+      fun args ->
+      let (loc, ofs) =
+        calling_conventions 0 7 100 112 outgoing 0 true args in
+      if Array.fold_left
+           (fun stk r ->
+              assert (Array.length r = 1);
+              match r.(0).loc with
+              | Stack _ -> true
+              | _ -> stk)
+           false loc
+      then (loc, ofs)
+      else (loc, 0)
+
+(* Results are in GPR 3 and FPR 1 *)
+
+let loc_external_results res =
+  let (loc, _ofs) =
+    calling_conventions 0 1 100 100 not_supported 0 false (single_regs res)
+  in
+  ensure_single_regs loc
+
+(* Exceptions are in GPR 3 *)
+
+let loc_exn_bucket = phys_reg 0
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _rs = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call =
+  Array.of_list(List.map phys_reg
+    [0; 1; 2; 3; 4; 5; 6; 7;
+     100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112])
+
+let destroyed_at_oper = function
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call
+  | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure = function
+    Iextcall _ -> 15
+  | _ -> 23
+
+let max_register_pressure = function
+    Iextcall _ -> [| 15; 18 |]
+  | _ -> [| 23; 30 |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers). *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
+  | Ispecific(Imultaddf | Imultsubf) -> true
+  | Ispecific _ -> false
+  | _ -> true
+
+(* Layout of the stack *)
+
+let num_stack_slots = [| 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler *)
+
+let assemble_file infile outfile =
+  Ccomp.command (Config.asm ^ " -o " ^
+                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+let init () = ()
diff --git a/asmcomp/power/reload.ml b/asmcomp/power/reload.ml
new file mode 100644
index 00000000..040c7939
--- /dev/null
+++ b/asmcomp/power/reload.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Reloading for the PowerPC *)
+
+let fundecl f =
+  (new Reloadgen.reload_generic)#fundecl f
diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml
new file mode 100644
index 00000000..dcbfca79
--- /dev/null
+++ b/asmcomp/power/scheduling.ml
@@ -0,0 +1,64 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction scheduling for the Power PC *)
+
+open Arch
+open Mach
+
+class scheduler = object
+
+inherit Schedgen.scheduler_generic
+
+(* Latencies (in cycles). Based roughly on the "common model". *)
+
+method oper_latency = function
+    Ireload -> 2
+  | Iload(_, _) -> 2
+  | Iconst_float _ -> 2 (* turned into a load *)
+  | Iconst_symbol _ -> 1
+  | Iintop(Imul | Imulh) -> 9
+  | Iintop_imm(Imul, _) -> 5
+  | Iintop(Idiv | Imod) -> 36
+  | Iaddf | Isubf -> 4
+  | Imulf -> 5
+  | Idivf -> 33
+  | Ispecific(Imultaddf | Imultsubf) -> 5
+  | _ -> 1
+
+method! reload_retaddr_latency = 12
+  (* If we can have that many cycles between the reloadretaddr and the
+     return, we can expect that the blr branch will be completely folded. *)
+
+(* Issue cycles.  Rough approximations. *)
+
+method oper_issue_cycles = function
+    Iconst_float _ | Iconst_symbol _ -> 2
+  | Iload(_, Ibased(_, _)) -> 2
+  | Istore(_, Ibased(_, _), _) -> 2
+  | Ialloc _ -> 4
+  | Iintop(Imod) -> 40 (* assuming full stall *)
+  | Iintop(Icomp _) -> 4
+  | Iintop_imm(Icomp _, _) -> 4
+  | Ifloatofint -> 9
+  | Iintoffloat -> 4
+  | _ -> 1
+
+method! reload_retaddr_issue_cycles = 3
+  (* load then stalling mtlr *)
+
+end
+
+let fundecl f = (new scheduler)#schedule_fundecl f
diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml
new file mode 100644
index 00000000..e62b0b89
--- /dev/null
+++ b/asmcomp/power/selection.ml
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the Power PC processor *)
+
+open Cmm
+open Arch
+open Mach
+
+(* Recognition of addressing modes *)
+
+type addressing_expr =
+    Asymbol of string
+  | Alinear of expression
+  | Aadd of expression * expression
+
+let rec select_addr = function
+    Cconst_symbol s ->
+      (Asymbol s, 0, Debuginfo.none)
+  | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], dbg) ->
+      let (a, n, _) = select_addr arg in (a, n + m, dbg)
+  | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], dbg) ->
+      let (a, n, _) = select_addr arg in (a, n + m, dbg)
+  | Cop((Caddi | Caddv | Cadda), [arg1; arg2], dbg) ->
+      begin match (select_addr arg1, select_addr arg2) with
+          ((Alinear e1, n1, _), (Alinear e2, n2, _)) ->
+              (Aadd(e1, e2), n1 + n2, dbg)
+        | _ ->
+              (Aadd(arg1, arg2), 0, dbg)
+      end
+  | exp ->
+      (Alinear exp, 0, Debuginfo.none)
+
+(* Instruction selection *)
+
+class selector = object (self)
+
+inherit Selectgen.selector_generic as super
+
+method is_immediate n = (n <= 32767) && (n >= -32768)
+
+method select_addressing _chunk exp =
+  match select_addr exp with
+    (Asymbol s, d, _dbg) ->
+      (Ibased(s, d), Ctuple [])
+  | (Alinear e, d, _dbg) ->
+      (Iindexed d, e)
+  | (Aadd(e1, e2), d, dbg) ->
+      if d = 0
+      then (Iindexed2, Ctuple[e1; e2])
+      else (Iindexed d, Cop(Cadda, [e1; e2], dbg))
+
+method! select_operation op args dbg =
+  match (op, args) with
+  (* PowerPC does not support immediate operands for multiply high *)
+    (Cmulhi, _) -> (Iintop Imulh, args)
+  (* The and, or and xor instructions have a different range of immediate
+     operands than the other instructions *)
+  | (Cand, _) -> self#select_logical Iand args
+  | (Cor, _) -> self#select_logical Ior args
+  | (Cxor, _) -> self#select_logical Ixor args
+  (* Recognize mult-add and mult-sub instructions *)
+  | (Caddf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
+      (Ispecific Imultaddf, [arg1; arg2; arg3])
+  | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2], _)]) ->
+      (Ispecific Imultaddf, [arg1; arg2; arg3])
+  | (Csubf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
+      (Ispecific Imultsubf, [arg1; arg2; arg3])
+  | _ ->
+      super#select_operation op args dbg
+
+method select_logical op = function
+    [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF ->
+      (Iintop_imm(op, n), [arg])
+  | [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF ->
+      (Iintop_imm(op, n), [arg])
+  | args ->
+      (Iintop op, args)
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
new file mode 100644
index 00000000..c4a790a2
--- /dev/null
+++ b/asmcomp/printclambda.ml
@@ -0,0 +1,227 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open Format
+open Asttypes
+open Clambda
+
+let mutable_flag = function
+  | Mutable-> "[mut]"
+  | Immutable -> ""
+
+let value_kind =
+  let open Lambda in
+  function
+  | Pgenval -> ""
+  | Pintval -> ":int"
+  | Pfloatval -> ":float"
+  | Pboxedintval Pnativeint -> ":nativeint"
+  | Pboxedintval Pint32 -> ":int32"
+  | Pboxedintval Pint64 -> ":int64"
+
+let rec structured_constant ppf = function
+  | Uconst_float x -> fprintf ppf "%F" x
+  | Uconst_int32 x -> fprintf ppf "%ldl" x
+  | Uconst_int64 x -> fprintf ppf "%LdL" x
+  | Uconst_nativeint x -> fprintf ppf "%ndn" x
+  | Uconst_block (tag, l) ->
+      fprintf ppf "block(%i" tag;
+      List.iter (fun u -> fprintf ppf ",%a" uconstant u) l;
+      fprintf ppf ")"
+  | Uconst_float_array [] ->
+      fprintf ppf "floatarray()"
+  | Uconst_float_array (f1 :: fl) ->
+      fprintf ppf "floatarray(%F" f1;
+      List.iter (fun f -> fprintf ppf ",%F" f) fl;
+      fprintf ppf ")"
+  | Uconst_string s -> fprintf ppf "%S" s
+  | Uconst_closure(clos, sym, fv) ->
+      let idents ppf =
+        List.iter (fprintf ppf "@ %a" Ident.print)in
+      let one_fun ppf f =
+        fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])"
+          f.label f.arity idents f.params lam f.body in
+      let funs ppf =
+        List.iter (fprintf ppf "@ %a" one_fun) in
+      let sconsts ppf scl =
+        List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
+      fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
+
+
+and uconstant ppf = function
+  | Uconst_ref (s, Some c) ->
+      fprintf ppf "%S=%a" s structured_constant c
+  | Uconst_ref (s, None) -> fprintf ppf "%S"s
+  | Uconst_int i -> fprintf ppf "%i" i
+  | Uconst_ptr i -> fprintf ppf "%ia" i
+
+and lam ppf = function
+  | Uvar id ->
+      Ident.print ppf id
+  | Uconst c -> uconstant ppf c
+  | Udirect_apply(f, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
+  | Ugeneric_apply(lfun, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
+  | Uclosure(clos, fv) ->
+      let idents ppf =
+        List.iter (fprintf ppf "@ %a" Ident.print)in
+      let one_fun ppf f =
+        fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])"
+          f.label f.arity idents f.params lam f.body in
+      let funs ppf =
+        List.iter (fprintf ppf "@ %a" one_fun) in
+      let lams ppf =
+        List.iter (fprintf ppf "@ %a" lam) in
+      fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
+  | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
+  | Ulet(mut, kind, id, arg, body) ->
+      let rec letbody ul = match ul with
+        | Ulet(mut, kind, id, arg, body) ->
+            fprintf ppf "@ @[<2>%a%s%s@ %a@]"
+              Ident.print id (mutable_flag mut) (value_kind kind) lam arg;
+            letbody body
+        | _ -> ul in
+      fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]"
+        Ident.print id (mutable_flag mut) (value_kind kind) lam arg;
+      let expr = letbody body in
+      fprintf ppf ")@]@ %a)@]" lam expr
+  | Uletrec(id_arg_list, body) ->
+      let bindings ppf id_arg_list =
+        let spc = ref false in
+        List.iter
+          (fun (id, l) ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l)
+          id_arg_list in
+      fprintf ppf
+        "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body
+  | Uprim(prim, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs
+  | Uswitch(larg, sw) ->
+      let print_case tag index i ppf =
+        for j = 0 to Array.length index - 1 do
+          if index.(j) = i then fprintf ppf "case %s %i:" tag j
+        done in
+      let print_cases tag index cases ppf =
+        for i = 0 to Array.length cases - 1 do
+          fprintf ppf "@ @[<2>%t@ %a@]"
+            (print_case tag index i) sequence cases.(i)
+        done in
+      let switch ppf sw =
+        print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ;
+        print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf  in
+      fprintf ppf
+       "@[@[<2>(switch@ %a@ @]%a)@]"
+        lam larg switch sw
+  | Ustringswitch(larg,sw,d) ->
+      let switch ppf sw =
+        let spc = ref false in
+        List.iter
+          (fun (s,l) ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[case \"%s\":@ %a@]"
+              (String.escaped s) lam l)
+          sw ;
+        begin match d with
+        | Some d ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[default:@ %a@]" lam d
+        | None -> ()
+        end in
+      fprintf ppf
+        "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw
+  | Ustaticfail (i, ls)  ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
+  | Ucatch(i, vars, lbody, lhandler) ->
+      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
+        lam lbody i
+        (fun ppf vars -> match vars with
+          | [] -> ()
+          | _ ->
+              List.iter
+                (fun x -> fprintf ppf " %a" Ident.print x)
+                vars)
+        vars
+        lam lhandler
+  | Utrywith(lbody, param, lhandler) ->
+      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
+        lam lbody Ident.print param lam lhandler
+  | Uifthenelse(lcond, lif, lelse) ->
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
+  | Usequence(l1, l2) ->
+      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
+  | Uwhile(lcond, lbody) ->
+      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
+  | Ufor(param, lo, hi, dir, body) ->
+      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
+       Ident.print param lam lo
+       (match dir with Upto -> "to" | Downto -> "downto")
+       lam hi lam body
+  | Uassign(id, expr) ->
+      fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
+  | Usend (k, met, obj, largs, _) ->
+      let args ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      let kind =
+        if k = Lambda.Self then "self"
+        else if k = Lambda.Cached then "cache"
+        else "" in
+      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
+  | Uunreachable ->
+      fprintf ppf "unreachable"
+
+and sequence ppf ulam = match ulam with
+  | Usequence(l1, l2) ->
+      fprintf ppf "%a@ %a" sequence l1 sequence l2
+  | _ -> lam ppf ulam
+
+let clambda ppf ulam =
+  fprintf ppf "%a@." lam ulam
+
+
+let rec approx ppf = function
+    Value_closure(fundesc, a) ->
+      Format.fprintf ppf "@[<2>function %s@ arity %i"
+        fundesc.fun_label fundesc.fun_arity;
+      if fundesc.fun_closed then begin
+        Format.fprintf ppf "@ (closed)"
+      end;
+      if fundesc.fun_inline <> None then begin
+        Format.fprintf ppf "@ (inline)"
+      end;
+      Format.fprintf ppf "@ -> @ %a@]" approx a
+  | Value_tuple a ->
+      let tuple ppf a =
+        for i = 0 to Array.length a - 1 do
+          if i > 0 then Format.fprintf ppf ";@ ";
+          Format.fprintf ppf "%i: %a" i approx a.(i)
+        done in
+      Format.fprintf ppf "@[(%a)@]" tuple a
+  | Value_unknown ->
+      Format.fprintf ppf "_"
+  | Value_const c ->
+      fprintf ppf "@[const(%a)@]" uconstant c
+  | Value_global_field (s, i) ->
+      fprintf ppf "@[global(%s,%i)@]" s i
diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli
new file mode 100644
index 00000000..3b1ff58f
--- /dev/null
+++ b/asmcomp/printclambda.mli
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Clambda
+open Format
+
+val clambda: formatter -> ulambda -> unit
+val approx: formatter -> value_approximation -> unit
+val structured_constant: formatter -> ustructured_constant -> unit
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
new file mode 100644
index 00000000..697ebca8
--- /dev/null
+++ b/asmcomp/printcmm.ml
@@ -0,0 +1,234 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pretty-printing of C-- code *)
+
+open Format
+open Cmm
+
+let rec_flag ppf = function
+  | Nonrecursive -> ()
+  | Recursive -> fprintf ppf " rec"
+
+let machtype_component ppf = function
+  | Val -> fprintf ppf "val"
+  | Addr -> fprintf ppf "addr"
+  | Int -> fprintf ppf "int"
+  | Float -> fprintf ppf "float"
+
+let machtype ppf mty =
+  match Array.length mty with
+  | 0 -> fprintf ppf "unit"
+  | n -> machtype_component ppf mty.(0);
+         for i = 1 to n-1 do
+           fprintf ppf "*%a" machtype_component mty.(i)
+         done
+
+let comparison = function
+  | Ceq -> "=="
+  | Cne -> "!="
+  | Clt -> "<"
+  | Cle -> "<="
+  | Cgt -> ">"
+  | Cge -> ">="
+
+let chunk = function
+  | Byte_unsigned -> "unsigned int8"
+  | Byte_signed -> "signed int8"
+  | Sixteen_unsigned -> "unsigned int16"
+  | Sixteen_signed -> "signed int16"
+  | Thirtytwo_unsigned -> "unsigned int32"
+  | Thirtytwo_signed -> "signed int32"
+  | Word_int -> "int"
+  | Word_val -> "val"
+  | Single -> "float32"
+  | Double -> "float64"
+  | Double_u -> "float64u"
+
+let raise_kind fmt = function
+  | Raise_withtrace -> Format.fprintf fmt "raise_withtrace"
+  | Raise_notrace -> Format.fprintf fmt "raise_notrace"
+
+let operation d = function
+  | Capply _ty -> "app" ^ Debuginfo.to_string d
+  | Cextcall(lbl, _ty, _alloc, _) ->
+      Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d)
+  | Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
+  | Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
+  | Calloc -> "alloc" ^ Debuginfo.to_string d
+  | Cstore (c, init) ->
+    let init =
+      match init with
+      | Lambda.Heap_initialization -> "(heap-init)"
+      | Lambda.Root_initialization -> "(root-init)"
+      | Lambda.Assignment -> ""
+    in
+    Printf.sprintf "store %s%s" (chunk c) init
+  | Caddi -> "+"
+  | Csubi -> "-"
+  | Cmuli -> "*"
+  | Cmulhi -> "*h"
+  | Cdivi -> "/"
+  | Cmodi -> "mod"
+  | Cand -> "and"
+  | Cor -> "or"
+  | Cxor -> "xor"
+  | Clsl -> "<<"
+  | Clsr -> ">>u"
+  | Casr -> ">>s"
+  | Ccmpi c -> comparison c
+  | Caddv -> "+v"
+  | Cadda -> "+a"
+  | Ccmpa c -> Printf.sprintf "%sa" (comparison c)
+  | Cnegf -> "~f"
+  | Cabsf -> "absf"
+  | Caddf -> "+f"
+  | Csubf -> "-f"
+  | Cmulf -> "*f"
+  | Cdivf -> "/f"
+  | Cfloatofint -> "floatofint"
+  | Cintoffloat -> "intoffloat"
+  | Ccmpf c -> Printf.sprintf "%sf" (comparison c)
+  | Craise k -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d)
+  | Ccheckbound -> "checkbound" ^ Debuginfo.to_string d
+
+let rec expr ppf = function
+  | Cconst_int n -> fprintf ppf "%i" n
+  | Cconst_natint n ->
+    fprintf ppf "%s" (Nativeint.to_string n)
+  | Cblockheader(n, d) ->
+    fprintf ppf "block-hdr(%s)%s"
+      (Nativeint.to_string n) (Debuginfo.to_string d)
+  | Cconst_float n -> fprintf ppf "%F" n
+  | Cconst_symbol s -> fprintf ppf "\"%s\"" s
+  | Cconst_pointer n -> fprintf ppf "%ia" n
+  | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n)
+  | Cvar id -> Ident.print ppf id
+  | Clet(id, def, (Clet(_, _, _) as body)) ->
+      let print_binding id ppf def =
+        fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in
+      let rec in_part ppf = function
+        | Clet(id, def, body) ->
+            fprintf ppf "@ %a" (print_binding id) def;
+            in_part ppf body
+        | exp -> exp in
+      fprintf ppf "@[<2>(let@ @[<1>(%a" (print_binding id) def;
+      let exp = in_part ppf body in
+      fprintf ppf ")@]@ %a)@]" sequence exp
+  | Clet(id, def, body) ->
+     fprintf ppf
+      "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]"
+      Ident.print id expr def sequence body
+  | Cassign(id, exp) ->
+      fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp
+  | Ctuple el ->
+      let tuple ppf el =
+       let first = ref true in
+       List.iter
+        (fun e ->
+          if !first then first := false else fprintf ppf "@ ";
+          expr ppf e)
+        el in
+      fprintf ppf "@[<1>[%a]@]" tuple el
+  | Cop(op, el, dbg) ->
+      fprintf ppf "@[<2>(%s" (operation dbg op);
+      List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
+      begin match op with
+      | Capply mty -> fprintf ppf "@ %a" machtype mty
+      | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
+      | _ -> ()
+      end;
+      fprintf ppf ")@]"
+  | Csequence(e1, e2) ->
+      fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2
+  | Cifthenelse(e1, e2, e3) ->
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3
+  | Cswitch(e1, index, cases, _dbg) ->
+      let print_case i ppf =
+        for j = 0 to Array.length index - 1 do
+          if index.(j) = i then fprintf ppf "case %i:" j
+        done in
+      let print_cases ppf =
+       for i = 0 to Array.length cases - 1 do
+        fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i)
+       done in
+      fprintf ppf "@[@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
+  | Cloop e ->
+      fprintf ppf "@[<2>(loop@ %a)@]" sequence e
+  | Ccatch(flag, handlers, e1) ->
+      let print_handler ppf (i, ids, e2) =
+        fprintf ppf "(%d%a)@ %a"
+          i
+          (fun ppf ids ->
+             List.iter
+               (fun id -> fprintf ppf " %a" Ident.print id)
+               ids) ids
+          sequence e2
+      in
+      let print_handlers ppf l =
+        List.iter (print_handler ppf) l
+      in
+      fprintf ppf
+        "@[<2>(catch%a@ %a@;<1 -2>with%a)@]"
+        rec_flag flag
+        sequence e1
+        print_handlers handlers
+  | Cexit (i, el) ->
+      fprintf ppf "@[<2>(exit %d" i;
+      List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
+      fprintf ppf ")@]"
+  | Ctrywith(e1, id, e2) ->
+      fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]"
+             sequence e1 Ident.print id sequence e2
+
+and sequence ppf = function
+  | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2
+  | e -> expression ppf e
+
+and expression ppf e = fprintf ppf "%a" expr e
+
+let fundecl ppf f =
+  let print_cases ppf cases =
+    let first = ref true in
+    List.iter
+     (fun (id, ty) ->
+       if !first then first := false else fprintf ppf "@ ";
+       fprintf ppf "%a: %a" Ident.print id machtype ty)
+     cases in
+  fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
+         (Debuginfo.to_string f.fun_dbg) f.fun_name
+         print_cases f.fun_args sequence f.fun_body
+
+let data_item ppf = function
+  | Cdefine_symbol s -> fprintf ppf "\"%s\":" s
+  | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s
+  | Cint8 n -> fprintf ppf "byte %i" n
+  | Cint16 n -> fprintf ppf "int16 %i" n
+  | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n)
+  | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n)
+  | Csingle f -> fprintf ppf "single %F" f
+  | Cdouble f -> fprintf ppf "double %F" f
+  | Csymbol_address s -> fprintf ppf "addr \"%s\"" s
+  | Cstring s -> fprintf ppf "string \"%s\"" s
+  | Cskip n -> fprintf ppf "skip %i" n
+  | Calign n -> fprintf ppf "align %i" n
+
+let data ppf dl =
+  let items ppf = List.iter (fun d -> fprintf ppf "@ %a" data_item d) dl in
+  fprintf ppf "@[(data%t)@]" items
+
+let phrase ppf = function
+  | Cfunction f -> fundecl ppf f
+  | Cdata dl -> data ppf dl
diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli
new file mode 100644
index 00000000..bd4739b2
--- /dev/null
+++ b/asmcomp/printcmm.mli
@@ -0,0 +1,30 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pretty-printing of C-- code *)
+
+open Format
+
+val rec_flag : formatter -> Cmm.rec_flag -> unit
+val machtype_component : formatter -> Cmm.machtype_component -> unit
+val machtype : formatter -> Cmm.machtype_component array -> unit
+val comparison : Cmm.comparison -> string
+val chunk : Cmm.memory_chunk -> string
+val operation : Debuginfo.t -> Cmm.operation -> string
+val expression : formatter -> Cmm.expression -> unit
+val fundecl : formatter -> Cmm.fundecl -> unit
+val data : formatter -> Cmm.data_item list -> unit
+val phrase : formatter -> Cmm.phrase -> unit
+val raise_kind: formatter -> Cmm.raise_kind -> unit
diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml
new file mode 100644
index 00000000..faf26d2d
--- /dev/null
+++ b/asmcomp/printlinear.ml
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pretty-printing of linearized machine code *)
+
+open Format
+open Mach
+open Printmach
+open Linearize
+
+let label ppf l =
+  Format.fprintf ppf "L%i" l
+
+let instr ppf i =
+  begin match i.desc with
+  | Lend -> ()
+  | Lop op ->
+      begin match op with
+      | Ialloc _ | Icall_ind _ | Icall_imm _ | Iextcall _ ->
+          fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live
+      | _ -> ()
+      end;
+      operation op i.arg ppf i.res
+  | Lreloadretaddr ->
+      fprintf ppf "reload retaddr"
+  | Lreturn ->
+      fprintf ppf "return %a" regs i.arg
+  | Llabel lbl ->
+      fprintf ppf "%a:" label lbl
+  | Lbranch lbl ->
+      fprintf ppf "goto %a" label lbl
+  | Lcondbranch(tst, lbl) ->
+      fprintf ppf "if %a goto %a" (test tst) i.arg label lbl
+  | Lcondbranch3(lbl0, lbl1, lbl2) ->
+      fprintf ppf "switch3 %a" reg i.arg.(0);
+      let case n = function
+      | None -> ()
+      | Some lbl ->
+         fprintf ppf "@,case %i: goto %a" n label lbl in
+      case 0 lbl0; case 1 lbl1; case 2 lbl2;
+      fprintf ppf "@,endswitch"
+  | Lswitch lblv ->
+      fprintf ppf "switch %a" reg i.arg.(0);
+      for i = 0 to Array.length lblv - 1 do
+       fprintf ppf "case %i: goto %a" i label lblv.(i)
+      done;
+      fprintf ppf "@,endswitch"
+  | Lsetuptrap lbl ->
+      fprintf ppf "setup trap %a" label lbl
+  | Lpushtrap ->
+      fprintf ppf "push trap"
+  | Lpoptrap ->
+      fprintf ppf "pop trap"
+  | Lraise k ->
+      fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0)
+  end;
+  if not (Debuginfo.is_none i.dbg) then
+    fprintf ppf " %s" (Debuginfo.to_string i.dbg)
+
+let rec all_instr ppf i =
+  match i.desc with
+  | Lend -> ()
+  | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next
+
+let fundecl ppf f =
+  let dbg =
+    if Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      " " ^ Debuginfo.to_string f.fun_dbg in
+  fprintf ppf "@[%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body
diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli
new file mode 100644
index 00000000..b598868e
--- /dev/null
+++ b/asmcomp/printlinear.mli
@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pretty-printing of linearized machine code *)
+
+open Format
+open Linearize
+
+val instr: formatter -> instruction -> unit
+val fundecl: formatter -> fundecl -> unit
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
new file mode 100644
index 00000000..f45dbb8f
--- /dev/null
+++ b/asmcomp/printmach.ml
@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pretty-printing of pseudo machine code *)
+
+open Format
+open Cmm
+open Reg
+open Mach
+
+let reg ppf r =
+  if not (Reg.anonymous r) then
+    fprintf ppf "%s" (Reg.name r)
+  else
+    fprintf ppf "%s"
+      (match r.typ with Val -> "V" | Addr -> "A" | Int -> "I" | Float -> "F");
+  fprintf ppf "/%i" r.stamp;
+  begin match r.loc with
+  | Unknown -> ()
+  | Reg r ->
+      fprintf ppf "[%s]" (Proc.register_name r)
+  | Stack(Local s) ->
+      fprintf ppf "[s%i]" s
+  | Stack(Incoming s) ->
+      fprintf ppf "[si%i]" s
+  | Stack(Outgoing s) ->
+      fprintf ppf "[so%i]" s
+  end
+
+let regs ppf v =
+  match Array.length v with
+  | 0 -> ()
+  | 1 -> reg ppf v.(0)
+  | n -> reg ppf v.(0);
+         for i = 1 to n-1 do fprintf ppf " %a" reg v.(i) done
+
+let regset ppf s =
+  let first = ref true in
+  Reg.Set.iter
+    (fun r ->
+      if !first then begin first := false; fprintf ppf "%a" reg r end
+      else fprintf ppf "@ %a" reg r)
+    s
+
+let regsetaddr ppf s =
+  let first = ref true in
+  Reg.Set.iter
+    (fun r ->
+      if !first then begin first := false; fprintf ppf "%a" reg r end
+      else fprintf ppf "@ %a" reg r;
+      match r.typ with
+      | Val -> fprintf ppf "*"
+      | Addr -> fprintf ppf "!"
+      | _ -> ())
+    s
+
+let intcomp = function
+  | Isigned c -> Printf.sprintf " %ss " (Printcmm.comparison c)
+  | Iunsigned c -> Printf.sprintf " %su " (Printcmm.comparison c)
+
+let floatcomp c =
+    Printf.sprintf " %sf " (Printcmm.comparison c)
+
+let intop = function
+  | Iadd -> " + "
+  | Isub -> " - "
+  | Imul -> " * "
+  | Imulh -> " *h "
+  | Idiv -> " div "
+  | Imod -> " mod "
+  | Iand -> " & "
+  | Ior ->  " | "
+  | Ixor -> " ^ "
+  | Ilsl -> " << "
+  | Ilsr -> " >>u "
+  | Iasr -> " >>s "
+  | Icomp cmp -> intcomp cmp
+  | Icheckbound { label_after_error; spacetime_index; } ->
+    if not Config.spacetime then " check > "
+    else
+      Printf.sprintf "check[lbl=%s,index=%d] > "
+        begin
+          match label_after_error with
+          | None -> ""
+          | Some lbl -> string_of_int lbl
+        end
+        spacetime_index
+
+let test tst ppf arg =
+  match tst with
+  | Itruetest -> reg ppf arg.(0)
+  | Ifalsetest -> fprintf ppf "not %a" reg arg.(0)
+  | Iinttest cmp -> fprintf ppf "%a%s%a" reg arg.(0) (intcomp cmp) reg arg.(1)
+  | Iinttest_imm(cmp, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intcomp cmp) n
+  | Ifloattest(cmp, neg) ->
+      fprintf ppf "%s%a%s%a"
+       (if neg then "not " else "")
+       reg arg.(0) (floatcomp cmp) reg arg.(1)
+  | Ieventest -> fprintf ppf "%a & 1 == 0" reg arg.(0)
+  | Ioddtest -> fprintf ppf "%a & 1 == 1" reg arg.(0)
+
+let print_live = ref false
+
+let operation op arg ppf res =
+  if Array.length res > 0 then fprintf ppf "%a := " regs res;
+  match op with
+  | Imove -> regs ppf arg
+  | Ispill -> fprintf ppf "%a (spill)" regs arg
+  | Ireload -> fprintf ppf "%a (reload)" regs arg
+  | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n)
+  | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f)
+  | Iconst_symbol s -> fprintf ppf "\"%s\"" s
+  | Icall_ind _ -> fprintf ppf "call %a" regs arg
+  | Icall_imm { func; _ } -> fprintf ppf "call \"%s\" %a" func regs arg
+  | Itailcall_ind _ -> fprintf ppf "tailcall %a" regs arg
+  | Itailcall_imm { func; } -> fprintf ppf "tailcall \"%s\" %a" func regs arg
+  | Iextcall { func; alloc; _ } ->
+      fprintf ppf "extcall \"%s\" %a%s" func regs arg
+      (if alloc then "" else " (noalloc)")
+  | Istackoffset n ->
+      fprintf ppf "offset stack %i" n
+  | Iload(chunk, addr) ->
+      fprintf ppf "%s[%a]"
+       (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg
+  | Istore(chunk, addr, is_assign) ->
+      fprintf ppf "%s[%a] := %a %s"
+       (Printcmm.chunk chunk)
+       (Arch.print_addressing reg addr)
+       (Array.sub arg 1 (Array.length arg - 1))
+       reg arg.(0)
+       (if is_assign then "(assign)" else "(init)")
+  | Ialloc { words = n; _ } ->
+    fprintf ppf "alloc %i" n;
+    if Config.spacetime then begin
+      fprintf ppf "(spacetime node = %a)" reg arg.(0)
+    end
+  | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1)
+  | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n
+  | Inegf -> fprintf ppf "-f %a" reg arg.(0)
+  | Iabsf -> fprintf ppf "absf %a" reg arg.(0)
+  | Iaddf -> fprintf ppf "%a +f %a" reg arg.(0) reg arg.(1)
+  | Isubf -> fprintf ppf "%a -f %a" reg arg.(0) reg arg.(1)
+  | Imulf -> fprintf ppf "%a *f %a" reg arg.(0) reg arg.(1)
+  | Idivf -> fprintf ppf "%a /f %a" reg arg.(0) reg arg.(1)
+  | Ifloatofint -> fprintf ppf "floatofint %a" reg arg.(0)
+  | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0)
+  | Ispecific op ->
+      Arch.print_specific_operation reg op ppf arg
+
+let rec instr ppf i =
+  if !print_live then begin
+    fprintf ppf "@[<1>{%a" regsetaddr i.live;
+    if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg;
+    fprintf ppf "}@]@,";
+  end;
+  begin match i.desc with
+  | Iend -> ()
+  | Iop op ->
+      operation op i.arg ppf i.res
+  | Ireturn ->
+      fprintf ppf "return %a" regs i.arg
+  | Iifthenelse(tst, ifso, ifnot) ->
+      fprintf ppf "@[if %a then@,%a" (test tst) i.arg instr ifso;
+      begin match ifnot.desc with
+      | Iend -> ()
+      | _ -> fprintf ppf "@;<0 -2>else@,%a" instr ifnot
+      end;
+      fprintf ppf "@;<0 -2>endif@]"
+  | Iswitch(index, cases) ->
+      fprintf ppf "switch %a" reg i.arg.(0);
+      for i = 0 to Array.length cases - 1 do
+        fprintf ppf "@,@[@[";
+        for j = 0 to Array.length index - 1 do
+          if index.(j) = i then fprintf ppf "case %i:@," j
+        done;
+        fprintf ppf "@]@,%a@]" instr cases.(i)
+      done;
+      fprintf ppf "@,endswitch"
+  | Iloop(body) ->
+      fprintf ppf "@[loop@,%a@;<0 -2>endloop@]" instr body
+  | Icatch(flag, handlers, body) ->
+      fprintf ppf "@[catch%a@,%a@;<0 -2>with"
+        Printcmm.rec_flag flag instr body;
+      let h (nfail, handler) =
+        fprintf ppf "(%d)@,%a@;" nfail instr handler in
+      let rec aux = function
+        | [] -> ()
+        | [v] -> h v
+        | v :: t ->
+            h v;
+            fprintf ppf "@ and";
+            aux t
+      in
+      aux handlers
+  | Iexit i ->
+      fprintf ppf "exit(%d)" i
+  | Itrywith(body, handler) ->
+      fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]"
+             instr body instr handler
+  | Iraise k ->
+      fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0)
+  end;
+  if not (Debuginfo.is_none i.dbg) then
+    fprintf ppf "%s" (Debuginfo.to_string i.dbg);
+  begin match i.next.desc with
+    Iend -> ()
+  | _ -> fprintf ppf "@,%a" instr i.next
+  end
+
+let fundecl ppf f =
+  let dbg =
+    if Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      " " ^ Debuginfo.to_string f.fun_dbg in
+  fprintf ppf "@[%s(%a)%s@,%a@]"
+    f.fun_name regs f.fun_args dbg instr f.fun_body
+
+let phase msg ppf f =
+  fprintf ppf "*** %s@.%a@." msg fundecl f
+
+let interference ppf r =
+  let interf ppf =
+   List.iter
+    (fun r -> fprintf ppf "@ %a" reg r)
+    r.interf in
+  fprintf ppf "@[<2>%a:%t@]@." reg r interf
+
+let interferences ppf () =
+  fprintf ppf "*** Interferences@.";
+  List.iter (interference ppf) (Reg.all_registers())
+
+let preference ppf r =
+  let prefs ppf =
+    List.iter
+      (fun (r, w) -> fprintf ppf "@ %a weight %i" reg r w)
+      r.prefer in
+  fprintf ppf "@[<2>%a: %t@]@." reg r prefs
+
+let preferences ppf () =
+  fprintf ppf "*** Preferences@.";
+  List.iter (preference ppf) (Reg.all_registers())
diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli
new file mode 100644
index 00000000..fb7411a6
--- /dev/null
+++ b/asmcomp/printmach.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pretty-printing of pseudo machine code *)
+
+open Format
+
+val reg: formatter -> Reg.t -> unit
+val regs: formatter -> Reg.t array -> unit
+val regset: formatter -> Reg.Set.t -> unit
+val regsetaddr: formatter -> Reg.Set.t -> unit
+val operation: Mach.operation -> Reg.t array -> formatter -> Reg.t array -> unit
+val test: Mach.test -> formatter -> Reg.t array -> unit
+val instr: formatter -> Mach.instruction -> unit
+val fundecl: formatter -> Mach.fundecl -> unit
+val phase: string -> formatter -> Mach.fundecl -> unit
+val interferences: formatter -> unit -> unit
+val preferences: formatter -> unit -> unit
+
+val print_live: bool ref
diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli
new file mode 100644
index 00000000..23f503fa
--- /dev/null
+++ b/asmcomp/proc.mli
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Processor descriptions *)
+
+(* Instruction selection *)
+val word_addressed: bool
+
+(* Registers available for register allocation *)
+val num_register_classes: int
+val register_class: Reg.t -> int
+val num_available_registers: int array
+val first_available_register: int array
+val register_name: int -> string
+val phys_reg: int -> Reg.t
+val rotate_registers: bool
+
+(* Calling conventions *)
+val loc_arguments: Reg.t array -> Reg.t array * int
+val loc_results: Reg.t array -> Reg.t array
+val loc_parameters: Reg.t array -> Reg.t array
+(* For argument number [n] split across multiple registers, the target-specific
+   implementation of [loc_external_arguments] must return [regs] such that
+   [regs.(n).(0)] is to hold the part of the value at the lowest address.
+   (All that matters for the input to [loc_external_arguments] is the pattern
+   of lengths and register types of the various supplied arrays.) *)
+val loc_external_arguments: Reg.t array array -> Reg.t array array * int
+val loc_external_results: Reg.t array -> Reg.t array
+val loc_exn_bucket: Reg.t
+val loc_spacetime_node_hole: Reg.t
+
+(* The maximum number of arguments of an OCaml to OCaml function call for
+   which it is guaranteed there will be no arguments passed on the stack.
+   (Above this limit, tail call optimization may be disabled.)
+   N.B. The values for this parameter in the backends currently assume
+   that no unboxed floats are passed using the OCaml calling conventions.
+*)
+val max_arguments_for_tailcalls : int
+
+(* Maximal register pressures for pre-spilling *)
+val safe_register_pressure: Mach.operation -> int
+val max_register_pressure: Mach.operation -> int array
+
+(* Registers destroyed by operations *)
+val destroyed_at_oper: Mach.instruction_desc -> Reg.t array
+val destroyed_at_raise: Reg.t array
+
+(* Volatile registers: those that change value when read *)
+val regs_are_volatile: Reg.t array -> bool
+
+(* Pure operations *)
+val op_is_pure: Mach.operation -> bool
+
+(* Info for laying out the stack frame *)
+val num_stack_slots: int array
+val contains_calls: bool ref
+
+(* Calling the assembler *)
+val assemble_file: string -> string -> int
+
+(* Called before translating a fundecl. *)
+val init : unit -> unit
diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml
new file mode 100644
index 00000000..441a6d38
--- /dev/null
+++ b/asmcomp/reg.ml
@@ -0,0 +1,200 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmm
+
+module Raw_name = struct
+  type t =
+    | Anon
+    | R
+    | Ident of Ident.t
+
+  let create_from_ident ident = Ident ident
+
+  let to_string t =
+    match t with
+    | Anon -> None
+    | R -> Some "R"
+    | Ident ident ->
+      let name = Ident.name ident in
+      if String.length name <= 0 then None else Some name
+end
+
+type t =
+  { mutable raw_name: Raw_name.t;
+    stamp: int;
+    mutable typ: Cmm.machtype_component;
+    mutable loc: location;
+    mutable spill: bool;
+    mutable part: int option;
+    mutable interf: t list;
+    mutable prefer: (t * int) list;
+    mutable degree: int;
+    mutable spill_cost: int;
+    mutable visited: bool }
+
+and location =
+    Unknown
+  | Reg of int
+  | Stack of stack_location
+
+and stack_location =
+    Local of int
+  | Incoming of int
+  | Outgoing of int
+
+type reg = t
+
+let dummy =
+  { raw_name = Raw_name.Anon; stamp = 0; typ = Int; loc = Unknown;
+    spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0;
+    visited = false; part = None;
+  }
+
+let currstamp = ref 0
+let reg_list = ref([] : t list)
+
+let create ty =
+  let r = { raw_name = Raw_name.Anon; stamp = !currstamp; typ = ty;
+            loc = Unknown; spill = false; interf = []; prefer = []; degree = 0;
+            spill_cost = 0; visited = false; part = None; } in
+  reg_list := r :: !reg_list;
+  incr currstamp;
+  r
+
+let createv tyv =
+  let n = Array.length tyv in
+  let rv = Array.make n dummy in
+  for i = 0 to n-1 do rv.(i) <- create tyv.(i) done;
+  rv
+
+let createv_like rv =
+  let n = Array.length rv in
+  let rv' = Array.make n dummy in
+  for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done;
+  rv'
+
+let clone r =
+  let nr = create r.typ in
+  nr.raw_name <- r.raw_name;
+  nr
+
+let at_location ty loc =
+  let r = { raw_name = Raw_name.R; stamp = !currstamp; typ = ty; loc;
+            spill = false; interf = []; prefer = []; degree = 0;
+            spill_cost = 0; visited = false; part = None; } in
+  incr currstamp;
+  r
+
+let anonymous t =
+  match Raw_name.to_string t.raw_name with
+  | None -> true
+  | Some _raw_name -> false
+
+let name t =
+  match Raw_name.to_string t.raw_name with
+  | None -> ""
+  | Some raw_name ->
+    let with_spilled =
+      if t.spill then
+        "spilled-" ^ raw_name
+      else
+        raw_name
+    in
+    match t.part with
+    | None -> with_spilled
+    | Some part -> with_spilled ^ "#" ^ string_of_int part
+
+let first_virtual_reg_stamp = ref (-1)
+
+let reset() =
+  (* When reset() is called for the first time, the current stamp reflects
+     all hard pseudo-registers that have been allocated by Proc, so
+     remember it and use it as the base stamp for allocating
+     soft pseudo-registers *)
+  if !first_virtual_reg_stamp = -1 then first_virtual_reg_stamp := !currstamp;
+  currstamp := !first_virtual_reg_stamp;
+  reg_list := []
+
+let all_registers() = !reg_list
+let num_registers() = !currstamp
+
+let reinit_reg r =
+  r.loc <- Unknown;
+  r.interf <- [];
+  r.prefer <- [];
+  r.degree <- 0;
+  (* Preserve the very high spill costs introduced by the reloading pass *)
+  if r.spill_cost >= 100000
+  then r.spill_cost <- 100000
+  else r.spill_cost <- 0
+
+let reinit() =
+  List.iter reinit_reg !reg_list
+
+module RegOrder =
+  struct
+    type t = reg
+    let compare r1 r2 = r1.stamp - r2.stamp
+  end
+
+module Set = Set.Make(RegOrder)
+module Map = Map.Make(RegOrder)
+
+let add_set_array s v =
+  match Array.length v with
+    0 -> s
+  | 1 -> Set.add v.(0) s
+  | n -> let rec add_all i =
+           if i >= n then s else Set.add v.(i) (add_all(i+1))
+         in add_all 0
+
+let diff_set_array s v =
+  match Array.length v with
+    0 -> s
+  | 1 -> Set.remove v.(0) s
+  | n -> let rec remove_all i =
+           if i >= n then s else Set.remove v.(i) (remove_all(i+1))
+         in remove_all 0
+
+let inter_set_array s v =
+  match Array.length v with
+    0 -> Set.empty
+  | 1 -> if Set.mem v.(0) s
+         then Set.add v.(0) Set.empty
+         else Set.empty
+  | n -> let rec inter_all i =
+           if i >= n then Set.empty
+           else if Set.mem v.(i) s then Set.add v.(i) (inter_all(i+1))
+           else inter_all(i+1)
+         in inter_all 0
+
+let disjoint_set_array s v =
+  match Array.length v with
+    0 -> true
+  | 1 -> not (Set.mem v.(0) s)
+  | n -> let rec disjoint_all i =
+           if i >= n then true
+           else if Set.mem v.(i) s then false
+           else disjoint_all (i+1)
+         in disjoint_all 0
+
+let set_of_array v =
+  match Array.length v with
+    0 -> Set.empty
+  | 1 -> Set.add v.(0) Set.empty
+  | n -> let rec add_all i =
+           if i >= n then Set.empty else Set.add v.(i) (add_all(i+1))
+         in add_all 0
diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli
new file mode 100644
index 00000000..d918f07e
--- /dev/null
+++ b/asmcomp/reg.mli
@@ -0,0 +1,70 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pseudo-registers *)
+
+module Raw_name : sig
+  type t
+  val create_from_ident : Ident.t -> t
+end
+
+type t =
+  { mutable raw_name: Raw_name.t;       (* Name *)
+    stamp: int;                         (* Unique stamp *)
+    mutable typ: Cmm.machtype_component;(* Type of contents *)
+    mutable loc: location;              (* Actual location *)
+    mutable spill: bool;                (* "true" to force stack allocation  *)
+    mutable part: int option;           (* Zero-based index of part of value *)
+    mutable interf: t list;             (* Other regs live simultaneously *)
+    mutable prefer: (t * int) list;     (* Preferences for other regs *)
+    mutable degree: int;                (* Number of other regs live sim. *)
+    mutable spill_cost: int;            (* Estimate of spilling cost *)
+    mutable visited: bool }             (* For graph walks *)
+
+and location =
+    Unknown
+  | Reg of int
+  | Stack of stack_location
+
+and stack_location =
+    Local of int
+  | Incoming of int
+  | Outgoing of int
+
+val dummy: t
+val create: Cmm.machtype_component -> t
+val createv: Cmm.machtype -> t array
+val createv_like: t array -> t array
+val clone: t -> t
+val at_location: Cmm.machtype_component -> location -> t
+
+val anonymous : t -> bool
+
+(* Name for printing *)
+val name : t -> string
+
+module Set: Set.S with type elt = t
+module Map: Map.S with type key = t
+
+val add_set_array: Set.t -> t array -> Set.t
+val diff_set_array: Set.t -> t array -> Set.t
+val inter_set_array: Set.t -> t array -> Set.t
+val disjoint_set_array: Set.t -> t array -> bool
+val set_of_array: t array -> Set.t
+
+val reset: unit -> unit
+val all_registers: unit -> t list
+val num_registers: unit -> int
+val reinit: unit -> unit
diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli
new file mode 100644
index 00000000..f636877b
--- /dev/null
+++ b/asmcomp/reload.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
+
+val fundecl: Mach.fundecl -> Mach.fundecl * bool
diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml
new file mode 100644
index 00000000..3c0b9873
--- /dev/null
+++ b/asmcomp/reloadgen.ml
@@ -0,0 +1,135 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Insert load/stores for pseudoregs that got assigned to stack locations. *)
+
+open Misc
+open Reg
+open Mach
+
+let insert_move src dst next =
+  if src.loc = dst.loc
+  then next
+  else instr_cons (Iop Imove) [|src|] [|dst|] next
+
+let insert_moves src dst next =
+  let rec insmoves i =
+    if i >= Array.length src
+    then next
+    else insert_move src.(i) dst.(i) (insmoves (i+1))
+  in insmoves 0
+
+class reload_generic = object (self)
+
+val mutable redo_regalloc = false
+
+method makereg r =
+  match r.loc with
+    Unknown -> fatal_error "Reload.makereg"
+  | Reg _ -> r
+  | Stack _ ->
+      redo_regalloc <- true;
+      let newr = Reg.clone r in
+      (* Strongly discourage spilling this register *)
+      newr.spill_cost <- 100000;
+      newr
+
+method private makeregs rv =
+  let n = Array.length rv in
+  let newv = Array.make n Reg.dummy in
+  for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done;
+  newv
+
+method private makereg1 rv =
+  let newv = Array.copy rv in
+  newv.(0) <- self#makereg rv.(0);
+  newv
+
+method reload_operation op arg res =
+  (* By default, assume that arguments and results must reside
+     in hardware registers. For moves, allow one arg or one
+     res to be stack-allocated, but do something for
+     stack-to-stack moves *)
+  match op with
+    Imove | Ireload | Ispill ->
+      begin match arg.(0), res.(0) with
+        {loc = Stack s1}, {loc = Stack s2} when s1 <> s2 ->
+          ([| self#makereg arg.(0) |], res)
+      | _ ->
+          (arg, res)
+      end
+  | _ ->
+      (self#makeregs arg, self#makeregs res)
+
+method reload_test _tst args =
+  self#makeregs args
+
+method private reload i =
+  match i.desc with
+    (* For function calls, returns, etc: the arguments and results are
+       already at the correct position (e.g. on stack for some arguments).
+       However, something needs to be done for the function pointer in
+       indirect calls. *)
+    Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i
+  | Iop(Itailcall_ind _) ->
+      let newarg = self#makereg1 i.arg in
+      insert_moves i.arg newarg
+        {i with arg = newarg}
+  | Iop(Icall_imm _ | Iextcall _) ->
+      {i with next = self#reload i.next}
+  | Iop(Icall_ind _) ->
+      let newarg = self#makereg1 i.arg in
+      insert_moves i.arg newarg
+        {i with arg = newarg; next = self#reload i.next}
+  | Iop op ->
+      let (newarg, newres) = self#reload_operation op i.arg i.res in
+      insert_moves i.arg newarg
+        {i with arg = newarg; res = newres; next =
+          (insert_moves newres i.res
+            (self#reload i.next))}
+  | Iifthenelse(tst, ifso, ifnot) ->
+      let newarg = self#reload_test tst i.arg in
+      insert_moves i.arg newarg
+        (instr_cons
+          (Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||]
+          (self#reload i.next))
+  | Iswitch(index, cases) ->
+      let newarg = self#makeregs i.arg in
+      insert_moves i.arg newarg
+        (instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||]
+          (self#reload i.next))
+  | Iloop body ->
+      instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next)
+  | Icatch(rec_flag, handlers, body) ->
+      let new_handlers = List.map
+          (fun (nfail, handler) -> nfail, self#reload handler)
+          handlers in
+      instr_cons
+        (Icatch(rec_flag, new_handlers, self#reload body)) [||] [||]
+        (self#reload i.next)
+  | Iexit i ->
+      instr_cons (Iexit i) [||] [||] dummy_instr
+  | Itrywith(body, handler) ->
+      instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||]
+        (self#reload i.next)
+
+method fundecl f =
+  redo_regalloc <- false;
+  let new_body = self#reload f.fun_body in
+  ({fun_name = f.fun_name; fun_args = f.fun_args;
+    fun_body = new_body; fun_fast = f.fun_fast;
+    fun_dbg  = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape},
+   redo_regalloc)
+end
diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli
new file mode 100644
index 00000000..75e870fb
--- /dev/null
+++ b/asmcomp/reloadgen.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+class reload_generic : object
+  method reload_operation :
+    Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array
+  method reload_test : Mach.test -> Reg.t array -> Reg.t array
+    (* Can be overridden to reflect instructions that can operate
+       directly on stack locations *)
+  method makereg : Reg.t -> Reg.t
+    (* Can be overridden to avoid creating new registers of some class
+       (i.e. if all "registers" of that class are actually on stack) *)
+  method fundecl : Mach.fundecl -> Mach.fundecl * bool
+    (* The entry point *)
+end
diff --git a/asmcomp/s390x/CSE.ml b/asmcomp/s390x/CSE.ml
new file mode 100644
index 00000000..360a4f13
--- /dev/null
+++ b/asmcomp/s390x/CSE.ml
@@ -0,0 +1,42 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt            *)
+(*                          Bill O'Farrell, IBM                           *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini).    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for the Z Processor *)
+
+open Arch
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic as super
+
+method! class_of_operation op =
+  match op with
+  | Ispecific(Imultaddf | Imultsubf) -> Op_pure
+  | _ -> super#class_of_operation op
+
+method! is_cheap_operation op =
+  match op with
+  | Iconst_int n ->
+      n >= -0x8000_0000n && n <= 0x7FFF_FFFFn
+  | _ -> false
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/s390x/NOTES.md b/asmcomp/s390x/NOTES.md
new file mode 100644
index 00000000..679e77f2
--- /dev/null
+++ b/asmcomp/s390x/NOTES.md
@@ -0,0 +1,16 @@
+# Supported platforms
+
+IBM z Systems version 10 and up, in 64-bit flat addressing mode,
+running Linux (Debian architecture: `s390x`).
+
+# Reference documents
+
+* Instruction set architecture:
+   _z/Architecture Principles of Operation_,
+   SA22-7832-07, eight edition (Feb 2009).
+   This is the version that corresponds to z10.
+   Newer versions of this manual include additional instructions
+   that are not in z10.
+* ELF ABI:
+   _zSeries ELF Application Binary Interface Supplement_
+   (http://refspecs.linuxfoundation.org/ELF/zSeries/index.html)
diff --git a/asmcomp/s390x/arch.ml b/asmcomp/s390x/arch.ml
new file mode 100644
index 00000000..84d52d64
--- /dev/null
+++ b/asmcomp/s390x/arch.ml
@@ -0,0 +1,91 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt            *)
+(*                          Bill O'Farrell, IBM                           *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini).    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Specific operations for the Z processor *)
+
+open Format
+
+(* Machine-specific command-line options *)
+
+let pic_code = ref true
+
+let command_line_options =
+  [ "-fPIC", Arg.Set pic_code,
+      " Generate position-independent machine code (default)";
+    "-fno-PIC", Arg.Clear pic_code,
+      " Generate position-dependent machine code" ]
+
+(* Specific operations *)
+
+type specific_operation =
+    Imultaddf                           (* multiply and add *)
+  | Imultsubf                           (* multiply and subtract *)
+
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
+(* Addressing modes *)
+
+type addressing_mode =
+  | Iindexed of int                     (* reg + displ *)
+  | Iindexed2 of int                    (* reg + reg + displ *)
+
+(* Sizes, endianness *)
+
+let big_endian = true
+
+let size_addr = 8
+let size_int = size_addr
+let size_float = 8
+
+let allow_unaligned_access = false
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = true
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+  | Iindexed n -> Iindexed(n + delta)
+  | Iindexed2 n -> Iindexed2(n + delta)
+
+let num_args_addressing = function
+  | Iindexed _ -> 1
+  | Iindexed2 _ -> 2
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Iindexed n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a%s" printreg arg.(0) idx
+  | Iindexed2 n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx
+
+let print_specific_operation printreg op ppf arg =
+  match op with
+  | Imultaddf ->
+      fprintf ppf "%a *f %a +f %a"
+        printreg arg.(0) printreg arg.(1) printreg arg.(2)
+  | Imultsubf ->
+      fprintf ppf "%a *f %a -f %a"
+        printreg arg.(0) printreg arg.(1) printreg arg.(2)
diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp
new file mode 100644
index 00000000..0579bfd4
--- /dev/null
+++ b/asmcomp/s390x/emit.mlp
@@ -0,0 +1,759 @@
+#2 "asmcomp/s390x/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of Linux on Z 64-bit assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Layout of the stack.  The stack is kept 8-aligned. *)
+
+let stack_offset = ref 0
+
+let frame_size () =
+  let size =
+    !stack_offset +                     (* Trap frame, outgoing parameters *)
+    size_int * num_stack_slots.(0) +    (* Local int variables *)
+    size_float * num_stack_slots.(1) +  (* Local float variables *)
+    (if !contains_calls then size_addr else 0) in (* The return address *)
+  Misc.align size 8
+
+let slot_offset loc cls =
+  match loc with
+    Local n ->
+      if cls = 0
+      then !stack_offset + num_stack_slots.(1) * size_float + n * size_int
+      else !stack_offset + n * size_float
+  | Incoming n -> frame_size() + n
+  | Outgoing n -> n
+
+(* Output a symbol *)
+
+let emit_symbol s = Emitaux.emit_symbol '.' s
+
+(* Output function call *)
+
+let emit_call s =
+  if !pic_code then
+   `	brasl	%r14, {emit_symbol s}@PLT\n`
+  else
+   `	brasl	%r14, {emit_symbol s}\n`
+
+(* Output a label *)
+
+let label_prefix = ".L"
+
+let emit_label lbl =
+  emit_string label_prefix; emit_int lbl
+
+(* Section switching *)
+
+let data_space = "	.section \".data\"\n"
+
+let code_space = "	.section \".text\"\n"
+
+let rodata_space = "	.section \".rodata\"\n"
+
+(* Output a pseudo-register *)
+
+let emit_reg r =
+  match r.loc with
+  | Reg r -> emit_string (register_name r)
+  | _ -> fatal_error "Emit.emit_reg"
+
+
+(* Special registers *)
+
+let check_phys_reg reg_idx name =
+  let reg = phys_reg reg_idx in
+  assert (register_name reg_idx = name);
+  reg
+
+let reg_f15 = check_phys_reg 115 "%f15"
+let reg_r7 = check_phys_reg 5 "%r7"
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+    Stack s ->
+      let ofs = slot_offset s (register_class r) in `{emit_int ofs}(%r15)`
+  | _ -> fatal_error "Emit.emit_stack"
+
+
+(* Output a load of the address of a global symbol *)
+
+let emit_load_symbol_addr reg s =
+  if !pic_code then
+  `	lgrl	{emit_reg reg}, {emit_symbol s}@GOTENT\n`
+  else
+  `	larl	{emit_reg reg}, {emit_symbol s}\n`
+
+(* Output a load or store operation *)
+
+let emit_load_store instr addressing_mode addr n arg =
+  match addressing_mode with
+  | Iindexed ofs ->
+      `	{emit_string instr}	{emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n`
+  | Iindexed2 ofs ->
+      `	{emit_string instr}	{emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)},{emit_reg addr.(n+1)})\n`
+
+(* Adjust the stack pointer down by N.
+   Choose the shortest instruction possible for the value of N. *)
+
+let emit_stack_adjust n =
+  let n = -n in
+  if n = 0 then ()
+  else if n >= 0 && n < 4096 then
+    `	la	%r15, {emit_int n}(%r15)\n`
+  else if n >= -0x80000 && n < 0x80000 then
+    `	lay	%r15, {emit_int n}(%r15)\n`
+  else
+    `	agfi	%r15, {emit_int n}\n`
+
+(* Emit a 'add immediate' *)
+
+let emit_addimm res arg n =
+  if n >= 0 && n < 4096 then
+    `	la	{emit_reg res}, {emit_int n}({emit_reg arg})\n`
+  else if n >= -0x80000 && n < 0x80000 then
+    `	lay	{emit_reg res}, {emit_int n}({emit_reg arg})\n`
+  else begin
+    if arg.loc <> res.loc then
+      `	lgr	{emit_reg res}, {emit_reg arg}\n`;
+    `	agfi	{emit_reg res}, {emit_int n}\n`
+  end
+
+(* After a comparison, extract the result as 0 or 1 *)
+(* The locgr instruction is not available in the z10 architecture,
+   so this code is currently unused. *)
+(*
+let emit_set_comp cmp res =
+    `	lghi	%r1, 1\n`;
+    `	lghi	{emit_reg res}, 0\n`;
+  begin match cmp with
+      Ceq -> `	locgre	{emit_reg res}, %r1\n`
+    | Cne -> `	locgrne	{emit_reg res}, %r1\n`
+    | Cgt -> `	locgrh	{emit_reg res}, %r1\n`
+    | Cle -> `	locgrnh	{emit_reg res}, %r1\n`
+    | Clt -> `	locgrl	{emit_reg res}, %r1\n`
+    | Cge -> `	locgrnl	{emit_reg res}, %r1\n`
+  end
+*)
+
+(* Record live pointers at call points *)
+
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := (r lsl 1) + 1 :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ())
+    live;
+  record_frame_descr ~label:lbl ~frame_size:(frame_size())
+    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+  lbl
+
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in
+  `{emit_label lbl}:`
+
+(* Record calls to caml_call_gc, emitted out of line. *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_frame_lbl: label }               (* Label of frame descriptor *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  `{emit_label gc.gc_lbl}:`; emit_call "caml_call_gc";
+  `{emit_label gc.gc_frame_lbl}:	brcl	15, {emit_label gc.gc_return_lbl}\n`
+
+(* Record calls to caml_ml_array_bound_error, emitted out of line. *)
+
+type bound_error_call =
+  { bd_lbl: label;                      (* Entry label *)
+    bd_frame: label }                   (* Label of frame descriptor *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+let bound_error_call = ref 0
+
+let bound_error_label ?label dbg =
+  if !Clflags.debug then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    bound_error_sites :=
+     { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
+   lbl_bound_error
+ end else begin
+   if !bound_error_call = 0 then bound_error_call := new_label();
+   !bound_error_call
+ end
+
+let emit_call_bound_error bd =
+  `{emit_label bd.bd_lbl}:`; emit_call "caml_ml_array_bound_error";
+  `{emit_label bd.bd_frame}:\n`
+
+let emit_call_bound_errors () =
+  List.iter emit_call_bound_error !bound_error_sites;
+  if !bound_error_call > 0 then begin
+    `{emit_label !bound_error_call}:`; emit_call "caml_ml_array_bound_error";
+  end
+
+(* Record floating-point and large integer literals *)
+
+let float_literals = ref ([] : (int64 * int) list)
+let int_literals = ref ([] : (nativeint * int) list)
+
+(* Masks for conditional branches after comparisons *)
+
+let branch_for_comparison = function
+    Ceq -> 8  | Cne -> 7
+  | Cle -> 12 | Cgt -> 2
+  | Cge -> 10 | Clt -> 4
+
+let name_for_int_comparison = function
+    Isigned cmp -> ("cgr", branch_for_comparison cmp)
+  | Iunsigned cmp -> ("clgr", branch_for_comparison cmp)
+
+let name_for_int_comparison_imm = function
+    Isigned cmp -> ("cgfi", branch_for_comparison cmp)
+  | Iunsigned cmp -> ("clgfi", branch_for_comparison cmp)
+
+(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = unordered*)
+let branch_for_float_comparison cmp neg =
+   match cmp with
+     Ceq -> if neg then 7  else 8
+   | Cne -> if neg then 8  else 7
+   | Cle -> if neg then 3  else 12
+   | Cgt -> if neg then 13 else 2
+   | Cge -> if neg then 5  else 10
+   | Clt -> if neg then 11 else 4
+
+(* Names for various instructions *)
+
+let name_for_intop = function
+    Iadd  -> "agr"
+  | Isub  -> "sgr"
+  | Imul  -> "msgr"
+  | Iand  -> "ngr"
+  | Ior   -> "ogr"
+  | Ixor  -> "xgr"
+  | _ -> Misc.fatal_error "Emit.Intop"
+
+let name_for_floatop1 = function
+    Inegf -> "lcdbr"
+  | Iabsf -> "lpdbr"
+  | _ -> Misc.fatal_error "Emit.Iopf1"
+
+let name_for_floatop2 = function
+    Iaddf -> "adbr"
+  | Isubf -> "sdbr"
+  | Imulf -> "mdbr"
+  | Idivf -> "ddbr"
+  | _ -> Misc.fatal_error "Emit.Iopf2"
+
+let name_for_specific = function
+    Imultaddf -> "madbr"
+  | Imultsubf -> "msdbr"
+
+(* Name of current function *)
+let function_name = ref ""
+(* Entry point for tail recursive calls *)
+let tailrec_entry_point = ref 0
+
+(* Output the assembly code for an instruction *)
+
+let emit_instr i =
+    emit_debug_info i.dbg;
+    match i.desc with
+      Lend -> ()
+    | Lop(Imove | Ispill | Ireload) ->
+        let src = i.arg.(0) and dst = i.res.(0) in
+        if src.loc <> dst.loc then begin
+           match (src, dst) with
+              {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
+                `	lgr	{emit_reg dst}, {emit_reg src}\n`
+            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
+                `	ldr	{emit_reg dst}, {emit_reg src}\n`
+            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
+                `	stg	{emit_reg src}, {emit_stack dst}\n`
+            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
+                `	std	{emit_reg src}, {emit_stack dst}\n`
+            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
+                `	lg	{emit_reg dst}, {emit_stack src}\n`
+            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
+                `	ldy	{emit_reg dst}, {emit_stack src}\n`
+            | (_, _) ->
+                fatal_error "Emit: Imove"
+        end
+    | Lop(Iconst_int n) ->
+        if n >= -0x8000n && n <= 0x7FFFn then begin
+          `	lghi	{emit_reg i.res.(0)}, {emit_nativeint n}\n`;
+        end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin
+          `	lgfi	{emit_reg i.res.(0)}, {emit_nativeint n}\n`;
+        end else begin
+          let lbl = new_label() in
+          int_literals := (n, lbl) :: !int_literals;
+          `	lgrl	{emit_reg i.res.(0)}, {emit_label lbl}\n`;
+          end
+    | Lop(Iconst_float f) ->
+        let lbl = new_label() in
+        float_literals := (f, lbl) :: !float_literals;
+        `	larl	%r1, {emit_label lbl}\n`;
+        `	ld	{emit_reg i.res.(0)}, 0(%r1)\n`
+     | Lop(Iconst_symbol s) ->
+        emit_load_symbol_addr i.res.(0) s
+    | Lop(Icall_ind { label_after; }) ->
+        `	basr	%r14, {emit_reg i.arg.(0)}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+
+    | Lop(Icall_imm { func; label_after; }) ->
+        emit_call func;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+    | Lop(Itailcall_ind { label_after = _; }) ->
+        let n = frame_size() in
+        if !contains_calls then
+          `	lg	%r14, {emit_int(n - size_addr)}(%r15)\n`;
+        emit_stack_adjust (-n);
+        `	br	{emit_reg i.arg.(0)}\n`
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then
+          `	brcl	15, {emit_label !tailrec_entry_point}\n`
+        else begin
+          let n = frame_size() in
+          if !contains_calls then
+            `	lg	%r14, {emit_int(n - size_addr)}(%r15)\n`;
+          emit_stack_adjust (-n);
+          if !pic_code then
+            `	brcl	15, {emit_symbol func}@PLT\n`
+          else
+            `	brcl	15, {emit_symbol func}\n`
+        end
+
+     | Lop(Iextcall { func; alloc; label_after; }) ->
+        if not alloc then emit_call func
+        else begin
+          emit_load_symbol_addr reg_r7 func;
+          emit_call "caml_c_call";
+          `{record_frame i.live false i.dbg ~label:label_after}\n`
+        end
+
+     | Lop(Istackoffset n) ->
+        emit_stack_adjust n;
+        stack_offset := !stack_offset + n
+
+     | Lop(Iload(chunk, addr)) ->
+        let loadinstr =
+          match chunk with
+            Byte_unsigned -> "llgc"
+          | Byte_signed -> "lgb"
+          | Sixteen_unsigned -> "llgh"
+          | Sixteen_signed -> "lgh"
+          | Thirtytwo_unsigned -> "llgf"
+          | Thirtytwo_signed -> "lgf"
+          | Word_int | Word_val -> "lg"
+          | Single -> "ley"
+          | Double | Double_u -> "ldy" in
+        emit_load_store loadinstr addr i.arg 0 i.res.(0);
+        if chunk = Single then
+          `	ldebr	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
+
+    | Lop(Istore(Single, addr, _)) ->
+        `	ledbr	%f15, {emit_reg i.arg.(0)}\n`;
+        emit_load_store "stey" addr i.arg 1 reg_f15
+    | Lop(Istore(chunk, addr, _)) ->
+        let storeinstr =
+          match chunk with
+            Byte_unsigned | Byte_signed -> "stcy"
+          | Sixteen_unsigned | Sixteen_signed -> "sthy"
+          | Thirtytwo_unsigned | Thirtytwo_signed -> "sty"
+          | Word_int | Word_val -> "stg"
+          | Single -> assert false
+          | Double | Double_u -> "stdy" in
+        emit_load_store storeinstr addr i.arg 1 i.arg.(0)
+
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        let lbl_redo = new_label() in
+        let lbl_call_gc = new_label() in
+        let lbl_frame =
+          record_frame_label i.live false i.dbg ?label:label_after_call_gc
+        in
+        call_gc_sites :=
+          { gc_lbl = lbl_call_gc;
+            gc_return_lbl = lbl_redo;
+            gc_frame_lbl = lbl_frame } :: !call_gc_sites;
+        `{emit_label lbl_redo}:`;
+        `	lay	%r11, {emit_int(-n)}(%r11)\n`;
+        `	clgr	%r11, %r10\n`;
+        `	brcl	4, {emit_label lbl_call_gc}\n`;  (* less than *)
+        `	la	{emit_reg i.res.(0)}, 8(%r11)\n`
+
+    | Lop(Iintop Imulh) ->
+       (* Hacker's Delight section 8.3:
+            mul-high-signed(a, b) = mul-high-unsigned(a, b)
+                                    - a  if b < 0
+                                    - b  if a < 0
+          or, without branches,
+            mul-high-signed(a, b) = mul-high-unsigned(a, b)
+                                    - (a & (b >>s 63))
+                                    - (b & (a >>s 63))
+       *)
+       `	lgr	%r1, {emit_reg i.arg.(0)}\n`;
+       `	mlgr	%r0, {emit_reg i.arg.(1)}\n`;
+         (* r0:r1 is 128-bit unsigned product; r0 is the high bits *)
+       `	srag	%r1, {emit_reg i.arg.(0)}, 63\n`;
+       `	ngr	%r1, {emit_reg i.arg.(1)}\n`;
+       `	sgr	%r0, %r1\n`;
+       `	srag	%r1, {emit_reg i.arg.(1)}, 63\n`;
+       `	ngr	%r1, {emit_reg i.arg.(0)}\n`;
+       `	sgr	%r0, %r1\n`;
+       `	lgr	{emit_reg i.res.(0)}, %r0\n`
+    | Lop(Iintop Imod) ->
+        `	lgr	%r1, {emit_reg i.arg.(0)}\n`;
+        `	dsgr	%r0, {emit_reg i.arg.(1)}\n`;
+        `	lgr	{emit_reg i.res.(0)}, %r0\n`
+    | Lop(Iintop Idiv) ->
+        `	lgr	%r1, {emit_reg i.arg.(0)}\n`;
+        `	dsgr	%r0, {emit_reg i.arg.(1)}\n`;
+        `	lgr	{emit_reg i.res.(0)}, %r1\n`
+    | Lop(Iintop Ilsl) ->
+        `	sllg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n`
+    | Lop(Iintop Ilsr) ->
+        `	srlg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n`
+    | Lop(Iintop Iasr) ->
+        `	srag	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n`
+    | Lop(Iintop(Icomp cmp)) ->
+        let lbl = new_label() in
+        let (comp, mask) = name_for_int_comparison cmp in
+        `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	lghi	{emit_reg i.res.(0)}, 1\n`;
+        `	brc	{emit_int mask}, {emit_label lbl}\n`;
+        `	lghi	{emit_reg i.res.(0)}, 0\n`;
+        `{emit_label lbl}:\n`
+    | Lop(Iintop (Icheckbound { label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
+        `	clgr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	brcl	12, {emit_label lbl}\n`  (* branch if unsigned le *)
+    | Lop(Iintop op) ->
+        assert (i.arg.(0).loc = i.res.(0).loc);
+        let instr = name_for_intop op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop(Iintop_imm(Iadd, n)) ->
+        emit_addimm i.res.(0) i.arg.(0) n
+    | Lop(Iintop_imm(Isub, n)) ->
+        emit_addimm i.res.(0) i.arg.(0) (-n)
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        let lbl = new_label() in
+        let (comp, mask) = name_for_int_comparison_imm cmp in
+        `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+        `	lghi	{emit_reg i.res.(0)}, 1\n`;
+        `	brc	{emit_int mask}, {emit_label lbl}\n`;
+        `	lghi	{emit_reg i.res.(0)}, 0\n`;
+        `{emit_label lbl}:\n`
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+       let lbl = bound_error_label i.dbg ?label:label_after_error in
+       if n >= 0 then begin
+        `	clgfi	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+        `	brcl	12, {emit_label lbl}\n`  (* branch if unsigned le *)
+       end else begin
+        `	brcl	15, {emit_label lbl}\n`  (* branch always *)
+       end
+    | Lop(Iintop_imm(Ilsl, n)) ->
+        `	sllg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
+    | Lop(Iintop_imm(Ilsr, n)) ->
+        `	srlg	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
+    | Lop(Iintop_imm(Iasr, n)) ->
+        `	srag	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
+    | Lop(Iintop_imm(Iand, n)) ->
+        assert (i.arg.(0).loc = i.res.(0).loc);
+        `	nilf	{emit_reg i.res.(0)}, {emit_int (n land (1 lsl 32 - 1)(*0xFFFF_FFFF*))}\n`
+    | Lop(Iintop_imm(Ior, n)) ->
+        assert (i.arg.(0).loc = i.res.(0).loc);
+        `	oilf	{emit_reg i.res.(0)}, {emit_int n}\n`
+    | Lop(Iintop_imm(Ixor, n)) ->
+        assert (i.arg.(0).loc = i.res.(0).loc);
+        `	xilf	{emit_reg i.res.(0)}, {emit_int n}\n`
+    | Lop(Iintop_imm(Imul, n)) ->
+        assert (i.arg.(0).loc = i.res.(0).loc);
+          `	msgfi	{emit_reg i.res.(0)}, {emit_int n}\n`
+    | Lop(Iintop_imm((Imulh | Idiv | Imod), _)) ->
+        assert false
+    | Lop(Inegf | Iabsf as op) ->
+        let instr = name_for_floatop1 op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
+        assert (i.arg.(0).loc = i.res.(0).loc);
+        let instr = name_for_floatop2 op in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`;
+    | Lop(Ifloatofint) ->
+          `	cdgbr	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
+    | Lop(Iintoffloat) ->
+        (* rounding method #5 = round toward 0 *)
+        `	cgdbr	{emit_reg i.res.(0)}, 5, {emit_reg i.arg.(0)}\n`
+    | Lop(Ispecific sop) ->
+        assert (i.arg.(2).loc = i.res.(0).loc);
+        let instr = name_for_specific sop in
+        `	{emit_string instr}	{emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lreloadretaddr ->
+        let n = frame_size() in
+        `	lg	%r14, {emit_int(n - size_addr)}(%r15)\n`
+    | Lreturn ->
+        let n = frame_size() in
+        emit_stack_adjust (-n);
+        `	br	%r14\n`
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`
+    | Lbranch lbl ->
+        `	brcl	15,{emit_label lbl}\n`
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+          Itruetest ->
+            `	cgfi	{emit_reg i.arg.(0)}, 0\n`;
+            `	brcl	7, {emit_label lbl}\n`
+        | Ifalsetest ->
+            `	cgfi	{emit_reg i.arg.(0)}, 0\n`;
+            `	brcl	8, {emit_label lbl}\n`
+        | Iinttest cmp ->
+            let (comp, mask) = name_for_int_comparison cmp in
+            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `	brcl	{emit_int mask}, {emit_label lbl}\n`
+        | Iinttest_imm(cmp, n) ->
+            let (comp, mask) = name_for_int_comparison_imm cmp in
+            `	{emit_string comp}	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+            `	brcl	{emit_int mask}, {emit_label lbl}\n`
+        | Ifloattest(cmp, neg) ->
+            `	cdbr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            let mask = branch_for_float_comparison cmp neg in
+            `	brcl	{emit_int mask}, {emit_label lbl}\n`
+        | Ioddtest ->
+            `	tmll	{emit_reg i.arg.(0)}, 1\n`;
+            `	brcl	1, {emit_label lbl}\n`
+        | Ieventest ->
+            `	tmll	{emit_reg i.arg.(0)}, 1\n`;
+            `	brcl	8, {emit_label lbl}\n`
+        end
+    | Lcondbranch3(lbl0, lbl1, lbl2) ->
+        `	cgfi	{emit_reg i.arg.(0)}, 1\n`;
+        begin match lbl0 with
+          None -> ()
+        | Some lbl -> `	brcl	4, {emit_label lbl}\n`
+        end;
+        begin match lbl1 with
+          None -> ()
+        | Some lbl -> `	brcl	8, {emit_label lbl}\n`
+        end;
+        begin match lbl2 with
+          None -> ()
+        | Some lbl -> `	brcl	2, {emit_label lbl}\n`
+        end
+    | Lswitch jumptbl ->
+        let lbl = new_label() in
+        `	larl	%r0, {emit_label lbl}\n`;
+        `	sllg	%r1, {emit_reg i.arg.(0)}, 2(%r0)\n`;
+        `	agr	%r1, %r0\n`;
+        `	lgf	%r1, 0(%r1)\n`;
+        `	agr	%r1, %r0\n`;
+        `	br	%r1\n`;
+        emit_string rodata_space;
+        `	.align	8\n`;
+        `{emit_label lbl}:`;
+        for i = 0 to Array.length jumptbl - 1 do
+          `	.long	{emit_label jumptbl.(i)} - {emit_label lbl}\n`
+        done;
+        emit_string code_space
+    | Lsetuptrap lbl ->
+        `	brasl	%r14, {emit_label lbl}\n`;
+    | Lpushtrap ->
+        stack_offset := !stack_offset + 16;
+        emit_stack_adjust 16;
+        `	stg	%r14, 0(%r15)\n`;
+        `	stg	%r13, {emit_int size_addr}(%r15)\n`;
+        `	lgr	%r13, %r15\n`
+    | Lpoptrap ->
+        `	lg	%r13, {emit_int size_addr}(%r15)\n`;
+        emit_stack_adjust (-16);
+        stack_offset := !stack_offset - 16
+    | Lraise k ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
+          emit_call "caml_raise_exn";
+          `{record_frame Reg.Set.empty true i.dbg}\n`
+        | Cmm.Raise_notrace ->
+          `	lg	%r1, 0(%r13)\n`;
+          `	lgr	%r15, %r13\n`;
+          `	lg	%r13, {emit_int size_addr}(%r15)\n`;
+          emit_stack_adjust (-16);
+          `	br	%r1\n`
+        end
+
+
+(* Emit a sequence of instructions *)
+
+let rec emit_all i =
+  match i with
+    {desc = Lend} -> ()
+  | _ ->
+      emit_instr i;
+      emit_all i.next
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  tailrec_entry_point := new_label();
+  stack_offset := 0;
+  call_gc_sites := [];
+  bound_error_sites := [];
+  bound_error_call := 0;
+  float_literals := [];
+  int_literals := [];
+  `	.globl	{emit_symbol fundecl.fun_name}\n`;
+  emit_debug_info fundecl.fun_dbg;
+  `	.type	{emit_symbol fundecl.fun_name}, @function\n`;
+  emit_string code_space;
+  `	.align	8\n`;
+  `{emit_symbol fundecl.fun_name}:\n`;
+  let n = frame_size() in
+  emit_stack_adjust n;
+  if !contains_calls then
+    `	stg	%r14, {emit_int(n - size_addr)}(%r15)\n`;
+  `{emit_label !tailrec_entry_point}:\n`;
+  emit_all fundecl.fun_body;
+  (* Emit the glue code to call the GC *)
+  List.iter emit_call_gc !call_gc_sites;
+  (* Emit the glue code to handle bound errors *)
+  emit_call_bound_errors();
+  (* Emit the numeric literals *)
+  if !float_literals <> [] || !int_literals <> [] then begin
+    emit_string rodata_space;
+    `	.align	8\n`;
+    List.iter
+      (fun (f, lbl) ->
+        `{emit_label lbl}:`;
+        emit_float64_directive ".quad" f)
+      !float_literals;
+    List.iter
+      (fun (n, lbl) ->
+        `{emit_label lbl}:	.quad	{emit_nativeint n}\n`)
+      !int_literals
+  end
+
+(* Emission of data *)
+
+let declare_global_data s =
+  `	.globl	{emit_symbol s}\n`;
+  `	.type	{emit_symbol s}, @object\n`
+
+let emit_item = function
+    Cglobal_symbol s ->
+      declare_global_data s
+  | Cdefine_symbol s ->
+      `{emit_symbol s}:\n`;
+  | Cint8 n ->
+      `	.byte	{emit_int n}\n`
+  | Cint16 n ->
+      `	.short	{emit_int n}\n`
+  | Cint32 n ->
+      `	.long	{emit_nativeint n}\n`
+  | Cint n ->
+      `	.quad	{emit_nativeint n}\n`
+  | Csingle f ->
+      emit_float32_directive ".long" (Int32.bits_of_float f)
+  | Cdouble f ->
+      emit_float64_directive ".quad" (Int64.bits_of_float f)
+  | Csymbol_address s ->
+      `	.quad	{emit_symbol s}\n`
+  | Cstring s ->
+      emit_bytes_directive "	.byte	" s
+  | Cskip n ->
+      if n > 0 then `	.space	{emit_int n}\n`
+  | Calign n ->
+      if n < 8 then `	.align	8\n`
+               else `	.align	{emit_int n}\n`
+
+let data l =
+  emit_string data_space;
+  `	.align	8\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  reset_debug_info();
+  `	.file	\"\"\n`;  (* PR#7037 *)
+  (* Emit the beginning of the segments *)
+  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
+  emit_string data_space;
+  `	.align	8\n`;
+  declare_global_data lbl_begin;
+  `{emit_symbol lbl_begin}:\n`;
+  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
+  emit_string code_space;
+  declare_global_data lbl_begin;
+  `{emit_symbol lbl_begin}:\n`
+
+let end_assembly() =
+  (* Emit the end of the segments *)
+  emit_string code_space;
+  let lbl_end = Compilenv.make_symbol (Some "code_end") in
+  declare_global_data lbl_end;
+  `{emit_symbol lbl_end}:\n`;
+  `	.long	0\n`;
+  emit_string data_space;
+  `	.align	8\n`;
+  let lbl_end = Compilenv.make_symbol (Some "data_end") in
+  declare_global_data lbl_end;
+  `{emit_symbol lbl_end}:\n`;
+  `	.quad	0\n`;
+  (* Emit the frame descriptors *)
+  emit_string rodata_space;
+  `	.align	8\n`;
+  let lbl = Compilenv.make_symbol (Some "frametable") in
+  declare_global_data lbl;
+  `{emit_symbol lbl}:\n`;
+  emit_frames
+    { efa_code_label = (fun l -> `	.quad	{emit_label l}\n`);
+      efa_data_label = (fun l -> `	.quad	{emit_label l}\n`);
+      efa_16 = (fun n -> `	.short	{emit_int n}\n`);
+      efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
+      efa_word = (fun n -> `	.quad	{emit_int n}\n`);
+      efa_align = (fun n -> `	.align	{emit_int n}\n`);
+      efa_label_rel = (fun lbl ofs ->
+                           `	.long	({emit_label lbl} - .) + {emit_int32 ofs}\n`);
+      efa_def_label = (fun l -> `{emit_label l}:\n`);
+      efa_string = (fun s -> emit_bytes_directive "	.byte	" (s ^ "\000"))
+     };
+   (* Mark stack as non-executable *)
+   `	.section .note.GNU-stack,\"\",%progbits\n`
diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml
new file mode 100644
index 00000000..a8bd2cbf
--- /dev/null
+++ b/asmcomp/s390x/proc.ml
@@ -0,0 +1,214 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt            *)
+(*                          Bill O'Farrell, IBM                           *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini).    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the Z Processor *)
+
+open Misc
+open Cmm
+open Reg
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Registers available for register allocation *)
+
+(* Integer register map:
+    0                   temporary, null register for some operations (volatile)
+    1                   temporary (volatile)
+    2 - 5               function arguments and results (volatile)
+    6                   function arguments and results (persevered by C)
+    7 - 9               general purpose, preserved by C
+    10                  allocation limit (preserved by C)
+    11                  allocation pointer (preserved by C)
+    12                  general purpose  (preserved by C)
+    13                  trap pointer (preserved by C)
+    14                  return address (volatile)
+    15                  stack pointer (preserved by C)
+  Floating-point register map:
+    0, 2, 4, 6          function arguments and results (volatile)
+    1, 3, 5, 7          general purpose (volatile)
+    8 - 14              general purpose, preserved by C
+    15                  temporary, preserved by C
+
+Note: integer register r12 is used as GOT pointer by some C compilers.
+The code generated by OCaml does not need a GOT pointer, using PC-relative
+addressing instead for accessing the GOT.  This frees r12 as a
+general-purpose register. *)
+
+let int_reg_name =
+    [| "%r2"; "%r3"; "%r4"; "%r5"; "%r6"; "%r7"; "%r8"; "%r9"; "%r12" |]
+
+let float_reg_name =
+    [| "%f0"; "%f2"; "%f4"; "%f6"; "%f1"; "%f3"; "%f5"; "%f7";
+       "%f8"; "%f9"; "%f10"; "%f11"; "%f12"; "%f13"; "%f14"; "%f15" |]
+
+let num_register_classes = 2
+
+let register_class r =
+  match r.typ with
+  | Val | Int | Addr -> 0
+  | Float -> 1
+
+let num_available_registers = [| 9; 15 |]
+
+let first_available_register = [| 0; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+let rotate_registers = true
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 9 Reg.dummy in
+  for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v
+
+let hard_float_reg =
+  let v = Array.make 16 Reg.dummy in
+  for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v
+
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
+(* Calling conventions *)
+
+let calling_conventions
+    first_int last_int first_float last_float make_stack stack_ofs arg =
+  let loc = Array.make (Array.length arg) Reg.dummy in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref stack_ofs in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+    | Val | Int | Addr as ty ->
+        if !int <= last_int then begin
+          loc.(i) <- phys_reg !int;
+          incr int
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !float <= last_float then begin
+          loc.(i) <- phys_reg !float;
+          incr float
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align !ofs 16)
+  (* Keep stack 16-aligned. *)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+let max_arguments_for_tailcalls = 5
+
+let loc_arguments arg =
+  calling_conventions 0 4 100 103 outgoing 0 arg
+let loc_parameters arg =
+  let (loc, _ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc
+let loc_results res =
+  let (loc, _ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc
+
+(*   C calling conventions under SVR4:
+     use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions.
+     Using a float register does not affect the int registers.
+     Always reserve 160 bytes at bottom of stack, plus whatever is needed
+     to hold the overflow arguments. *)
+
+let loc_external_arguments arg =
+  let arg =
+    Array.map (fun regs -> assert (Array.length regs = 1); regs.(0)) arg in
+  let (loc, ofs) =
+    calling_conventions 0 4 100 103 outgoing 160 arg in
+  (Array.map (fun reg -> [|reg|]) loc, ofs)
+
+(* Results are in GPR 2 and FPR 0 *)
+
+let loc_external_results res =
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc
+
+(* Exceptions are in GPR 2 *)
+
+let loc_exn_bucket = phys_reg 0
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _rs = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call =
+  Array.of_list(List.map phys_reg
+    [0; 1; 2; 3; 4;
+     100; 101; 102; 103; 104; 105; 106; 107])
+
+let destroyed_at_oper = function
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call
+  | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure = function
+    Iextcall _ -> 4
+  | _ -> 9
+
+let max_register_pressure = function
+    Iextcall _ -> [| 4; 7 |]
+  | _ -> [| 9; 15 |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers). *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
+  | Ispecific(Imultaddf | Imultsubf) -> true
+  | _ -> true
+
+(* Layout of the stack *)
+
+let num_stack_slots = [| 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler *)
+
+let assemble_file infile outfile =
+  Ccomp.command (Config.asm ^ " -o " ^
+                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+let init () = ()
diff --git a/asmcomp/s390x/reload.ml b/asmcomp/s390x/reload.ml
new file mode 100644
index 00000000..f5d710a1
--- /dev/null
+++ b/asmcomp/s390x/reload.ml
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Reloading for the Z Processor *)
+
+open Arch
+open Mach
+
+class reload = object (self)
+
+inherit Reloadgen.reload_generic as super
+
+(* For 2-address instructions, reloading must make sure that the
+   temporary result register is the same as the appropriate
+   argument register. *)
+
+method! reload_operation op arg res =
+  match op with
+  (* Two-address binary operations: arg.(0) and res.(0) must be the same *)
+  | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor)  | Iaddf|Isubf|Imulf|Idivf ->
+      let res = self#makereg res.(0) in
+      ([|res; self#makereg arg.(1)|], [|res|])
+  (* Three-address ternary operations: arg.(2) and res.(0) must be the same *)
+  | Ispecific(Imultaddf|Imultsubf) ->
+      let res = self#makereg res.(0) in
+      ([|self#makereg arg.(0); self#makereg arg.(1); res|], [|res|])
+  (* One-address unary operations: arg.(0) and res.(0) must be the same *)
+  |  Iintop_imm((Imul|Iand|Ior|Ixor), _) ->
+      let res = self#makereg res.(0) in
+      ([|res|], [|res|])
+  (* Other instructions are regular *)
+  | _ ->
+      super#reload_operation op arg res
+
+end
+
+let fundecl f =
+  (new reload)#fundecl f
diff --git a/asmcomp/s390x/scheduling.ml b/asmcomp/s390x/scheduling.ml
new file mode 100644
index 00000000..a766d6a3
--- /dev/null
+++ b/asmcomp/s390x/scheduling.ml
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt            *)
+(*                          Bill O'Farrell, IBM                           *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini).    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction scheduling for the Z processor *)
+
+open Arch
+open Mach
+
+(* The z10 processor is in-order, dual-issue.  It could benefit from some
+   basic-block scheduling, although precise latency information
+   is not available.
+   The z196 and later are out-of-order processors.  Basic-block
+   scheduling probably makes no difference. *)
+
+class scheduler = object
+
+inherit Schedgen.scheduler_generic
+
+(* Latencies (in cycles). Wild guesses.  We multiply all latencies by 2
+   to favor dual-issue. *)
+
+method oper_latency = function
+    Ireload -> 4
+  | Iload(_, _) -> 4
+  | Iconst_float _ -> 4 (* turned into a load *)
+  | Iintop(Imul) -> 10
+  | Iintop_imm(Imul, _) -> 10
+  | Iaddf | Isubf | Imulf -> 8
+  | Idivf -> 40
+  | Ispecific(Imultaddf | Imultsubf) -> 8
+  | _ -> 2
+
+method! reload_retaddr_latency = 4
+
+(* Issue cycles.  Rough approximations. *)
+
+method oper_issue_cycles = function
+  | Ialloc _ -> 4
+  | Iintop(Imulh) -> 15
+  | Iintop(Idiv|Imod) -> 20
+  | Iintop(Icomp _) -> 4
+  | Iintop_imm(Icomp _, _) -> 4
+  | _ -> 1
+
+method! reload_retaddr_issue_cycles = 1
+
+end
+
+let fundecl f = (new scheduler)#schedule_fundecl f
diff --git a/asmcomp/s390x/selection.ml b/asmcomp/s390x/selection.ml
new file mode 100644
index 00000000..44ab1f9d
--- /dev/null
+++ b/asmcomp/s390x/selection.ml
@@ -0,0 +1,120 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt            *)
+(*                          Bill O'Farrell, IBM                           *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini).    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the Z processor *)
+
+open Cmm
+open Arch
+open Mach
+
+(* Recognition of addressing modes *)
+
+exception Use_default
+
+type addressing_expr =
+  | Alinear of expression
+  | Aadd of expression * expression
+
+let rec select_addr = function
+  | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m], _) ->
+      let (a, n) = select_addr arg in (a, n + m)
+  | Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg], _) ->
+      let (a, n) = select_addr arg in (a, n + m)
+  | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) ->
+      begin match (select_addr arg1, select_addr arg2) with
+          ((Alinear e1, n1), (Alinear e2, n2)) ->
+              (Aadd(e1, e2), n1 + n2)
+        | _ ->
+              (Aadd(arg1, arg2), 0)
+      end
+  | exp ->
+      (Alinear exp, 0)
+
+(* Instruction selection *)
+
+let pseudoregs_for_operation op arg res =
+  match op with
+  (* Two-address binary operations: arg.(0) and res.(0) must be the same *)
+  | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor)  | Iaddf|Isubf|Imulf|Idivf ->
+      ([|res.(0); arg.(1)|], res)
+  | Ispecific _ ->
+    ( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |])
+  (* One-address unary operations: arg.(0) and res.(0) must be the same *)
+  |  Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res)
+  (* Other instructions are regular *)
+  | _ -> raise Use_default
+
+class selector = object (self)
+
+inherit Selectgen.selector_generic as super
+
+method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF)
+  (* -1-.... : hack so that this can be compiled on 32-bit
+     (cf 'make check_all_arches') *)
+
+method select_addressing _chunk exp =
+  let (a, d) = select_addr exp in
+  (* 20-bit signed displacement *)
+  if d < 0x80000 && d >= -0x80000 then begin
+    match a with
+    | Alinear e -> (Iindexed d, e)
+    | Aadd(e1, e2) -> (Iindexed2 d, Ctuple [e1; e2])
+  end else
+    (Iindexed 0, exp)
+
+method! select_operation op args dbg =
+  match (op, args) with
+  (* Z does not support immediate operands for multiply high *)
+    (Cmulhi, _) -> (Iintop Imulh, args)
+  (* The and, or and xor instructions have a different range of immediate
+     operands than the other instructions *)
+  | (Cand, _) ->
+      self#select_logical Iand (-1 lsl 32 (*0x1_0000_0000*)) (-1) args
+  | (Cor, _) -> self#select_logical Ior 0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args
+  | (Cxor, _) -> self#select_logical Ixor  0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args
+  (* Recognize mult-add and mult-sub instructions *)
+  | (Caddf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
+      (Ispecific Imultaddf, [arg1; arg2; arg3])
+  | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2], _)]) ->
+      (Ispecific Imultaddf, [arg1; arg2; arg3])
+  | (Csubf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
+      (Ispecific Imultsubf, [arg1; arg2; arg3])
+  | _ ->
+      super#select_operation op args dbg
+
+method select_logical op lo hi = function
+    [arg; Cconst_int n] when n >= lo && n <= hi ->
+      (Iintop_imm(op, n), [arg])
+  | [Cconst_int n; arg] when n >= lo && n <= hi ->
+      (Iintop_imm(op, n), [arg])
+  | args ->
+      (Iintop op, args)
+
+
+method! insert_op_debug op dbg rs rd =
+  try
+    let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
+    self#insert_moves rs rsrc;
+    self#insert_debug (Iop op) dbg rsrc rdst;
+    self#insert_moves rdst rd;
+    rd
+  with Use_default ->
+    super#insert_op_debug op dbg rs rd
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
new file mode 100644
index 00000000..440fe2f0
--- /dev/null
+++ b/asmcomp/schedgen.ml
@@ -0,0 +1,400 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction scheduling *)
+
+open Reg
+open Mach
+open Linearize
+
+(* Representation of the code DAG. *)
+
+type code_dag_node =
+  { instr: instruction;                 (* The instruction *)
+    delay: int;           (* How many cycles before result is available *)
+    mutable sons: (code_dag_node * int) list;
+                                        (* Instructions that depend on it *)
+    mutable date: int;                  (* Start date *)
+    mutable length: int;                (* Length of longest path to result *)
+    mutable ancestors: int;             (* Number of ancestors *)
+    mutable emitted_ancestors: int }    (* Number of emitted ancestors *)
+
+let dummy_node =
+  { instr = end_instr; delay = 0; sons = []; date = 0;
+    length = -1; ancestors = 0; emitted_ancestors = 0 }
+
+(* The code dag itself is represented by two tables from registers to nodes:
+   - "results" maps registers to the instructions that produced them;
+   - "uses" maps registers to the instructions that use them.
+   In addition:
+   - code_stores contains the latest store nodes emitted so far
+   - code_loads contains all load nodes emitted since the last store
+   - code_checkbounds contains the latest checkbound node not matched
+     by a subsequent load or store. *)
+
+let code_results = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t)
+let code_uses = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t)
+let code_stores = ref ([] : code_dag_node list)
+let code_loads = ref ([] : code_dag_node list)
+let code_checkbounds = ref ([] : code_dag_node list)
+
+let clear_code_dag () =
+  Hashtbl.clear code_results;
+  Hashtbl.clear code_uses;
+  code_stores := [];
+  code_loads := [];
+  code_checkbounds := []
+
+(* Add an edge to the code DAG *)
+
+let add_edge ancestor son delay =
+  ancestor.sons <- (son, delay) :: ancestor.sons;
+  son.ancestors <- son.ancestors + 1
+
+let add_edge_after son ancestor = add_edge ancestor son 0
+
+(* Add edges from all instructions that define a pseudoregister [arg] being used
+   as argument to node [node] (RAW dependencies *)
+
+let add_RAW_dependencies node arg =
+  try
+    let ancestor = Hashtbl.find code_results arg.loc in
+    add_edge ancestor node ancestor.delay
+  with Not_found ->
+    ()
+
+(* Add edges from all instructions that use a pseudoregister [res] that is
+   defined by node [node] (WAR dependencies). *)
+
+let add_WAR_dependencies node res =
+  let ancestors = Hashtbl.find_all code_uses res.loc in
+  List.iter (add_edge_after node) ancestors
+
+(* Add edges from all instructions that have already defined a pseudoregister
+   [res] that is defined by node [node] (WAW dependencies). *)
+
+let add_WAW_dependencies node res =
+  try
+    let ancestor = Hashtbl.find code_results res.loc in
+    add_edge ancestor node 0
+  with Not_found ->
+    ()
+
+(* Compute length of longest path to a result.
+   For leafs of the DAG, see whether their result is used in the instruction
+   immediately following the basic block (a "critical" output). *)
+
+let is_critical critical_outputs results =
+  try
+    for i = 0 to Array.length results - 1 do
+      let r = results.(i).loc in
+      for j = 0 to Array.length critical_outputs - 1 do
+        if critical_outputs.(j).loc = r then raise Exit
+      done
+    done;
+    false
+  with Exit ->
+    true
+
+let rec longest_path critical_outputs node =
+  if node.length < 0 then begin
+    match node.sons with
+      [] ->
+        node.length <-
+          if is_critical critical_outputs node.instr.res
+          || node.instr.desc = Lreloadretaddr (* alway critical *)
+          then node.delay
+          else 0
+    | sons ->
+        node.length <-
+          List.fold_left
+            (fun len (son, delay) ->
+              max len (longest_path critical_outputs son + delay))
+            0 sons
+  end;
+  node.length
+
+(* Remove an instruction from the ready queue *)
+
+let rec remove_instr node = function
+    [] -> []
+  | instr :: rem ->
+      if instr == node then rem else instr :: remove_instr node rem
+
+(* We treat Lreloadretaddr as a word-sized load *)
+
+let some_load = (Iload(Cmm.Word_int, Arch.identity_addressing))
+
+(* The generic scheduler *)
+
+class virtual scheduler_generic = object (self)
+
+val mutable trywith_nesting = 0
+
+(* Determine whether an operation ends a basic block or not.
+   Can be overridden for some processors to signal specific instructions
+   that terminate a basic block. *)
+
+method oper_in_basic_block = function
+    Icall_ind _ -> false
+  | Icall_imm _ -> false
+  | Itailcall_ind _ -> false
+  | Itailcall_imm _ -> false
+  | Iextcall _ -> false
+  | Istackoffset _ -> false
+  | Ialloc _ -> false
+  | _ -> true
+
+(* Determine whether an instruction ends a basic block or not *)
+
+(* PR#2719: it is generally incorrect to schedule checkbound instructions
+   within a try ... with Invalid_argument _ -> ...
+   Hence, a checkbound instruction within a try...with block ends the
+   current basic block. *)
+
+method private instr_in_basic_block instr try_nesting =
+  match instr.desc with
+    Lop op ->
+      self#oper_in_basic_block op &&
+      not (try_nesting > 0 && self#is_checkbound op)
+  | Lreloadretaddr -> true
+  | _ -> false
+
+(* Determine whether an operation is a memory store or a memory load.
+   Can be overridden for some processors to signal specific
+   load or store instructions (e.g. on the I386). *)
+
+method is_store = function
+    Istore(_, _, _) -> true
+  | _ -> false
+
+method is_load = function
+    Iload(_, _) -> true
+  | _ -> false
+
+method is_checkbound = function
+    Iintop (Icheckbound _) -> true
+  | Iintop_imm(Icheckbound _, _) -> true
+  | _ -> false
+
+method private instr_is_store instr =
+  match instr.desc with
+    Lop op -> self#is_store op
+  | _ -> false
+
+method private instr_is_load instr =
+  match instr.desc with
+    Lop op -> self#is_load op
+  | _ -> false
+
+method private instr_is_checkbound instr =
+  match instr.desc with
+    Lop op -> self#is_checkbound op
+  | _ -> false
+
+(* Estimate the latency of an operation. *)
+
+method virtual oper_latency : Mach.operation -> int
+
+(* Estimate the latency of a Lreloadretaddr operation. *)
+
+method reload_retaddr_latency = self#oper_latency some_load
+
+(* Estimate the delay needed to evaluate an instruction *)
+
+method private instr_latency instr =
+  match instr.desc with
+    Lop op -> self#oper_latency op
+  | Lreloadretaddr -> self#reload_retaddr_latency
+  | _ -> assert false
+
+(* Estimate the number of cycles consumed by emitting an operation. *)
+
+method virtual oper_issue_cycles : Mach.operation -> int
+
+(* Estimate the number of cycles consumed by emitting a Lreloadretaddr. *)
+
+method reload_retaddr_issue_cycles = self#oper_issue_cycles some_load
+
+(* Estimate the number of cycles consumed by emitting an instruction. *)
+
+method private instr_issue_cycles instr =
+  match instr.desc with
+    Lop op -> self#oper_issue_cycles op
+  | Lreloadretaddr -> self#reload_retaddr_issue_cycles
+  | _ -> assert false
+
+(* Pseudoregisters destroyed by an instruction *)
+
+method private destroyed_by_instr instr =
+  match instr.desc with
+  | Lop op -> Proc.destroyed_at_oper (Iop op)
+  | Lreloadretaddr -> [||]
+  | _ -> assert false
+
+(* Add an instruction to the code dag *)
+
+method private add_instruction ready_queue instr =
+  let delay = self#instr_latency instr in
+  let destroyed = self#destroyed_by_instr instr in
+  let node =
+    { instr = instr;
+      delay = delay;
+      sons = [];
+      date = 0;
+      length = -1;
+      ancestors = 0;
+      emitted_ancestors = 0 } in
+  (* Add edges from all instructions that define one of the registers used
+     (RAW dependencies) *)
+  Array.iter (add_RAW_dependencies node) instr.arg;
+  (* Also add edges from all instructions that use one of the result regs
+     of this instruction, or a reg destroyed by this instruction
+     (WAR dependencies). *)
+  Array.iter (add_WAR_dependencies node) instr.res;
+  Array.iter (add_WAR_dependencies node) destroyed;   (* PR#5731 *)
+  (* Also add edges from all instructions that have already defined one
+     of the results of this instruction, or a reg destroyed by
+     this instruction (WAW dependencies). *)
+  Array.iter (add_WAW_dependencies node) instr.res;
+  Array.iter (add_WAW_dependencies node) destroyed;   (* PR#5731 *)
+  (* If this is a load, add edges from the most recent store viewed so
+     far (if any) and remember the load.  Also add edges from the most
+     recent checkbound and forget that checkbound. *)
+  if self#instr_is_load instr then begin
+    List.iter (add_edge_after node) !code_stores;
+    code_loads := node :: !code_loads;
+    List.iter (add_edge_after node) !code_checkbounds;
+    code_checkbounds := []
+  end
+  (* If this is a store, add edges from the most recent store,
+     as well as all loads viewed since then, and also the most recent
+     checkbound. Remember the store,
+     discarding the previous stores, loads and checkbounds. *)
+  else if self#instr_is_store instr then begin
+    List.iter (add_edge_after node) !code_stores;
+    List.iter (add_edge_after node) !code_loads;
+    List.iter (add_edge_after node) !code_checkbounds;
+    code_stores := [node];
+    code_loads := [];
+    code_checkbounds := []
+  end
+  else if self#instr_is_checkbound instr then begin
+    code_checkbounds := [node]
+  end;
+  (* Remember the registers used and produced by this instruction *)
+  for i = 0 to Array.length instr.res - 1 do
+    Hashtbl.add code_results instr.res.(i).loc node
+  done;
+  for i = 0 to Array.length destroyed - 1 do
+    Hashtbl.add code_results destroyed.(i).loc node  (* PR#5731 *)
+  done;
+  for i = 0 to Array.length instr.arg - 1 do
+    Hashtbl.add code_uses instr.arg.(i).loc node
+  done;
+  (* If this is a root instruction (all arguments already computed),
+     add it to the ready queue *)
+  if node.ancestors = 0 then node :: ready_queue else ready_queue
+
+(* Given a list of instructions and a date, choose one or several
+   that are ready to be computed (start date <= current date)
+   and that we can emit in one cycle.  Favor instructions with
+   maximal distance to result.  If we can't find any, return None.
+   This does not take multiple issues into account, though. *)
+
+method private ready_instruction date queue =
+  let rec extract best = function
+    [] ->
+      if best == dummy_node then None else Some best
+  | instr :: rem ->
+      let new_best =
+        if instr.date <= date && instr.length > best.length
+        then instr else best in
+      extract new_best rem in
+  extract dummy_node queue
+
+(* Schedule a basic block, adding its instructions in front of the given
+   instruction sequence *)
+
+method private reschedule ready_queue date cont =
+  if ready_queue = [] then cont else begin
+    match self#ready_instruction date ready_queue with
+      None ->
+        self#reschedule ready_queue (date + 1) cont
+    | Some node ->
+        (* Remove node from queue *)
+        let new_queue = ref (remove_instr node ready_queue) in
+        (* Update the start date and number of ancestors emitted of
+           all descendents of this node. Enter those that become ready
+           in the queue. *)
+        let issue_cycles = self#instr_issue_cycles node.instr in
+        List.iter
+          (fun (son, delay) ->
+            let completion_date = date + issue_cycles + delay - 1 in
+            if son.date < completion_date then son.date <- completion_date;
+            son.emitted_ancestors <- son.emitted_ancestors + 1;
+            if son.emitted_ancestors = son.ancestors then
+              new_queue := son :: !new_queue)
+          node.sons;
+        { node.instr with next =
+            self#reschedule !new_queue (date + issue_cycles) cont }
+  end
+
+(* Entry point *)
+(* Don't bother to schedule for initialization code and the like. *)
+
+method schedule_fundecl f =
+
+  let rec schedule i try_nesting =
+    match i.desc with
+    | Lend -> i
+    | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) }
+    | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) }
+    | _ ->
+        if self#instr_in_basic_block i try_nesting then begin
+          clear_code_dag();
+          schedule_block [] i try_nesting
+        end else
+          { i with next = schedule i.next try_nesting }
+
+  and schedule_block ready_queue i try_nesting =
+    if self#instr_in_basic_block i try_nesting then
+      schedule_block (self#add_instruction ready_queue i) i.next try_nesting
+    else begin
+      let critical_outputs =
+        match i.desc with
+          Lop(Icall_ind _ | Itailcall_ind _) -> [| i.arg.(0) |]
+        | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||]
+        | Lreturn -> [||]
+        | _ -> i.arg in
+      List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue;
+      self#reschedule ready_queue 0 (schedule i try_nesting)
+    end in
+
+  if f.fun_fast then begin
+    let new_body = schedule f.fun_body 0 in
+    clear_code_dag();
+    { fun_name = f.fun_name;
+      fun_body = new_body;
+      fun_fast = f.fun_fast;
+      fun_dbg  = f.fun_dbg;
+      fun_spacetime_shape = f.fun_spacetime_shape;
+    }
+  end else
+    f
+
+end
+
+let reset () = clear_code_dag ()
diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli
new file mode 100644
index 00000000..0fa16dac
--- /dev/null
+++ b/asmcomp/schedgen.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction scheduling *)
+
+type code_dag_node =
+  { instr: Linearize.instruction;
+    delay: int;
+    mutable sons: (code_dag_node * int) list;
+    mutable date: int;
+    mutable length: int;
+    mutable ancestors: int;
+    mutable emitted_ancestors: int }
+
+class virtual scheduler_generic : object
+  (* Can be overridden by processor description *)
+  method virtual oper_issue_cycles : Mach.operation -> int
+      (* Number of cycles needed to issue the given operation *)
+  method virtual oper_latency : Mach.operation -> int
+      (* Number of cycles needed to complete the given operation *)
+  method reload_retaddr_issue_cycles : int
+      (* Number of cycles needed to issue a Lreloadretaddr operation *)
+  method reload_retaddr_latency : int
+      (* Number of cycles needed to complete a Lreloadretaddr operation *)
+  method oper_in_basic_block : Mach.operation -> bool
+      (* Says whether the given operation terminates a basic block *)
+  method is_store : Mach.operation -> bool
+      (* Says whether the given operation is a memory store *)
+  method is_load : Mach.operation -> bool
+      (* Says whether the given operation is a memory load *)
+  method is_checkbound : Mach.operation -> bool
+      (* Says whether the given operation is a checkbound *)
+  (* Entry point *)
+  method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl
+end
+
+val reset : unit -> unit
diff --git a/asmcomp/scheduling.mli b/asmcomp/scheduling.mli
new file mode 100644
index 00000000..93830106
--- /dev/null
+++ b/asmcomp/scheduling.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction scheduling *)
+
+val fundecl: Linearize.fundecl -> Linearize.fundecl
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
new file mode 100644
index 00000000..7cd8cd5c
--- /dev/null
+++ b/asmcomp/selectgen.ml
@@ -0,0 +1,1239 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Selection of pseudo-instructions, assignment of pseudo-registers,
+   sequentialization. *)
+
+open Misc
+open Cmm
+open Reg
+open Mach
+
+type environment =
+  { vars : (Ident.t, Reg.t array) Tbl.t;
+    static_exceptions : (int, Reg.t array list) Tbl.t;
+    (** Which registers must be populated when jumping to the given
+        handler. *)
+  }
+
+let env_add id v env =
+  { env with vars = Tbl.add id v env.vars }
+
+let env_add_static_exception id v env =
+  { env with static_exceptions = Tbl.add id v env.static_exceptions }
+
+let env_find id env =
+  Tbl.find id env.vars
+
+let env_find_static_exception id env =
+  Tbl.find id env.static_exceptions
+
+let env_empty = {
+  vars = Tbl.empty;
+  static_exceptions = Tbl.empty;
+}
+
+(* Infer the type of the result of an operation *)
+
+let oper_result_type = function
+    Capply ty -> ty
+  | Cextcall(_s, ty, _alloc, _) -> ty
+  | Cload (c, _) ->
+      begin match c with
+      | Word_val -> typ_val
+      | Single | Double | Double_u -> typ_float
+      | _ -> typ_int
+      end
+  | Calloc -> typ_val
+  | Cstore (_c, _) -> typ_void
+  | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi |
+    Cand | Cor | Cxor | Clsl | Clsr | Casr |
+    Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int
+  | Caddv -> typ_val
+  | Cadda -> typ_addr
+  | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float
+  | Cfloatofint -> typ_float
+  | Cintoffloat -> typ_int
+  | Craise _ -> typ_void
+  | Ccheckbound -> typ_void
+
+(* Infer the size in bytes of the result of an expression whose evaluation
+   may be deferred (cf. [emit_parts]). *)
+
+let size_expr (env:environment) exp =
+  let rec size localenv = function
+      Cconst_int _ | Cconst_natint _ -> Arch.size_int
+    | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ ->
+        Arch.size_addr
+    | Cconst_float _ -> Arch.size_float
+    | Cblockheader _ -> Arch.size_int
+    | Cvar id ->
+        begin try
+          Tbl.find id localenv
+        with Not_found ->
+        try
+          let regs = env_find id env in
+          size_machtype (Array.map (fun r -> r.typ) regs)
+        with Not_found ->
+          fatal_error("Selection.size_expr: unbound var " ^
+                      Ident.unique_name id)
+        end
+    | Ctuple el ->
+        List.fold_right (fun e sz -> size localenv e + sz) el 0
+    | Cop(op, _, _) ->
+        size_machtype(oper_result_type op)
+    | Clet(id, arg, body) ->
+        size (Tbl.add id (size localenv arg) localenv) body
+    | Csequence(_e1, e2) ->
+        size localenv e2
+    | _ ->
+        fatal_error "Selection.size_expr"
+  in size Tbl.empty exp
+
+(* Swap the two arguments of an integer comparison *)
+
+let swap_intcomp = function
+    Isigned cmp -> Isigned(swap_comparison cmp)
+  | Iunsigned cmp -> Iunsigned(swap_comparison cmp)
+
+(* Naming of registers *)
+
+let all_regs_anonymous rv =
+  try
+    for i = 0 to Array.length rv - 1 do
+      if not (Reg.anonymous rv.(i)) then raise Exit
+    done;
+    true
+  with Exit ->
+    false
+
+let name_regs id rv =
+  if Array.length rv = 1 then
+    rv.(0).raw_name <- Raw_name.create_from_ident id
+  else
+    for i = 0 to Array.length rv - 1 do
+      rv.(i).raw_name <- Raw_name.create_from_ident id;
+      rv.(i).part <- Some i
+    done
+
+(* "Join" two instruction sequences, making sure they return their results
+   in the same registers. *)
+
+let join opt_r1 seq1 opt_r2 seq2 =
+  match (opt_r1, opt_r2) with
+    (None, _) -> opt_r2
+  | (_, None) -> opt_r1
+  | (Some r1, Some r2) ->
+      let l1 = Array.length r1 in
+      assert (l1 = Array.length r2);
+      let r = Array.make l1 Reg.dummy in
+      for i = 0 to l1-1 do
+        if Reg.anonymous r1.(i)
+          && Cmm.ge_component r1.(i).typ r2.(i).typ
+        then begin
+          r.(i) <- r1.(i);
+          seq2#insert_move r2.(i) r1.(i)
+        end else if Reg.anonymous r2.(i)
+          && Cmm.ge_component r2.(i).typ r1.(i).typ
+        then begin
+          r.(i) <- r2.(i);
+          seq1#insert_move r1.(i) r2.(i)
+        end else begin
+          let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in
+          r.(i) <- Reg.create typ;
+          seq1#insert_move r1.(i) r.(i);
+          seq2#insert_move r2.(i) r.(i)
+        end
+      done;
+      Some r
+
+(* Same, for N branches *)
+
+let join_array rs =
+  let some_res = ref None in
+  for i = 0 to Array.length rs - 1 do
+    let (r, _) = rs.(i) in
+    match r with
+    | None -> ()
+    | Some r ->
+      match !some_res with
+      | None -> some_res := Some (r, Array.map (fun r -> r.typ) r)
+      | Some (r', types) ->
+        let types =
+          Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types
+        in
+        some_res := Some (r', types)
+  done;
+  match !some_res with
+    None -> None
+  | Some (template, types) ->
+      let size_res = Array.length template in
+      let res = Array.make size_res Reg.dummy in
+      for i = 0 to size_res - 1 do
+        res.(i) <- Reg.create types.(i)
+      done;
+      for i = 0 to Array.length rs - 1 do
+        let (r, s) = rs.(i) in
+        match r with
+          None -> ()
+        | Some r -> s#insert_moves r res
+      done;
+      Some res
+
+(* Name of function being compiled *)
+let current_function_name = ref ""
+
+module Effect = struct
+  type t =
+    | None
+    | Raise
+    | Arbitrary
+
+  let join t1 t2 =
+    match t1, t2 with
+    | None, t2 -> t2
+    | t1, None -> t1
+    | Raise, Raise -> Raise
+    | Arbitrary, _ | _, Arbitrary -> Arbitrary
+
+  let pure = function
+    | None -> true
+    | Raise | Arbitrary -> false
+end
+
+module Coeffect = struct
+  type t =
+    | None
+    | Read_mutable
+    | Arbitrary
+
+  let join t1 t2 =
+    match t1, t2 with
+    | None, t2 -> t2
+    | t1, None -> t1
+    | Read_mutable, Read_mutable -> Read_mutable
+    | Arbitrary, _ | _, Arbitrary -> Arbitrary
+
+  let copure = function
+    | None -> true
+    | Read_mutable | Arbitrary -> false
+end
+
+module Effect_and_coeffect : sig
+  type t
+
+  val none : t
+  val arbitrary : t
+
+  val effect : t -> Effect.t
+  val coeffect : t -> Coeffect.t
+
+  val pure_and_copure : t -> bool
+
+  val effect_only : Effect.t -> t
+  val coeffect_only : Coeffect.t -> t
+
+  val join : t -> t -> t
+  val join_list_map : 'a list -> ('a -> t) -> t
+end = struct
+  type t = Effect.t * Coeffect.t
+
+  let none = Effect.None, Coeffect.None
+  let arbitrary = Effect.Arbitrary, Coeffect.Arbitrary
+
+  let effect (e, _ce) = e
+  let coeffect (_e, ce) = ce
+
+  let pure_and_copure (e, ce) = Effect.pure e && Coeffect.copure ce
+
+  let effect_only e = e, Coeffect.None
+  let coeffect_only ce = Effect.None, ce
+
+  let join (e1, ce1) (e2, ce2) =
+    Effect.join e1 e2, Coeffect.join ce1 ce2
+
+  let join_list_map xs f =
+    match xs with
+    | [] -> none
+    | x::xs -> List.fold_left (fun acc x -> join acc (f x)) (f x) xs
+end
+
+(* The default instruction selection class *)
+
+class virtual selector_generic = object (self)
+
+(* A syntactic criterion used in addition to judgements about (co)effects as
+   to whether the evaluation of a given expression may be deferred by
+   [emit_parts].  This criterion is a property of the instruction selection
+   algorithm in this file rather than a property of the Cmm language.
+*)
+method is_simple_expr = function
+    Cconst_int _ -> true
+  | Cconst_natint _ -> true
+  | Cconst_float _ -> true
+  | Cconst_symbol _ -> true
+  | Cconst_pointer _ -> true
+  | Cconst_natpointer _ -> true
+  | Cblockheader _ -> true
+  | Cvar _ -> true
+  | Ctuple el -> List.for_all self#is_simple_expr el
+  | Clet(_id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body
+  | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2
+  | Cop(op, args, _) ->
+      begin match op with
+        (* The following may have side effects *)
+      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false
+        (* The remaining operations are simple if their args are *)
+      | Cload _ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor
+      | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf
+      | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat
+      | Ccmpf _ | Ccheckbound -> List.for_all self#is_simple_expr args
+      end
+  | Cassign _ | Cifthenelse _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _
+  | Ctrywith _ -> false
+
+(* Analyses the effects and coeffects of an expression.  This is used across
+   a whole list of expressions with a view to determining which expressions
+   may have their evaluation deferred.  The result of this function, modulo
+   target-specific judgements if the [effects_of] method is overridden, is a
+   property of the Cmm language rather than anything particular about the
+   instruction selection algorithm in this file.
+
+   In the case of e.g. an OCaml function call, the arguments whose evaluation
+   cannot be deferred (cf. [emit_parts], below) are computed in right-to-left
+   order first with their results going into temporaries, then the block is
+   allocated, then the remaining arguments are evaluated before being
+   combined with the temporaries. *)
+method effects_of exp =
+  let module EC = Effect_and_coeffect in
+  match exp with
+  | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
+  | Cconst_pointer _ | Cconst_natpointer _ | Cblockheader _
+  | Cvar _ -> EC.none
+  | Ctuple el -> EC.join_list_map el self#effects_of
+  | Clet (_id, arg, body) ->
+    EC.join (self#effects_of arg) (self#effects_of body)
+  | Csequence (e1, e2) ->
+    EC.join (self#effects_of e1) (self#effects_of e2)
+  | Cifthenelse (cond, ifso, ifnot) ->
+    EC.join (self#effects_of cond)
+      (EC.join (self#effects_of ifso) (self#effects_of ifnot))
+  | Cop (op, args, _) ->
+    let from_op =
+      match op with
+      | Capply _ | Cextcall _ -> EC.arbitrary
+      | Calloc -> EC.none
+      | Cstore _ -> EC.effect_only Effect.Arbitrary
+      | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise
+      | Cload (_, Asttypes.Immutable) -> EC.none
+      | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable
+      | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor
+      | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf | Cabsf
+      | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf _ ->
+        EC.none
+    in
+    EC.join from_op (EC.join_list_map args self#effects_of)
+  | Cassign _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _ | Ctrywith _ ->
+    EC.arbitrary
+
+(* Says whether an integer constant is a suitable immediate argument *)
+
+method virtual is_immediate : int -> bool
+
+(* Selection of addressing modes *)
+
+method virtual select_addressing :
+  Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
+
+(* Default instruction selection for stores (of words) *)
+
+method select_store is_assign addr arg =
+  (Istore(Word_val, addr, is_assign), arg)
+
+(* call marking methods, documented in selectgen.mli *)
+
+method mark_call =
+  Proc.contains_calls := true
+
+method mark_tailcall = ()
+
+method mark_c_tailcall = ()
+
+method mark_instr = function
+  | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) ->
+      self#mark_call
+  | Iop (Itailcall_ind _ | Itailcall_imm _) ->
+      self#mark_tailcall
+  | Iop (Ialloc _) ->
+      self#mark_call (* caml_alloc*, caml_garbage_collection *)
+  | Iop (Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _)) ->
+      self#mark_c_tailcall (* caml_ml_array_bound_error *)
+  | Iraise raise_kind ->
+    begin match raise_kind with
+      | Cmm.Raise_notrace -> ()
+      | Cmm.Raise_withtrace ->
+          (* PR#6239 *)
+          (* caml_stash_backtrace; we #mark_call rather than
+             #mark_c_tailcall to get a good stack backtrace *)
+          self#mark_call
+    end
+  | Itrywith _ ->
+    self#mark_call
+  | _ -> ()
+
+(* Default instruction selection for operators *)
+
+method select_allocation words =
+  Ialloc { words; spacetime_index = 0; label_after_call_gc = None; }
+method select_allocation_args _env = [| |]
+
+method select_checkbound () =
+  Icheckbound { spacetime_index = 0; label_after_error = None; }
+method select_checkbound_extra_args () = []
+
+method select_operation op args _dbg =
+  match (op, args) with
+  | (Capply _, Cconst_symbol func :: rem) ->
+    let label_after = Cmm.new_label () in
+    (Icall_imm { func; label_after; }, rem)
+  | (Capply _, _) ->
+    let label_after = Cmm.new_label () in
+    (Icall_ind { label_after; }, args)
+  | (Cextcall(func, _ty, alloc, label_after), _) ->
+    let label_after =
+      match label_after with
+      | None -> Cmm.new_label ()
+      | Some label_after -> label_after
+    in
+    Iextcall { func; alloc; label_after; }, args
+  | (Cload (chunk, _mut), [arg]) ->
+      let (addr, eloc) = self#select_addressing chunk arg in
+      (Iload(chunk, addr), [eloc])
+  | (Cstore (chunk, init), [arg1; arg2]) ->
+      let (addr, eloc) = self#select_addressing chunk arg1 in
+      let is_assign =
+        match init with
+        | Lambda.Root_initialization -> false
+        | Lambda.Heap_initialization -> false
+        | Lambda.Assignment -> true
+      in
+      if chunk = Word_int || chunk = Word_val then begin
+        let (op, newarg2) = self#select_store is_assign addr arg2 in
+        (op, [newarg2; eloc])
+      end else begin
+        (Istore(chunk, addr, is_assign), [arg2; eloc])
+        (* Inversion addr/datum in Istore *)
+      end
+  | (Calloc, _) -> (self#select_allocation 0), args
+  | (Caddi, _) -> self#select_arith_comm Iadd args
+  | (Csubi, _) -> self#select_arith Isub args
+  | (Cmuli, _) -> self#select_arith_comm Imul args
+  | (Cmulhi, _) -> self#select_arith_comm Imulh args
+  | (Cdivi, _) -> (Iintop Idiv, args)
+  | (Cmodi, _) -> (Iintop Imod, args)
+  | (Cand, _) -> self#select_arith_comm Iand args
+  | (Cor, _) -> self#select_arith_comm Ior args
+  | (Cxor, _) -> self#select_arith_comm Ixor args
+  | (Clsl, _) -> self#select_shift Ilsl args
+  | (Clsr, _) -> self#select_shift Ilsr args
+  | (Casr, _) -> self#select_shift Iasr args
+  | (Ccmpi comp, _) -> self#select_arith_comp (Isigned comp) args
+  | (Caddv, _) -> self#select_arith_comm Iadd args
+  | (Cadda, _) -> self#select_arith_comm Iadd args
+  | (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args
+  | (Cnegf, _) -> (Inegf, args)
+  | (Cabsf, _) -> (Iabsf, args)
+  | (Caddf, _) -> (Iaddf, args)
+  | (Csubf, _) -> (Isubf, args)
+  | (Cmulf, _) -> (Imulf, args)
+  | (Cdivf, _) -> (Idivf, args)
+  | (Cfloatofint, _) -> (Ifloatofint, args)
+  | (Cintoffloat, _) -> (Iintoffloat, args)
+  | (Ccheckbound, _) ->
+    let extra_args = self#select_checkbound_extra_args () in
+    let op = self#select_checkbound () in
+    self#select_arith op (args @ extra_args)
+  | _ -> fatal_error "Selection.select_oper"
+
+method private select_arith_comm op = function
+    [arg; Cconst_int n] when self#is_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | [arg; Cconst_pointer n] when self#is_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | [Cconst_int n; arg] when self#is_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | [Cconst_pointer n; arg] when self#is_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | args ->
+      (Iintop op, args)
+
+method private select_arith op = function
+    [arg; Cconst_int n] when self#is_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | [arg; Cconst_pointer n] when self#is_immediate n ->
+      (Iintop_imm(op, n), [arg])
+  | args ->
+      (Iintop op, args)
+
+method private select_shift op = function
+    [arg; Cconst_int n] when n >= 0 && n < Arch.size_int * 8 ->
+      (Iintop_imm(op, n), [arg])
+  | args ->
+      (Iintop op, args)
+
+method private select_arith_comp cmp = function
+    [arg; Cconst_int n] when self#is_immediate n ->
+      (Iintop_imm(Icomp cmp, n), [arg])
+  | [arg; Cconst_pointer n] when self#is_immediate n ->
+      (Iintop_imm(Icomp cmp, n), [arg])
+  | [Cconst_int n; arg] when self#is_immediate n ->
+      (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
+  | [Cconst_pointer n; arg] when self#is_immediate n ->
+      (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
+  | args ->
+      (Iintop(Icomp cmp), args)
+
+(* Instruction selection for conditionals *)
+
+method select_condition = function
+    Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
+      (Iinttest_imm(Isigned cmp, n), arg1)
+  | Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
+      (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
+  | Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
+      (Iinttest_imm(Isigned cmp, n), arg1)
+  | Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
+      (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
+  | Cop(Ccmpi cmp, args, _) ->
+      (Iinttest(Isigned cmp), Ctuple args)
+  | Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
+      (Iinttest_imm(Iunsigned cmp, n), arg1)
+  | Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
+      (Iinttest_imm(Iunsigned cmp, n), arg1)
+  | Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
+      (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
+  | Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
+      (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
+  | Cop(Ccmpa cmp, args, _) ->
+      (Iinttest(Iunsigned cmp), Ctuple args)
+  | Cop(Ccmpf cmp, args, _) ->
+      (Ifloattest(cmp, false), Ctuple args)
+  | Cop(Cand, [arg; Cconst_int 1], _) ->
+      (Ioddtest, arg)
+  | arg ->
+      (Itruetest, arg)
+
+(* Return an array of fresh registers of the given type.
+   Normally implemented as Reg.createv, but some
+   ports (e.g. Arm) can override this definition to store float values
+   in pairs of integer registers. *)
+
+method regs_for tys = Reg.createv tys
+
+(* Buffering of instruction sequences *)
+
+val mutable instr_seq = dummy_instr
+
+method insert_debug desc dbg arg res =
+  instr_seq <- instr_cons_debug desc arg res dbg instr_seq
+
+method insert desc arg res =
+  instr_seq <- instr_cons desc arg res instr_seq
+
+method extract_core ~end_instr =
+  let rec extract res i =
+    if i == dummy_instr
+    then res
+    else extract {i with next = res} i.next in
+  extract end_instr instr_seq
+
+method extract =
+  self#extract_core ~end_instr:(end_instr ())
+
+(* Insert a sequence of moves from one pseudoreg set to another. *)
+
+method insert_move src dst =
+  if src.stamp <> dst.stamp then
+    self#insert (Iop Imove) [|src|] [|dst|]
+
+method insert_moves src dst =
+  for i = 0 to min (Array.length src) (Array.length dst) - 1 do
+    self#insert_move src.(i) dst.(i)
+  done
+
+(* Adjust the types of destination pseudoregs for a [Cassign] assignment.
+   The type inferred at [let] binding might be [Int] while we assign
+   something of type [Val] (PR#6501). *)
+
+method adjust_type src dst =
+  let ts = src.typ and td = dst.typ in
+  if ts <> td then
+    match ts, td with
+    | Val, Int -> dst.typ <- Val
+    | Int, Val -> ()
+    | _, _ -> fatal_error("Selection.adjust_type: bad assignment to "
+                                                           ^ Reg.name dst)
+
+method adjust_types src dst =
+  for i = 0 to min (Array.length src) (Array.length dst) - 1 do
+    self#adjust_type src.(i) dst.(i)
+  done
+
+(* Insert moves and stack offsets for function arguments and results *)
+
+method insert_move_args arg loc stacksize =
+  if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||];
+  self#insert_moves arg loc
+
+method insert_move_results loc res stacksize =
+  if stacksize <> 0 then self#insert(Iop(Istackoffset(-stacksize))) [||] [||];
+  self#insert_moves loc res
+
+(* Add an Iop opcode. Can be overridden by processor description
+   to insert moves before and after the operation, i.e. for two-address
+   instructions, or instructions using dedicated registers. *)
+
+method insert_op_debug op dbg rs rd =
+  self#insert_debug (Iop op) dbg rs rd;
+  rd
+
+method insert_op op rs rd =
+  self#insert_op_debug op Debuginfo.none rs rd
+
+method emit_blockheader _env n _dbg =
+  let r = self#regs_for typ_int in
+  Some(self#insert_op (Iconst_int n) [||] r)
+
+method about_to_emit_call _env _insn _arg = None
+
+(* Prior to a function call, update the Spacetime node hole pointer hard
+   register. *)
+
+method private maybe_emit_spacetime_move ~spacetime_reg =
+  Misc.Stdlib.Option.iter (fun reg ->
+      self#insert_moves reg [| Proc.loc_spacetime_node_hole |])
+    spacetime_reg
+
+(* Add the instructions for the given expression
+   at the end of the self sequence *)
+
+method emit_expr (env:environment) exp =
+  match exp with
+    Cconst_int n ->
+      let r = self#regs_for typ_int in
+      Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r)
+  | Cconst_natint n ->
+      let r = self#regs_for typ_int in
+      Some(self#insert_op (Iconst_int n) [||] r)
+  | Cconst_float n ->
+      let r = self#regs_for typ_float in
+      Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r)
+  | Cconst_symbol n ->
+      let r = self#regs_for typ_val in
+      Some(self#insert_op (Iconst_symbol n) [||] r)
+  | Cconst_pointer n ->
+      let r = self#regs_for typ_val in  (* integer as Caml value *)
+      Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r)
+  | Cconst_natpointer n ->
+      let r = self#regs_for typ_val in  (* integer as Caml value *)
+      Some(self#insert_op (Iconst_int n) [||] r)
+  | Cblockheader(n, dbg) ->
+      self#emit_blockheader env n dbg
+  | Cvar v ->
+      begin try
+        Some(env_find v env)
+      with Not_found ->
+        fatal_error("Selection.emit_expr: unbound var " ^ Ident.unique_name v)
+      end
+  | Clet(v, e1, e2) ->
+      begin match self#emit_expr env e1 with
+        None -> None
+      | Some r1 -> self#emit_expr (self#bind_let env v r1) e2
+      end
+  | Cassign(v, e1) ->
+      let rv =
+        try
+          env_find v env
+        with Not_found ->
+          fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in
+      begin match self#emit_expr env e1 with
+        None -> None
+      | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||]
+      end
+  | Ctuple [] ->
+      Some [||]
+  | Ctuple exp_list ->
+      begin match self#emit_parts_list env exp_list with
+        None -> None
+      | Some(simple_list, ext_env) ->
+          Some(self#emit_tuple ext_env simple_list)
+      end
+  | Cop(Craise k, [arg], dbg) ->
+      begin match self#emit_expr env arg with
+        None -> None
+      | Some r1 ->
+          let rd = [|Proc.loc_exn_bucket|] in
+          self#insert (Iop Imove) r1 rd;
+          self#insert_debug (Iraise k) dbg rd [||];
+          None
+      end
+  | Cop(Ccmpf _, _, _) ->
+      self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
+  | Cop(op, args, dbg) ->
+      begin match self#emit_parts_list env args with
+        None -> None
+      | Some(simple_args, env) ->
+          let ty = oper_result_type op in
+          let (new_op, new_args) = self#select_operation op simple_args dbg in
+          match new_op with
+            Icall_ind _ ->
+              let r1 = self#emit_tuple env new_args in
+              let rarg = Array.sub r1 1 (Array.length r1 - 1) in
+              let rd = self#regs_for ty in
+              let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
+              let loc_res = Proc.loc_results rd in
+              let spacetime_reg =
+                self#about_to_emit_call env (Iop new_op) [| r1.(0) |]
+              in
+              self#insert_move_args rarg loc_arg stack_ofs;
+              self#maybe_emit_spacetime_move ~spacetime_reg;
+              self#insert_debug (Iop new_op) dbg
+                          (Array.append [|r1.(0)|] loc_arg) loc_res;
+              self#insert_move_results loc_res rd stack_ofs;
+              Some rd
+          | Icall_imm _ ->
+              let r1 = self#emit_tuple env new_args in
+              let rd = self#regs_for ty in
+              let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
+              let loc_res = Proc.loc_results rd in
+              let spacetime_reg =
+                self#about_to_emit_call env (Iop new_op) [| |]
+              in
+              self#insert_move_args r1 loc_arg stack_ofs;
+              self#maybe_emit_spacetime_move ~spacetime_reg;
+              self#insert_debug (Iop new_op) dbg loc_arg loc_res;
+              self#insert_move_results loc_res rd stack_ofs;
+              Some rd
+          | Iextcall _ ->
+              let spacetime_reg =
+                self#about_to_emit_call env (Iop new_op) [| |]
+              in
+              let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in
+              self#maybe_emit_spacetime_move ~spacetime_reg;
+              let rd = self#regs_for ty in
+              let loc_res =
+                self#insert_op_debug new_op dbg
+                  loc_arg (Proc.loc_external_results rd) in
+              self#insert_move_results loc_res rd stack_ofs;
+              Some rd
+          | Ialloc { words = _; spacetime_index; label_after_call_gc; } ->
+              let rd = self#regs_for typ_val in
+              let size = size_expr env (Ctuple new_args) in
+              let op =
+                Ialloc { words = size; spacetime_index; label_after_call_gc; }
+              in
+              let args = self#select_allocation_args env in
+              self#insert_debug (Iop op) dbg args rd;
+              self#emit_stores env new_args rd;
+              Some rd
+          | op ->
+              let r1 = self#emit_tuple env new_args in
+              let rd = self#regs_for ty in
+              Some (self#insert_op_debug op dbg r1 rd)
+      end
+  | Csequence(e1, e2) ->
+      begin match self#emit_expr env e1 with
+        None -> None
+      | Some _ -> self#emit_expr env e2
+      end
+  | Cifthenelse(econd, eif, eelse) ->
+      let (cond, earg) = self#select_condition econd in
+      begin match self#emit_expr env earg with
+        None -> None
+      | Some rarg ->
+          let (rif, sif) = self#emit_sequence env eif in
+          let (relse, selse) = self#emit_sequence env eelse in
+          let r = join rif sif relse selse in
+          self#insert (Iifthenelse(cond, sif#extract, selse#extract))
+                      rarg [||];
+          r
+      end
+  | Cswitch(esel, index, ecases, _dbg) ->
+      begin match self#emit_expr env esel with
+        None -> None
+      | Some rsel ->
+          let rscases = Array.map (self#emit_sequence env) ecases in
+          let r = join_array rscases in
+          self#insert (Iswitch(index,
+                               Array.map (fun (_, s) -> s#extract) rscases))
+                      rsel [||];
+          r
+      end
+  | Cloop(ebody) ->
+      let (_rarg, sbody) = self#emit_sequence env ebody in
+      self#insert (Iloop(sbody#extract)) [||] [||];
+      Some [||]
+  | Ccatch(_, [], e1) ->
+      self#emit_expr env e1
+  | Ccatch(rec_flag, handlers, body) ->
+      let handlers =
+        List.map (fun (nfail, ids, e2) ->
+            let rs =
+              List.map
+                (* CR-someday mshinwell: consider how we can do better than
+                   [typ_val] when appropriate. *)
+                (fun id -> let r = self#regs_for typ_val in name_regs id r; r)
+                ids in
+            (nfail, ids, rs, e2))
+          handlers
+      in
+      let env =
+        (* Since the handlers may be recursive, and called from the body,
+           the same environment is used for translating both the handlers and
+           the body. *)
+        List.fold_left (fun env (nfail, _ids, rs, _e2) ->
+            env_add_static_exception nfail rs env)
+          env handlers
+      in
+      let (r_body, s_body) = self#emit_sequence env body in
+      let translate_one_handler (nfail, ids, rs, e2) =
+        assert(List.length ids = List.length rs);
+        let new_env =
+          List.fold_left (fun env (id, r) -> env_add id r env)
+            env (List.combine ids rs)
+        in
+        let (r, s) = self#emit_sequence new_env e2 in
+        (nfail, (r, s))
+      in
+      let l = List.map translate_one_handler handlers in
+      let a = Array.of_list ((r_body, s_body) :: List.map snd l) in
+      let r = join_array a in
+      let aux (nfail, (_r, s)) = (nfail, s#extract) in
+      self#insert (Icatch (rec_flag, List.map aux l, s_body#extract)) [||] [||];
+      r
+  | Cexit (nfail,args) ->
+      begin match self#emit_parts_list env args with
+        None -> None
+      | Some (simple_list, ext_env) ->
+          let src = self#emit_tuple ext_env simple_list in
+          let dest_args =
+            try env_find_static_exception nfail env
+            with Not_found ->
+              fatal_error ("Selection.emit_expr: unboun label "^
+                           string_of_int nfail)
+          in
+          (* Intermediate registers to handle cases where some
+             registers from src are present in dest *)
+          let tmp_regs = Reg.createv_like src in
+          (* Ccatch registers are created with type Val. They must not
+             contain out of heap pointers *)
+          Array.iter (fun reg -> assert(reg.typ <> Addr)) src;
+          self#insert_moves src tmp_regs ;
+          self#insert_moves tmp_regs (Array.concat dest_args) ;
+          self#insert (Iexit nfail) [||] [||];
+          None
+      end
+  | Ctrywith(e1, v, e2) ->
+      let (r1, s1) = self#emit_sequence env e1 in
+      let rv = self#regs_for typ_val in
+      let (r2, s2) = self#emit_sequence (env_add v rv env) e2 in
+      let r = join r1 s1 r2 s2 in
+      self#insert
+        (Itrywith(s1#extract,
+                  instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv
+                             (s2#extract)))
+        [||] [||];
+      r
+
+method private emit_sequence (env:environment) exp =
+  let s = {< instr_seq = dummy_instr >} in
+  let r = s#emit_expr env exp in
+  (r, s)
+
+method private bind_let (env:environment) v r1 =
+  if all_regs_anonymous r1 then begin
+    name_regs v r1;
+    env_add v r1 env
+  end else begin
+    let rv = Reg.createv_like r1 in
+    name_regs v rv;
+    self#insert_moves r1 rv;
+    env_add v rv env
+  end
+
+(* The following two functions, [emit_parts] and [emit_parts_list], force
+   right-to-left evaluation order as required by the Flambda [Un_anf] pass
+   (and to be consistent with the bytecode compiler). *)
+
+method private emit_parts (env:environment) ~effects_after exp =
+  let module EC = Effect_and_coeffect in
+  let may_defer_evaluation =
+    let ec = self#effects_of exp in
+    match EC.effect ec with
+    | Effect.Arbitrary | Effect.Raise ->
+      (* Preserve the ordering of effectful expressions by evaluating them
+         early (in the correct order) and assigning their results to
+         temporaries.  We can avoid this in just one case: if we know that
+         every [exp'] in the original expression list (cf. [emit_parts_list])
+         to be evaluated after [exp] cannot possibly affect the result of
+         [exp] or depend on the result of [exp], then [exp] may be deferred.
+         (Checking purity here is not enough: we need to check copurity too
+         to avoid e.g. moving mutable reads earlier than the raising of
+         an exception.) *)
+      EC.pure_and_copure effects_after
+    | Effect.None ->
+      match EC.coeffect ec with
+      | Coeffect.None ->
+        (* Pure expressions may be moved. *)
+        true
+      | Coeffect.Read_mutable -> begin
+        (* Read-mutable expressions may only be deferred if evaluation of
+           every [exp'] (for [exp'] as in the comment above) has no effects
+           "worse" (in the sense of the ordering in [Effect.t]) than raising
+           an exception. *)
+        match EC.effect effects_after with
+        | Effect.None | Effect.Raise -> true
+        | Effect.Arbitrary -> false
+      end
+      | Coeffect.Arbitrary -> begin
+        (* Arbitrary expressions may only be deferred if evaluation of
+           every [exp'] (for [exp'] as in the comment above) has no effects. *)
+        match EC.effect effects_after with
+        | Effect.None -> true
+        | Effect.Arbitrary | Effect.Raise -> false
+      end
+  in
+  (* Even though some expressions may look like they can be deferred from
+     the (co)effect analysis, it may be forbidden to move them. *)
+  if may_defer_evaluation && self#is_simple_expr exp then
+    Some (exp, env)
+  else begin
+    match self#emit_expr env exp with
+      None -> None
+    | Some r ->
+        if Array.length r = 0 then
+          Some (Ctuple [], env)
+        else begin
+          (* The normal case *)
+          let id = Ident.create "bind" in
+          if all_regs_anonymous r then
+            (* r is an anonymous, unshared register; use it directly *)
+            Some (Cvar id, env_add id r env)
+          else begin
+            (* Introduce a fresh temp to hold the result *)
+            let tmp = Reg.createv_like r in
+            self#insert_moves r tmp;
+            Some (Cvar id, env_add id tmp env)
+          end
+        end
+  end
+
+method private emit_parts_list (env:environment) exp_list =
+  let module EC = Effect_and_coeffect in
+  let exp_list_right_to_left, _effect =
+    (* Annotate each expression with the (co)effects that happen after it
+       when the original expression list is evaluated from right to left.
+       The resulting expression list has the rightmost expression first. *)
+    List.fold_left (fun (exp_list, effects_after) exp ->
+        let exp_effect = self#effects_of exp in
+        (exp, effects_after)::exp_list, EC.join exp_effect effects_after)
+      ([], EC.none)
+      exp_list
+  in
+  List.fold_left (fun results_and_env (exp, effects_after) ->
+      match results_and_env with
+      | None -> None
+      | Some (result, env) ->
+          match self#emit_parts env exp ~effects_after with
+          | None -> None
+          | Some (exp_result, env) -> Some (exp_result :: result, env))
+    (Some ([], env))
+    exp_list_right_to_left
+
+method private emit_tuple_not_flattened env exp_list =
+  let rec emit_list = function
+    [] -> []
+  | exp :: rem ->
+      (* Again, force right-to-left evaluation *)
+      let loc_rem = emit_list rem in
+      match self#emit_expr env exp with
+        None -> assert false  (* should have been caught in emit_parts *)
+      | Some loc_exp -> loc_exp :: loc_rem
+  in
+  emit_list exp_list
+
+method private emit_tuple env exp_list =
+  Array.concat (self#emit_tuple_not_flattened env exp_list)
+
+method emit_extcall_args env args =
+  let args = self#emit_tuple_not_flattened env args in
+  let arg_hard_regs, stack_ofs =
+    Proc.loc_external_arguments (Array.of_list args)
+  in
+  (* Flattening [args] and [arg_hard_regs] causes parts of values split
+     across multiple registers to line up correctly, by virtue of the
+     semantics of [split_int64_for_32bit_target] in cmmgen.ml, and the
+     required semantics of [loc_external_arguments] (see proc.mli). *)
+  let args = Array.concat args in
+  let arg_hard_regs = Array.concat (Array.to_list arg_hard_regs) in
+  self#insert_move_args args arg_hard_regs stack_ofs;
+  arg_hard_regs, stack_ofs
+
+method emit_stores env data regs_addr =
+  let a =
+    ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in
+  List.iter
+    (fun e ->
+      let (op, arg) = self#select_store false !a e in
+      match self#emit_expr env arg with
+        None -> assert false
+      | Some regs ->
+          match op with
+            Istore(_, _, _) ->
+              for i = 0 to Array.length regs - 1 do
+                let r = regs.(i) in
+                let kind = if r.typ = Float then Double_u else Word_val in
+                self#insert (Iop(Istore(kind, !a, false)))
+                            (Array.append [|r|] regs_addr) [||];
+                a := Arch.offset_addressing !a (size_component r.typ)
+              done
+          | _ ->
+              self#insert (Iop op) (Array.append regs regs_addr) [||];
+              a := Arch.offset_addressing !a (size_expr env e))
+    data
+
+(* Same, but in tail position *)
+
+method private emit_return (env:environment) exp =
+  match self#emit_expr env exp with
+    None -> ()
+  | Some r ->
+      let loc = Proc.loc_results r in
+      self#insert_moves r loc;
+      self#insert Ireturn loc [||]
+
+method emit_tail (env:environment) exp =
+  match exp with
+    Clet(v, e1, e2) ->
+      begin match self#emit_expr env e1 with
+        None -> ()
+      | Some r1 -> self#emit_tail (self#bind_let env v r1) e2
+      end
+  | Cop((Capply ty) as op, args, dbg) ->
+      begin match self#emit_parts_list env args with
+        None -> ()
+      | Some(simple_args, env) ->
+          let (new_op, new_args) = self#select_operation op simple_args dbg in
+          match new_op with
+            Icall_ind { label_after; } ->
+              let r1 = self#emit_tuple env new_args in
+              let rarg = Array.sub r1 1 (Array.length r1 - 1) in
+              let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
+              if stack_ofs = 0 then begin
+                let call = Iop (Itailcall_ind { label_after; }) in
+                let spacetime_reg =
+                  self#about_to_emit_call env call [| r1.(0) |]
+                in
+                self#insert_moves rarg loc_arg;
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug call dbg
+                            (Array.append [|r1.(0)|] loc_arg) [||];
+              end else begin
+                let rd = self#regs_for ty in
+                let loc_res = Proc.loc_results rd in
+                let spacetime_reg =
+                  self#about_to_emit_call env (Iop new_op) [| r1.(0) |]
+                in
+                self#insert_move_args rarg loc_arg stack_ofs;
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug (Iop new_op) dbg
+                            (Array.append [|r1.(0)|] loc_arg) loc_res;
+                self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
+                self#insert Ireturn loc_res [||]
+              end
+          | Icall_imm { func; label_after; } ->
+              let r1 = self#emit_tuple env new_args in
+              let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
+              if stack_ofs = 0 then begin
+                let call = Iop (Itailcall_imm { func; label_after; }) in
+                let spacetime_reg =
+                  self#about_to_emit_call env call [| |]
+                in
+                self#insert_moves r1 loc_arg;
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug call dbg loc_arg [||];
+              end else if func = !current_function_name then begin
+                let call = Iop (Itailcall_imm { func; label_after; }) in
+                let loc_arg' = Proc.loc_parameters r1 in
+                let spacetime_reg =
+                  self#about_to_emit_call env call [| |]
+                in
+                self#insert_moves r1 loc_arg';
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug call dbg loc_arg' [||];
+              end else begin
+                let rd = self#regs_for ty in
+                let loc_res = Proc.loc_results rd in
+                let spacetime_reg =
+                  self#about_to_emit_call env (Iop new_op) [| |]
+                in
+                self#insert_move_args r1 loc_arg stack_ofs;
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug (Iop new_op) dbg loc_arg loc_res;
+                self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
+                self#insert Ireturn loc_res [||]
+              end
+          | _ -> fatal_error "Selection.emit_tail"
+      end
+  | Csequence(e1, e2) ->
+      begin match self#emit_expr env e1 with
+        None -> ()
+      | Some _ -> self#emit_tail env e2
+      end
+  | Cifthenelse(econd, eif, eelse) ->
+      let (cond, earg) = self#select_condition econd in
+      begin match self#emit_expr env earg with
+        None -> ()
+      | Some rarg ->
+          self#insert (Iifthenelse(cond, self#emit_tail_sequence env eif,
+                                         self#emit_tail_sequence env eelse))
+                      rarg [||]
+      end
+  | Cswitch(esel, index, ecases, _dbg) ->
+      begin match self#emit_expr env esel with
+        None -> ()
+      | Some rsel ->
+          self#insert
+            (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases))
+            rsel [||]
+      end
+  | Ccatch(_, [], e1) ->
+      self#emit_tail env e1
+  | Ccatch(rec_flag, handlers, e1) ->
+      let handlers =
+        List.map (fun (nfail, ids, e2) ->
+            let rs =
+              List.map
+                (fun id -> let r = self#regs_for typ_val in name_regs id r; r)
+                ids in
+            (nfail, ids, rs, e2))
+          handlers in
+      let env =
+        List.fold_left (fun env (nfail, _ids, rs, _e2) ->
+            env_add_static_exception nfail rs env)
+          env handlers in
+      let s_body = self#emit_tail_sequence env e1 in
+      let aux (nfail, ids, rs, e2) =
+        assert(List.length ids = List.length rs);
+        let new_env =
+          List.fold_left
+            (fun env (id,r) -> env_add id r env)
+            env (List.combine ids rs) in
+        nfail, self#emit_tail_sequence new_env e2
+      in
+      self#insert (Icatch(rec_flag, List.map aux handlers, s_body)) [||] [||]
+  | Ctrywith(e1, v, e2) ->
+      let (opt_r1, s1) = self#emit_sequence env e1 in
+      let rv = self#regs_for typ_val in
+      let s2 = self#emit_tail_sequence (env_add v rv env) e2 in
+      self#insert
+        (Itrywith(s1#extract,
+                  instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2))
+        [||] [||];
+      begin match opt_r1 with
+        None -> ()
+      | Some r1 ->
+          let loc = Proc.loc_results r1 in
+          self#insert_moves r1 loc;
+          self#insert Ireturn loc [||]
+      end
+  | _ ->
+      self#emit_return env exp
+
+method private emit_tail_sequence env exp =
+  let s = {< instr_seq = dummy_instr >} in
+  s#emit_tail env exp;
+  s#extract
+
+(* Insertion of the function prologue *)
+
+method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env:_ =
+  self#insert_moves loc_arg rarg;
+  None
+
+(* Sequentialization of a function definition *)
+
+method initial_env () = env_empty
+
+method emit_fundecl f =
+  Proc.contains_calls := false;
+  current_function_name := f.Cmm.fun_name;
+  let rargs =
+    List.map
+      (fun (id, ty) -> let r = self#regs_for ty in name_regs id r; r)
+      f.Cmm.fun_args in
+  let rarg = Array.concat rargs in
+  let loc_arg = Proc.loc_parameters rarg in
+  (* To make it easier to add the Spacetime instrumentation code, we
+     first emit the body and extract the resulting instruction sequence;
+     then we emit the prologue followed by any Spacetime instrumentation.  The
+     sequence resulting from extracting the latter (prologue + instrumentation)
+     together is then simply prepended to the body. *)
+  let env =
+    List.fold_right2
+      (fun (id, _ty) r env -> env_add id r env)
+      f.Cmm.fun_args rargs (self#initial_env ()) in
+  let spacetime_node_hole, env =
+    if not Config.spacetime then None, env
+    else begin
+      let reg = self#regs_for typ_int in
+      let node_hole = Ident.create "spacetime_node_hole" in
+      Some (node_hole, reg), env_add node_hole reg env
+    end
+  in
+  self#emit_tail env f.Cmm.fun_body;
+  let body = self#extract in
+  instr_seq <- dummy_instr;
+  let fun_spacetime_shape =
+    self#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env
+  in
+  let body = self#extract_core ~end_instr:body in
+  instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body;
+  { fun_name = f.Cmm.fun_name;
+    fun_args = loc_arg;
+    fun_body = body;
+    fun_fast = f.Cmm.fun_fast;
+    fun_dbg  = f.Cmm.fun_dbg;
+    fun_spacetime_shape;
+  }
+
+end
+
+(* Tail call criterion (estimated).  Assumes:
+- all arguments are of type "int" (always the case for OCaml function calls)
+- one extra argument representing the closure environment (conservative).
+*)
+
+let is_tail_call nargs =
+  assert (Reg.dummy.typ = Int);
+  let args = Array.make (nargs + 1) Reg.dummy in
+  let (_loc_arg, stack_ofs) = Proc.loc_arguments args in
+  stack_ofs = 0
+
+let _ =
+  Simplif.is_tail_native_heuristic := is_tail_call
+
+let reset () =
+  current_function_name := ""
diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
new file mode 100644
index 00000000..6ab3c215
--- /dev/null
+++ b/asmcomp/selectgen.mli
@@ -0,0 +1,176 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Selection of pseudo-instructions, assignment of pseudo-registers,
+   sequentialization. *)
+
+type environment
+
+val env_add : Ident.t -> Reg.t array -> environment -> environment
+
+val env_find : Ident.t -> environment -> Reg.t array
+
+val size_expr : environment -> Cmm.expression -> int
+
+module Effect : sig
+  type t =
+    | None
+    | Raise
+    | Arbitrary
+end
+
+module Coeffect : sig
+  type t =
+    | None
+    | Read_mutable
+    | Arbitrary
+end
+
+module Effect_and_coeffect : sig
+  type t
+
+  val none : t
+  val arbitrary : t
+
+  val effect : t -> Effect.t
+  val coeffect : t -> Coeffect.t
+
+  val effect_only : Effect.t -> t
+  val coeffect_only : Coeffect.t -> t
+
+  val join : t -> t -> t
+  val join_list_map : 'a list -> ('a -> t) -> t
+end
+
+class virtual selector_generic : object
+  (* The following methods must or can be overridden by the processor
+     description *)
+  method virtual is_immediate : int -> bool
+    (* Must be defined to indicate whether a constant is a suitable
+       immediate operand to arithmetic instructions *)
+  method virtual select_addressing :
+    Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
+    (* Must be defined to select addressing modes *)
+  method is_simple_expr: Cmm.expression -> bool
+  method effects_of : Cmm.expression -> Effect_and_coeffect.t
+    (* Can be overridden to reflect special extcalls known to be pure *)
+  method select_operation :
+    Cmm.operation ->
+    Cmm.expression list ->
+    Debuginfo.t ->
+    Mach.operation * Cmm.expression list
+    (* Can be overridden to deal with special arithmetic instructions *)
+  method select_condition : Cmm.expression -> Mach.test * Cmm.expression
+    (* Can be overridden to deal with special test instructions *)
+  method select_store :
+    bool -> Arch.addressing_mode -> Cmm.expression ->
+                                         Mach.operation * Cmm.expression
+    (* Can be overridden to deal with special store constant instructions *)
+  method regs_for : Cmm.machtype -> Reg.t array
+    (* Return an array of fresh registers of the given type.
+       Default implementation is like Reg.createv.
+       Can be overridden if float values are stored as pairs of
+       integer registers. *)
+  method insert_op :
+    Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array
+    (* Can be overridden to deal with 2-address instructions
+       or instructions with hardwired input/output registers *)
+  method insert_op_debug :
+    Mach.operation -> Debuginfo.t -> Reg.t array -> Reg.t array -> Reg.t array
+    (* Can be overridden to deal with 2-address instructions
+       or instructions with hardwired input/output registers *)
+  method emit_extcall_args :
+    environment -> Cmm.expression list -> Reg.t array * int
+    (* Can be overridden to deal with stack-based calling conventions *)
+  method emit_stores :
+    environment -> Cmm.expression list -> Reg.t array -> unit
+    (* Fill a freshly allocated block.  Can be overridden for architectures
+       that do not provide Arch.offset_addressing. *)
+
+  method mark_call : unit
+  (* informs the code emitter that the current function is non-leaf:
+     it may perform a (non-tail) call; by default, sets
+     [Proc.contains_calls := true] *)
+
+  method mark_tailcall : unit
+  (* informs the code emitter that the current function may end with
+     a tail-call; by default, does nothing *)
+
+  method mark_c_tailcall : unit
+  (* informs the code emitter that the current function may call
+     a C function that never returns; by default, does nothing.
+
+     It is unecessary to save the stack pointer in this situation
+     (which is the main purpose of tracking leaf functions) but some
+     architectures still need to ensure that the stack is properly
+     aligned when the C function is called. This is achieved by
+     overloading this method to set [Proc.contains_calls := true] *)
+
+  method mark_instr : Mach.instruction_desc -> unit
+  (* dispatches on instructions to call one of the marking function
+     above; overloading this is useful if Ispecific instructions need
+     marking *)
+
+  (* The following method is the entry point and should not be overridden
+     (except by [Spacetime_profiling]). *)
+  method emit_fundecl : Cmm.fundecl -> Mach.fundecl
+
+  (* The following methods should not be overridden.  They cannot be
+     declared "private" in the current implementation because they
+     are not always applied to "self", but ideally they should be private. *)
+  method extract : Mach.instruction
+  method extract_core : end_instr:Mach.instruction -> Mach.instruction
+  method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit
+  method insert_debug : Mach.instruction_desc -> Debuginfo.t ->
+                                        Reg.t array -> Reg.t array -> unit
+  method insert_move : Reg.t -> Reg.t -> unit
+  method insert_move_args : Reg.t array -> Reg.t array -> int -> unit
+  method insert_move_results : Reg.t array -> Reg.t array -> int -> unit
+  method insert_moves : Reg.t array -> Reg.t array -> unit
+  method adjust_type : Reg.t -> Reg.t -> unit
+  method adjust_types : Reg.t array -> Reg.t array -> unit
+  method emit_expr :
+    environment -> Cmm.expression -> Reg.t array option
+  method emit_tail : environment -> Cmm.expression -> unit
+
+  (* Only for the use of [Spacetime_profiling]. *)
+  method select_allocation : int -> Mach.operation
+  method select_allocation_args : environment -> Reg.t array
+  method select_checkbound : unit -> Mach.integer_operation
+  method select_checkbound_extra_args : unit -> Cmm.expression list
+  method emit_blockheader
+     : environment
+    -> nativeint
+    -> Debuginfo.t
+    -> Reg.t array option
+  method about_to_emit_call
+     : environment
+    -> Mach.instruction_desc
+    -> Reg.t array
+    -> Reg.t array option
+  method initial_env : unit -> environment
+  method insert_prologue
+     : Cmm.fundecl
+    -> loc_arg:Reg.t array
+    -> rarg:Reg.t array
+    -> spacetime_node_hole:(Ident.t * Reg.t array) option
+    -> env:environment
+    -> Mach.spacetime_shape option
+
+  val mutable instr_seq : Mach.instruction
+
+end
+
+val reset : unit -> unit
diff --git a/asmcomp/selection.mli b/asmcomp/selection.mli
new file mode 100644
index 00000000..3c055fe0
--- /dev/null
+++ b/asmcomp/selection.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Selection of pseudo-instructions, assignment of pseudo-registers,
+   sequentialization. *)
+
+val fundecl: Cmm.fundecl -> Mach.fundecl
diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml
new file mode 100644
index 00000000..b6786c1d
--- /dev/null
+++ b/asmcomp/spacetime_profiling.ml
@@ -0,0 +1,431 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let node_num_header_words = 2 (* [Node_num_header_words] in the runtime. *)
+let index_within_node = ref node_num_header_words
+(* The [lazy]s are to ensure that we don't create [Ident.t]s at toplevel
+   when not using Spacetime profiling.  (This could cause stamps to differ
+   between bytecode and native .cmis when no .mli is present, e.g.
+   arch.ml.) *)
+let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create "dummy")))
+let spacetime_node_ident = ref (lazy (Ident.create "dummy"))
+let current_function_label = ref ""
+let direct_tail_call_point_indexes = ref []
+
+let reverse_shape = ref ([] : Mach.spacetime_shape)
+
+let something_was_instrumented () =
+  !index_within_node > node_num_header_words
+
+let next_index_within_node ~part_of_shape ~label =
+  let index = !index_within_node in
+  begin match part_of_shape with
+  | Mach.Direct_call_point _ | Mach.Indirect_call_point ->
+    incr index_within_node
+  | Mach.Allocation_point ->
+    incr index_within_node;
+    incr index_within_node;
+    incr index_within_node
+  end;
+  reverse_shape := (part_of_shape, label) :: !reverse_shape;
+  index
+
+let reset ~spacetime_node_ident:ident ~function_label =
+  index_within_node := node_num_header_words;
+  spacetime_node := lazy (Cmm.Cvar ident);
+  spacetime_node_ident := lazy ident;
+  direct_tail_call_point_indexes := [];
+  current_function_label := function_label;
+  reverse_shape := []
+
+let code_for_function_prologue ~function_name ~node_hole =
+  let node = Ident.create "node" in
+  let new_node = Ident.create "new_node" in
+  let must_allocate_node = Ident.create "must_allocate_node" in
+  let is_new_node = Ident.create "is_new_node" in
+  let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in
+  let dbg = Debuginfo.none in
+  let open Cmm in
+  let initialize_direct_tail_call_points_and_return_node =
+    let new_node_encoded = Ident.create "new_node_encoded" in
+    (* The callee node pointers within direct tail call points must initially
+       point back at the start of the current node and be marked as per
+       [Encode_tail_caller_node] in the runtime. *)
+    let indexes = !direct_tail_call_point_indexes in
+    let body =
+      List.fold_left (fun init_code index ->
+          (* Cf. [Direct_callee_node] in the runtime. *)
+          let offset_in_bytes = index * Arch.size_addr in
+          Csequence (
+            Cop (Cstore (Word_int, Lambda.Assignment),
+              [Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes], dbg);
+               Cvar new_node_encoded], dbg),
+            init_code))
+        (Cvar new_node)
+        indexes
+    in
+    match indexes with
+    | [] -> body
+    | _ ->
+      Clet (new_node_encoded,
+        (* Cf. [Encode_tail_caller_node] in the runtime. *)
+        Cop (Cor, [Cvar new_node; Cconst_int 1], dbg),
+        body)
+  in
+  let pc = Ident.create "pc" in
+  Clet (node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
+    Clet (must_allocate_node,
+      Cop (Cand, [Cvar node; Cconst_int 1], dbg),
+      Cifthenelse (
+        Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg),
+        Cvar node,
+        Clet (is_new_node,
+          Clet (pc, Cconst_symbol function_name,
+            Cop (Cextcall ("caml_spacetime_allocate_node",
+                [| Int |], false, None),
+              [Cconst_int (1 (* header *) + !index_within_node);
+               Cvar pc;
+               Cvar node_hole;
+              ],
+              dbg)),
+            Clet (new_node,
+              Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
+              if no_tail_calls then Cvar new_node
+              else
+                Cifthenelse (
+                  Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg),
+                  Cvar new_node,
+                  initialize_direct_tail_call_points_and_return_node))))))
+
+let code_for_blockheader ~value's_header ~node ~dbg =
+  let num_words = Nativeint.shift_right_logical value's_header 10 in
+  let existing_profinfo = Ident.create "existing_profinfo" in
+  let existing_count = Ident.create "existing_count" in
+  let profinfo = Ident.create "profinfo" in
+  let address_of_profinfo = Ident.create "address_of_profinfo" in
+  let label = Cmm.new_label () in
+  let index_within_node =
+    next_index_within_node ~part_of_shape:Mach.Allocation_point ~label
+  in
+  let offset_into_node = Arch.size_addr * index_within_node in
+  let open Cmm in
+  let generate_new_profinfo =
+    (* This will generate a static branch to a function that should usually
+       be in the cache, which hopefully gives a good code size/performance
+       balance.
+       The "Some label" is important: it provides the link between the shape
+       table, the allocation point, and the frame descriptor table---enabling
+       the latter table to be used for resolving a program counter at such
+       a point to a location.
+    *)
+    Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |],
+        false, Some label),
+      [Cvar address_of_profinfo;
+       Cconst_int (index_within_node + 1)],
+      dbg)
+  in
+  (* Check if we have already allocated a profinfo value for this allocation
+     point with the current backtrace.  If so, use that value; if not,
+     allocate a new one. *)
+  Clet (address_of_profinfo,
+    Cop (Caddi, [
+      Cvar node;
+      Cconst_int offset_into_node;
+    ], dbg),
+    Clet (existing_profinfo,
+        Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo],
+          dbg),
+      Clet (profinfo,
+        Cifthenelse (
+          Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)], dbg),
+          Cvar existing_profinfo,
+          generate_new_profinfo),
+        Clet (existing_count,
+          Cop (Cload (Word_int, Asttypes.Mutable), [
+            Cop (Caddi,
+              [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg)
+          ], dbg),
+          Csequence (
+            Cop (Cstore (Word_int, Lambda.Assignment),
+              [Cop (Caddi,
+                [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg);
+                Cop (Caddi, [
+                  Cvar existing_count;
+                  (* N.B. "*2" since the count is an OCaml integer.
+                     The "1 +" is to count the value's header. *)
+                  Cconst_int (2 * (1 + Nativeint.to_int num_words));
+                ], dbg);
+              ], dbg),
+            (* [profinfo] looks like a black [Infix_tag] header.  Instead of
+               having to mask [profinfo] before ORing it with the desired
+               header, we can use an XOR trick, to keep code size down. *)
+            let value's_header =
+              Nativeint.logxor value's_header
+                (Nativeint.logor
+                  ((Nativeint.logor (Nativeint.of_int Obj.infix_tag)
+                    (Nativeint.shift_left 3n (* <- Caml_black *) 8)))
+                  (Nativeint.shift_left
+                    (* The following is the [Infix_offset_val], in words. *)
+                    (Nativeint.of_int (index_within_node + 1)) 10))
+            in
+            Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header], dbg))))))
+
+type callee =
+  | Direct of string
+  | Indirect of Cmm.expression
+
+let code_for_call ~node ~callee ~is_tail ~label =
+  (* We treat self recursive calls as tail calls to avoid blow-ups in the
+     graph. *)
+  let is_self_recursive_call =
+    match callee with
+    | Direct callee -> callee = !current_function_label
+    | Indirect _ -> false
+  in
+  let is_tail = is_tail || is_self_recursive_call in
+  let index_within_node =
+    match callee with
+    | Direct callee ->
+      next_index_within_node
+        ~part_of_shape:(Mach.Direct_call_point { callee; })
+        ~label
+    | Indirect _ ->
+      next_index_within_node ~part_of_shape:Mach.Indirect_call_point ~label
+  in
+  begin match callee with
+    (* If this is a direct tail call point, we need to note down its index,
+       so the correct initialization code can be emitted in the prologue. *)
+    | Direct _ when is_tail ->
+      direct_tail_call_point_indexes :=
+        index_within_node::!direct_tail_call_point_indexes
+    | Direct _ | Indirect _ -> ()
+  end;
+  let place_within_node = Ident.create "place_within_node" in
+  let dbg = Debuginfo.none in
+  let open Cmm in
+  Clet (place_within_node,
+    Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)], dbg),
+    (* The following code returns the address that is to be moved into the
+       (hard) node hole pointer register immediately before the call.
+       (That move is inserted in [Selectgen].) *)
+    match callee with
+    | Direct _callee -> Cvar place_within_node
+    | Indirect callee ->
+      let caller_node =
+        if is_tail then node
+        else Cconst_int 1  (* [Val_unit] *)
+      in
+      Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr",
+          [| Int |], false, None),
+        [callee; Cvar place_within_node; caller_node],
+        dbg))
+
+class virtual instruction_selection = object (self)
+  inherit Selectgen.selector_generic as super
+
+  (* [disable_instrumentation] ensures that we don't try to instrument the
+     instrumentation... *)
+  val mutable disable_instrumentation = false
+
+  method private instrument_direct_call ~env ~func ~is_tail ~label_after =
+    let instrumentation =
+      code_for_call
+        ~node:(Lazy.force !spacetime_node)
+        ~callee:(Direct func)
+        ~is_tail
+        ~label:label_after
+    in
+    match self#emit_expr env instrumentation with
+    | None -> assert false
+    | Some reg -> Some reg
+
+  method private instrument_indirect_call ~env ~callee ~is_tail
+      ~label_after =
+    (* [callee] is a pseudoregister, so we have to bind it in the environment
+       and reference the variable to which it is bound. *)
+    let callee_ident = Ident.create "callee" in
+    let env = Selectgen.env_add callee_ident [| callee |] env in
+    let instrumentation =
+      code_for_call
+        ~node:(Lazy.force !spacetime_node)
+        ~callee:(Indirect (Cmm.Cvar callee_ident))
+        ~is_tail
+        ~label:label_after
+    in
+    match self#emit_expr env instrumentation with
+    | None -> assert false
+    | Some reg -> Some reg
+
+  method private can_instrument () =
+    Config.spacetime && not disable_instrumentation
+
+  method! about_to_emit_call env desc arg =
+    if not (self#can_instrument ()) then None
+    else
+      let module M = Mach in
+      match desc with
+      | M.Iop (M.Icall_imm { func; label_after; }) ->
+        assert (Array.length arg = 0);
+        self#instrument_direct_call ~env ~func ~is_tail:false ~label_after
+      | M.Iop (M.Icall_ind { label_after; }) ->
+        assert (Array.length arg = 1);
+        self#instrument_indirect_call ~env ~callee:arg.(0)
+          ~is_tail:false ~label_after
+      | M.Iop (M.Itailcall_imm { func; label_after; }) ->
+        assert (Array.length arg = 0);
+        self#instrument_direct_call ~env ~func ~is_tail:true ~label_after
+      | M.Iop (M.Itailcall_ind { label_after; }) ->
+        assert (Array.length arg = 1);
+        self#instrument_indirect_call ~env ~callee:arg.(0)
+          ~is_tail:true ~label_after
+      | M.Iop (M.Iextcall { func; alloc = true; label_after; }) ->
+        (* N.B. No need to instrument "noalloc" external calls. *)
+        assert (Array.length arg = 0);
+        self#instrument_direct_call ~env ~func ~is_tail:false ~label_after
+      | _ -> None
+
+  method private instrument_blockheader ~env ~value's_header ~dbg =
+    let instrumentation =
+      code_for_blockheader
+        ~node:(Lazy.force !spacetime_node_ident)
+        ~value's_header ~dbg
+    in
+    self#emit_expr env instrumentation
+
+  method private emit_prologue f ~node_hole ~env =
+    (* We don't need the prologue unless we inserted some instrumentation.
+       This corresponds to adding the prologue if the function contains one
+       or more call or allocation points. *)
+    if something_was_instrumented () then begin
+      let prologue_cmm =
+        code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole
+      in
+      disable_instrumentation <- true;
+      let node_temp_reg =
+        match self#emit_expr env prologue_cmm with
+        | None ->
+          Misc.fatal_error "Spacetime prologue instruction \
+              selection did not yield a destination register"
+        | Some node_temp_reg -> node_temp_reg
+      in
+      disable_instrumentation <- false;
+      let node = Lazy.force !spacetime_node_ident in
+      let node_reg = Selectgen.env_find node env in
+      self#insert_moves node_temp_reg node_reg
+    end
+
+  method! emit_blockheader env n dbg =
+    if self#can_instrument () then begin
+      disable_instrumentation <- true;
+      let result = self#instrument_blockheader ~env ~value's_header:n ~dbg in
+      disable_instrumentation <- false;
+      result
+    end else begin
+      super#emit_blockheader env n dbg
+    end
+
+  method! select_allocation words =
+    if self#can_instrument () then begin
+      (* Leave space for a direct call point.  We cannot easily insert any
+         instrumentation code, so the fields are filled in instead by
+         [caml_spacetime_caml_garbage_collection]. *)
+      let label = Cmm.new_label () in
+      let index =
+        next_index_within_node
+          ~part_of_shape:(Mach.Direct_call_point { callee = "caml_call_gc"; })
+          ~label
+      in
+      Mach.Ialloc {
+        words;
+        label_after_call_gc = Some label;
+        spacetime_index = index;
+      }
+    end else begin
+      super#select_allocation words
+    end
+
+  method! select_allocation_args env =
+    if self#can_instrument () then begin
+      let regs = Selectgen.env_find (Lazy.force !spacetime_node_ident) env in
+      match regs with
+      | [| reg |] -> [| reg |]
+      | _ -> failwith "Expected one register only for spacetime_node_ident"
+    end else begin
+      super#select_allocation_args env
+    end
+
+  method! select_checkbound () =
+    (* This follows [select_allocation], above. *)
+    if self#can_instrument () then begin
+      let label = Cmm.new_label () in
+      let index =
+        next_index_within_node
+          ~part_of_shape:(
+            Mach.Direct_call_point { callee = "caml_ml_array_bound_error"; })
+          ~label
+      in
+      Mach.Icheckbound {
+        label_after_error = Some label;
+        spacetime_index = index;
+      }
+    end else begin
+      super#select_checkbound ()
+    end
+
+  method! select_checkbound_extra_args () =
+    if self#can_instrument () then begin
+      (* This follows [select_allocation_args], above. *)
+      [Cmm.Cvar (Lazy.force !spacetime_node_ident)]
+    end else begin
+      super#select_checkbound_extra_args ()
+    end
+
+  method! initial_env () =
+    let env = super#initial_env () in
+    if Config.spacetime then
+      Selectgen.env_add (Lazy.force !spacetime_node_ident)
+        (self#regs_for Cmm.typ_int) env
+    else
+      env
+
+  method! emit_fundecl f =
+    if Config.spacetime then begin
+      disable_instrumentation <- false;
+      let node = Ident.create "spacetime_node" in
+      reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name
+    end;
+    super#emit_fundecl f
+
+  method! insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env =
+    let fun_spacetime_shape =
+      super#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env
+    in
+    (* CR-soon mshinwell: add check to make sure the node size doesn't exceed
+       the chunk size of the allocator *)
+    if not Config.spacetime then fun_spacetime_shape
+    else begin
+      let node_hole, node_hole_reg =
+        match spacetime_node_hole with
+        | None -> assert false
+        | Some (node_hole, reg) -> node_hole, reg
+      in
+      self#insert_moves [| Proc.loc_spacetime_node_hole |] node_hole_reg;
+      self#emit_prologue f ~node_hole ~env;
+      match !reverse_shape with
+      | [] -> None
+      (* N.B. We do not reverse the shape list, since the function that
+         reconstructs it (caml_spacetime_shape_table) reverses it again. *)
+      | reverse_shape -> Some reverse_shape
+    end
+end
diff --git a/asmcomp/spacetime_profiling.mli b/asmcomp/spacetime_profiling.mli
new file mode 100644
index 00000000..16c69148
--- /dev/null
+++ b/asmcomp/spacetime_profiling.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Insertion of instrumentation code for Spacetime profiling. *)
+
+class virtual instruction_selection : Selectgen.selector_generic
diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml
new file mode 100644
index 00000000..7d246ba3
--- /dev/null
+++ b/asmcomp/sparc/CSE.ml
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CSE for Sparc *)
+
+open Mach
+open CSEgen
+
+class cse = object
+
+inherit cse_generic (* as super *)
+
+method! is_cheap_operation op =
+  match op with
+  | Iconst_int n -> n <= 4095n && n >= -4096n
+  | _ -> false
+
+end
+
+let fundecl f =
+  (new cse)#fundecl f
diff --git a/asmcomp/sparc/NOTES.md b/asmcomp/sparc/NOTES.md
new file mode 100644
index 00000000..18c3db4a
--- /dev/null
+++ b/asmcomp/sparc/NOTES.md
@@ -0,0 +1,17 @@
+# Supported platforms
+
+SPARC v8 and up, in 32-bit mode.
+
+Operating systems: Solaris, Linux
+  (abandoned since major Linux distributions no longer support SPARC).
+
+Status of this port: nearly abandoned
+  (no hardware or virtual machine available for testing).
+
+# Reference documents
+
+* Instruction set architecture:
+  _The SPARC Architecture Manual_ version 8.
+* ELF application binary interface:
+  _System V Application Binary Interface,
+   SPARC Processor Supplement_
diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml
new file mode 100644
index 00000000..1f7e2abd
--- /dev/null
+++ b/asmcomp/sparc/arch.ml
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Specific operations for the Sparc processor *)
+
+open Format
+
+(* SPARC V8 adds multiply and divide.
+   SPARC V9 adds double precision float operations, conditional
+   move, and more instructions that are only useful in 64 bit mode.
+   Sun calls 32 bit V9 "V8+". *)
+type arch_version = SPARC_V7 | SPARC_V8 | SPARC_V9
+
+let arch_version = ref SPARC_V7
+
+let command_line_options =
+  [ "-march=v8", Arg.Unit (fun () -> arch_version := SPARC_V8),
+        " Generate code for SPARC V8 processors";
+    "-march=v9", Arg.Unit (fun () -> arch_version := SPARC_V9),
+        " Generate code for SPARC V9 processors" ]
+
+type specific_operation = unit          (* None worth mentioning *)
+
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
+(* Addressing modes *)
+
+type addressing_mode =
+    Ibased of string * int              (* symbol + displ *)
+  | Iindexed of int                     (* reg + displ *)
+
+(* Sizes, endianness *)
+
+let big_endian = true
+
+let size_addr = 4
+let size_int = 4
+let size_float = 8
+
+let allow_unaligned_access = false
+
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
+(* Operations on addressing modes *)
+
+let identity_addressing = Iindexed 0
+
+let offset_addressing addr delta =
+  match addr with
+    Ibased(s, n) -> Ibased(s, n + delta)
+  | Iindexed n -> Iindexed(n + delta)
+
+let num_args_addressing = function
+    Ibased _ -> 0
+  | Iindexed _ -> 1
+
+(* Printing operations and addressing modes *)
+
+let print_addressing printreg addr ppf arg =
+  match addr with
+  | Ibased(s, n) ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "\"%s\"%s" s idx
+  | Iindexed n ->
+      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
+      fprintf ppf "%a%s" printreg arg.(0) idx
+
+let print_specific_operation _printreg _op _ppf _arg =
+  Misc.fatal_error "Arch_sparc.print_specific_operation"
diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
new file mode 100644
index 00000000..a4a50f94
--- /dev/null
+++ b/asmcomp/sparc/emit.mlp
@@ -0,0 +1,771 @@
+#2 "asmcomp/sparc/emit.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Emission of Sparc assembly code *)
+
+open Misc
+open Cmm
+open Arch
+open Proc
+open Reg
+open Mach
+open Linearize
+open Emitaux
+
+(* Solaris vs. the other ports *)
+
+let solaris = Config.system = "solaris"
+
+(* Tradeoff between code size and code speed *)
+
+let fastcode_flag = ref true
+
+(* Layout of the stack *)
+(* Always keep the stack 8-aligned.
+   Always leave 96 bytes at the bottom of the stack *)
+
+let stack_offset = ref 0
+
+let frame_size () =
+  let size =
+    !stack_offset +
+    4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
+    (if !contains_calls then 4 else 0) in
+  Misc.align size 8
+
+let slot_offset loc cl =
+  match loc with
+    Incoming n -> frame_size() + n + 96
+  | Local n ->
+      if cl = 0
+      then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + 96
+      else !stack_offset + n * 8 + 96
+  | Outgoing n -> n + 96
+
+(* Return the other register in a register pair *)
+
+let next_in_pair = function
+    {loc = Reg r; typ = (Int | Addr | Val)} -> phys_reg (r + 1)
+  | {loc = Reg r; typ = Float} -> phys_reg (r + 16)
+  | _ -> fatal_error "Emit.next_in_pair"
+
+(* Symbols are prefixed with _ under SunOS *)
+
+let symbol_prefix =
+  if Config.system = "sunos" then "_" else ""
+
+let emit_symbol s =
+  if String.length s >= 1 && s.[0] = '.'
+  then emit_string s
+  else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end
+
+let emit_size lbl =
+  if Config.system = "solaris" then
+    `	.size	{emit_symbol lbl},.-{emit_symbol lbl}\n`
+
+let rodata () =
+  if Config.system = "solaris" (* || Config.system = "linux" *)
+  (* || Config.system = "gnu" *) then
+    `	.section \".rodata\"\n`
+  else
+    `	.data\n`
+
+(* Check if an integer or native integer is an immediate operand *)
+
+let is_immediate n =
+  n <= 4095 && n >= -4096
+
+let is_native_immediate n =
+  n <= Nativeint.of_int 4095 && n >= Nativeint.of_int (-4096)
+
+(* Output a label *)
+
+let label_prefix =
+  if Config.system = "sunos" then "L" else ".L"
+
+let emit_label lbl =
+  emit_string label_prefix; emit_int lbl
+
+(* Output a pseudo-register *)
+
+let emit_reg r =
+  match r.loc with
+    Reg r -> emit_string (register_name r)
+  | _ -> fatal_error "Emit.emit_reg"
+
+(* Output a stack reference *)
+
+let emit_stack r =
+  match r.loc with
+    Stack s ->
+      let ofs = slot_offset s (register_class r) in `[%sp + {emit_int ofs}]`
+  | _ -> fatal_error "Emit.emit_stack"
+
+(* Output a load *)
+
+let emit_load instr addr arg dst =
+  match addr with
+    Ibased(s, 0) ->
+        `	sethi	%hi({emit_symbol s}), %g1\n`;
+        `	{emit_string instr}	[%g1 + %lo({emit_symbol s})], {emit_reg dst}\n`
+  | Ibased(s, ofs) ->
+        `	sethi	%hi({emit_symbol s} + {emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	[%g1 + %lo({emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n`
+  | Iindexed ofs ->
+      if is_immediate ofs then
+        `	{emit_string instr}	[{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n`
+      else begin
+        `	sethi	%hi({emit_int ofs}), %g1\n`;
+        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	[{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
+      end
+
+(* Output a store *)
+
+let emit_store instr addr arg src =
+  match addr with
+    Ibased(s, 0) ->
+        `	sethi	%hi({emit_symbol s}), %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [%g1 + %lo({emit_symbol s})]\n`
+  | Ibased(s, ofs) ->
+        `	sethi	%hi({emit_symbol s} + {emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [%g1 + %lo({emit_symbol s} + {emit_int ofs})]\n`
+  | Iindexed ofs ->
+      if is_immediate ofs then
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n`
+      else begin
+        `	sethi	%hi({emit_int ofs}), %g1\n`;
+        `	or	%g1, %lo({emit_int ofs}), %g1\n`;
+        `	{emit_string instr}	{emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
+      end
+
+(* Record live pointers at call points *)
+
+type frame_descr =
+  { fd_lbl: int;                        (* Return address *)
+    fd_frame_size: int;                 (* Size of stack frame *)
+    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
+
+let frame_descriptors = ref([] : frame_descr list)
+
+let record_frame ?label live =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
+  let live_offset = ref [] in
+  Reg.Set.iter
+    (function
+      | {typ = Val; loc = Reg r} ->
+          live_offset := ((r lsl 1) + 1) :: !live_offset
+      | {typ = Val; loc = Stack s} as reg ->
+          live_offset := slot_offset s (register_class reg) :: !live_offset
+      | {typ = Addr} as r ->
+          Misc.fatal_error ("bad GC root " ^ Reg.name r)
+      | _ -> ())
+    live;
+  live_offset := List.sort_uniq (-) !live_offset;
+  frame_descriptors :=
+    { fd_lbl = lbl;
+      fd_frame_size = frame_size();
+      fd_live_offset = !live_offset } :: !frame_descriptors;
+  `{emit_label lbl}:`
+
+let emit_frame fd =
+  `	.word	{emit_label fd.fd_lbl}\n`;
+  `	.half	{emit_int fd.fd_frame_size}\n`;
+  `	.half	{emit_int (List.length fd.fd_live_offset)}\n`;
+  List.iter
+    (fun n ->
+      `	.half	{emit_int n}\n`)
+    fd.fd_live_offset;
+  `	.align	4\n`
+
+(* Record floating-point constants *)
+
+let float_constants = ref ([] : (int * int64) list)
+
+let emit_float_constant (lbl, cst) =
+  rodata ();
+  `	.align	8\n`;
+  `{emit_label lbl}:`;
+  emit_float64_split_directive ".word" cst
+
+(* Emission of the profiling prelude *)
+let emit_profile () =
+  begin match Config.system with
+    "solaris" ->
+      let lbl = new_label() in
+      `	.section \".bss\"\n`;
+      `{emit_label lbl}:	.skip 4\n`;
+      `	.text\n`;
+      `	save	%sp,-96,%sp\n`;
+      `	sethi	%hi({emit_label lbl}),%o0\n`;
+      `	call	_mcount\n`;
+      `	or	%o0,%lo({emit_label lbl}),%o0\n`;
+      `	restore\n`
+  | _ -> ()
+  end
+
+(* Names of various instructions *)
+
+let name_for_int_operation = function
+    Iadd -> "add"
+  | Isub -> "sub"
+  | Iand -> "and"
+  | Ior -> "or"
+  | Ixor -> "xor"
+  | Ilsl -> "sll"
+  | Ilsr -> "srl"
+  | Iasr -> "sra"
+  | Imul -> "smul"
+  | _ -> Misc.fatal_error "Emit.name_for_int_operation"
+
+let name_for_float_operation = function
+    Inegf -> if !arch_version = SPARC_V9 then "fnegd" else "fnegs"
+  | Iabsf -> if !arch_version = SPARC_V9 then "fabsd" else "fabss"
+  | Iaddf -> "faddd"
+  | Isubf -> "fsubd"
+  | Imulf -> "fmuld"
+  | Idivf -> "fdivd"
+  | _ -> Misc.fatal_error "Emit.name_for_float_operation"
+
+let name_for_int_movcc = function
+    Isigned Ceq -> "e"	    | Isigned Cne -> "ne"
+  | Isigned Cle -> "le"	    | Isigned Cgt -> "g"
+  | Isigned Clt -> "l"	    | Isigned Cge -> "ge"
+  | Iunsigned Ceq -> "e"    | Iunsigned Cne -> "ne"
+  | Iunsigned Cle -> "leu"  | Iunsigned Cgt -> "gu"
+  | Iunsigned Clt -> "lu"   | Iunsigned Cge -> "geu"
+
+let name_for_int_comparison = function
+    Isigned Ceq -> "be"      | Isigned Cne -> "bne"
+  | Isigned Cle -> "ble"     | Isigned Cgt -> "bg"
+  | Isigned Clt -> "bl"      | Isigned Cge -> "bge"
+  | Iunsigned Ceq -> "be"    | Iunsigned Cne -> "bne"
+  | Iunsigned Cle -> "bleu"  | Iunsigned Cgt -> "bgu"
+  | Iunsigned Clt -> "blu"   | Iunsigned Cge -> "bgeu"
+
+let name_for_float_comparison cmp neg =
+  match cmp with
+    Ceq -> if neg then "fbne" else "fbe"
+  | Cne -> if neg then "fbe" else "fbne"
+  | Cle -> if neg then "fbug" else "fble"
+  | Cgt -> if neg then "fbule" else "fbg"
+  | Clt -> if neg then "fbuge" else "fbl"
+  | Cge -> if neg then "fbul" else "fbge"
+
+(* Output the assembly code for an instruction *)
+
+let function_name = ref ""
+let tailrec_entry_point = ref 0
+let range_check_trap = ref 0
+
+let rec emit_instr i dslot =
+    match i.desc with
+      Lend -> ()
+    | Lop(Imove | Ispill | Ireload) ->
+        let src = i.arg.(0) and dst = i.res.(0) in
+        begin match (src, dst) with
+            {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
+              `	mov	{emit_reg src}, {emit_reg dst}\n`
+          | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
+              if !arch_version = SPARC_V9 then
+                `	fmovd	{emit_reg src}, {emit_reg dst}\n`
+              else begin
+                `	fmovs	{emit_reg src}, {emit_reg dst}\n`;
+                `	fmovs	{emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n`
+              end
+          | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} ->
+              (* This happens when calling C functions and passing a float arg
+                 in %o0...%o5 *)
+              `	sub	%sp, 8, %sp\n`;
+              `	std	{emit_reg src}, [%sp + 96]\n`;
+              `	ld	[%sp + 96], {emit_reg dst}\n`;
+              let dst2 = i.res.(1) in
+              begin match dst2 with
+                | {loc = Reg _; typ = Int} ->
+                    `	ld	[%sp + 100], {emit_reg dst2}\n`;
+                | {loc = Stack _; typ = Int} ->
+                    `	ld	[%sp + 100], %g1\n`;
+                    `	st	%g1, {emit_stack dst2}\n`;
+                | _ ->
+                    fatal_error "Emit: Imove Float [| _; _ |]"
+              end;
+              `	add	%sp, 8, %sp\n`
+          | {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} ->
+              `	st	{emit_reg src}, {emit_stack dst}\n`
+          | {loc = Reg _; typ = Float}, {loc = Stack _} ->
+              `	std	{emit_reg src}, {emit_stack dst}\n`
+          | {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
+              `	ld	{emit_stack src}, {emit_reg dst}\n`
+          | {loc = Stack _; typ = Float}, {loc = Reg _} ->
+              `	ldd	{emit_stack src}, {emit_reg dst}\n`
+          | (_, _) ->
+              fatal_error "Emit: Imove"
+        end
+    | Lop(Iconst_int n) ->
+        if is_native_immediate n then
+          `	mov	{emit_nativeint n}, {emit_reg i.res.(0)}\n`
+        else begin
+          `	sethi	%hi({emit_nativeint n}), %g1\n`;
+          `	or	%g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n`
+        end
+    | Lop(Iconst_float f) ->
+        (* On UltraSPARC, the fzero instruction could be used to set a
+           floating point register pair to zero. *)
+        let lbl = new_label() in
+        float_constants := (lbl, f) :: !float_constants;
+        `	sethi	%hi({emit_label lbl}), %g1\n`;
+        `	ldd	[%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n`
+    | Lop(Iconst_symbol s) ->
+        `	sethi	%hi({emit_symbol s}), %g1\n`;
+        `	or	%g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n`
+    | Lop(Icall_ind { label_after; }) ->
+        `{record_frame i.live ~label:label_after}	call	{emit_reg i.arg.(0)}\n`;
+        fill_delay_slot dslot
+    | Lop(Icall_imm { func; label_after; }) ->
+        `{record_frame i.live ~label:label_after}	call	{emit_symbol func}\n`;
+        fill_delay_slot dslot
+    | Lop(Itailcall_ind { label_after = _; }) ->
+        let n = frame_size() in
+        if !contains_calls then
+          `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`;
+        `	jmp	{emit_reg i.arg.(0)}\n`;
+        `	add	%sp, {emit_int n}, %sp\n` (* in delay slot *)
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        let n = frame_size() in
+        if func = !function_name then begin
+            `	b	{emit_label !tailrec_entry_point}\n`;
+            fill_delay_slot dslot
+        end else begin
+          if !contains_calls then
+            `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`;
+          `	sethi	%hi({emit_symbol func}), %g1\n`;
+          `	jmp	%g1 + %lo({emit_symbol func})\n`;
+          `	add	%sp, {emit_int n}, %sp\n` (* in delay slot *)
+        end
+    | Lop(Iextcall { func; alloc; label_after; }) ->
+        if alloc then begin
+          `	sethi	%hi({emit_symbol func}), %g2\n`;
+          `{record_frame i.live ~label:label_after}	call	{emit_symbol "caml_c_call"}\n`;
+          `	or	%g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *)
+        end else begin
+          `	call	{emit_symbol func}\n`;
+          fill_delay_slot dslot
+        end
+    | Lop(Istackoffset n) ->
+        `	add	%sp, {emit_int (-n)}, %sp\n`;
+        stack_offset := !stack_offset + n
+    | Lop(Iload(chunk, addr)) ->
+        let dest = i.res.(0) in
+        begin match chunk with
+          Double_u ->
+            emit_load "ld" addr i.arg dest;
+            emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair dest)
+        | Single ->
+            emit_load "ld" addr i.arg dest;
+            `	fstod	{emit_reg dest}, {emit_reg dest}\n`
+        | _ ->
+            let loadinstr =
+              match chunk with
+                Byte_unsigned -> "ldub"
+              | Byte_signed -> "ldsb"
+              | Sixteen_unsigned -> "lduh"
+              | Sixteen_signed -> "ldsh"
+              | Double -> "ldd"
+              | _ -> "ld" in
+            emit_load loadinstr addr i.arg dest
+        end
+    | Lop(Istore(chunk, addr, _)) ->
+        let src = i.arg.(0) in
+        begin match chunk with
+          Double_u ->
+            emit_store "st" addr i.arg src;
+            emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair src)
+        | Single ->
+            `	fdtos	{emit_reg src}, %f30\n`;
+            emit_store "st" addr i.arg (phys_reg 115) (* %f30 *)
+        | _ ->
+            let storeinstr =
+              match chunk with
+              | Byte_unsigned | Byte_signed -> "stb"
+              | Sixteen_unsigned | Sixteen_signed -> "sth"
+              | Double -> "std"
+              | _ -> "st" in
+            emit_store storeinstr addr i.arg src
+        end
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        if !fastcode_flag then begin
+          let lbl_cont = new_label() in
+          if solaris then begin
+            `	sub	%l6, {emit_int n}, %l6\n`;
+            `	cmp	%l6, %l7\n`
+          end else begin
+            `	ld	[%l7], %g1\n`;
+            `	sub	%l6, {emit_int n}, %l6\n`;
+            `	cmp	%l6, %g1\n`
+          end;
+          `	bgeu	{emit_label lbl_cont}\n`;
+          `	add	%l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *)
+          `{record_frame i.live ?label:label_after_call_gc}	call	{emit_symbol "caml_call_gc"}\n`;
+          `	mov	{emit_int n}, %g2\n`; (* in delay slot *)
+          `	add	%l6, 4, {emit_reg i.res.(0)}\n`;
+          `{emit_label lbl_cont}:\n`
+        end else begin
+          `{record_frame i.live}	call	{emit_symbol "caml_allocN"}\n`;
+          `	mov	{emit_int n}, %g2\n`; (* in delay slot *)
+          `	add	%l6, 4, {emit_reg i.res.(0)}\n`
+        end
+    | Lop(Iintop(Icomp cmp)) ->
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        if !arch_version = SPARC_V9 then begin
+          let comp = name_for_int_movcc cmp in
+          `	mov	0, {emit_reg i.res.(0)}\n`;
+          `	mov{emit_string comp}	%icc, 1, {emit_reg i.res.(0)}\n`
+        end
+        else begin
+          let comp = name_for_int_comparison cmp
+          and lbl = new_label() in
+          `	{emit_string comp},a	{emit_label lbl}\n`;
+          `	mov	1, {emit_reg i.res.(0)}\n`;
+          `	mov	0, {emit_reg i.res.(0)}\n`;
+          `{emit_label lbl}:\n`
+        end
+    | Lop(Iintop (Icheckbound _)) ->
+        `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        if solaris then
+          `	tleu	5\n`            (* 5 = ST_RANGE_CHECK *)
+        else begin
+          if !range_check_trap = 0 then range_check_trap := new_label();
+          `	bleu	{emit_label !range_check_trap}\n`;
+          `	nop\n`                  (* delay slot *)
+        end
+    | Lop(Iintop Idiv) ->
+        `	sra	{emit_reg i.arg.(0)}, 31, %g1\n`;
+        `	wr	%g1, %y\n`;
+        `	sdiv	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop Imulh) ->
+        `	smul	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`;
+        `	rd	%y, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop op) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(Ilsl, 1)) ->
+        (* UltraSPARC has two add units but only one shifter. *)
+        `	add	{emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+        if !arch_version = SPARC_V9 then begin
+          let comp = name_for_int_movcc cmp in
+          `	mov	0, {emit_reg i.res.(0)}\n`;
+          `	mov{emit_string comp}	%icc, 1, {emit_reg i.res.(0)}\n`
+        end else begin
+          let comp = name_for_int_comparison cmp
+          and lbl = new_label() in
+          `	{emit_string comp},a	{emit_label lbl}\n`;
+          `	mov	1, {emit_reg i.res.(0)}\n`;
+          `	mov	0, {emit_reg i.res.(0)}\n`;
+          `{emit_label lbl}:\n`
+        end
+    | Lop(Iintop_imm(Icheckbound _, n)) ->
+        `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+        if solaris then
+          `	tleu	5\n`            (* 5 = ST_RANGE_CHECK *)
+        else begin
+          if !range_check_trap = 0 then range_check_trap := new_label();
+          `	bleu	{emit_label !range_check_trap}\n`;
+          `	nop\n`                  (* delay slot *)
+        end
+    | Lop(Iintop_imm(Imulh, n)) ->
+        `	smul	{emit_reg i.arg.(0)}, {emit_int n}, %g1\n`;
+        `	rd	%y, {emit_reg i.res.(0)}\n`
+    | Lop(Iintop_imm(op, n)) ->
+        let instr = name_for_int_operation op in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
+    | Lop(Inegf | Iabsf as op) ->
+        let instr = name_for_float_operation op in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
+        if !arch_version <> SPARC_V9 then
+          `	fmovs	{emit_reg(next_in_pair i.arg.(0))}, {emit_reg(next_in_pair i.res.(0))}\n`
+    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
+        let instr = name_for_float_operation op in
+        `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
+    | Lop(Ifloatofint) ->
+        `	sub	%sp, 8, %sp\n`;
+        `	st	{emit_reg i.arg.(0)}, [%sp + 96]\n`;
+        `	ld	[%sp + 96], %f30\n`;
+        `	add	%sp, 8, %sp\n`;
+        `	fitod	%f30, {emit_reg i.res.(0)}\n`
+    | Lop(Iintoffloat) ->
+        `	fdtoi	{emit_reg i.arg.(0)}, %f30\n`;
+        `	sub	%sp, 8, %sp\n`;
+        `	st	%f30, [%sp + 96]\n`;
+        `	ld	[%sp + 96], {emit_reg i.res.(0)}\n`;
+        `	add	%sp, 8, %sp\n`
+    | Lop(Ispecific _) ->
+	assert false
+    | Lreloadretaddr ->
+        let n = frame_size() in
+        `	ld	[%sp + {emit_int(n - 4 + 96)}], %o7\n`
+    | Lreturn ->
+        let n = frame_size() in
+        `	retl\n`;
+        if n = 0 then
+          `	nop\n`
+        else
+          `	add	%sp, {emit_int n}, %sp\n`
+    | Llabel lbl ->
+        `{emit_label lbl}:\n`
+    | Lbranch lbl ->
+        `	b	{emit_label lbl}\n`;
+        fill_delay_slot dslot
+    | Lcondbranch(tst, lbl) ->
+        begin match tst with
+          Itruetest ->
+            `	tst	{emit_reg i.arg.(0)}\n`;
+            `	bne	{emit_label lbl}\n`
+        | Ifalsetest ->
+            `	tst	{emit_reg i.arg.(0)}\n`;
+            `	be	{emit_label lbl}\n`
+        | Iinttest cmp ->
+            let comp = name_for_int_comparison cmp in
+            `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `	{emit_string comp}	{emit_label lbl}\n`
+        | Iinttest_imm(cmp, n) ->
+            let comp = name_for_int_comparison cmp in
+            `	cmp	{emit_reg i.arg.(0)}, {emit_int n}\n`;
+            `	{emit_string comp}	{emit_label lbl}\n`
+        | Ifloattest(cmp, neg) ->
+            let comp = name_for_float_comparison cmp neg in
+            `	fcmpd	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `	nop\n`;
+            `	{emit_string comp}	{emit_label lbl}\n`
+        | Ioddtest ->
+            `	andcc	{emit_reg i.arg.(0)}, 1, %g0\n`;
+            `	bne	{emit_label lbl}\n`
+        | Ieventest ->
+            `	andcc	{emit_reg i.arg.(0)}, 1, %g0\n`;
+            `	be	{emit_label lbl}\n`
+        end;
+        fill_delay_slot dslot
+  | Lcondbranch3(lbl0, lbl1, lbl2) ->
+        `	cmp	{emit_reg i.arg.(0)}, 1\n`;
+        begin match lbl0 with
+          None -> ()
+        | Some lbl -> `	bl	{emit_label lbl}\n	nop\n`
+        end;
+        begin match lbl1 with
+          None -> ()
+        | Some lbl -> `	be	{emit_label lbl}\n	nop\n`
+        end;
+        begin match lbl2 with
+          None -> ()
+        | Some lbl -> `	bg	{emit_label lbl}\n	nop\n`
+        end
+    | Lswitch jumptbl ->
+        let lbl_jumptbl = new_label() in
+        `	sethi	%hi({emit_label lbl_jumptbl}), %g1\n`;
+        `	or	%g1, %lo({emit_label lbl_jumptbl}), %g1\n`;
+        `	sll	{emit_reg i.arg.(0)}, 2, %g2\n`;
+        `	ld	[%g1 + %g2], %g1\n`;
+        `	jmp	%g1\n`;         (* poor scheduling *)
+        `	nop\n`;
+        `{emit_label lbl_jumptbl}:`;
+        for i = 0 to Array.length jumptbl - 1 do
+          `	.word	{emit_label jumptbl.(i)}\n`
+        done
+    | Lsetuptrap lbl ->
+        `	call	{emit_label lbl}\n`;
+        `	sub	%sp, 8, %sp\n`  (* in delay slot *)
+    | Lpushtrap ->
+        stack_offset := !stack_offset + 8;
+        `	st	%o7, [%sp + 96]\n`;
+        `	st	%l5, [%sp + 100]\n`;
+        `	mov	%sp, %l5\n`
+    | Lpoptrap ->
+        `	ld	[%sp + 100], %l5\n`;
+        `	add	%sp, 8, %sp\n`;
+        stack_offset := !stack_offset - 8
+    | Lraise _ ->
+        `	ld	[%l5 + 96], %g1\n`;
+        `	mov	%l5, %sp\n`;
+        `	ld	[%sp + 100], %l5\n`;
+        `	jmp	%g1 + 8\n`;
+        `	add	%sp, 8, %sp\n`
+
+and fill_delay_slot = function
+    None -> `	nop\n`
+  | Some i -> emit_instr i None
+
+(* Checks if a pseudo-instruction expands to exactly one machine instruction
+   that does not branch. *)
+
+let is_one_instr_op = function
+    Imulh | Idiv | Imod | Icomp _ | Icheckbound _ -> false
+  | _ -> true
+
+let is_one_instr i =
+  match i.desc with
+    Lop op ->
+      begin match op with
+        Imove | Ispill | Ireload ->
+          i.arg.(0).typ <> Float && i.res.(0).typ <> Float
+      | Iconst_int n -> is_native_immediate n
+      | Istackoffset _ -> true
+      | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n
+      | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n
+      | Iintop(op) -> is_one_instr_op op
+      | Iintop_imm(op, _) -> is_one_instr_op op
+      | Iaddf | Isubf | Imulf | Idivf -> true
+      | Iabsf | Inegf -> !arch_version = SPARC_V9
+      | _ -> false
+      end
+  | _ -> false
+
+let no_interference res arg =
+  try
+    for i = 0 to Array.length arg - 1 do
+      for j = 0 to Array.length res - 1 do
+        if arg.(i).loc = res.(j).loc then raise Exit
+      done
+    done;
+    true
+  with Exit ->
+    false
+
+(* Emit a sequence of instructions, trying to fill delay slots for branches *)
+
+let rec emit_all i =
+  match i with
+    {desc = Lend} -> ()
+  | {next = {desc = Lop(Icall_imm _)
+  | Lop(Iextcall { alloc = false; }) | Lbranch _}}
+    when is_one_instr i ->
+      emit_instr i.next (Some i);
+      emit_all i.next.next
+  | {next = {desc = Lop(Itailcall_imm { func; _ })}}
+    when func = !function_name && is_one_instr i ->
+      emit_instr i.next (Some i);
+      emit_all i.next.next
+  | {next = {desc = Lop(Icall_ind _)}}
+    when is_one_instr i && no_interference i.res i.next.arg ->
+      emit_instr i.next (Some i);
+      emit_all i.next.next
+  | {next = {desc = Lcondbranch(_, _)}}
+    when is_one_instr i && no_interference i.res i.next.arg ->
+      emit_instr i.next (Some i);
+      emit_all i.next.next
+  | _ ->
+      emit_instr i None;
+      emit_all i.next
+
+(* Emission of a function declaration *)
+
+let fundecl fundecl =
+  function_name := fundecl.fun_name;
+  fastcode_flag := fundecl.fun_fast;
+  tailrec_entry_point := new_label();
+  range_check_trap := 0;
+  stack_offset := 0;
+  float_constants := [];
+  `	.text\n`;
+  `	.align	4\n`;
+  `	.global	{emit_symbol fundecl.fun_name}\n`;
+  if Config.system = "solaris" then
+    `	.type	{emit_symbol fundecl.fun_name},#function\n`;
+  `{emit_symbol fundecl.fun_name}:\n`;
+  if !Clflags.gprofile then emit_profile();
+  let n = frame_size() in
+  if n > 0 then
+    `	sub	%sp, {emit_int n}, %sp\n`;
+  if !contains_calls then
+    `	st	%o7, [%sp + {emit_int(n - 4 + 96)}]\n`;
+  `{emit_label !tailrec_entry_point}:\n`;
+  emit_all fundecl.fun_body;
+  if !range_check_trap > 0 then begin
+    `{emit_label !range_check_trap}:\n`;
+    `	call	{emit_symbol "caml_ml_array_bound_error"}\n`;
+    `	nop\n`
+  end;
+  emit_size fundecl.fun_name;
+  List.iter emit_float_constant !float_constants
+
+(* Emission of data *)
+
+let emit_item = function
+    Cglobal_symbol s ->
+      `	.global	{emit_symbol s}\n`;
+  | Cdefine_symbol s ->
+      `{emit_symbol s}:\n`
+  | Cint8 n ->
+      `	.byte	{emit_int n}\n`
+  | Cint16 n ->
+      `	.half	{emit_int n}\n`
+  | Cint32 n ->
+      `	.word	{emit_nativeint n}\n`
+  | Cint n ->
+      `	.word	{emit_nativeint n}\n`
+  | Csingle f ->
+      emit_float32_directive ".word" (Int32.bits_of_float f)
+  | Cdouble f ->
+      emit_float64_split_directive ".word" (Int64.bits_of_float f)
+  | Csymbol_address s ->
+      `	.word	{emit_symbol s}\n`
+  | Cstring s ->
+      emit_string_directive "	.ascii	" s
+  | Cskip n ->
+      if n > 0 then `	.skip	{emit_int n}\n`
+  | Calign n ->
+      `	.align	{emit_int n}\n`
+
+let data l =
+  `	.data\n`;
+  List.iter emit_item l
+
+(* Beginning / end of an assembly file *)
+
+let begin_assembly() =
+  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
+  `	.data\n`;
+  `	.global	{emit_symbol lbl_begin}\n`;
+  `{emit_symbol lbl_begin}:\n`;
+  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.make_symbol (Some "code_end") in
+  `	.global	{emit_symbol lbl_end}\n`;
+  `{emit_symbol lbl_end}:\n`;
+  `	.data\n`;
+  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.make_symbol (Some "frametable") in
+  rodata ();
+  `	.global	{emit_symbol lbl}\n`;
+  if Config.system = "solaris" then
+    `	.type   {emit_symbol lbl},#object\n`;
+  `{emit_symbol lbl}:\n`;
+  `	.word	{emit_int (List.length !frame_descriptors)}\n`;
+  List.iter emit_frame !frame_descriptors;
+  emit_size lbl;
+  frame_descriptors := []
diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml
new file mode 100644
index 00000000..04f3b19c
--- /dev/null
+++ b/asmcomp/sparc/proc.ml
@@ -0,0 +1,251 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of the Sparc processor *)
+
+open Misc
+open Cmm
+open Reg
+open Arch
+open Mach
+
+(* Instruction selection *)
+
+let word_addressed = false
+
+(* Registers available for register allocation *)
+
+(* Register map:
+    %o0 - %o5   0 - 5       function results, C functions args / res
+    %i0 - %i5   6 - 11      function arguments, preserved by C
+    %l0 - %l4   12 - 16     general purpose, preserved by C
+    %g3 - %g4   17 - 18     general purpose, not preserved by C
+
+    %l5                     exception pointer
+    %l6                     allocation pointer
+    %l7                     address of allocation limit
+
+    %g0                     always zero
+    %g1 - %g2               temporaries
+    %g5 - %g7               reserved for system libraries
+
+    %f0 - %f10  100 - 105   function arguments and results
+    %f12 - %f28 106 - 114   general purpose
+    %f30                    temporary *)
+
+let int_reg_name = [|
+  (* 0-5 *)   "%o0"; "%o1"; "%o2"; "%o3"; "%o4"; "%o5";
+  (* 6-11 *)  "%i0"; "%i1"; "%i2"; "%i3"; "%i4"; "%i5";
+  (* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4";
+  (* 17-18 *) "%g3"; "%g4"
+|]
+
+let float_reg_name = [|
+  (* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10";
+  (* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18";
+  (* 110-114 *) "%f20"; "%f22"; "%f24"; "%f26"; "%f28";
+  (* 115 *)     "%f30";
+  (* Odd parts of register pairs *)
+  (* 116-121 *) "%f1"; "%f3"; "%f5"; "%f7"; "%f9"; "%f11";
+  (* 122-125 *) "%f13"; "%f15"; "%f17"; "%f19";
+  (* 126-130 *) "%f21"; "%f23"; "%f25"; "%f27"; "%f29";
+  (* 131 *)     "%f31"
+|]
+
+let num_register_classes = 2
+
+let register_class r =
+  match r.typ with
+  | Val | Int | Addr -> 0
+  | Float -> 1
+
+let num_available_registers = [| 19; 15 |]
+
+let first_available_register = [| 0; 100 |]
+
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
+
+let rotate_registers = true
+
+(* Representation of hard registers by pseudo-registers *)
+
+let hard_int_reg =
+  let v = Array.make 19 Reg.dummy in
+  for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done;
+  v
+
+let hard_float_reg =
+  let v = Array.make 32 Reg.dummy in
+  for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
+  v
+
+let all_phys_regs =
+  Array.append hard_int_reg (Array.sub hard_float_reg 0 15)
+  (* No need to include the odd parts of float register pairs,
+     nor the temporary register %f30 *)
+
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
+
+let stack_slot slot ty =
+  Reg.at_location ty (Stack slot)
+
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
+(* Calling conventions *)
+
+let calling_conventions first_int last_int first_float last_float make_stack
+                        arg =
+  let loc = Array.make (Array.length arg) Reg.dummy in
+  let int = ref first_int in
+  let float = ref first_float in
+  let ofs = ref 0 in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+    | Val | Int | Addr as ty ->
+        if !int <= last_int then begin
+          loc.(i) <- phys_reg !int;
+          incr int
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !float <= last_float then begin
+          loc.(i) <- phys_reg !float;
+          incr float
+        end else begin
+          loc.(i) <- stack_slot (make_stack !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align !ofs 8)         (* Keep stack 8-aligned *)
+
+let incoming ofs = Incoming ofs
+let outgoing ofs = Outgoing ofs
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+let max_arguments_for_tailcalls = 10
+
+let loc_arguments arg =
+  calling_conventions 6 15 100 105 outgoing arg
+let loc_parameters arg =
+  let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc
+let loc_results res =
+  let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc
+
+(* On the Sparc, all arguments to C functions, even floating-point arguments,
+   are passed in %o0..%o5, then on the stack *)
+
+let loc_external_arguments arg =
+  let loc = Array.make (Array.length arg) [| |] in
+  let reg = ref 0 (* %o0 *) in
+  let ofs = ref (-4) in              (* start at sp + 92 = sp + 96 - 4 *)
+  let next_loc typ =
+    if !reg <= 5 (* %o5 *) then begin
+      assert (size_component typ = size_int);
+      let loc = phys_reg !reg in
+      incr reg;
+      loc
+    end else begin
+      let loc = stack_slot (outgoing !ofs) typ in
+      ofs := !ofs + size_component typ;
+      loc
+    end
+  in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i) with
+    | [| { typ = (Val | Int | Addr as typ) } |] ->
+      loc.(i) <- [| next_loc typ |]
+    | [| { typ = Float } |] ->
+      if !reg <= 5 then begin
+        let loc1 = next_loc Int in
+        let loc2 = next_loc Int in
+        loc.(i) <- [| loc1; loc2 |]
+      end else
+        loc.(i) <- [| next_loc Float |]
+    | [| { typ = Int }; { typ = Int } |] ->
+      (* int64 unboxed *)
+      let loc1 = next_loc Int in
+      let loc2 = next_loc Int in
+      loc.(i) <- [| loc1; loc2 |]
+    | _ ->
+      fatal_error "Proc.loc_external_arguments: cannot call"
+  done;
+  (* Keep stack 8-aligned *)
+  (loc, Misc.align (!ofs + 4) 8)
+
+let loc_external_results res =
+  let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc
+
+let loc_exn_bucket = phys_reg 0         (* $o0 *)
+
+(* Volatile registers: none *)
+
+let regs_are_volatile _rs = false
+
+(* Registers destroyed by operations *)
+
+let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *)
+  Array.of_list(List.map phys_reg
+    [0; 1; 2; 3; 4; 5; 17; 18;
+     100; 101; 102; 103; 104; 105; 106; 107;
+     108; 109; 110; 111; 112; 113; 114])
+
+let destroyed_at_oper = function
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
+  | _ -> [||]
+
+let destroyed_at_raise = all_phys_regs
+
+(* Maximal register pressure *)
+
+let safe_register_pressure = function
+    Iextcall _ -> 0
+  | _ -> 15
+
+let max_register_pressure = function
+    Iextcall _ -> [| 11; 0 |]
+  | _ -> [| 19; 15 |]
+
+(* Pure operations (without any side effect besides updating their result
+   registers). *)
+
+let op_is_pure = function
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
+  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
+  | _ -> true
+
+(* Layout of the stack *)
+
+let num_stack_slots = [| 0; 0 |]
+let contains_calls = ref false
+
+(* Calling the assembler and the archiver *)
+
+let assemble_file infile outfile =
+  let asflags = begin match !arch_version with
+    SPARC_V7 -> " -o "
+  | SPARC_V8 -> " -xarch=v8 -o "
+  | SPARC_V9 -> " -xarch=v8plus -o "
+  end in
+  Ccomp.command (Config.asm ^ asflags ^
+                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+let init () = ()
diff --git a/asmcomp/sparc/reload.ml b/asmcomp/sparc/reload.ml
new file mode 100644
index 00000000..356dc7f1
--- /dev/null
+++ b/asmcomp/sparc/reload.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Reloading for the Sparc *)
+
+let fundecl f =
+  (new Reloadgen.reload_generic)#fundecl f
diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml
new file mode 100644
index 00000000..c169b475
--- /dev/null
+++ b/asmcomp/sparc/scheduling.ml
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmm
+open Mach
+
+(* Instruction scheduling for the Sparc *)
+
+class scheduler = object
+
+inherit Schedgen.scheduler_generic
+
+(* Latencies (in cycles). *)
+
+(* UltraSPARC issues two integer operations, plus a single load or store,
+   per cycle.  At most one of the integer instructions may be a shift.
+   Most integer operations have one cycle latency.  Unsigned loads take
+   two cycles.  Signed loads take three cycles.  Conditional moves have
+   two cycle latency and may not issue in the same cycle as any other
+   instruction.  Floating point issue rules are complicated, but in
+   general independent add and multiply can dual issue with four cycle
+   latency.  *)
+
+method oper_latency = function
+    Ireload -> 2
+  | Iload((Byte_signed|Sixteen_signed|Thirtytwo_signed), _) -> 3
+  | Iload(_, _) -> 2
+  | Iconst_float _ -> 2 (* turned into a load *)
+  | Inegf | Iabsf | Iaddf | Isubf | Imulf -> 4
+  | Idivf -> 15
+  | _ -> 1
+
+(* Issue cycles.  Rough approximations. *)
+
+method oper_issue_cycles = function
+    Iconst_float _ -> 2
+  | Iconst_symbol _ -> 2
+  | Ialloc _ -> 6
+  | Iintop(Icomp _) -> 4
+  | Iintop(Icheckbound _) -> 2
+  | Iintop_imm(Icomp _, _) -> 4
+  | Iintop_imm(Icheckbound _, _) -> 2
+  | Inegf -> 2
+  | Iabsf -> 2
+  | Ifloatofint -> 6
+  | Iintoffloat -> 6
+  | _ -> 1
+
+end
+
+let fundecl f = (new scheduler)#schedule_fundecl f
diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml
new file mode 100644
index 00000000..1083aa38
--- /dev/null
+++ b/asmcomp/sparc/selection.ml
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Instruction selection for the Sparc processor *)
+
+open Cmm
+open Reg
+open Arch
+open Mach
+
+class selector = object (self)
+
+inherit Selectgen.selector_generic as super
+
+method is_immediate n = (n <= 4095) && (n >= -4096)
+
+method select_addressing _chunk = function
+    Cconst_symbol s ->
+      (Ibased(s, 0), Ctuple [])
+  | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _) ->
+      (Ibased(s, n), Ctuple [])
+  | Cop((Caddv | Cadda), [arg; Cconst_int n], _) ->
+      (Iindexed n, arg)
+  | Cop((Caddv | Cadda as op),
+        [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) ->
+      (Iindexed n, Cop(op, [arg1; arg2], dbg))
+  | arg ->
+      (Iindexed 0, arg)
+
+method private iextcall (func, alloc) =
+  Iextcall { func; alloc; label_after = Cmm.new_label (); }
+
+method! select_operation op args dbg =
+  match (op, args) with
+  (* For SPARC V7 multiplication, division and modulus are turned into
+     calls to C library routines.
+     For SPARC V8 and V9, use hardware multiplication and division,
+     but C library routine for modulus. *)
+    (Cmuli, _) when !arch_version = SPARC_V7 ->
+      (self#iextcall(".umul", false), args)
+  | (Cdivi, _) when !arch_version = SPARC_V7 ->
+      (self#iextcall(".div", false), args)
+  | (Cmodi, _) ->
+      (self#iextcall(".rem", false), args)
+  | _ ->
+      super#select_operation op args dbg
+
+(* Override insert_move_args to deal correctly with floating-point
+   arguments being passed into pairs of integer registers. *)
+method! insert_move_args arg loc stacksize =
+  if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||];
+  let locpos = ref 0 in
+  for i = 0 to Array.length arg - 1 do
+    let src = arg.(i) in
+    let dst = loc.(!locpos) in
+    match (src, dst) with
+      ({typ = Float}, {typ = Int}) ->
+        let dst2 = loc.(!locpos + 1) in
+        self#insert (Iop Imove) [|src|] [|dst; dst2|];
+        locpos := !locpos + 2
+    | (_, _) ->
+        self#insert_move src dst;
+        incr locpos
+  done
+
+end
+
+let fundecl f = (new selector)#emit_fundecl f
diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
new file mode 100644
index 00000000..cefef95e
--- /dev/null
+++ b/asmcomp/spill.ml
@@ -0,0 +1,476 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Insertion of moves to suggest possible spilling / reloading points
+   before register allocation. *)
+
+open Reg
+open Mach
+
+(* We say that a register is "destroyed" if it is live across a construct
+   that potentially destroys all physical registers: function calls or
+   try...with constructs.
+
+   The "destroyed" registers must therefore reside in the stack during
+   these instructions.. We will insert spills (stores) just after they
+   are defined, and reloads just before their first use following a
+   "destroying" construct.
+
+   Instructions with more live registers than actual registers also
+   "destroy" registers: we mark as "destroyed" the registers live
+   across the instruction that haven't been used for the longest time.
+   These registers will be spilled and reloaded as described above. *)
+
+(* Association of spill registers to registers *)
+
+let spill_env = ref (Reg.Map.empty : Reg.t Reg.Map.t)
+
+let spill_reg r =
+  try
+    Reg.Map.find r !spill_env
+  with Not_found ->
+    let spill_r = Reg.create r.typ in
+    spill_r.spill <- true;
+    if not (Reg.anonymous r) then spill_r.raw_name <- r.raw_name;
+    spill_env := Reg.Map.add r spill_r !spill_env;
+    spill_r
+
+(* Record the position of last use of registers *)
+
+let use_date = ref (Reg.Map.empty : int Reg.Map.t)
+let current_date = ref 0
+
+let record_use regv =
+  for i = 0 to Array.length regv - 1 do
+    let r = regv.(i) in
+    let prev_date = try Reg.Map.find r !use_date with Not_found -> 0 in
+    if !current_date > prev_date then
+      use_date := Reg.Map.add r !current_date !use_date
+  done
+
+(* Check if the register pressure overflows the maximum pressure allowed
+   at that point. If so, spill enough registers to lower the pressure. *)
+
+let add_superpressure_regs op live_regs res_regs spilled =
+  let max_pressure = Proc.max_register_pressure op in
+  let regs = Reg.add_set_array live_regs res_regs in
+  (* Compute the pressure in each register class *)
+  let pressure = Array.make Proc.num_register_classes 0 in
+  Reg.Set.iter
+    (fun r ->
+      if Reg.Set.mem r spilled then () else begin
+        match r.loc with
+          Stack _ -> ()
+        | _ -> let c = Proc.register_class r in
+               pressure.(c) <- pressure.(c) + 1
+      end)
+    regs;
+  (* Check if pressure is exceeded for each class. *)
+  let rec check_pressure cl spilled =
+    if cl >= Proc.num_register_classes then
+      spilled
+    else if pressure.(cl) <= max_pressure.(cl) then
+      check_pressure (cl+1) spilled
+    else begin
+      (* Find the least recently used, unspilled, unallocated, live register
+         in the class *)
+      let lru_date = ref 1000000 and lru_reg = ref Reg.dummy in
+      Reg.Set.iter
+        (fun r ->
+          if Proc.register_class r = cl &&
+             not (Reg.Set.mem r spilled) &&
+             r.loc = Unknown
+          then begin
+            try
+              let d = Reg.Map.find r !use_date in
+              if d < !lru_date then begin
+                lru_date := d;
+                lru_reg := r
+              end
+            with Not_found ->                 (* Should not happen *)
+              ()
+          end)
+        live_regs;
+      if !lru_reg != Reg.dummy then begin
+        pressure.(cl) <- pressure.(cl) - 1;
+        check_pressure cl (Reg.Set.add !lru_reg spilled)
+      end else
+        (* Couldn't find any spillable register, give up for this class *)
+        check_pressure (cl+1) spilled
+    end in
+  check_pressure 0 spilled
+
+(* A-list recording what is destroyed at if-then-else points. *)
+
+let destroyed_at_fork = ref ([] : (instruction * Reg.Set.t) list)
+
+(* First pass: insert reload instructions based on an approximation of
+   what is destroyed at pressure points. *)
+
+let add_reloads regset i =
+  Reg.Set.fold
+    (fun r i -> instr_cons (Iop Ireload) [|spill_reg r|] [|r|] i)
+    regset i
+
+let reload_at_exit = ref []
+
+let find_reload_at_exit k =
+  try
+    List.assoc k !reload_at_exit
+  with
+  | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit"
+
+let rec reload i before =
+  incr current_date;
+  record_use i.arg;
+  record_use i.res;
+  match i.desc with
+    Iend ->
+      (i, before)
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
+      (add_reloads (Reg.inter_set_array before i.arg) i,
+       Reg.Set.empty)
+  | Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
+      (* All regs live across must be spilled *)
+      let (new_next, finally) = reload i.next i.live in
+      (add_reloads (Reg.inter_set_array before i.arg)
+                   (instr_cons_debug i.desc i.arg i.res i.dbg new_next),
+       finally)
+  | Iop op ->
+      let new_before =
+        (* Quick check to see if the register pressure is below the maximum *)
+        if Reg.Set.cardinal i.live + Array.length i.res <=
+           Proc.safe_register_pressure op
+        then before
+        else add_superpressure_regs op i.live i.res before in
+      let after =
+        Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in
+      let (new_next, finally) = reload i.next after in
+      (add_reloads (Reg.inter_set_array new_before i.arg)
+                   (instr_cons_debug i.desc i.arg i.res i.dbg new_next),
+       finally)
+  | Iifthenelse(test, ifso, ifnot) ->
+      let at_fork = Reg.diff_set_array before i.arg in
+      let date_fork = !current_date in
+      let (new_ifso, after_ifso) = reload ifso at_fork in
+      let date_ifso = !current_date in
+      current_date := date_fork;
+      let (new_ifnot, after_ifnot) = reload ifnot at_fork in
+      current_date := max date_ifso !current_date;
+      let (new_next, finally) =
+        reload i.next (Reg.Set.union after_ifso after_ifnot) in
+      let new_i =
+        instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
+        i.arg i.res new_next in
+      destroyed_at_fork := (new_i, at_fork) :: !destroyed_at_fork;
+      (add_reloads (Reg.inter_set_array before i.arg) new_i,
+       finally)
+  | Iswitch(index, cases) ->
+      let at_fork = Reg.diff_set_array before i.arg in
+      let date_fork = !current_date in
+      let date_join = ref 0 in
+      let after_cases = ref Reg.Set.empty in
+      let new_cases =
+        Array.map
+          (fun c ->
+            current_date := date_fork;
+            let (new_c, after_c) = reload c at_fork in
+            after_cases := Reg.Set.union !after_cases after_c;
+            date_join := max !date_join !current_date;
+            new_c)
+          cases in
+      current_date := !date_join;
+      let (new_next, finally) = reload i.next !after_cases in
+      (add_reloads (Reg.inter_set_array before i.arg)
+                   (instr_cons (Iswitch(index, new_cases))
+                               i.arg i.res new_next),
+       finally)
+  | Iloop(body) ->
+      let date_start = !current_date in
+      let destroyed_at_fork_start = !destroyed_at_fork in
+      let at_head = ref before in
+      let final_body = ref body in
+      begin try
+        while true do
+          current_date := date_start;
+          destroyed_at_fork := destroyed_at_fork_start;
+          let (new_body, new_at_head) = reload body !at_head in
+          let merged_at_head = Reg.Set.union !at_head new_at_head in
+          if Reg.Set.equal merged_at_head !at_head then begin
+            final_body := new_body;
+            raise Exit
+          end;
+          at_head := merged_at_head
+        done
+      with Exit -> ()
+      end;
+      let (new_next, finally) = reload i.next Reg.Set.empty in
+      (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
+       finally)
+  | Icatch(rec_flag, handlers, body) ->
+      let new_sets = List.map
+          (fun (nfail, _) -> nfail, ref Reg.Set.empty) handlers in
+      let previous_reload_at_exit = !reload_at_exit in
+      reload_at_exit := new_sets @ !reload_at_exit ;
+      let (new_body, after_body) = reload body before in
+      let rec fixpoint () =
+        let at_exits = List.map (fun (nfail, set) -> (nfail, !set)) new_sets in
+        let res =
+          List.map2 (fun (nfail', handler) (nfail, at_exit) ->
+              assert(nfail = nfail');
+              reload handler at_exit) handlers at_exits in
+        match rec_flag with
+        | Cmm.Nonrecursive ->
+            res
+        | Cmm.Recursive ->
+            let equal = List.for_all2 (fun (nfail', at_exit) (nfail, new_set) ->
+                assert(nfail = nfail');
+                Reg.Set.equal at_exit !new_set)
+                at_exits new_sets in
+            if equal
+            then res
+            else fixpoint ()
+      in
+      let res = fixpoint () in
+      reload_at_exit := previous_reload_at_exit;
+      let union = List.fold_left
+          (fun acc (_, after_handler) -> Reg.Set.union acc after_handler)
+          after_body res in
+      let (new_next, finally) = reload i.next union in
+      let new_handlers = List.map2
+          (fun (nfail, _) (new_handler, _) -> nfail, new_handler)
+          handlers res in
+      (instr_cons
+         (Icatch(rec_flag, new_handlers, new_body)) i.arg i.res new_next,
+       finally)
+  | Iexit nfail ->
+      let set = find_reload_at_exit nfail in
+      set := Reg.Set.union !set before;
+      (i, Reg.Set.empty)
+  | Itrywith(body, handler) ->
+      let (new_body, after_body) = reload body before in
+      (* All registers live at the beginning of the handler are destroyed,
+         except the exception bucket *)
+      let before_handler =
+        Reg.Set.remove Proc.loc_exn_bucket
+                       (Reg.add_set_array handler.live handler.arg) in
+      let (new_handler, after_handler) = reload handler before_handler in
+      let (new_next, finally) =
+        reload i.next (Reg.Set.union after_body after_handler) in
+      (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
+       finally)
+  | Iraise _ ->
+      (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty)
+
+(* Second pass: add spill instructions based on what we've decided to reload.
+   That is, any register that may be reloaded in the future must be spilled
+   just after its definition. *)
+
+(*
+   As an optimization, if a register needs to be spilled in one branch of
+   a conditional but not in the other, then we spill it late on entrance
+   in the branch that needs it spilled.
+   NB: This strategy is turned off in loops, as it may prevent a spill from
+   being lifted up all the way out of the loop.
+   NB again: This strategy is also off in switch arms
+   as it generates many useless spills inside switch arms
+   NB ter: is it the same thing for catch bodies ?
+*)
+
+(* CR mshinwell for pchambart: Try to test the new algorithms for dealing
+   with Icatch. *)
+
+let spill_at_exit = ref []
+let find_spill_at_exit k =
+  try
+    let used, set = List.assoc k !spill_at_exit in
+    used := true;
+    set
+  with
+  | Not_found -> Misc.fatal_error "Spill.find_spill_at_exit"
+
+let spill_at_raise = ref Reg.Set.empty
+let inside_loop = ref false
+and inside_arm = ref false
+and inside_catch = ref false
+
+let add_spills regset i =
+  Reg.Set.fold
+    (fun r i -> instr_cons (Iop Ispill) [|r|] [|spill_reg r|] i)
+    regset i
+
+let rec spill i finally =
+  match i.desc with
+    Iend ->
+      (i, finally)
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
+      (i, Reg.Set.empty)
+  | Iop Ireload ->
+      let (new_next, after) = spill i.next finally in
+      let before1 = Reg.diff_set_array after i.res in
+      (instr_cons i.desc i.arg i.res new_next,
+       Reg.add_set_array before1 i.res)
+  | Iop _ ->
+      let (new_next, after) = spill i.next finally in
+      let before1 = Reg.diff_set_array after i.res in
+      let before =
+        match i.desc with
+          Iop Icall_ind _ | Iop(Icall_imm _) | Iop(Iextcall _)
+        | Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm((Icheckbound _), _)) ->
+            Reg.Set.union before1 !spill_at_raise
+        | _ ->
+            before1 in
+      (instr_cons_debug i.desc i.arg i.res i.dbg
+                  (add_spills (Reg.inter_set_array after i.res) new_next),
+       before)
+  | Iifthenelse(test, ifso, ifnot) ->
+      let (new_next, at_join) = spill i.next finally in
+      let (new_ifso, before_ifso) = spill ifso at_join in
+      let (new_ifnot, before_ifnot) = spill ifnot at_join in
+      if
+        !inside_loop || !inside_arm || !inside_catch
+      then
+        (instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
+                     i.arg i.res new_next,
+         Reg.Set.union before_ifso before_ifnot)
+      else begin
+        let destroyed = List.assq i !destroyed_at_fork in
+        let spill_ifso_branch =
+          Reg.Set.diff (Reg.Set.diff before_ifso before_ifnot) destroyed
+        and spill_ifnot_branch =
+          Reg.Set.diff (Reg.Set.diff before_ifnot before_ifso) destroyed in
+        (instr_cons
+            (Iifthenelse(test, add_spills spill_ifso_branch new_ifso,
+                               add_spills spill_ifnot_branch new_ifnot))
+            i.arg i.res new_next,
+         Reg.Set.diff (Reg.Set.diff (Reg.Set.union before_ifso before_ifnot)
+                                    spill_ifso_branch)
+                       spill_ifnot_branch)
+      end
+  | Iswitch(index, cases) ->
+      let (new_next, at_join) = spill i.next finally in
+      let saved_inside_arm = !inside_arm in
+      inside_arm := true ;
+      let before = ref Reg.Set.empty in
+      let new_cases =
+        Array.map
+          (fun c ->
+            let (new_c, before_c) = spill c at_join in
+            before := Reg.Set.union !before before_c;
+            new_c)
+          cases in
+      inside_arm := saved_inside_arm ;
+      (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next,
+       !before)
+  | Iloop(body) ->
+      let (new_next, _) = spill i.next finally in
+      let saved_inside_loop = !inside_loop in
+      inside_loop := true;
+      let at_head = ref Reg.Set.empty in
+      let final_body = ref body in
+      begin try
+        while true do
+          let (new_body, before_body) = spill body !at_head in
+          let new_at_head = Reg.Set.union !at_head before_body in
+          if Reg.Set.equal new_at_head !at_head then begin
+            final_body := new_body; raise Exit
+          end;
+          at_head := new_at_head
+        done
+      with Exit -> ()
+      end;
+      inside_loop := saved_inside_loop;
+      (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
+       !at_head)
+  | Icatch(rec_flag, handlers, body) ->
+      let (new_next, at_join) = spill i.next finally in
+      let saved_inside_catch = !inside_catch in
+      inside_catch := true ;
+      let previous_spill_at_exit = !spill_at_exit in
+      let spill_at_exit_add at_exits = List.map2
+          (fun (nfail,_) at_exit -> nfail, (ref false, at_exit))
+          handlers at_exits
+      in
+      let rec fixpoint at_exits =
+        let spill_at_exit_add = spill_at_exit_add at_exits in
+        spill_at_exit := spill_at_exit_add @ !spill_at_exit;
+        let res =
+          List.map (fun (_, handler) -> spill handler at_join) handlers
+        in
+        spill_at_exit := previous_spill_at_exit;
+        match rec_flag with
+        | Cmm.Nonrecursive ->
+            res
+        | Cmm.Recursive ->
+            let equal =
+              List.for_all2
+                (fun (_new_handler, new_at_exit) (_, (used, at_exit)) ->
+                   Reg.Set.equal at_exit new_at_exit || not !used)
+                res spill_at_exit_add in
+            if equal
+            then res
+            else fixpoint (List.map snd res)
+      in
+      let res = fixpoint (List.map (fun _ -> Reg.Set.empty) handlers) in
+      inside_catch := saved_inside_catch ;
+      let spill_at_exit_add = spill_at_exit_add (List.map snd res) in
+      spill_at_exit := spill_at_exit_add @ !spill_at_exit;
+      let (new_body, before) = spill body at_join in
+      spill_at_exit := previous_spill_at_exit;
+      let new_handlers = List.map2
+          (fun (nfail, _) (handler, _) -> nfail, handler)
+          handlers res in
+      (instr_cons (Icatch(rec_flag, new_handlers, new_body))
+         i.arg i.res new_next,
+       before)
+  | Iexit nfail ->
+      (i, find_spill_at_exit nfail)
+  | Itrywith(body, handler) ->
+      let (new_next, at_join) = spill i.next finally in
+      let (new_handler, before_handler) = spill handler at_join in
+      let saved_spill_at_raise = !spill_at_raise in
+      spill_at_raise := before_handler;
+      let (new_body, before_body) = spill body at_join in
+      spill_at_raise := saved_spill_at_raise;
+      (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
+       before_body)
+  | Iraise _ ->
+      (i, !spill_at_raise)
+
+(* Entry point *)
+
+let reset () =
+  spill_env := Reg.Map.empty;
+  use_date := Reg.Map.empty;
+  current_date := 0;
+  destroyed_at_fork := []
+
+let fundecl f =
+  reset ();
+
+  let (body1, _) = reload f.fun_body Reg.Set.empty in
+  let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in
+  let new_body =
+    add_spills (Reg.inter_set_array tospill_at_entry f.fun_args) body2 in
+  spill_env := Reg.Map.empty;
+  use_date := Reg.Map.empty;
+  destroyed_at_fork := [];
+  { fun_name = f.fun_name;
+    fun_args = f.fun_args;
+    fun_body = new_body;
+    fun_fast = f.fun_fast;
+    fun_dbg  = f.fun_dbg;
+    fun_spacetime_shape = f.fun_spacetime_shape;
+  }
diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli
new file mode 100644
index 00000000..cb1917e4
--- /dev/null
+++ b/asmcomp/spill.mli
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Insertion of moves to suggest possible spilling / reloading points
+   before register allocation. *)
+
+val fundecl: Mach.fundecl -> Mach.fundecl
+val reset : unit -> unit
diff --git a/asmcomp/split.ml b/asmcomp/split.ml
new file mode 100644
index 00000000..ec1a52de
--- /dev/null
+++ b/asmcomp/split.ml
@@ -0,0 +1,227 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Renaming of registers at reload points to split live ranges. *)
+
+open Reg
+open Mach
+
+(* Substitutions are represented by register maps *)
+
+type subst = Reg.t Reg.Map.t
+
+let subst_reg r (sub : subst) =
+  try
+    Reg.Map.find r sub
+  with Not_found ->
+    r
+
+let subst_regs rv sub =
+  match sub with
+    None -> rv
+  | Some s ->
+      let n = Array.length rv in
+      let nv = Array.make n Reg.dummy in
+      for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done;
+      nv
+
+(* We maintain equivalence classes of registers using a standard
+   union-find algorithm *)
+
+let equiv_classes = ref (Reg.Map.empty : Reg.t Reg.Map.t)
+
+let rec repres_reg r =
+  try
+    repres_reg(Reg.Map.find r !equiv_classes)
+  with Not_found ->
+    r
+
+let repres_regs rv =
+  let n = Array.length rv in
+  for i = 0 to n-1 do rv.(i) <- repres_reg rv.(i) done
+
+(* Identify two registers.
+   The second register is chosen as canonical representative. *)
+
+let identify r1 r2 =
+  let repres1 = repres_reg r1 in
+  let repres2 = repres_reg r2 in
+  if repres1.stamp = repres2.stamp then () else begin
+    equiv_classes := Reg.Map.add repres1 repres2 !equiv_classes
+  end
+
+(* Identify the image of a register by two substitutions.
+   Be careful to use the original register as canonical representative
+   in case it does not belong to the domain of one of the substitutions. *)
+
+let identify_sub sub1 sub2 reg =
+  try
+    let r1 = Reg.Map.find reg sub1 in
+    try
+      let r2 = Reg.Map.find reg sub2 in
+      identify r1 r2
+    with Not_found ->
+      identify r1 reg
+  with Not_found ->
+    try
+      let r2 = Reg.Map.find reg sub2 in
+      identify r2 reg
+    with Not_found ->
+      ()
+
+(* Identify registers so that the two substitutions agree on the
+   registers live before the given instruction. *)
+
+let merge_substs sub1 sub2 i =
+  match (sub1, sub2) with
+    (None, None) -> None
+  | (Some _, None) -> sub1
+  | (None, Some _) -> sub2
+  | (Some s1, Some s2) ->
+      Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg);
+      sub1
+
+(* Same, for N substitutions *)
+
+let merge_subst_array subv instr =
+  let rec find_one_subst i =
+    if i >= Array.length subv then None else begin
+      match subv.(i) with
+        None -> find_one_subst (i+1)
+      | Some si as sub ->
+          for j = i+1 to Array.length subv - 1 do
+            match subv.(j) with
+              None -> ()
+            | Some sj ->
+                Reg.Set.iter (identify_sub si sj)
+                             (Reg.add_set_array instr.live instr.arg)
+          done;
+          sub
+    end in
+  find_one_subst 0
+
+(* First pass: rename registers at reload points *)
+
+let exit_subst = ref []
+
+let find_exit_subst k =
+  try
+    List.assoc k !exit_subst with
+  | Not_found -> Misc.fatal_error "Split.find_exit_subst"
+
+let rec rename i sub =
+  match i.desc with
+    Iend ->
+      (i, sub)
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
+      (instr_cons_debug i.desc (subst_regs i.arg sub) [||] i.dbg i.next,
+       None)
+  | Iop Ireload when i.res.(0).loc = Unknown ->
+      begin match sub with
+        None -> rename i.next sub
+      | Some s ->
+          let oldr = i.res.(0) in
+          let newr = Reg.clone i.res.(0) in
+          let (new_next, sub_next) =
+            rename i.next (Some(Reg.Map.add oldr newr s)) in
+          (instr_cons i.desc i.arg [|newr|] new_next,
+           sub_next)
+      end
+  | Iop _ ->
+      let (new_next, sub_next) = rename i.next sub in
+      (instr_cons_debug i.desc (subst_regs i.arg sub) (subst_regs i.res sub)
+                        i.dbg new_next,
+       sub_next)
+  | Iifthenelse(tst, ifso, ifnot) ->
+      let (new_ifso, sub_ifso) = rename ifso sub in
+      let (new_ifnot, sub_ifnot) = rename ifnot sub in
+      let (new_next, sub_next) =
+        rename i.next (merge_substs sub_ifso sub_ifnot i.next) in
+      (instr_cons (Iifthenelse(tst, new_ifso, new_ifnot))
+                  (subst_regs i.arg sub) [||] new_next,
+       sub_next)
+  | Iswitch(index, cases) ->
+      let new_sub_cases = Array.map (fun c -> rename c sub) cases in
+      let sub_merge =
+        merge_subst_array (Array.map (fun (_n, s) -> s) new_sub_cases) i.next in
+      let (new_next, sub_next) = rename i.next sub_merge in
+      (instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases))
+                  (subst_regs i.arg sub) [||] new_next,
+       sub_next)
+  | Iloop(body) ->
+      let (new_body, sub_body) = rename body sub in
+      let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in
+      (instr_cons (Iloop(new_body)) [||] [||] new_next,
+       sub_next)
+  | Icatch(rec_flag, handlers, body) ->
+      let new_subst = List.map (fun (nfail, _) -> nfail, ref None)
+          handlers in
+      let previous_exit_subst = !exit_subst in
+      exit_subst := new_subst @ !exit_subst;
+      let (new_body, sub_body) = rename body sub in
+      let res = List.map2 (fun (_, handler) (_, new_subst) -> rename handler !new_subst)
+          handlers new_subst in
+      exit_subst := previous_exit_subst;
+      let merged_subst =
+        List.fold_left (fun acc (_, sub_handler) ->
+            merge_substs acc sub_handler i.next)
+          sub_body res in
+      let (new_next, sub_next) = rename i.next merged_subst in
+      let new_handlers = List.map2 (fun (nfail, _) (handler, _) ->
+          (nfail, handler)) handlers res in
+      (instr_cons
+         (Icatch(rec_flag, new_handlers, new_body)) [||] [||] new_next,
+       sub_next)
+  | Iexit nfail ->
+      let r = find_exit_subst nfail in
+      r := merge_substs !r sub i;
+      (i, None)
+  | Itrywith(body, handler) ->
+      let (new_body, sub_body) = rename body sub in
+      let (new_handler, sub_handler) = rename handler sub in
+      let (new_next, sub_next) =
+        rename i.next (merge_substs sub_body sub_handler i.next) in
+      (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next,
+       sub_next)
+  | Iraise k ->
+      (instr_cons_debug (Iraise k) (subst_regs i.arg sub) [||] i.dbg i.next,
+       None)
+
+(* Second pass: replace registers by their final representatives *)
+
+let set_repres i =
+  instr_iter (fun i -> repres_regs i.arg; repres_regs i.res) i
+
+(* Entry point *)
+
+let reset () =
+  equiv_classes := Reg.Map.empty;
+  exit_subst := []
+
+let fundecl f =
+  reset ();
+
+  let new_args = Array.copy f.fun_args in
+  let (new_body, _sub_body) = rename f.fun_body (Some Reg.Map.empty) in
+  repres_regs new_args;
+  set_repres new_body;
+  equiv_classes := Reg.Map.empty;
+  { fun_name = f.fun_name;
+    fun_args = new_args;
+    fun_body = new_body;
+    fun_fast = f.fun_fast;
+    fun_dbg  = f.fun_dbg;
+    fun_spacetime_shape = f.fun_spacetime_shape;
+  }
diff --git a/asmcomp/split.mli b/asmcomp/split.mli
new file mode 100644
index 00000000..ed1dea54
--- /dev/null
+++ b/asmcomp/split.mli
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Renaming of registers at reload points to split live ranges. *)
+
+val fundecl: Mach.fundecl -> Mach.fundecl
+
+val reset : unit -> unit
diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml
new file mode 100644
index 00000000..983f5340
--- /dev/null
+++ b/asmcomp/strmatch.ml
@@ -0,0 +1,395 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+open Lambda
+open Cmm
+
+module type I = sig
+  val string_block_length : Cmm.expression -> Cmm.expression
+  val transl_switch :
+      Cmm.expression -> int -> int ->
+        (int * Cmm.expression) list -> Cmm.expression ->
+          Cmm.expression
+end
+
+module Make(I:I) = struct
+
+(* Debug *)
+
+  let dbg = false
+
+  let mask =
+    let open Nativeint in
+    sub (shift_left one 8) one
+
+  let pat_as_string p =
+    let rec digits k n p =
+      if n <= 0 then k
+      else
+        let d = Nativeint.to_int (Nativeint.logand mask p) in
+        let d = Char.escaped (Char.chr d) in
+        digits (d::k) (n-1) (Nativeint.shift_right_logical p  8) in
+    let ds = digits [] Arch.size_addr p in
+    let ds =
+      if Arch.big_endian then ds else List.rev ds in
+    String.concat "" ds
+
+  let do_pp_cases chan cases =
+    List.iter
+      (fun (ps,_) ->
+        Printf.fprintf chan "  [%s]\n"
+          (String.concat "; " (List.map pat_as_string ps)))
+      cases
+
+  let pp_cases chan tag cases =
+    Printf.eprintf "%s:\n" tag ;
+    do_pp_cases chan cases
+
+  let pp_match chan tag idxs cases =
+    Printf.eprintf
+      "%s: idx=[%s]\n" tag
+      (String.concat "; " (List.map string_of_int idxs)) ;
+    do_pp_cases chan cases
+
+(* Utilities *)
+
+  let gen_cell_id () = Ident.create "cell"
+  let gen_size_id () = Ident.create "size"
+
+  let mk_let_cell id str ind body =
+    let dbg = Debuginfo.none in
+    let cell =
+      Cop(Cload (Word_int, Asttypes.Mutable),
+        [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)], dbg)],
+        dbg) in
+    Clet(id, cell, body)
+
+  let mk_let_size id str body =
+    let size = I.string_block_length str in
+    Clet(id, size, body)
+
+  let mk_cmp_gen cmp_op id nat ifso ifnot =
+    let dbg = Debuginfo.none in
+    let test =
+      Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ], dbg)
+    in
+    Cifthenelse (test, ifso, ifnot)
+
+  let mk_lt = mk_cmp_gen Clt
+  let mk_eq = mk_cmp_gen Ceq
+
+  module IntArg =
+    struct
+      type t = int
+      let compare (x:int) (y:int) =
+        if x < y then -1
+        else if x > y then 1
+        else 0
+    end
+
+  let interval m0 n =
+    let rec do_rec m =
+      if m >= n then []
+      else m::do_rec (m+1) in
+    do_rec m0
+
+
+(*****************************************************)
+(* Compile strings to a lists of words [native ints] *)
+(*****************************************************)
+
+  let pat_of_string str =
+    let len = String.length str in
+    let n = len / Arch.size_addr + 1 in
+    let get_byte i =
+      if i < len then int_of_char str.[i]
+      else if i < n * Arch.size_addr - 1 then 0
+      else n * Arch.size_addr - 1 - len in
+    let mk_word ind =
+      let w = ref 0n in
+      let imin = ind * Arch.size_addr
+      and imax = (ind + 1) * Arch.size_addr - 1 in
+      if Arch.big_endian then
+        for i = imin to imax do
+          w := Nativeint.logor (Nativeint.shift_left !w 8)
+              (Nativeint.of_int (get_byte i));
+        done
+      else
+        for i = imax downto imin do
+          w := Nativeint.logor (Nativeint.shift_left !w 8)
+              (Nativeint.of_int (get_byte i));
+        done;
+      !w in
+    let rec mk_words ind  =
+      if ind >= n then []
+      else mk_word ind::mk_words (ind+1) in
+    mk_words 0
+
+(*****************************)
+(* Discriminating heuristics *)
+(*****************************)
+
+  module IntSet = Set.Make(IntArg)
+  module NativeSet = Set.Make(Nativeint)
+
+  let rec add_one sets ps = match sets,ps with
+  | [],[] -> []
+  | set::sets,p::ps ->
+      let sets = add_one sets ps in
+      NativeSet.add p set::sets
+  | _,_ -> assert false
+
+  let count_arities cases = match cases with
+  | [] -> assert false
+  | (ps,_)::_ ->
+      let sets =
+        List.fold_left
+          (fun sets (ps,_) -> add_one sets ps)
+          (List.map (fun _ -> NativeSet.empty) ps) cases in
+      List.map NativeSet.cardinal sets
+
+  let count_arities_first cases =
+    let set =
+      List.fold_left
+        (fun set case -> match case with
+        | (p::_,_) -> NativeSet.add p set
+        | _ -> assert false)
+        NativeSet.empty cases in
+    NativeSet.cardinal set
+
+  let count_arities_length cases =
+    let set =
+      List.fold_left
+        (fun set (ps,_) -> IntSet.add (List.length ps) set)
+        IntSet.empty cases in
+    IntSet.cardinal set
+
+  let best_col =
+    let rec do_rec kbest best k = function
+      | [] -> kbest
+      | x::xs ->
+          if x < best then
+            do_rec k x (k+1) xs
+          else
+            do_rec kbest best (k+1) xs in
+    let smallest = do_rec (-1) max_int 0 in
+    fun cases ->
+      let ars = count_arities cases in
+      smallest ars
+
+  let swap_list =
+    let rec do_rec k xs = match xs with
+    | [] -> assert false
+    | x::xs ->
+        if k <= 0 then [],x,xs
+        else
+          let xs,mid,ys = do_rec (k-1) xs in
+          x::xs,mid,ys in
+    fun k xs ->
+      let xs,x,ys = do_rec  k xs in
+      x::xs @ ys
+
+  let swap k idxs cases =
+    if k = 0 then idxs,cases
+    else
+      let idxs = swap_list k idxs
+      and cases =
+        List.map
+          (fun (ps,act) -> swap_list k ps,act)
+          cases in
+      if dbg then begin
+        pp_match stderr "SWAP" idxs cases
+      end ;
+      idxs,cases
+
+  let best_first idxs cases = match idxs with
+  | []|[_] -> idxs,cases (* optimisation: one column only *)
+  | _ ->
+      let k = best_col cases in
+      swap k idxs cases
+
+(************************************)
+(* Divide according to first column *)
+(************************************)
+
+  module Divide(O:Set.OrderedType) = struct
+
+    module OMap = Map.Make(O)
+
+    let divide cases =
+      let env =
+        List.fold_left
+          (fun env (p,psact) ->
+            let old =
+              try OMap.find p env
+              with Not_found -> [] in
+            OMap.add p ((psact)::old) env)
+          OMap.empty cases in
+      let r =  OMap.fold (fun key v k -> (key,v)::k) env [] in
+      List.rev r (* Now sorted *)
+  end
+
+(***************)
+(* Compilation *)
+(***************)
+
+(* Group by cell *)
+
+    module DivideNative = Divide(Nativeint)
+
+    let by_cell cases =
+      DivideNative.divide
+        (List.map
+           (fun case -> match case with
+           | (p::ps),act -> p,(ps,act)
+           | [],_ -> assert false)
+           cases)
+
+(* Split into two halves *)
+
+    let rec do_split idx env = match env with
+    | [] -> assert false
+    | (midkey,_ as x)::rem ->
+        if idx <= 0 then [],midkey,env
+        else
+          let lt,midkey,ge = do_split (idx-1) rem in
+          x::lt,midkey,ge
+
+    let split_env len env = do_split (len/2) env
+
+(* Switch according to one cell *)
+
+(*
+  Emit the switch, here as a comparison tree.
+  Argument compile_rec is to be called to compile the rest of patterns,
+  as match_on_cell can be called in two different contexts :
+  from do_compile_pats and top_compile below.
+ *)
+    let match_oncell compile_rec str default idx env =
+      let id = gen_cell_id () in
+      let rec comp_rec env =
+        let len = List.length env in
+        if len <= 3 then
+          List.fold_right
+            (fun (key,cases) ifnot ->
+              mk_eq id key
+                (compile_rec str default cases)
+              ifnot)
+            env default
+        else
+          let lt,midkey,ge = split_env len env in
+          mk_lt id midkey (comp_rec lt) (comp_rec ge) in
+      mk_let_cell id str idx (comp_rec env)
+
+(*
+  Recursive 'list of cells' compile function:
+  - choose the matched cell and switch on it
+  - notice: patterns (and idx) all have the same length
+ *)
+
+    let rec do_compile_pats idxs str default cases =
+      if dbg then begin
+        pp_match stderr "COMPILE" idxs cases
+      end ;
+      match idxs with
+      | [] ->
+          begin match cases with
+          | [] -> default
+          | (_,e)::_ -> e
+          end
+      | _::_ ->
+          let idxs,cases = best_first idxs cases in
+          begin match idxs with
+          | [] -> assert false
+          | idx::idxs ->
+              match_oncell
+                (do_compile_pats idxs) str default idx (by_cell cases)
+          end
+
+
+(* Group by size *)
+
+    module DivideInt = Divide(IntArg)
+
+
+    let by_size cases =
+      DivideInt.divide
+        (List.map
+           (fun (ps,_ as case) -> List.length ps,case)
+           cases)
+(*
+  Switch according to pattern size
+  Argument from_ind is the starting index, it can be zero
+  or one (when the swicth on the cell 0 has already been performed.
+  In that latter case pattern len is string length-1 and is corrected.
+ *)
+
+    let compile_by_size dbg from_ind str default cases =
+      let size_cases =
+        List.map
+          (fun (len,cases) ->
+            let len = len+from_ind in
+            let act =
+              do_compile_pats
+                (interval from_ind len)
+                str default  cases in
+            (len,act))
+          (by_size cases) in
+      let id = gen_size_id () in
+      ignore dbg;
+      let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in
+      mk_let_size id str switch
+
+(*
+  Compilation entry point: we choose to switch
+  either on size or on first cell, using the
+  'least discriminant' heuristics.
+ *)
+    let top_compile debuginfo str default cases =
+      let a_len = count_arities_length cases
+      and a_fst = count_arities_first cases in
+      if a_len <= a_fst then begin
+        if dbg then pp_cases stderr "SIZE" cases ;
+        compile_by_size debuginfo 0 str default cases
+      end else begin
+        if dbg then pp_cases stderr "FIRST COL" cases ;
+        let compile_size_rest str default cases =
+          compile_by_size debuginfo 1 str default cases in
+        match_oncell compile_size_rest str default 0 (by_cell cases)
+      end
+
+(* Module entry point *)
+
+    let catch arg k = match arg with
+    | Cexit (_e,[]) ->  k arg
+    | _ ->
+        let e =  next_raise_count () in
+        ccatch (e,[],k (Cexit (e,[])),arg)
+
+    let compile dbg str default cases =
+(* We do not attempt to really optimise default=None *)
+      let cases,default = match cases,default with
+      | (_,e)::cases,None
+      | cases,Some e -> cases,e
+      | [],None -> assert false in
+      let cases =
+        List.rev_map
+          (fun (s,act) -> pat_of_string s,act)
+          cases in
+      catch default (fun default -> top_compile dbg str default cases)
+
+  end
diff --git a/asmcomp/strmatch.mli b/asmcomp/strmatch.mli
new file mode 100644
index 00000000..35bfc535
--- /dev/null
+++ b/asmcomp/strmatch.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+module type I = sig
+  val string_block_length : Cmm.expression -> Cmm.expression
+  val transl_switch :
+      Cmm.expression -> int -> int ->
+        (int * Cmm.expression) list -> Cmm.expression ->
+          Cmm.expression
+end
+
+module Make(I:I) : sig
+  (* Compile stringswitch (arg,cases,d)
+     Note: cases should not contain string duplicates *)
+  val compile : Debuginfo.t -> Cmm.expression (* arg *)
+    -> Cmm.expression option (* d *) ->
+    (string * Cmm.expression) list (* cases *)-> Cmm.expression
+end
diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml
new file mode 100644
index 00000000..9d373cab
--- /dev/null
+++ b/asmcomp/un_anf.ml
@@ -0,0 +1,750 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-30-40-41-42"]
+
+(* We say that an [Ident.t] is "linear" iff:
+   (a) it is used exactly once;
+   (b) it is never assigned to (using [Uassign]).
+*)
+type ident_info =
+  { used : Ident.Set.t;
+    linear : Ident.Set.t;
+    assigned : Ident.Set.t;
+    closure_environment : Ident.Set.t;
+    let_bound_vars_that_can_be_moved : Ident.Set.t;
+  }
+
+let ignore_uconstant (_ : Clambda.uconstant) = ()
+let ignore_ulambda (_ : Clambda.ulambda) = ()
+let ignore_ulambda_list (_ : Clambda.ulambda list) = ()
+let ignore_function_label (_ : Clambda.function_label) = ()
+let ignore_debuginfo (_ : Debuginfo.t) = ()
+let ignore_int (_ : int) = ()
+let ignore_ident (_ : Ident.t) = ()
+let ignore_ident_option (_ : Ident.t option) = ()
+let ignore_primitive (_ : Lambda.primitive) = ()
+let ignore_string (_ : string) = ()
+let ignore_int_array (_ : int array) = ()
+let ignore_ident_list (_ : Ident.t list) = ()
+let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
+let ignore_meth_kind (_ : Lambda.meth_kind) = ()
+
+(* CR-soon mshinwell: check we aren't traversing function bodies more than
+   once (need to analyse exactly what the calls are from Cmmgen into this
+   module). *)
+
+let closure_environment_ident (ufunction:Clambda.ufunction) =
+  (* The argument after the arity is the environment *)
+  if List.length ufunction.params = ufunction.arity + 1 then
+    let env_var = List.nth ufunction.params ufunction.arity in
+    assert(Ident.name env_var = "env");
+    Some env_var
+  else
+    (* closed function, no environment *)
+    None
+
+let make_ident_info (clam : Clambda.ulambda) : ident_info =
+  let t : int Ident.Tbl.t = Ident.Tbl.create 42 in
+  let assigned_idents = ref Ident.Set.empty in
+  let environment_idents = ref Ident.Set.empty in
+  let rec loop : Clambda.ulambda -> unit = function
+    (* No underscores in the pattern match, to reduce the chance of failing
+       to traverse some subexpression. *)
+    | Uvar id ->
+      begin match Ident.Tbl.find t id with
+      | n -> Ident.Tbl.replace t id (n + 1)
+      | exception Not_found -> Ident.Tbl.add t id 1
+      end
+    | Uconst const ->
+      (* The only variables that might occur in [const] are those in constant
+         closures---and those are all bound by such closures.  It follows that
+         [const] cannot contain any variables that are bound in the current
+         scope, so we do not need to count them here.  (The function bodies
+         of the closures will be traversed when this function is called from
+         [Cmmgen.transl_function].) *)
+      ignore_uconstant const
+    | Udirect_apply (label, args, dbg) ->
+      ignore_function_label label;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Ugeneric_apply (func, args, dbg) ->
+      loop func;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Uclosure (functions, captured_variables) ->
+      List.iter loop captured_variables;
+      List.iter (fun (
+        { Clambda. label; arity; params; body; dbg; env; } as clos) ->
+          (match closure_environment_ident clos with
+           | None -> ()
+           | Some env_var ->
+             environment_idents :=
+               Ident.Set.add env_var !environment_idents);
+          ignore_function_label label;
+          ignore_int arity;
+          ignore_ident_list params;
+          loop body;
+          ignore_debuginfo dbg;
+          ignore_ident_option env)
+        functions
+    | Uoffset (expr, offset) ->
+      loop expr;
+      ignore_int offset
+    | Ulet (_let_kind, _value_kind, _ident, def, body) ->
+      loop def;
+      loop body
+    | Uletrec (defs, body) ->
+      List.iter (fun (ident, def) ->
+          ignore_ident ident;
+          loop def)
+        defs;
+      loop body
+    | Uprim (prim, args, dbg) ->
+      ignore_primitive prim;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Uswitch (cond, { us_index_consts; us_actions_consts;
+          us_index_blocks; us_actions_blocks }) ->
+      loop cond;
+      ignore_int_array us_index_consts;
+      Array.iter loop us_actions_consts;
+      ignore_int_array us_index_blocks;
+      Array.iter loop us_actions_blocks
+    | Ustringswitch (cond, branches, default) ->
+      loop cond;
+      List.iter (fun (str, branch) ->
+          ignore_string str;
+          loop branch)
+        branches;
+      Misc.may loop default
+    | Ustaticfail (static_exn, args) ->
+      ignore_int static_exn;
+      List.iter loop args
+    | Ucatch (static_exn, idents, body, handler) ->
+      ignore_int static_exn;
+      ignore_ident_list idents;
+      loop body;
+      loop handler
+    | Utrywith (body, ident, handler) ->
+      loop body;
+      ignore_ident ident;
+      loop handler
+    | Uifthenelse (cond, ifso, ifnot) ->
+      loop cond;
+      loop ifso;
+      loop ifnot
+    | Usequence (e1, e2) ->
+      loop e1;
+      loop e2
+    | Uwhile (cond, body) ->
+      loop cond;
+      loop body
+    | Ufor (ident, low, high, direction_flag, body) ->
+      ignore_ident ident;
+      loop low;
+      loop high;
+      ignore_direction_flag direction_flag;
+      loop body
+    | Uassign (ident, expr) ->
+      assigned_idents := Ident.Set.add ident !assigned_idents;
+      loop expr
+    | Usend (meth_kind, e1, e2, args, dbg) ->
+      ignore_meth_kind meth_kind;
+      loop e1;
+      loop e2;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Uunreachable ->
+      ()
+  in
+  loop clam;
+  let linear =
+    Ident.Tbl.fold (fun id n acc ->
+        assert (n >= 1);
+        if n = 1 && not (Ident.Set.mem id !assigned_idents)
+        then Ident.Set.add id acc
+        else acc)
+      t Ident.Set.empty
+  in
+  let assigned = !assigned_idents in
+  let used =
+    (* This doesn't work transitively and thus is somewhat restricted.  In
+       particular, it does not allow us to get rid of useless chains of [let]s.
+       However it should be sufficient to remove the majority of unnecessary
+       [let] bindings that might hinder [Cmmgen]. *)
+    Ident.Tbl.fold (fun id _n acc -> Ident.Set.add id acc)
+      t assigned
+  in
+  { used; linear; assigned; closure_environment = !environment_idents;
+    let_bound_vars_that_can_be_moved = Ident.Set.empty;
+  }
+
+(* When sequences of [let]-bindings match the evaluation order in a subsequent
+   primitive or function application whose arguments are linearly-used
+   non-assigned variables bound by such lets (possibly interspersed with other
+   variables that are known to be constant), and it is known that there were no
+   intervening side-effects during the evaluation of the [let]-bindings,
+   permit substitution of the variables for their defining expressions. *)
+let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
+  let obviously_constant = ref Ident.Set.empty in
+  let can_move = ref Ident.Set.empty in
+  let let_stack = ref [] in
+  let examine_argument_list args =
+    let rec loop let_bound_vars (args : Clambda.ulambda list) =
+      match let_bound_vars, args with
+      | _, [] ->
+        (* We've matched all arguments and will not substitute (in the
+           current application being considered) any of the remaining
+           [let_bound_vars].  As such they may stay on the stack. *)
+        let_bound_vars
+      | [], _ ->
+        (* There are no more [let]-bindings to consider, so the stack
+           is left empty. *)
+        []
+      | let_bound_vars, (Uvar arg)::args
+          when Ident.Set.mem arg !obviously_constant ->
+        loop let_bound_vars args
+      | let_bound_var::let_bound_vars, (Uvar arg)::args
+          when Ident.same let_bound_var arg
+            && not (Ident.Set.mem arg ident_info.assigned) ->
+        assert (Ident.Set.mem arg ident_info.used);
+        assert (Ident.Set.mem arg ident_info.linear);
+        can_move := Ident.Set.add arg !can_move;
+        loop let_bound_vars args
+      | _::_, _::_ ->
+        (* The [let] sequence has ceased to match the evaluation order
+           or we have encountered some complicated argument.  In this case
+           we empty the stack to ensure that we do not end up moving an
+           outer [let] across a side effect. *)
+        []
+    in
+    (* Start at the most recent let binding and the leftmost argument
+       (the last argument to be evaluated). *)
+    let_stack := loop !let_stack args
+  in
+  let rec loop : Clambda.ulambda -> unit = function
+    | Uvar ident ->
+      if Ident.Set.mem ident ident_info.assigned then begin
+        let_stack := []
+      end
+    | Uconst const ->
+      ignore_uconstant const
+    | Udirect_apply (label, args, dbg) ->
+      ignore_function_label label;
+      examine_argument_list args;
+      (* We don't currently traverse [args]; they should all be variables
+         anyway.  If this is added in the future, take care to traverse [args]
+         following the evaluation order. *)
+      ignore_debuginfo dbg
+    | Ugeneric_apply (func, args, dbg) ->
+      examine_argument_list (args @ [func]);
+      ignore_debuginfo dbg
+    | Uclosure (functions, captured_variables) ->
+      ignore_ulambda_list captured_variables;
+      (* Start a new let stack for speed. *)
+      List.iter (fun { Clambda. label; arity; params; body; dbg; env; } ->
+          ignore_function_label label;
+          ignore_int arity;
+          ignore_ident_list params;
+          let_stack := [];
+          loop body;
+          let_stack := [];
+          ignore_debuginfo dbg;
+          ignore_ident_option env)
+        functions
+    | Uoffset (expr, offset) ->
+      (* [expr] should usually be a variable. *)
+      examine_argument_list [expr];
+      ignore_int offset
+    | Ulet (_let_kind, _value_kind, ident, def, body) ->
+      begin match def with
+      | Uconst _ ->
+        (* The defining expression is obviously constant, so we don't
+           have to put this [let] on the stack, and we don't have to
+           traverse the defining expression either. *)
+        obviously_constant := Ident.Set.add ident !obviously_constant;
+        loop body
+      | _ ->
+        loop def;
+        if Ident.Set.mem ident ident_info.linear then begin
+          let_stack := ident::!let_stack
+        end else begin
+          (* If we encounter a non-linear [let]-binding then we must clear
+             the let stack, since we cannot now move any previous binding
+             across the non-linear one. *)
+          let_stack := []
+        end;
+        loop body
+      end
+    | Uletrec (defs, body) ->
+      (* Evaluation order for [defs] is not defined, and this case
+         probably isn't important for [Cmmgen] anyway. *)
+      let_stack := [];
+      List.iter (fun (ident, def) ->
+          ignore_ident ident;
+          loop def;
+          let_stack := [])
+        defs;
+      loop body
+    | Uprim (prim, args, dbg) ->
+      ignore_primitive prim;
+      examine_argument_list args;
+      ignore_debuginfo dbg
+    | Uswitch (cond, { us_index_consts; us_actions_consts;
+          us_index_blocks; us_actions_blocks }) ->
+      examine_argument_list [cond];
+      ignore_int_array us_index_consts;
+      Array.iter (fun action ->
+          let_stack := [];
+          loop action)
+        us_actions_consts;
+      ignore_int_array us_index_blocks;
+      Array.iter (fun action ->
+          let_stack := [];
+          loop action)
+        us_actions_blocks;
+      let_stack := []
+    | Ustringswitch (cond, branches, default) ->
+      examine_argument_list [cond];
+      List.iter (fun (str, branch) ->
+          ignore_string str;
+          let_stack := [];
+          loop branch)
+        branches;
+      let_stack := [];
+      Misc.may loop default;
+      let_stack := []
+    | Ustaticfail (static_exn, args) ->
+      ignore_int static_exn;
+      ignore_ulambda_list args;
+      let_stack := []
+    | Ucatch (static_exn, idents, body, handler) ->
+      ignore_int static_exn;
+      ignore_ident_list idents;
+      let_stack := [];
+      loop body;
+      let_stack := [];
+      loop handler;
+      let_stack := []
+    | Utrywith (body, ident, handler) ->
+      let_stack := [];
+      loop body;
+      let_stack := [];
+      ignore_ident ident;
+      loop handler;
+      let_stack := []
+    | Uifthenelse (cond, ifso, ifnot) ->
+      examine_argument_list [cond];
+      let_stack := [];
+      loop ifso;
+      let_stack := [];
+      loop ifnot;
+      let_stack := []
+    | Usequence (e1, e2) ->
+      loop e1;
+      let_stack := [];
+      loop e2;
+      let_stack := []
+    | Uwhile (cond, body) ->
+      let_stack := [];
+      loop cond;
+      let_stack := [];
+      loop body;
+      let_stack := []
+    | Ufor (ident, low, high, direction_flag, body) ->
+      ignore_ident ident;
+      (* Cmmgen generates code that evaluates low before high,
+         but we don't do anything here at the moment anyway. *)
+      ignore_ulambda low;
+      ignore_ulambda high;
+      ignore_direction_flag direction_flag;
+      let_stack := [];
+      loop body;
+      let_stack := []
+    | Uassign (ident, expr) ->
+      ignore_ident ident;
+      ignore_ulambda expr;
+      let_stack := []
+    | Usend (meth_kind, e1, e2, args, dbg) ->
+      ignore_meth_kind meth_kind;
+      ignore_ulambda e1;
+      ignore_ulambda e2;
+      ignore_ulambda_list args;
+      let_stack := [];
+      ignore_debuginfo dbg
+    | Uunreachable ->
+      let_stack := []
+  in
+  loop clam;
+  !can_move
+
+(* Substitution of an expression for a let-moveable variable can cause the
+   surrounding expression to become fixed.  To avoid confusion, do the
+   let-moveable substitutions first. *)
+let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
+      : Clambda.ulambda =
+  match clam with
+  | Uvar id ->
+    if not (Ident.Set.mem id is_let_moveable) then
+      clam
+    else
+      begin match Ident.Map.find id env with
+      | clam -> clam
+      | exception Not_found ->
+        Misc.fatal_errorf "substitute_let_moveable: Unbound identifier %a"
+          Ident.print id
+      end
+  | Uconst _ -> clam
+  | Udirect_apply (label, args, dbg) ->
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Udirect_apply (label, args, dbg)
+  | Ugeneric_apply (func, args, dbg) ->
+    let func = substitute_let_moveable is_let_moveable env func in
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Ugeneric_apply (func, args, dbg)
+  | Uclosure (functions, variables_bound_by_the_closure) ->
+    let functions =
+      List.map (fun (ufunction : Clambda.ufunction) ->
+          { ufunction with
+            body = substitute_let_moveable is_let_moveable env ufunction.body;
+          })
+        functions
+    in
+    let variables_bound_by_the_closure =
+      substitute_let_moveable_list is_let_moveable env
+        variables_bound_by_the_closure
+    in
+    Uclosure (functions, variables_bound_by_the_closure)
+  | Uoffset (clam, n) ->
+    let clam = substitute_let_moveable is_let_moveable env clam in
+    Uoffset (clam, n)
+  | Ulet (let_kind, value_kind, id, def, body) ->
+    let def = substitute_let_moveable is_let_moveable env def in
+    if Ident.Set.mem id is_let_moveable then
+      let env = Ident.Map.add id def env in
+      substitute_let_moveable is_let_moveable env body
+    else
+      Ulet (let_kind, value_kind,
+            id, def, substitute_let_moveable is_let_moveable env body)
+  | Uletrec (defs, body) ->
+    let defs =
+      List.map (fun (id, def) ->
+          id, substitute_let_moveable is_let_moveable env def)
+        defs
+    in
+    let body = substitute_let_moveable is_let_moveable env body in
+    Uletrec (defs, body)
+  | Uprim (prim, args, dbg) ->
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Uprim (prim, args, dbg)
+  | Uswitch (cond, sw) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let sw =
+      { sw with
+        us_actions_consts =
+          substitute_let_moveable_array is_let_moveable env
+            sw.us_actions_consts;
+        us_actions_blocks =
+          substitute_let_moveable_array is_let_moveable env
+            sw.us_actions_blocks;
+      }
+    in
+    Uswitch (cond, sw)
+  | Ustringswitch (cond, branches, default) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let branches =
+      List.map (fun (s, branch) ->
+          s, substitute_let_moveable is_let_moveable env branch)
+        branches
+    in
+    let default =
+      Misc.may_map (substitute_let_moveable is_let_moveable env) default
+    in
+    Ustringswitch (cond, branches, default)
+  | Ustaticfail (n, args) ->
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Ustaticfail (n, args)
+  | Ucatch (n, ids, body, handler) ->
+    let body = substitute_let_moveable is_let_moveable env body in
+    let handler = substitute_let_moveable is_let_moveable env handler in
+    Ucatch (n, ids, body, handler)
+  | Utrywith (body, id, handler) ->
+    let body = substitute_let_moveable is_let_moveable env body in
+    let handler = substitute_let_moveable is_let_moveable env handler in
+    Utrywith (body, id, handler)
+  | Uifthenelse (cond, ifso, ifnot) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let ifso = substitute_let_moveable is_let_moveable env ifso in
+    let ifnot = substitute_let_moveable is_let_moveable env ifnot in
+    Uifthenelse (cond, ifso, ifnot)
+  | Usequence (e1, e2) ->
+    let e1 = substitute_let_moveable is_let_moveable env e1 in
+    let e2 = substitute_let_moveable is_let_moveable env e2 in
+    Usequence (e1, e2)
+  | Uwhile (cond, body) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let body = substitute_let_moveable is_let_moveable env body in
+    Uwhile (cond, body)
+  | Ufor (id, low, high, direction, body) ->
+    let low = substitute_let_moveable is_let_moveable env low in
+    let high = substitute_let_moveable is_let_moveable env high in
+    let body = substitute_let_moveable is_let_moveable env body in
+    Ufor (id, low, high, direction, body)
+  | Uassign (id, expr) ->
+    let expr = substitute_let_moveable is_let_moveable env expr in
+    Uassign (id, expr)
+  | Usend (kind, e1, e2, args, dbg) ->
+    let e1 = substitute_let_moveable is_let_moveable env e1 in
+    let e2 = substitute_let_moveable is_let_moveable env e2 in
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Usend (kind, e1, e2, args, dbg)
+  | Uunreachable ->
+    Uunreachable
+
+and substitute_let_moveable_list is_let_moveable env clams =
+  List.map (substitute_let_moveable is_let_moveable env) clams
+
+and substitute_let_moveable_array is_let_moveable env clams =
+  Array.map (substitute_let_moveable is_let_moveable env) clams
+
+(* We say that an expression is "moveable" iff it has neither effects nor
+   coeffects.  (See semantics_of_primitives.mli.)
+*)
+type moveable = Fixed | Constant | Moveable
+
+let both_moveable a b =
+  match a, b with
+  | Constant, Constant -> Constant
+  | Constant, Moveable
+  | Moveable, Constant
+  | Moveable, Moveable -> Moveable
+  | Constant, Fixed
+  | Moveable, Fixed
+  | Fixed, Constant
+  | Fixed, Moveable
+  | Fixed, Fixed -> Fixed
+
+let primitive_moveable (prim : Lambda.primitive)
+    (args : Clambda.ulambda list)
+    (ident_info : ident_info) =
+  match prim, args with
+  | Pfield _, [Uconst (Uconst_ref (_, _))] ->
+    (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these
+       should have been simplified to [Read_symbol_field], which doesn't yield
+       a Clambda let.  This might be fixed when Inline_and_simplify can
+       turn Pfield into Read_symbol_field. *)
+    (* Allow field access of symbols to be moveable.  (The comment in
+       flambda.mli on [Read_symbol_field] may be helpful to the reader.) *)
+    Moveable
+  | Pfield _, [Uvar id] when Ident.Set.mem id ident_info.closure_environment ->
+    (* accesses to the function environment is coeffect free: this block
+       is never mutated *)
+    Moveable
+  | _ ->
+    match Semantics_of_primitives.for_primitive prim with
+    | No_effects, No_coeffects -> Moveable
+    | No_effects, Has_coeffects
+    | Only_generative_effects, No_coeffects
+    | Only_generative_effects, Has_coeffects
+    | Arbitrary_effects, No_coeffects
+    | Arbitrary_effects, Has_coeffects -> Fixed
+
+type moveable_for_env = Constant | Moveable
+
+(** Eliminate, through substitution, [let]-bindings of linear variables with
+    moveable defining expressions. *)
+let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
+      : Clambda.ulambda * moveable =
+  match clam with
+  | Uvar id ->
+    begin match Ident.Map.find id env with
+    | Constant, def -> def, Constant
+    | Moveable, def -> def, Moveable
+    | exception Not_found ->
+      let moveable : moveable =
+        if Ident.Set.mem id ident_info.assigned then
+          Fixed
+        else
+          Moveable
+      in
+      clam, moveable
+    end
+  | Uconst _ ->
+    (* Constant closures are rewritten separately. *)
+    clam, Constant
+  | Udirect_apply (label, args, dbg) ->
+    let args = un_anf_list ident_info env args in
+    Udirect_apply (label, args, dbg), Fixed
+  | Ugeneric_apply (func, args, dbg) ->
+    let func = un_anf ident_info env func in
+    let args = un_anf_list ident_info env args in
+    Ugeneric_apply (func, args, dbg), Fixed
+  | Uclosure (functions, variables_bound_by_the_closure) ->
+    let functions =
+      List.map (fun (ufunction : Clambda.ufunction) ->
+          { ufunction with
+            body = un_anf ident_info env ufunction.body;
+          })
+        functions
+    in
+    let variables_bound_by_the_closure =
+      un_anf_list ident_info env variables_bound_by_the_closure
+    in
+    Uclosure (functions, variables_bound_by_the_closure), Fixed
+  | Uoffset (clam, n) ->
+    let clam, moveable = un_anf_and_moveable ident_info env clam in
+    Uoffset (clam, n), both_moveable Moveable moveable
+  | Ulet (_let_kind, _value_kind, id, def, Uvar id') when Ident.same id id' ->
+    un_anf_and_moveable ident_info env def
+  | Ulet (let_kind, value_kind, id, def, body) ->
+    let def, def_moveable = un_anf_and_moveable ident_info env def in
+    let is_linear = Ident.Set.mem id ident_info.linear in
+    let is_used = Ident.Set.mem id ident_info.used in
+    let is_assigned = Ident.Set.mem id ident_info.assigned in
+    begin match def_moveable, is_linear, is_used, is_assigned with
+    | (Constant | Moveable), _, false, _ ->
+      (* A moveable expression that is never used may be eliminated. *)
+      un_anf_and_moveable ident_info env body
+    | Constant, _, true, false
+    (* A constant expression bound to an unassigned identifier can replace any
+         occurances of the identifier. *)
+    | Moveable, true, true, false  ->
+      (* A moveable expression bound to a linear unassigned [Ident.t]
+         may replace the single occurrence of the identifier. *)
+      let def_moveable =
+        match def_moveable with
+        | Moveable -> Moveable
+        | Constant -> Constant
+        | Fixed -> assert false
+      in
+      let env = Ident.Map.add id (def_moveable, def) env in
+      un_anf_and_moveable ident_info env body
+    | (Constant | Moveable), _, _, true
+        (* Constant or Moveable but assigned. *)
+    | Moveable, false, _, _
+        (* Moveable but not used linearly. *)
+    | Fixed, _, _, _ ->
+      let body, body_moveable = un_anf_and_moveable ident_info env body in
+      Ulet (let_kind, value_kind, id, def, body),
+      both_moveable def_moveable body_moveable
+    end
+  | Uletrec (defs, body) ->
+    let defs =
+      List.map (fun (id, def) -> id, un_anf ident_info env def) defs
+    in
+    let body = un_anf ident_info env body in
+    Uletrec (defs, body), Fixed
+  | Uprim (prim, args, dbg) ->
+    let args, args_moveable = un_anf_list_and_moveable ident_info env args in
+    let moveable =
+      both_moveable args_moveable (primitive_moveable prim args ident_info)
+    in
+    Uprim (prim, args, dbg), moveable
+  | Uswitch (cond, sw) ->
+    let cond = un_anf ident_info env cond in
+    let sw =
+      { sw with
+        us_actions_consts = un_anf_array ident_info env sw.us_actions_consts;
+        us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks;
+      }
+    in
+    Uswitch (cond, sw), Fixed
+  | Ustringswitch (cond, branches, default) ->
+    let cond = un_anf ident_info env cond in
+    let branches =
+      List.map (fun (s, branch) -> s, un_anf ident_info env branch)
+        branches
+    in
+    let default = Misc.may_map (un_anf ident_info env) default in
+    Ustringswitch (cond, branches, default), Fixed
+  | Ustaticfail (n, args) ->
+    let args = un_anf_list ident_info env args in
+    Ustaticfail (n, args), Fixed
+  | Ucatch (n, ids, body, handler) ->
+    let body = un_anf ident_info env body in
+    let handler = un_anf ident_info env handler in
+    Ucatch (n, ids, body, handler), Fixed
+  | Utrywith (body, id, handler) ->
+    let body = un_anf ident_info env body in
+    let handler = un_anf ident_info env handler in
+    Utrywith (body, id, handler), Fixed
+  | Uifthenelse (cond, ifso, ifnot) ->
+    let cond, cond_moveable = un_anf_and_moveable ident_info env cond in
+    let ifso, ifso_moveable = un_anf_and_moveable ident_info env ifso in
+    let ifnot, ifnot_moveable = un_anf_and_moveable ident_info env ifnot in
+    let moveable =
+      both_moveable cond_moveable
+        (both_moveable ifso_moveable ifnot_moveable)
+    in
+    Uifthenelse (cond, ifso, ifnot), moveable
+  | Usequence (e1, e2) ->
+    let e1 = un_anf ident_info env e1 in
+    let e2 = un_anf ident_info env e2 in
+    Usequence (e1, e2), Fixed
+  | Uwhile (cond, body) ->
+    let cond = un_anf ident_info env cond in
+    let body = un_anf ident_info env body in
+    Uwhile (cond, body), Fixed
+  | Ufor (id, low, high, direction, body) ->
+    let low = un_anf ident_info env low in
+    let high = un_anf ident_info env high in
+    let body = un_anf ident_info env body in
+    Ufor (id, low, high, direction, body), Fixed
+  | Uassign (id, expr) ->
+    let expr = un_anf ident_info env expr in
+    Uassign (id, expr), Fixed
+  | Usend (kind, e1, e2, args, dbg) ->
+    let e1 = un_anf ident_info env e1 in
+    let e2 = un_anf ident_info env e2 in
+    let args = un_anf_list ident_info env args in
+    Usend (kind, e1, e2, args, dbg), Fixed
+  | Uunreachable ->
+    Uunreachable, Fixed
+
+and un_anf ident_info env clam : Clambda.ulambda =
+  let clam, _moveable = un_anf_and_moveable ident_info env clam in
+  clam
+
+and un_anf_list_and_moveable ident_info env clams
+      : Clambda.ulambda list * moveable =
+  List.fold_right (fun clam (l, acc_moveable) ->
+      let clam, moveable = un_anf_and_moveable ident_info env clam in
+      clam :: l, both_moveable moveable acc_moveable)
+    clams ([], (Moveable : moveable))
+
+and un_anf_list ident_info env clams : Clambda.ulambda list =
+  let clams, _moveable = un_anf_list_and_moveable ident_info env clams in
+  clams
+
+and un_anf_array ident_info env clams : Clambda.ulambda array =
+  Array.map (un_anf ident_info env) clams
+
+let apply clam ~what =
+  let ident_info = make_ident_info clam in
+  let let_bound_vars_that_can_be_moved =
+    let_bound_vars_that_can_be_moved ident_info clam
+  in
+  let clam =
+    substitute_let_moveable let_bound_vars_that_can_be_moved
+      Ident.Map.empty clam
+  in
+  let ident_info = make_ident_info clam in
+  let clam = un_anf ident_info Ident.Map.empty clam in
+  if !Clflags.dump_clambda then begin
+    Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
+  end;
+  clam
diff --git a/asmcomp/un_anf.mli b/asmcomp/un_anf.mli
new file mode 100644
index 00000000..004704da
--- /dev/null
+++ b/asmcomp/un_anf.mli
@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will
+    work correctly. *)
+val apply
+   : Clambda.ulambda
+  -> what:string
+  -> Clambda.ulambda
diff --git a/asmcomp/x86_ast.mli b/asmcomp/x86_ast.mli
new file mode 100644
index 00000000..96d87beb
--- /dev/null
+++ b/asmcomp/x86_ast.mli
@@ -0,0 +1,219 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Structured representation of Intel assembly language (32 and 64 bit). *)
+
+type condition =
+  | L | GE     (* signed comparisons: less/greater *)
+  | LE | G
+  | B | AE     (* unsigned comparisons: below/above *)
+  | BE | A
+  | E | NE     (* equal *)
+  | O | NO     (* overflow *)
+  | S | NS     (* sign *)
+  | P | NP     (* parity *)
+
+type rounding =
+  | RoundUp
+  | RoundDown
+  | RoundNearest
+  | RoundTruncate
+
+type constant =
+  | Const of int64
+  | ConstThis
+  | ConstLabel of string
+  | ConstAdd of constant * constant
+  | ConstSub of constant * constant
+
+(* data_type is used mainly on memory addressing to specify
+   the size of the addressed memory chunk.  It is directly
+   used by the MASM emitter and indirectly by the GAS emitter
+   to infer the instruction suffix. *)
+
+type data_type =
+  | NONE
+  | REAL4 | REAL8 (* floating point values *)
+  | BYTE | WORD | DWORD | QWORD | OWORD (* integer values *)
+  | NEAR | PROC
+
+type reg64 =
+  | RAX | RBX | RCX | RDX | RSP | RBP | RSI | RDI
+  | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15
+
+type reg8h =
+  | AH | BH | CH | DH
+
+
+type registerf = XMM of int | TOS | ST of int
+
+type arch = X64 | X86
+
+type addr =
+  {
+    arch: arch;
+    typ: data_type;
+    idx: reg64;
+    scale: int;
+    base: reg64 option;
+    sym: string option;
+    displ: int;
+  }
+  (** Addressing modes:
+      displ + sym + base + idx * scale
+      (if scale = 0, idx is ignored and base must be None)
+  *)
+
+type arg =
+  | Imm of int64
+  (** Operand is an immediate constant integer *)
+
+  | Sym of  string
+  (** Address of a symbol (absolute address except for call/jmp target
+      where it is interpreted as a relative displacement *)
+
+  | Reg8L of reg64
+  | Reg8H of reg8h
+  | Reg16 of reg64
+  | Reg32 of reg64
+  | Reg64 of reg64
+  | Regf of registerf
+
+  | Mem of addr
+  | Mem64_RIP of data_type * string * int
+
+type instruction =
+  | ADD of arg * arg
+  | ADDSD of arg * arg
+  | AND of arg * arg
+  | ANDPD of arg * arg
+  | BSWAP of arg
+  | CALL of arg
+  | CDQ
+  | CMOV of condition * arg * arg
+  | CMP of arg * arg
+  | COMISD of arg * arg
+  | CQO
+  | CVTSD2SI of arg * arg
+  | CVTSD2SS of arg * arg
+  | CVTSI2SD of arg * arg
+  | CVTSS2SD of arg * arg
+  | CVTTSD2SI of arg * arg
+  | DEC of arg
+  | DIVSD of arg * arg
+  | FABS
+  | FADD of arg
+  | FADDP of arg * arg
+  | FCHS
+  | FCOMP of arg
+  | FCOMPP
+  | FCOS
+  | FDIV of arg
+  | FDIVP of arg * arg
+  | FDIVR of arg
+  | FDIVRP of arg * arg
+  | FILD of arg
+  | FISTP of arg
+  | FLD of arg
+  | FLD1
+  | FLDCW of arg
+  | FLDLG2
+  | FLDLN2
+  | FLDZ
+  | FMUL of arg
+  | FMULP of arg * arg
+  | FNSTCW of arg
+  | FNSTSW of arg
+  | FPATAN
+  | FPTAN
+  | FSIN
+  | FSQRT
+  | FSTP of arg
+  | FSUB of arg
+  | FSUBP of arg * arg
+  | FSUBR of arg
+  | FSUBRP of arg * arg
+  | FXCH of arg
+  | FYL2X
+  | HLT
+  | IDIV of arg
+  | IMUL of arg * arg option
+  | INC of arg
+  | J of condition * arg
+  | JMP of arg
+  | LEA of arg * arg
+  | LEAVE
+  | MOV of arg * arg
+  | MOVAPD of arg * arg
+  | MOVLPD of arg * arg
+  | MOVSD of arg * arg
+  | MOVSS of arg * arg
+  | MOVSX of arg * arg
+  | MOVSXD of arg * arg
+  | MOVZX of arg * arg
+  | MULSD of arg * arg
+  | NEG of arg
+  | NOP
+  | OR of arg * arg
+  | POP of arg
+  | PUSH of arg
+  | RET
+  | ROUNDSD of rounding * arg * arg
+  | SAL of arg * arg
+  | SAR of arg * arg
+  | SET of condition * arg
+  | SHR of arg * arg
+  | SQRTSD of arg * arg
+  | SUB of arg * arg
+  | SUBSD of arg * arg
+  | TEST of arg * arg
+  | UCOMISD of arg * arg
+  | XCHG of arg * arg
+  | XOR of arg * arg
+  | XORPD of arg * arg
+
+type asm_line =
+  | Ins of instruction
+
+  | Align of bool * int
+  | Byte of constant
+  | Bytes of string
+  | Comment of string
+  | Global of string
+  | Long of constant
+  | NewLabel of string * data_type
+  | Quad of constant
+  | Section of string list * string option * string list
+  | Space of int
+  | Word of constant
+
+  (* masm only (the gas emitter will fail on them) *)
+  | External of string * data_type
+  | Mode386
+  | Model of string
+
+  (* gas only (the masm emitter will fail on them) *)
+  | Cfi_adjust_cfa_offset of int
+  | Cfi_endproc
+  | Cfi_startproc
+  | File of int * string (* (file_num, file_name) *)
+  | Indirect_symbol of string
+  | Loc of int * int * int (* (file_num, line, col) *)
+  | Private_extern of string
+  | Set of string * constant
+  | Size of string * constant
+  | Type of string * string
+
+type asm_program = asm_line list
diff --git a/asmcomp/x86_dsl.ml b/asmcomp/x86_dsl.ml
new file mode 100644
index 00000000..e647f66c
--- /dev/null
+++ b/asmcomp/x86_dsl.ml
@@ -0,0 +1,199 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for Intel code generators *)
+
+(* The DSL* modules expose functions to emit x86/x86_64 instructions
+   using a syntax close to AT&T (in particular, arguments are reversed compared
+   to the official Intel syntax).
+
+   Some notes:
+
+     - Unary floating point instructions such as fadd/fmul/fstp/fld/etc.
+       come with a single version supporting both the single and double
+       precision instructions.  (As with Intel syntax.)
+
+     - A legacy bug in GAS:
+   https://sourceware.org/binutils/docs-2.22/as/i386_002dBugs.html#i386_002dBugs
+       is not replicated here.  It is managed by X86_gas.
+*)
+
+
+open X86_ast
+open X86_proc
+
+let sym s = Sym s
+
+let nat n = Imm (Int64.of_nativeint n)
+let int n = Imm (Int64.of_int n)
+
+let const_32 n = Const (Int64.of_int32 n)
+let const_nat n = Const (Int64.of_nativeint n)
+let const n = Const (Int64.of_int n)
+
+let al  = Reg8L RAX
+let ah  = Reg8H AH
+let cl  = Reg8L RCX
+let ax  = Reg16 RAX
+let rax = Reg64 RAX
+let r10 = Reg64 R10
+let r11 = Reg64 R11
+let r13 = Reg64 R13
+let r14 = Reg64 R14
+let r15 = Reg64 R15
+let rsp = Reg64 RSP
+let rbp = Reg64 RBP
+let xmm15 = Regf (XMM 15)
+let eax = Reg32 RAX
+let ebx = Reg32 RBX
+let ecx = Reg32 RCX
+let edx = Reg32 RDX
+let ebp = Reg32 RBP
+let esp = Reg32 RSP
+let st0 = Regf (ST 0)
+let st1 = Regf (ST 1)
+
+let mem32 typ ?(scale = 1) ?base ?sym displ idx =
+  assert(scale >= 0);
+  Mem {arch = X86; typ; idx; scale; base; sym; displ}
+
+let mem64 typ ?(scale = 1) ?base ?sym displ idx =
+  assert(scale > 0);
+  Mem {arch = X64; typ; idx; scale; base; sym; displ}
+
+let mem64_rip typ ?(ofs = 0) s =
+  Mem64_RIP (typ, s, ofs)
+
+module D = struct
+  let section segment flags args = directive (Section (segment, flags, args))
+  let align n = directive (Align (false, n))
+  let byte n = directive (Byte n)
+  let bytes s = directive (Bytes s)
+  let cfi_adjust_cfa_offset n = directive (Cfi_adjust_cfa_offset n)
+  let cfi_endproc () = directive Cfi_endproc
+  let cfi_startproc () = directive Cfi_startproc
+  let comment s = directive (Comment s)
+  let data () = section [ ".data" ] None []
+  let extrn s ptr = directive (External (s, ptr))
+  let file ~file_num ~file_name = directive (File (file_num, file_name))
+  let global s = directive (Global s)
+  let indirect_symbol s = directive (Indirect_symbol s)
+  let label ?(typ = NONE) s = directive (NewLabel (s, typ))
+  let loc ~file_num ~line ~col = directive (Loc (file_num, line, col))
+  let long cst = directive (Long cst)
+  let mode386 () = directive Mode386
+  let model name = directive (Model name)
+  let private_extern s = directive (Private_extern s)
+  let qword cst = directive (Quad cst)
+  let setvar (x, y) = directive (Set (x, y))
+  let size name cst = directive (Size (name, cst))
+  let space n = directive (Space n)
+  let text () = section [ ".text" ] None []
+  let type_ name typ = directive (Type (name, typ))
+  let word cst = directive (Word cst)
+end
+
+module I = struct
+  let add x y = emit (ADD (x, y))
+  let addsd x y = emit (ADDSD (x, y))
+  let and_ x y= emit (AND (x, y))
+  let andpd x y = emit (ANDPD (x, y))
+  let bswap x = emit (BSWAP x)
+  let call x = emit (CALL x)
+  let cdq () = emit CDQ
+  let cmp x y = emit (CMP (x, y))
+  let comisd x y = emit (COMISD (x, y))
+  let cqo () = emit CQO
+  let cvtsd2ss x y = emit (CVTSD2SS (x, y))
+  let cvtsi2sd x y = emit (CVTSI2SD (x, y))
+  let cvtss2sd x y = emit (CVTSS2SD (x, y))
+  let cvttsd2si x y = emit (CVTTSD2SI (x, y))
+  let dec x = emit (DEC x)
+  let divsd x y = emit (DIVSD (x, y))
+  let fabs () = emit FABS
+  let fadd x = emit (FADD x)
+  let faddp x y = emit (FADDP (x, y))
+  let fchs () = emit FCHS
+  let fcomp x = emit (FCOMP x)
+  let fcompp () = emit FCOMPP
+  let fcos () = emit FCOS
+  let fdiv x = emit (FDIV x)
+  let fdivp x y = emit (FDIVP (x, y))
+  let fdivr x = emit (FDIVR x)
+  let fdivrp x y = emit (FDIVRP (x, y))
+  let fild x = emit (FILD x)
+  let fistp x = emit (FISTP x)
+  let fld x = emit (FLD x)
+  let fld1 () = emit FLD1
+  let fldcw x = emit (FLDCW x)
+  let fldlg2 () = emit FLDLG2
+  let fldln2 () = emit FLDLN2
+  let fldz () = emit FLDZ
+  let fmul x = emit (FMUL x)
+  let fmulp x y = emit (FMULP (x, y))
+  let fnstcw x = emit (FNSTCW x)
+  let fnstsw x = emit (FNSTSW x)
+  let fpatan () = emit FPATAN
+  let fptan () = emit FPTAN
+  let fsin () = emit FSIN
+  let fsqrt () = emit FSQRT
+  let fstp x = emit (FSTP x)
+  let fsub x = emit (FSUB x)
+  let fsubp x y = emit (FSUBP (x, y))
+  let fsubr x = emit (FSUBR x)
+  let fsubrp x y = emit (FSUBRP (x, y))
+  let fxch x = emit (FXCH x)
+  let fyl2x () = emit FYL2X
+  let hlt () = emit HLT
+  let idiv x = emit (IDIV x)
+  let imul x y = emit (IMUL (x, y))
+  let inc x = emit (INC x)
+  let j cond x = emit (J (cond, x))
+  let ja = j A
+  let jae = j AE
+  let jb = j B
+  let jbe = j BE
+  let je = j E
+  let jg = j G
+  let jmp x = emit (JMP x)
+  let jne = j NE
+  let jp = j P
+  let lea x y = emit (LEA (x, y))
+  let mov x y = emit (MOV (x, y))
+  let movapd x y = emit (MOVAPD (x, y))
+  let movsd x y = emit (MOVSD (x, y))
+  let movss x y = emit (MOVSS (x, y))
+  let movsx x y = emit (MOVSX (x, y))
+  let movsxd x y = emit (MOVSXD  (x, y))
+  let movzx x y = emit (MOVZX (x, y))
+  let mulsd x y = emit (MULSD (x, y))
+  let nop () = emit NOP
+  let or_ x y = emit (OR (x, y))
+  let pop x = emit (POP x)
+  let push x = emit (PUSH x)
+  let ret () = emit RET
+  let sal x y = emit (SAL (x, y))
+  let sar x y = emit (SAR (x, y))
+  let set cond x = emit (SET (cond, x))
+  let shr x y = emit (SHR (x, y))
+  let sqrtsd x y = emit (SQRTSD (x, y))
+  let sub x y = emit (SUB (x, y))
+  let subsd  x y = emit (SUBSD (x, y))
+  let test x y= emit (TEST (x, y))
+  let ucomisd x y = emit (UCOMISD (x, y))
+  let xchg x y = emit (XCHG (x, y))
+  let xor x y= emit (XOR (x, y))
+  let xorpd x y = emit (XORPD (x, y))
+end
diff --git a/asmcomp/x86_dsl.mli b/asmcomp/x86_dsl.mli
new file mode 100644
index 00000000..080331fc
--- /dev/null
+++ b/asmcomp/x86_dsl.mli
@@ -0,0 +1,192 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for Intel code generators *)
+
+(* The DSL* modules expose functions to emit x86/x86_64 instructions
+   using a syntax close to the official Intel syntax, except that
+   source and destination operands are reversed as in the AT&T
+   syntax:
+
+     mov src dst
+*)
+
+
+open X86_ast
+
+val sym: string -> arg
+val nat: nativeint -> arg
+val int: int -> arg
+val const_32: int32 -> constant
+val const_nat: nativeint -> constant
+val const: int -> constant
+val al: arg
+val ah: arg
+val cl: arg
+val ax: arg
+val rax: arg
+val r10: arg
+val r11: arg
+val r13: arg
+val r14: arg
+val r15: arg
+val rsp: arg
+val rbp: arg
+val xmm15: arg
+val eax: arg
+val ebx: arg
+val ecx: arg
+val edx: arg
+val ebp: arg
+val esp: arg
+val st0: arg
+val st1: arg
+
+val mem32:
+  data_type -> ?scale:int -> ?base:reg64 -> ?sym:string ->
+  int -> reg64 -> arg
+
+val mem64:
+  data_type -> ?scale:int -> ?base:reg64 -> ?sym:string ->
+  int -> reg64 -> arg
+
+val mem64_rip: data_type -> ?ofs:int -> string -> arg
+
+
+module D : sig
+  (** Directives *)
+
+  val align: int -> unit
+  val byte: constant -> unit
+  val bytes: string -> unit
+  val cfi_adjust_cfa_offset: int -> unit
+  val cfi_endproc: unit -> unit
+  val cfi_startproc: unit -> unit
+  val comment: string -> unit
+  val data: unit -> unit
+  val extrn: string -> data_type -> unit
+  val file: file_num:int -> file_name:string -> unit
+  val global: string -> unit
+  val indirect_symbol: string -> unit
+  val label: ?typ:data_type -> string -> unit
+  val loc: file_num:int -> line:int -> col:int -> unit
+  val long: constant -> unit
+  val mode386: unit -> unit
+  val model: string -> unit
+  val private_extern: string -> unit
+  val qword: constant -> unit
+  val section: string list -> string option -> string list -> unit
+  val setvar: string * constant -> unit
+  val size: string -> constant -> unit
+  val space: int -> unit
+  val text: unit -> unit
+  val type_: string -> string -> unit
+  val word: constant -> unit
+end
+
+module I : sig
+  (* Instructions *)
+
+  val add: arg -> arg -> unit
+  val addsd: arg -> arg -> unit
+  val and_: arg -> arg -> unit
+  val andpd: arg -> arg -> unit
+  val bswap: arg -> unit
+  val call: arg -> unit
+  val cdq: unit -> unit
+  val cmp: arg -> arg -> unit
+  val comisd: arg -> arg -> unit
+  val cqo: unit -> unit
+  val cvtsd2ss: arg -> arg -> unit
+  val cvtsi2sd: arg -> arg -> unit
+  val cvtss2sd: arg -> arg -> unit
+  val cvttsd2si: arg -> arg -> unit
+  val dec: arg -> unit
+  val divsd: arg -> arg -> unit
+  val fabs: unit -> unit
+  val fadd: arg -> unit
+  val faddp: arg -> arg -> unit
+  val fchs: unit -> unit
+  val fcomp: arg -> unit
+  val fcompp: unit -> unit
+  val fcos: unit -> unit
+  val fdiv: arg -> unit
+  val fdivp: arg -> arg -> unit
+  val fdivr: arg -> unit
+  val fdivrp: arg -> arg -> unit
+  val fild: arg -> unit
+  val fistp: arg -> unit
+  val fld1: unit -> unit
+  val fld: arg -> unit
+  val fldcw: arg -> unit
+  val fldlg2: unit -> unit
+  val fldln2: unit -> unit
+  val fldz: unit -> unit
+  val fmul: arg -> unit
+  val fmulp: arg -> arg -> unit
+  val fnstcw: arg -> unit
+  val fnstsw: arg -> unit
+  val fpatan: unit -> unit
+  val fptan: unit -> unit
+  val fsin: unit -> unit
+  val fsqrt: unit -> unit
+  val fstp: arg -> unit
+  val fsub: arg -> unit
+  val fsubp: arg -> arg -> unit
+  val fsubr: arg -> unit
+  val fsubrp: arg -> arg -> unit
+  val fxch: arg -> unit
+  val fyl2x: unit -> unit
+  val hlt: unit -> unit
+  val idiv: arg -> unit
+  val imul: arg -> arg option -> unit
+  val inc: arg -> unit
+  val j: condition -> arg -> unit
+  val ja: arg -> unit
+  val jae: arg -> unit
+  val jb: arg -> unit
+  val jbe: arg -> unit
+  val je: arg -> unit
+  val jg: arg -> unit
+  val jmp: arg -> unit
+  val jne: arg -> unit
+  val jp: arg -> unit
+  val lea: arg -> arg -> unit
+  val mov: arg -> arg -> unit
+  val movapd: arg -> arg -> unit
+  val movsd: arg -> arg -> unit
+  val movss: arg -> arg -> unit
+  val movsx: arg -> arg -> unit
+  val movsxd: arg -> arg -> unit
+  val movzx: arg -> arg -> unit
+  val mulsd: arg -> arg -> unit
+  val nop: unit -> unit
+  val or_: arg -> arg -> unit
+  val pop: arg -> unit
+  val push: arg -> unit
+  val ret: unit -> unit
+  val sal: arg -> arg -> unit
+  val sar: arg -> arg -> unit
+  val set: condition -> arg -> unit
+  val shr: arg -> arg -> unit
+  val sqrtsd: arg -> arg -> unit
+  val sub: arg -> arg -> unit
+  val subsd: arg -> arg -> unit
+  val test: arg -> arg -> unit
+  val ucomisd: arg -> arg -> unit
+  val xchg: arg -> arg -> unit
+  val xor: arg -> arg -> unit
+  val xorpd: arg -> arg -> unit
+end
diff --git a/asmcomp/x86_gas.ml b/asmcomp/x86_gas.ml
new file mode 100644
index 00000000..f905dc33
--- /dev/null
+++ b/asmcomp/x86_gas.ml
@@ -0,0 +1,311 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open X86_ast
+open X86_proc
+
+let bprintf = Printf.bprintf
+
+let print_reg b f r =
+  Buffer.add_char b '%';
+  Buffer.add_string b (f r)
+
+let opt_displ b displ =
+  if displ = 0 then ()
+  else if displ > 0 then bprintf b "+%d" displ
+  else bprintf b "%d" displ
+
+let arg_mem b {arch; typ=_; idx; scale; base; sym; displ} =
+  let string_of_register =
+    match arch with
+    | X86 -> string_of_reg32
+    | X64 -> string_of_reg64
+  in
+  begin match sym with
+  | None ->
+      if displ <> 0 || scale = 0 then
+        Buffer.add_string b (string_of_int displ)
+  | Some s ->
+      Buffer.add_string b s;
+      opt_displ b displ
+  end;
+  if scale <> 0 then begin
+    Buffer.add_char b '(';
+    begin match base with
+    | None -> ()
+    | Some base -> print_reg b string_of_register base
+    end;
+    if base != None || scale <> 1 then Buffer.add_char b ',';
+    print_reg b string_of_register idx;
+    if scale <> 1 then bprintf b ",%s" (string_of_int scale);
+    Buffer.add_char b ')'
+  end
+
+let arg b = function
+  | Sym x -> Buffer.add_char b '$'; Buffer.add_string b x
+  | Imm x -> bprintf b "$%Ld" x
+  | Reg8L x -> print_reg b string_of_reg8l x
+  | Reg8H x -> print_reg b string_of_reg8h x
+  | Reg16 x -> print_reg b string_of_reg16 x
+  | Reg32 x -> print_reg b string_of_reg32 x
+  | Reg64 x -> print_reg b string_of_reg64 x
+  | Regf x  -> print_reg b string_of_registerf x
+  | Mem addr -> arg_mem b addr
+  | Mem64_RIP (_, s, displ) -> bprintf b "%s%a(%%rip)" s opt_displ displ
+
+let rec cst b = function
+  | ConstLabel _ | Const _ | ConstThis as c -> scst b c
+  | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2
+  | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2
+
+and scst b = function
+  | ConstThis -> Buffer.add_string b "."
+  | ConstLabel l -> Buffer.add_string b l
+  | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L ->
+      Buffer.add_string b (Int64.to_string n)
+  | Const n -> bprintf b "0x%Lx" n
+  | ConstAdd (c1, c2) -> bprintf b "(%a + %a)" scst c1 scst c2
+  | ConstSub (c1, c2) -> bprintf b "(%a - %a)" scst c1 scst c2
+
+let typeof = function
+  | Mem {typ; _} | Mem64_RIP (typ, _, _) -> typ
+  | Reg8L _ | Reg8H _ -> BYTE
+  | Reg16 _ -> WORD
+  | Reg32 _ -> DWORD
+  | Reg64 _ -> QWORD
+  | Imm _ | Sym _ -> NONE
+  | Regf _ -> assert false
+
+let suf arg =
+  match typeof arg with
+  | BYTE -> "b"
+  | WORD -> "w"
+  | DWORD | REAL8 -> "l"
+  | QWORD -> "q"
+  | REAL4 -> "s"
+  | NONE -> ""
+  | OWORD | NEAR | PROC -> assert false
+
+let i0 b s = bprintf b "\t%s" s
+let i1 b s x = bprintf b "\t%s\t%a" s arg x
+let i1_s b s x = bprintf b "\t%s%s\t%a" s (suf x) arg x
+let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg x arg y
+let i2_s b s x y = bprintf b "\t%s%s\t%a, %a" s (suf y) arg x arg y
+let i2_ss b s x y = bprintf b "\t%s%s%s\t%a, %a" s (suf x) (suf y) arg x arg y
+
+let i1_call_jmp b s = function
+  (* this is the encoding of jump labels: don't use * *)
+  | Mem {arch=X86; idx=_;   scale=0; base=None; sym=Some _; _} as x ->
+      i1 b s x
+  | Reg32 _ | Reg64 _ | Mem _  | Mem64_RIP _ as x ->
+      bprintf b "\t%s\t*%a" s arg x
+  | Sym x -> bprintf b "\t%s\t%s" s x
+  | _ -> assert false
+
+let print_instr b = function
+  | ADD (arg1, arg2) -> i2_s b "add" arg1 arg2
+  | ADDSD (arg1, arg2) -> i2 b "addsd" arg1 arg2
+  | AND (arg1, arg2) -> i2_s b "and" arg1 arg2
+  | ANDPD (arg1, arg2) -> i2 b "andpd" arg1 arg2
+  | BSWAP arg -> i1 b "bswap" arg
+  | CALL arg  -> i1_call_jmp b "call" arg
+  | CDQ -> i0 b "cltd"
+  | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2
+  | CMP (arg1, arg2) -> i2_s b "cmp" arg1 arg2
+  | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2
+  | CQO ->  i0 b "cqto"
+  | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2
+  | CVTSD2SS (arg1, arg2) -> i2 b "cvtsd2ss" arg1 arg2
+  | CVTSI2SD (arg1, arg2) -> i2 b ("cvtsi2sd" ^ suf arg1) arg1 arg2
+  | CVTSS2SD (arg1, arg2) -> i2 b "cvtss2sd" arg1 arg2
+  | CVTTSD2SI (arg1, arg2) -> i2_s b "cvttsd2si" arg1 arg2
+  | DEC arg -> i1_s b "dec" arg
+  | DIVSD (arg1, arg2) -> i2 b "divsd" arg1 arg2
+  | FABS -> i0 b "fabs"
+  | FADD arg -> i1_s b "fadd" arg
+  | FADDP (arg1, arg2)  -> i2 b "faddp" arg1 arg2
+  | FCHS -> i0 b "fchs"
+  | FCOMP arg -> i1_s b "fcomp" arg
+  | FCOMPP -> i0 b "fcompp"
+  | FCOS -> i0 b "fcos"
+  | FDIV arg -> i1_s b "fdiv" arg
+  | FDIVP (Regf (ST 0), arg2)  -> i2 b "fdivrp" (Regf (ST 0)) arg2 (* bug *)
+  | FDIVP (arg1, arg2)  -> i2 b "fdivp" arg1 arg2
+  | FDIVR arg -> i1_s b "fdivr" arg
+  | FDIVRP (Regf (ST 0), arg2)  -> i2 b "fdivp" (Regf (ST 0)) arg2 (* bug *)
+  | FDIVRP (arg1, arg2)  -> i2 b "fdivrp" arg1 arg2
+  | FILD arg -> i1_s b "fild" arg
+  | FISTP arg -> i1_s b "fistp" arg
+  | FLD (Mem {typ=REAL4; _} as arg) -> i1 b "flds" arg
+  | FLD arg -> i1 b "fldl" arg
+  | FLD1 -> i0 b "fld1"
+  | FLDCW arg -> i1 b "fldcw" arg
+  | FLDLG2 -> i0 b "fldlg2"
+  | FLDLN2 -> i0 b "fldln2"
+  | FLDZ -> i0 b "fldz"
+  | FMUL arg -> i1_s b "fmul" arg
+  | FMULP (arg1, arg2)  -> i2 b "fmulp" arg1 arg2
+  | FNSTCW arg -> i1 b "fnstcw" arg
+  | FNSTSW arg -> i1 b "fnstsw" arg
+  | FPATAN -> i0 b "fpatan"
+  | FPTAN -> i0 b "fptan"
+  | FSIN -> i0 b "fsin"
+  | FSQRT -> i0 b "fsqrt"
+  | FSTP (Mem {typ=REAL4; _} as arg) -> i1 b "fstps" arg
+  | FSTP arg -> i1 b "fstpl" arg
+  | FSUB arg -> i1_s b "fsub" arg
+  | FSUBP (Regf (ST 0), arg2)  -> i2 b "fsubrp" (Regf (ST 0)) arg2 (* bug *)
+  | FSUBP (arg1, arg2)  -> i2 b "fsubp" arg1 arg2
+  | FSUBR arg -> i1_s b "fsubr" arg
+  | FSUBRP (Regf (ST 0), arg2) -> i2 b "fsubp" (Regf (ST 0)) arg2 (* bug *)
+  | FSUBRP (arg1, arg2)  -> i2 b "fsubrp" arg1 arg2
+  | FXCH arg -> i1 b "fxch" arg
+  | FYL2X -> i0 b "fyl2x"
+  | HLT -> i0 b "hlt"
+  | IDIV arg -> i1_s b "idiv" arg
+  | IMUL (arg, None) -> i1_s b "imul" arg
+  | IMUL (arg1, Some arg2) -> i2_s b "imul" arg1 arg2
+  | INC arg -> i1_s b "inc" arg
+  | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg
+  | JMP arg -> i1_call_jmp b "jmp" arg
+  | LEA (arg1, arg2) -> i2_s b "lea" arg1 arg2
+  | LEAVE -> i0 b "leave"
+  | MOV ((Imm n as arg1), (Reg64 _ as arg2))
+    when not (n <= 0x7FFF_FFFFL && n >= -0x8000_0000L) ->
+      i2 b "movabsq" arg1 arg2
+  | MOV ((Sym _ as arg1), (Reg64 _ as arg2)) when windows ->
+      i2 b "movabsq" arg1 arg2
+  | MOV (arg1, arg2) -> i2_s b "mov" arg1 arg2
+  | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2
+  | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2
+  | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2
+  | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2
+  | MOVSX (arg1, arg2) -> i2_ss b "movs" arg1 arg2
+  | MOVSXD (arg1, arg2) -> i2 b "movslq" arg1 arg2
+  | MOVZX (arg1, arg2) -> i2_ss b "movz" arg1 arg2
+  | MULSD (arg1, arg2) -> i2 b "mulsd" arg1 arg2
+  | NEG arg -> i1 b "neg" arg
+  | NOP -> i0 b "nop"
+  | OR (arg1, arg2) -> i2_s b "or" arg1 arg2
+  | POP  arg -> i1_s b "pop" arg
+  | PUSH arg -> i1_s b "push" arg
+  | RET ->  i0 b "ret"
+  | ROUNDSD (r, arg1, arg2) -> i2 b (string_of_rounding r) arg1 arg2
+  | SAL (arg1, arg2) -> i2_s b "sal" arg1 arg2
+  | SAR (arg1, arg2) -> i2_s b "sar" arg1 arg2
+  | SET (c, arg) -> i1 b ("set" ^ string_of_condition c) arg
+  | SHR (arg1, arg2) -> i2_s b "shr" arg1 arg2
+  | SQRTSD (arg1, arg2) -> i2 b "sqrtsd" arg1 arg2
+  | SUB (arg1, arg2) -> i2_s b "sub" arg1 arg2
+  | SUBSD (arg1, arg2) -> i2 b "subsd" arg1 arg2
+  | TEST (arg1, arg2) -> i2_s b "test" arg1 arg2
+  | UCOMISD (arg1, arg2) -> i2 b "ucomisd" arg1 arg2
+  | XCHG (arg1, arg2) -> i2 b "xchg" arg1 arg2
+  | XOR (arg1, arg2) -> i2_s b "xor" arg1 arg2
+  | XORPD (arg1, arg2) -> i2 b "xorpd" arg1 arg2
+
+(* bug:
+   https://sourceware.org/binutils/docs-2.22/as/i386_002dBugs.html#i386_002dBugs
+
+   The AT&T syntax has a bug for fsub/fdiv/fsubr/fdivr instructions when
+   the source register is %st and the destination is %st(i).  In those
+   case, AT&T use fsub (resp. fsubr) in place of fsubr (resp. fsub),
+   and idem for fdiv/fdivr.
+
+   Concretely, AT&T syntax interpretation of:
+
+      fsub  %st, %st(3)
+
+   should normally be:
+
+      %st(3) := %st(3) - %st
+
+   but it should actually be interpreted as:
+
+      %st(3) := %st - %st(3)
+
+   which means the FSUBR instruction should be used.
+*)
+
+
+let print_line b = function
+  | Ins instr -> print_instr b instr
+
+  | Align (_data,n) ->
+      (* MacOSX assembler interprets the integer n as a 2^n alignment *)
+      let n = if system = S_macosx then Misc.log2 n else n in
+      bprintf b "\t.align\t%d" n
+  | Byte n -> bprintf b "\t.byte\t%a" cst n
+  | Bytes s ->
+      if system = S_solaris then buf_bytes_directive b ".byte" s
+      else bprintf b "\t.ascii\t\"%s\"" (string_of_string_literal s)
+  | Comment s -> bprintf b "\t\t\t\t/* %s */" s
+  | Global s -> bprintf b "\t.globl\t%s" s;
+  | Long n -> bprintf b "\t.long\t%a" cst n
+  | NewLabel (s, _) -> bprintf b "%s:" s
+  | Quad n -> bprintf b "\t.quad\t%a" cst n
+  | Section ([".data" ], _, _) -> bprintf b "\t.data"
+  | Section ([".text" ], _, _) -> bprintf b "\t.text"
+  | Section (name, flags, args) ->
+      bprintf b "\t.section %s" (String.concat "," name);
+      begin match flags with
+      | None -> ()
+      | Some flags -> bprintf b ",%S" flags
+      end;
+      begin match args with
+      | [] -> ()
+      | _ -> bprintf b ",%s" (String.concat "," args)
+      end
+  | Space n ->
+      if system = S_solaris then bprintf b "\t.zero\t%d" n
+      else bprintf b "\t.space\t%d" n
+  | Word n ->
+      if system = S_solaris then bprintf b "\t.value\t%a" cst n
+      else bprintf b "\t.word\t%a" cst n
+
+  (* gas only *)
+  | Cfi_adjust_cfa_offset n -> bprintf b "\t.cfi_adjust_cfa_offset %d" n
+  | Cfi_endproc -> bprintf b "\t.cfi_endproc"
+  | Cfi_startproc -> bprintf b "\t.cfi_startproc"
+  | File (file_num, file_name) ->
+      bprintf b "\t.file\t%d\t\"%s\""
+        file_num (X86_proc.string_of_string_literal file_name)
+  | Indirect_symbol s -> bprintf b "\t.indirect_symbol %s" s
+  | Loc (file_num, line, col) ->
+      (* PR#7726: Location.none uses column -1, breaks LLVM assembler *)
+      if col >= 0 then bprintf b "\t.loc\t%d\t%d\t%d" file_num line col
+      else bprintf b "\t.loc\t%d\t%d" file_num line
+  | Private_extern s -> bprintf b "\t.private_extern %s" s
+  | Set (arg1, arg2) -> bprintf b "\t.set %s, %a" arg1 cst arg2
+  | Size (s, c) -> bprintf b "\t.size %s,%a" s cst c
+  | Type (s, typ) -> bprintf b "\t.type %s,%s" s typ
+
+  (* masm only *)
+  | External _
+  | Mode386
+  | Model _
+    -> assert false
+
+let generate_asm oc lines =
+  let b = Buffer.create 10000 in
+  output_string oc "\t.file \"\"\n"; (* PR#7037 *)
+  List.iter
+    (fun i ->
+       Buffer.clear b;
+       print_line b i;
+       Buffer.add_char b '\n';
+       Buffer.output_buffer oc b;
+    )
+    lines
diff --git a/asmcomp/x86_gas.mli b/asmcomp/x86_gas.mli
new file mode 100644
index 00000000..3c3a4aee
--- /dev/null
+++ b/asmcomp/x86_gas.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Emit assembly instructions for gas. *)
+
+val generate_asm: out_channel -> X86_ast.asm_line list -> unit
diff --git a/asmcomp/x86_masm.ml b/asmcomp/x86_masm.ml
new file mode 100644
index 00000000..eb010b8b
--- /dev/null
+++ b/asmcomp/x86_masm.ml
@@ -0,0 +1,261 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open X86_ast
+open X86_proc
+
+let bprintf = Printf.bprintf
+
+let string_of_datatype = function
+  | QWORD -> "QWORD"
+  | OWORD -> "OWORD"
+  | NONE -> assert false
+  | REAL4 -> "REAL4"
+  | REAL8 -> "REAL8"
+  | BYTE -> "BYTE"
+  | WORD -> "WORD"
+  | DWORD -> "DWORD"
+  | NEAR -> "NEAR"
+  | PROC -> "PROC"
+
+
+let string_of_datatype_ptr = function
+  | QWORD -> "QWORD PTR "
+  | OWORD -> "OWORD PTR "
+  | NONE -> ""
+  | REAL4 -> "REAL4 PTR "
+  | REAL8 -> "REAL8 PTR "
+  | BYTE -> "BYTE PTR "
+  | WORD -> "WORD PTR "
+  | DWORD -> "DWORD PTR "
+  | NEAR -> "NEAR PTR "
+  | PROC -> "PROC PTR "
+
+let arg_mem b {arch; typ; idx; scale; base; sym; displ} =
+  let string_of_register =
+    match arch with
+    | X86 -> string_of_reg32
+    | X64 -> string_of_reg64
+  in
+  Buffer.add_string b (string_of_datatype_ptr typ);
+  Buffer.add_char b '[';
+  begin match sym with
+  | None -> ()
+  | Some s -> Buffer.add_string b s
+  end;
+  if scale <> 0 then begin
+    if sym <> None then Buffer.add_char b '+';
+    Buffer.add_string b (string_of_register idx);
+    if scale <> 1 then bprintf b "*%d" scale;
+  end;
+  begin match base with
+  | None -> ()
+  | Some r ->
+      assert(scale > 0);
+      Buffer.add_char b '+';
+      Buffer.add_string b (string_of_register r);
+  end;
+  begin if displ > 0 then bprintf b "+%d" displ
+    else if displ < 0 then bprintf b "%d" displ
+  end;
+  Buffer.add_char b ']'
+
+let arg b = function
+  | Sym s -> bprintf b "OFFSET %s" s
+  | Imm n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> bprintf b "%Ld" n
+  | Imm int -> bprintf b "0%LxH" int (* force ml64 to use mov reg, imm64 *)
+  | Reg8L x -> Buffer.add_string b (string_of_reg8l x)
+  | Reg8H x -> Buffer.add_string b (string_of_reg8h x)
+  | Reg16 x -> Buffer.add_string b (string_of_reg16 x)
+  | Reg32 x -> Buffer.add_string b (string_of_reg32 x)
+  | Reg64 x -> Buffer.add_string b (string_of_reg64 x)
+  | Regf x -> Buffer.add_string b (string_of_registerf x)
+
+  (* We don't need to specify RIP on Win64, since EXTERN will provide
+     the list of external symbols that need this addressing mode, and
+     MASM will automatically use RIP addressing when needed. *)
+  | Mem64_RIP (typ, s, displ) ->
+      bprintf b "%s%s" (string_of_datatype_ptr typ) s;
+      if displ > 0 then bprintf b "+%d" displ
+      else if displ < 0 then bprintf b "%d" displ
+  | Mem addr -> arg_mem b addr
+
+let rec cst b = function
+  | ConstLabel _ | Const _ | ConstThis as c -> scst b c
+  | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2
+  | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2
+
+and scst b = function
+  | ConstThis -> Buffer.add_string b "THIS BYTE"
+  | ConstLabel l -> Buffer.add_string b l
+  | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L ->
+      Buffer.add_string b (Int64.to_string n)
+  | Const n -> bprintf b "0%LxH" n
+  | ConstAdd (c1, c2) -> bprintf b "(%a + %a)" scst c1 scst c2
+  | ConstSub (c1, c2) -> bprintf b "(%a - %a)" scst c1 scst c2
+
+let i0 b s = bprintf b "\t%s" s
+let i1 b s x = bprintf b "\t%s\t%a" s arg x
+let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg y arg x
+
+let i1_call_jmp b s = function
+  | Sym x -> bprintf b "\t%s\t%s" s x
+  | x -> i1 b s x
+
+let print_instr b = function
+  | ADD (arg1, arg2) -> i2 b "add" arg1 arg2
+  | ADDSD (arg1, arg2) -> i2 b "addsd" arg1 arg2
+  | AND (arg1, arg2) -> i2 b "and" arg1 arg2
+  | ANDPD (arg1, arg2) -> i2 b "andpd" arg1 arg2
+  | BSWAP arg -> i1 b "bswap" arg
+  | CALL arg  -> i1_call_jmp b "call" arg
+  | CDQ -> i0 b "cdq"
+  | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2
+  | CMP (arg1, arg2) -> i2 b "cmp" arg1 arg2
+  | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2
+  | CQO -> i0 b "cqo"
+  | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2
+  | CVTSD2SS (arg1, arg2) -> i2 b "cvtsd2ss" arg1 arg2
+  | CVTSI2SD (arg1, arg2) -> i2 b "cvtsi2sd" arg1 arg2
+  | CVTSS2SD (arg1, arg2) -> i2 b "cvtss2sd" arg1 arg2
+  | CVTTSD2SI (arg1, arg2) -> i2 b "cvttsd2si" arg1 arg2
+  | DEC arg -> i1 b "dec" arg
+  | DIVSD (arg1, arg2) -> i2 b "divsd" arg1 arg2
+  | FABS -> i0 b "fabs"
+  | FADD arg -> i1 b "fadd" arg
+  | FADDP (arg1, arg2)  -> i2 b "faddp" arg1 arg2
+  | FCHS -> i0 b "fchs"
+  | FCOMP arg -> i1 b "fcomp" arg
+  | FCOMPP -> i0 b "fcompp"
+  | FCOS -> i0 b "fcos"
+  | FDIV arg -> i1 b "fdiv" arg
+  | FDIVP (arg1, arg2)  -> i2 b "fdivp" arg1 arg2
+  | FDIVR arg -> i1 b "fdivr" arg
+  | FDIVRP (arg1, arg2)  -> i2 b "fdivrp" arg1 arg2
+  | FILD arg -> i1 b "fild" arg
+  | FISTP arg -> i1 b "fistp" arg
+  | FLD arg -> i1 b "fld" arg
+  | FLD1 -> i0 b "fld1"
+  | FLDCW arg -> i1 b "fldcw" arg
+  | FLDLG2 -> i0 b "fldlg2"
+  | FLDLN2 -> i0 b "fldln2"
+  | FLDZ -> i0 b "fldz"
+  | FMUL arg -> i1 b "fmul" arg
+  | FMULP (arg1, arg2)  -> i2 b "fmulp" arg1 arg2
+  | FNSTCW arg -> i1 b "fnstcw" arg
+  | FNSTSW arg -> i1 b "fnstsw" arg
+  | FPATAN -> i0 b "fpatan"
+  | FPTAN -> i0 b "fptan"
+  | FSIN -> i0 b "fsin"
+  | FSQRT -> i0 b "fsqrt"
+  | FSTP arg -> i1 b "fstp" arg
+  | FSUB arg -> i1 b "fsub" arg
+  | FSUBP (arg1, arg2)  -> i2 b "fsubp" arg1 arg2
+  | FSUBR arg -> i1 b "fsubr" arg
+  | FSUBRP (arg1, arg2)  -> i2 b "fsubrp" arg1 arg2
+  | FXCH arg -> i1 b "fxch" arg
+  | FYL2X -> i0 b "fyl2x"
+  | HLT -> assert false
+  | IDIV arg -> i1 b "idiv" arg
+  | IMUL (arg, None) -> i1 b "imul" arg
+  | IMUL (arg1, Some arg2) -> i2 b "imul" arg1 arg2
+  | INC arg -> i1 b "inc" arg
+  | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg
+  | JMP arg -> i1_call_jmp b "jmp" arg
+  | LEA (arg1, arg2) -> i2 b "lea" arg1 arg2
+  | LEAVE -> i0 b "leave"
+  | MOV (Imm n as arg1, Reg64 r) when
+      n >= 0x8000_0000L && n <= 0xFFFF_FFFFL ->
+      (* Work-around a bug in ml64.  Use a mov to the corresponding
+         32-bit lower register when the constant fits in 32-bit.
+         The associated higher 32-bit register will be zeroed. *)
+      i2 b "mov" arg1 (Reg32 r)
+  | MOV (arg1, arg2) -> i2 b "mov" arg1 arg2
+  | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2
+  | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2
+  | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2
+  | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2
+  | MOVSX (arg1, arg2) -> i2 b "movsx" arg1 arg2
+  | MOVSXD (arg1, arg2) -> i2 b "movsxd" arg1 arg2
+  | MOVZX (arg1, arg2) -> i2 b "movzx" arg1 arg2
+  | MULSD (arg1, arg2) -> i2 b "mulsd" arg1 arg2
+  | NEG arg -> i1 b "neg" arg
+  | NOP -> i0 b "nop"
+  | OR (arg1, arg2) -> i2 b "or" arg1 arg2
+  | POP arg -> i1 b "pop" arg
+  | PUSH arg -> i1 b "push" arg
+  | RET -> i0 b "ret"
+  | ROUNDSD (r, arg1, arg2) -> i2 b (string_of_rounding r) arg1 arg2
+  | SAL (arg1, arg2) -> i2 b "sal" arg1 arg2
+  | SAR (arg1, arg2) -> i2 b "sar" arg1 arg2
+  | SET (c, arg) -> i1 b ("set" ^ string_of_condition c) arg
+  | SHR (arg1, arg2) -> i2 b "shr" arg1 arg2
+  | SQRTSD (arg1, arg2) -> i2 b "sqrtsd" arg1 arg2
+  | SUB (arg1, arg2) -> i2 b "sub" arg1 arg2
+  | SUBSD (arg1, arg2) -> i2 b "subsd" arg1 arg2
+  | TEST (arg1, arg2) -> i2 b "test" arg1 arg2
+  | UCOMISD (arg1, arg2) -> i2 b "ucomisd" arg1 arg2
+  | XCHG (arg1, arg2) -> i2 b "xchg" arg1 arg2
+  | XOR (arg1, arg2) -> i2 b "xor" arg1 arg2
+  | XORPD (arg1, arg2) -> i2 b "xorpd" arg1 arg2
+
+
+let print_line b = function
+  | Ins instr -> print_instr b instr
+
+  | Align (_data,n) -> bprintf b "\tALIGN\t%d" n
+  | Byte n -> bprintf b "\tBYTE\t%a" cst n
+  | Bytes s -> buf_bytes_directive b "BYTE" s
+  | Comment s -> bprintf b " ; %s " s
+  | Global s -> bprintf b "\tPUBLIC\t%s" s
+  | Long n -> bprintf b "\tDWORD\t%a" cst n
+  | NewLabel (s, NONE) -> bprintf b "%s:" s
+  | NewLabel (s, ptr) -> bprintf b "%s LABEL %s" s (string_of_datatype ptr)
+  | Quad n -> bprintf b "\tQWORD\t%a" cst n
+  | Section ([".data"], None, []) -> bprintf b "\t.DATA"
+  | Section ([".text"], None, []) -> bprintf b "\t.CODE"
+  | Section _ -> assert false
+  | Space n -> bprintf b "\tBYTE\t%d DUP (?)" n
+  | Word n -> bprintf b "\tWORD\t%a" cst n
+
+  (* windows only *)
+  | External (s, ptr) -> bprintf b "\tEXTRN\t%s: %s" s (string_of_datatype ptr)
+  | Mode386 -> bprintf b "\t.386"
+  | Model name -> bprintf b "\t.MODEL %s" name (* name = FLAT *)
+
+  (* gas only *)
+  | Cfi_adjust_cfa_offset _
+  | Cfi_endproc
+  | Cfi_startproc
+  | File _
+  | Indirect_symbol _
+  | Loc _
+  | Private_extern _
+  | Set _
+  | Size _
+  | Type _
+    -> assert false
+
+let generate_asm oc lines =
+  let b = Buffer.create 10000 in
+  List.iter
+    (fun i ->
+       Buffer.clear b;
+       print_line b i;
+       Buffer.add_char b '\n';
+       Buffer.output_buffer oc b
+    )
+    lines;
+  output_string oc "\tEND\n"
diff --git a/asmcomp/x86_masm.mli b/asmcomp/x86_masm.mli
new file mode 100644
index 00000000..9027fe67
--- /dev/null
+++ b/asmcomp/x86_masm.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Emit assembly instructions for MASM (Intel syntax). *)
+
+val generate_asm: out_channel -> X86_ast.asm_line list -> unit
diff --git a/asmcomp/x86_proc.ml b/asmcomp/x86_proc.ml
new file mode 100644
index 00000000..30b77af5
--- /dev/null
+++ b/asmcomp/x86_proc.ml
@@ -0,0 +1,275 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open X86_ast
+
+type system =
+  (* 32 bits and 64 bits *)
+  | S_macosx
+  | S_gnu
+  | S_cygwin
+
+  (* 32 bits only *)
+  | S_solaris
+  | S_win32
+  | S_linux_elf
+  | S_bsd_elf
+  | S_beos
+  | S_mingw
+
+  (* 64 bits only *)
+  | S_win64
+  | S_linux
+  | S_mingw64
+
+  | S_unknown
+
+
+let system = match Config.system with
+  | "macosx" -> S_macosx
+  | "solaris" -> S_solaris
+  | "win32" -> S_win32
+  | "linux_elf" -> S_linux_elf
+  | "bsd_elf" -> S_bsd_elf
+  | "beos" -> S_beos
+  | "gnu" -> S_gnu
+  | "cygwin" -> S_cygwin
+  | "mingw" -> S_mingw
+  | "mingw64" -> S_mingw64
+  | "win64" -> S_win64
+  | "linux" -> S_linux
+
+  | _ -> S_unknown
+
+let windows =
+  match system with
+  | S_mingw64 | S_cygwin | S_win64 -> true
+  | _ -> false
+
+let string_of_string_literal s =
+  let b = Buffer.create (String.length s + 2) in
+  let last_was_escape = ref false in
+  for i = 0 to String.length s - 1 do
+    let c = s.[i] in
+    if c >= '0' && c <= '9' then
+      if !last_was_escape
+      then Printf.bprintf b "\\%o" (Char.code c)
+      else Buffer.add_char b c
+    else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin
+      Buffer.add_char b c;
+      last_was_escape := false
+    end else begin
+      Printf.bprintf b "\\%o" (Char.code c);
+      last_was_escape := true
+    end
+  done;
+  Buffer.contents b
+
+let string_of_symbol prefix s =
+  let spec = ref false in
+  for i = 0 to String.length s - 1 do
+    match String.unsafe_get s i with
+    | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> ()
+    | _ -> spec := true;
+  done;
+  if not !spec then if prefix = "" then s else prefix ^ s
+  else
+    let b = Buffer.create (String.length s + 10) in
+    Buffer.add_string b prefix;
+    String.iter
+      (function
+        | ('A'..'Z' | 'a'..'z' | '0'..'9' | '_') as c -> Buffer.add_char b c
+        | c -> Printf.bprintf b "$%02x" (Char.code c)
+      )
+      s;
+    Buffer.contents b
+
+let buf_bytes_directive b directive s =
+  let pos = ref 0 in
+  for i = 0 to String.length s - 1 do
+    if !pos = 0
+    then begin
+      if i > 0 then Buffer.add_char b '\n';
+      Buffer.add_char b '\t';
+      Buffer.add_string b directive;
+      Buffer.add_char b '\t';
+    end
+    else Buffer.add_char b ',';
+    Printf.bprintf b "%d" (Char.code s.[i]);
+    incr pos;
+    if !pos >= 16 then begin pos := 0 end
+  done
+
+let string_of_reg64 = function
+  | RAX -> "rax"
+  | RBX -> "rbx"
+  | RDI -> "rdi"
+  | RSI -> "rsi"
+  | RDX -> "rdx"
+  | RCX -> "rcx"
+  | RBP -> "rbp"
+  | RSP -> "rsp"
+  | R8  -> "r8"
+  | R9  -> "r9"
+  | R10 -> "r10"
+  | R11 -> "r11"
+  | R12 -> "r12"
+  | R13 -> "r13"
+  | R14 -> "r14"
+  | R15 -> "r15"
+
+let string_of_reg8l = function
+  | RAX -> "al"
+  | RBX -> "bl"
+  | RCX -> "cl"
+  | RDX -> "dl"
+  | RSP -> "spl"
+  | RBP -> "bpl"
+  | RSI -> "sil"
+  | RDI -> "dil"
+  | R8  -> "r8b"
+  | R9  -> "r9b"
+  | R10 -> "r10b"
+  | R11 -> "r11b"
+  | R12 -> "r12b"
+  | R13 -> "r13b"
+  | R14 -> "r14b"
+  | R15 -> "r15b"
+
+let string_of_reg8h = function
+  | AH -> "ah"
+  | BH -> "bh"
+  | CH -> "ch"
+  | DH -> "dh"
+
+let string_of_reg16 = function
+  | RAX -> "ax"
+  | RBX -> "bx"
+  | RCX -> "cx"
+  | RDX -> "dx"
+  | RSP -> "sp"
+  | RBP -> "bp"
+  | RSI -> "si"
+  | RDI -> "di"
+  | R8  -> "r8w"
+  | R9  -> "r9w"
+  | R10 -> "r10w"
+  | R11 -> "r11w"
+  | R12 -> "r12w"
+  | R13 -> "r13w"
+  | R14 -> "r14w"
+  | R15 -> "r15w"
+
+let string_of_reg32 = function
+  | RAX -> "eax"
+  | RBX -> "ebx"
+  | RCX -> "ecx"
+  | RDX -> "edx"
+  | RSP -> "esp"
+  | RBP -> "ebp"
+  | RSI -> "esi"
+  | RDI -> "edi"
+  | R8  -> "r8d"
+  | R9  -> "r9d"
+  | R10 -> "r10d"
+  | R11 -> "r11d"
+  | R12 -> "r12d"
+  | R13 -> "r13d"
+  | R14 -> "r14d"
+  | R15 -> "r15d"
+
+let string_of_registerf = function
+  | XMM n -> Printf.sprintf "xmm%d" n
+  | TOS -> Printf.sprintf "tos"
+  | ST n -> Printf.sprintf "st(%d)" n
+
+let string_of_condition = function
+  | E -> "e"
+  | AE -> "ae"
+  | A -> "a"
+  | GE -> "ge"
+  | G -> "g"
+  | NE -> "ne"
+  | B -> "b"
+  | BE -> "be"
+  | L -> "l"
+  | LE -> "le"
+  | NP -> "np"
+  | P -> "p"
+  | NS -> "ns"
+  | S -> "s"
+  | NO -> "no"
+  | O -> "o"
+
+let string_of_rounding = function
+  | RoundDown -> "roundsd.down"
+  | RoundUp -> "roundsd.up"
+  | RoundTruncate -> "roundsd.trunc"
+  | RoundNearest -> "roundsd.near"
+
+
+(* These hooks can be used to insert optimization passes on
+   the assembly code. *)
+let assembler_passes = ref ([] : (asm_program -> asm_program) list)
+
+let internal_assembler = ref None
+let register_internal_assembler f = internal_assembler := Some f
+
+(* Which asm conventions to use *)
+let masm =
+  match system with
+  | S_win32 | S_win64 -> true
+  | _ -> false
+
+(* Shall we use an external assembler command ?
+   If [binary_content] contains some data, we can directly
+   save it. Otherwise, we have to ask an external command.
+*)
+let binary_content = ref None
+
+let compile infile outfile =
+  if masm then
+    Ccomp.command (Config.asm ^
+                   Filename.quote outfile ^ " " ^ Filename.quote infile ^
+                   (if !Clflags.verbose then "" else ">NUL"))
+  else
+    Ccomp.command (Config.asm ^ " -o " ^
+                   Filename.quote outfile ^ " " ^ Filename.quote infile)
+
+let assemble_file infile outfile =
+  match !binary_content with
+  | None -> compile infile outfile
+  | Some content -> content outfile; binary_content := None; 0
+
+let asm_code = ref []
+
+let directive dir = asm_code := dir :: !asm_code
+let emit ins = directive (Ins ins)
+
+let reset_asm_code () = asm_code := []
+
+let generate_code asm =
+  let instrs = List.rev !asm_code in
+  let instrs =
+    List.fold_left (fun instrs pass -> pass instrs) instrs !assembler_passes
+  in
+  begin match asm with
+  | Some f -> f instrs
+  | None -> ()
+  end;
+  begin match !internal_assembler with
+  | Some f -> binary_content := Some (f instrs)
+  | None -> binary_content := None
+  end
diff --git a/asmcomp/x86_proc.mli b/asmcomp/x86_proc.mli
new file mode 100644
index 00000000..388420b2
--- /dev/null
+++ b/asmcomp/x86_proc.mli
@@ -0,0 +1,91 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(** Definitions shared between the 32 and 64 bit Intel backends. *)
+
+open X86_ast
+
+(** Helpers for textual emitters *)
+
+val string_of_reg8l: reg64 -> string
+val string_of_reg8h: reg8h -> string
+val string_of_reg16: reg64 -> string
+val string_of_reg32: reg64 -> string
+val string_of_reg64: reg64 -> string
+val string_of_registerf: registerf -> string
+val string_of_string_literal: string -> string
+val string_of_condition: condition -> string
+val string_of_symbol: (*prefix*) string -> string -> string
+val string_of_rounding: rounding -> string
+val buf_bytes_directive:
+  Buffer.t -> (*directive*) string -> (*data*)string -> unit
+
+
+(** Buffer of assembly code *)
+
+val emit: instruction -> unit
+val directive: asm_line -> unit
+val reset_asm_code: unit -> unit
+
+(** Code emission *)
+
+val generate_code: (X86_ast.asm_line list -> unit) option -> unit
+  (** Post-process the stream of instructions.  Dump it (using
+      the provided syntax emitter) in a file (if provided) and
+      compile it with an internal assembler (if registered
+      through [register_internal_assembler]). *)
+
+val assemble_file: (*infile*) string -> (*outfile*) string -> (*retcode*) int
+(** Generate an object file corresponding to the last call to
+    [generate_code].  An internal assembler is used if available (and
+    the input file is ignored). Otherwise, the source asm file with an
+    external assembler. *)
+
+(** System detection *)
+
+type system =
+  (* 32 bits and 64 bits *)
+  | S_macosx
+  | S_gnu
+  | S_cygwin
+
+  (* 32 bits only *)
+  | S_solaris
+  | S_win32
+  | S_linux_elf
+  | S_bsd_elf
+  | S_beos
+  | S_mingw
+
+  (* 64 bits only *)
+  | S_win64
+  | S_linux
+  | S_mingw64
+
+  | S_unknown
+
+val system: system
+val masm: bool
+val windows:bool
+
+(** Support for plumbing a binary code emitter *)
+
+val register_internal_assembler: (asm_program -> string -> unit) -> unit
+
+
+(** Hooks for rewriting the assembly code *)
+
+val assembler_passes: (asm_program -> asm_program) list ref
diff --git a/asmrun/.depend b/asmrun/.depend
new file mode 100644
index 00000000..c2fa489b
--- /dev/null
+++ b/asmrun/.depend
@@ -0,0 +1,1520 @@
+afl.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
+alloc.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/stacks.h
+array.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+backtrace.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
+backtrace_prim.o: backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
+callback.o: callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+clambda_checks.o: clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
+compact.o: compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+compare.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+custom.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+debugger.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
+dynlink.o: dynlink.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+extern.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+fail.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
+finalise.o: finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h
+floats.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h ../byterun/caml/stacks.h
+freelist.o: freelist.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+gc_ctrl.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/compact.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
+globroots.o: globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/globroots.h
+hash.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/custom.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/hash.h
+intern.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+ints.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+io.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h
+lexing.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+main.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
+major_gc.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+md5.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+memory.o: memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+meta.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/fix_code.h \
+  ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+minor_gc.o: minor_gc.c ../byterun/caml/custom.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+misc.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/version.h
+natdynlink.o: natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
+obj.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
+parsing.o: parsing.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/alloc.h
+printexc.o: printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h \
+  ../byterun/caml/callback.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/printexc.h
+roots.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
+signals.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h
+signals_asm.o: signals_asm.c ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
+  signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+spacetime.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
+spacetime_snapshot.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h \
+  ../byterun/caml/spacetime.h
+startup.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
+startup_aux.o: startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.h
+str.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h
+sys.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
+  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h
+terminfo.o: terminfo.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+unix.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h ../byterun/caml/io.h
+weak.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/weak.h
+afl.p.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
+alloc.p.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/stacks.h
+array.p.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+backtrace.p.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
+backtrace_prim.p.o: backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
+callback.p.o: callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+clambda_checks.p.o: clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
+compact.p.o: compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+compare.p.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+custom.p.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+debugger.p.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
+dynlink.p.o: dynlink.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+extern.p.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+fail.p.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
+finalise.p.o: finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h
+floats.p.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h ../byterun/caml/stacks.h
+freelist.p.o: freelist.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+gc_ctrl.p.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/compact.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
+globroots.p.o: globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/globroots.h
+hash.p.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/custom.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/hash.h
+intern.p.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+ints.p.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+io.p.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h
+lexing.p.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+main.p.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
+major_gc.p.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+md5.p.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+memory.p.o: memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+meta.p.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/fix_code.h \
+  ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+minor_gc.p.o: minor_gc.c ../byterun/caml/custom.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+misc.p.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/version.h
+natdynlink.p.o: natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
+obj.p.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
+parsing.p.o: parsing.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/alloc.h
+printexc.p.o: printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h \
+  ../byterun/caml/callback.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/printexc.h
+roots.p.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
+signals.p.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h
+signals_asm.p.o: signals_asm.c ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
+  signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+spacetime.p.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.p.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
+spacetime_snapshot.p.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h \
+  ../byterun/caml/spacetime.h
+startup.p.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
+startup_aux.p.o: startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.h
+str.p.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h
+sys.p.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
+  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h
+terminfo.p.o: terminfo.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+unix.p.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h ../byterun/caml/io.h
+weak.p.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/weak.h
+afl.d.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
+alloc.d.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/stacks.h
+array.d.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+backtrace.d.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
+backtrace_prim.d.o: backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
+callback.d.o: callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+clambda_checks.d.o: clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
+compact.d.o: compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+compare.d.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+custom.d.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+debugger.d.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
+dynlink.d.o: dynlink.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+extern.d.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+fail.d.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
+finalise.d.o: finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h
+floats.d.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h ../byterun/caml/stacks.h
+freelist.d.o: freelist.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+gc_ctrl.d.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/compact.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
+globroots.d.o: globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/globroots.h
+hash.d.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/custom.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/hash.h
+intern.d.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+ints.d.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+io.d.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h
+lexing.d.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+main.d.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
+major_gc.d.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+md5.d.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+memory.d.o: memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+meta.d.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/fix_code.h \
+  ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+minor_gc.d.o: minor_gc.c ../byterun/caml/custom.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+misc.d.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/version.h
+natdynlink.d.o: natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
+obj.d.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
+parsing.d.o: parsing.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/alloc.h
+printexc.d.o: printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h \
+  ../byterun/caml/callback.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/printexc.h
+roots.d.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
+signals.d.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h
+signals_asm.d.o: signals_asm.c ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
+  signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+spacetime.d.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.d.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
+spacetime_snapshot.d.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h \
+  ../byterun/caml/spacetime.h
+startup.d.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
+startup_aux.d.o: startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.h
+str.d.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h
+sys.d.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
+  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h
+terminfo.d.o: terminfo.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+unix.d.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h ../byterun/caml/io.h
+weak.d.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/weak.h
+afl.i.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
+alloc.i.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/stacks.h
+array.i.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+backtrace.i.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
+backtrace_prim.i.o: backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
+callback.i.o: callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+clambda_checks.i.o: clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
+compact.i.o: compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+compare.i.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+custom.i.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+debugger.i.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
+dynlink.i.o: dynlink.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+extern.i.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+fail.i.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
+finalise.i.o: finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h
+floats.i.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h ../byterun/caml/stacks.h
+freelist.i.o: freelist.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+gc_ctrl.i.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/compact.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
+globroots.i.o: globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/globroots.h
+hash.i.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/custom.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/hash.h
+intern.i.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/custom.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/md5.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+ints.i.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+io.i.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h
+lexing.i.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+main.i.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
+major_gc.i.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+md5.i.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+memory.i.o: memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+meta.i.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/fix_code.h \
+  ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+minor_gc.i.o: minor_gc.c ../byterun/caml/custom.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/fail.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+misc.i.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/version.h
+natdynlink.i.o: natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
+obj.i.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
+parsing.i.o: parsing.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/alloc.h
+printexc.i.o: printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h \
+  ../byterun/caml/callback.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/printexc.h
+roots.i.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
+signals.i.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/callback.h ../byterun/caml/fail.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h
+signals_asm.i.o: signals_asm.c ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
+  signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+spacetime.i.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.i.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
+spacetime_snapshot.i.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h \
+  ../byterun/caml/spacetime.h
+startup.i.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/freelist.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
+startup_aux.i.o: startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.h
+str.i.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h
+sys.i.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
+  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h
+terminfo.i.o: terminfo.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+unix.i.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/sys.h ../byterun/caml/io.h
+weak.i.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
+  ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/fail.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/weak.h
diff --git a/asmrun/Makefile b/asmrun/Makefile
new file mode 100644
index 00000000..aab82db0
--- /dev/null
+++ b/asmrun/Makefile
@@ -0,0 +1,197 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include ../config/Makefile
+
+LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
+  compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
+  parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
+  weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \
+  $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c startup_aux.c \
+  backtrace.c afl.c
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+CC=$(NATIVECC)
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+LN = cp
+else
+LN = ln -s
+endif
+
+FLAGS=\
+  -I../byterun \
+  -DNATIVE_CODE -DTARGET_$(ARCH)
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+FLAGS += -DMODEL_$(MODEL)
+endif
+
+FLAGS += -DSYS_$(SYSTEM) \
+  $(NATIVECCCOMPOPTS) $(IFLEXDIR) \
+  $(LIBUNWIND_INCLUDE_FLAGS)
+
+ifeq "$(TOOLCHAIN)" "msvc"
+DFLAGS=$(FLAGS) -DDEBUG
+PFLAGS=$(FLAGS) -DPROFILING $(NATIVECCPROFOPTS)
+OUTPUTOBJ = -Fo
+ASMOBJS=$(ARCH)nt.$(O)
+else
+DFLAGS=$(FLAGS) -g -DDEBUG
+PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS)
+OUTPUTOBJ = -o
+ASMOBJS=$(ARCH).$(O)
+endif
+
+IFLAGS=$(FLAGS) -DCAML_INSTR
+PICFLAGS=$(FLAGS) $(SHAREDCCCOMPOPTS)
+
+ASPPFLAGS = -DSYS_$(SYSTEM)
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ASPPFLAGS += -DMODEL_$(MODEL)
+CFLAGS=$(FLAGS) -g
+else
+CFLAGS=$(FLAGS)
+endif
+
+COBJS=startup_aux.$(O) startup.$(O) main.$(O) fail.$(O)		\
+  roots.$(O) signals.$(O) signals_asm.$(O) misc.$(O) freelist.$(O)	\
+  major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) compare.$(O)	\
+  ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O)		\
+  intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O)		\
+  terminfo.$(O) md5.$(O) obj.$(O) lexing.$(O) $(UNIX_OR_WIN32).$(O)	\
+  printexc.$(O) callback.$(O) weak.$(O) compact.$(O) finalise.$(O)	\
+  custom.$(O) globroots.$(O) backtrace_prim.$(O) backtrace.$(O)		\
+  natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O)			\
+  clambda_checks.$(O) spacetime.$(O) spacetime_snapshot.$(O)		\
+  spacetime_offline.$(O) afl.$(O)
+
+OBJS=$(COBJS) $(ASMOBJS)
+
+DOBJS=$(COBJS:.$(O)=.d.$(O)) $(ASMOBJS)
+IOBJS=$(COBJS:.$(O)=.i.$(O)) $(ASMOBJS)
+POBJS=$(COBJS:.$(O)=.p.$(O)) $(ASMOBJS:.$(O)=.p.$(O))
+PICOBJS=$(COBJS:.$(O)=.pic.$(O)) $(ASMOBJS:.$(O)=.pic.$(O))
+
+TARGETS = libasmrun.$(A)
+
+ifeq "$(RUNTIMED)" "true"
+TARGETS += libasmrund.$(A)
+endif
+
+ifeq "$(RUNTIMEI)" "true"
+TARGETS += libasmruni.$(A)
+endif
+
+ifeq "$(PROFILING)" "true"
+TARGETS += libasmrunp.$(A)
+endif
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
+TARGETS += libasmrun_pic.$(A) libasmrun_shared.$(SO)
+endif
+endif
+
+.PHONY: all
+all: $(TARGETS)
+
+libasmrun.$(A): $(OBJS)
+	$(call MKLIB,$@, $^)
+
+libasmrund.$(A): $(DOBJS)
+	$(call MKLIB,$@, $^)
+
+libasmruni.$(A): $(IOBJS)
+	$(call MKLIB,$@, $^)
+
+libasmrunp.$(A): $(POBJS)
+	$(call MKLIB,$@, $^)
+
+libasmrun_pic.$(A): $(PICOBJS)
+	$(call MKLIB,$@, $^)
+
+libasmrun_shared.$(SO): $(PICOBJS)
+	$(MKDLL) -o $@ $^ $(NATIVECCLIBS)
+
+.PHONY: install
+install:
+	cp $(TARGETS) "$(INSTALL_LIBDIR)"
+
+$(LINKEDFILES): %.c: ../byterun/%.c
+	$(LN) $< $@
+
+%.d.$(O): %.c
+	$(CC) -c $(DFLAGS) $(OUTPUTOBJ)$@ $<
+
+%.i.$(O): %.c
+	$(CC) -c $(IFLAGS) $(OUTPUTOBJ)$@ $<
+
+%.p.$(O): %.c
+	$(CC) -c $(PFLAGS) $(OUTPUTOBJ)$@ $<
+
+%.pic.$(O): %.c
+	$(CC) -c $(PICFLAGS) $(OUTPUTOBJ)$@ $<
+
+%.$(O): %.c
+	$(CC) $(CFLAGS) -c $<
+
+%.o: %.S
+	$(ASPP) $(ASPPFLAGS) -o $@ $< || \
+	{ echo "If your assembler produced syntax errors, it is probably";\
+          echo "unhappy with the preprocessor. Check your assembler, or";\
+          echo "try producing $*.o by hand.";\
+          exit 2; }
+
+%.p.o: %.S
+	$(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $@ $<
+
+%.pic.o: %.S
+	$(ASPP) $(ASPPFLAGS) $(SHAREDCCCOMPOPTS) -o $@ $<
+
+%.obj: %.asm
+	$(ASM)$@ $<
+
+%.pic.obj: %.asm
+	$(ASM)$@ $<
+
+.PHONY: clean
+clean:
+	rm -f $(LINKEDFILES)
+	rm -f *.$(O) *.$(A) *.$(SO)
+
+.PHONY: distclean
+distclean: clean
+	rm -r *~
+
+ifneq "$(TOOLCHAIN)" "msvc"
+.PHONY: depend
+depend: $(COBJS:.$(O)=.c) $(LINKEDFILES)
+	$(CC) -MM $(FLAGS) *.c > .depend
+	$(CC) -MM $(FLAGS) -DPROFILING *.c | sed -e 's/\.o/.p.o/' >> .depend
+	$(CC) -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend
+	$(CC) -MM $(FLAGS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' >> .depend
+endif
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+.depend.nt: .depend
+	sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
+
+include .depend.nt
+
+else
+include .depend
+endif
diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/asmrun/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/asmrun/amd64.S b/asmrun/amd64.S
new file mode 100644
index 00000000..efb8fd9b
--- /dev/null
+++ b/asmrun/amd64.S
@@ -0,0 +1,742 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Asm part of the runtime system, AMD64 processor */
+/* Must be preprocessed by cpp */
+
+/* PIC mode support based on contribution by Paul Stravers (see PR#4795) */
+
+#include "../config/m.h"
+
+#if defined(SYS_macosx)
+
+#define LBL(x) L##x
+#define G(r) _##r
+#define GREL(r) _##r@GOTPCREL
+#define GCALL(r) _##r
+#define FUNCTION_ALIGN 2
+#define EIGHT_ALIGN 3
+#define SIXTEEN_ALIGN 4
+#define FUNCTION(name) \
+        .globl name; \
+        .align FUNCTION_ALIGN; \
+        name:
+
+#elif defined(SYS_mingw64) || defined(SYS_cygwin)
+
+#define LBL(x) .L##x
+#define G(r) r
+#undef  GREL
+#define GCALL(r) r
+#define FUNCTION_ALIGN 4
+#define EIGHT_ALIGN 8
+#define SIXTEEN_ALIGN 16
+#define FUNCTION(name) \
+        .globl name; \
+        .align FUNCTION_ALIGN; \
+        name:
+
+#else
+
+#define LBL(x) .L##x
+#define G(r) r
+#define GREL(r) r@GOTPCREL
+#define GCALL(r) r@PLT
+#define FUNCTION_ALIGN 4
+#define EIGHT_ALIGN 8
+#define SIXTEEN_ALIGN 16
+#define FUNCTION(name) \
+        .globl name; \
+        .type name,@function; \
+        .align FUNCTION_ALIGN; \
+        name:
+
+#endif
+
+#ifdef ASM_CFI_SUPPORTED
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#define CFI_OFFSET(r, n) .cfi_offset r, n
+#define CFI_SAME_VALUE(r) .cfi_same_value r
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#define CFI_OFFSET(r, n)
+#define CFI_SAME_VALUE(r)
+#endif
+
+#ifdef WITH_FRAME_POINTERS
+
+#define ENTER_FUNCTION \
+        pushq   %rbp; CFI_ADJUST(8); \
+        movq    %rsp, %rbp
+#define LEAVE_FUNCTION \
+        popq    %rbp; CFI_ADJUST(-8);
+
+#else
+
+#define ENTER_FUNCTION \
+        subq    $8, %rsp; CFI_ADJUST (8);
+#define LEAVE_FUNCTION \
+        addq    $8, %rsp; CFI_ADJUST (-8);
+
+#endif
+
+#if defined(__PIC__) && !defined(SYS_mingw64) && !defined(SYS_cygwin)
+
+/* Position-independent operations on global variables. */
+
+/* Store [srcreg] in global [dstlabel].  Clobbers %r11. */
+#define STORE_VAR(srcreg,dstlabel) \
+        movq    GREL(dstlabel)(%rip), %r11 ; \
+        movq    srcreg, (%r11)
+
+#define STORE_VAR32(srcreg,dstlabel) \
+        movq    GREL(dstlabel)(%rip), %r11 ; \
+        movl    srcreg, (%r11)
+
+/* Load global [srclabel] in register [dstreg].  Clobbers %r11. */
+#define LOAD_VAR(srclabel,dstreg) \
+        movq    GREL(srclabel)(%rip), %r11 ; \
+        movq    (%r11), dstreg
+
+/* Compare global [label] with register [reg].  Clobbers %rax. */
+#define CMP_VAR(label,reg) \
+        movq    GREL(label)(%rip), %rax ; \
+        cmpq    (%rax), reg
+
+/* Test 32-bit global [label] against mask [imm].  Clobbers %r11. */
+#define TESTL_VAR(imm,label) \
+        movq    GREL(label)(%rip), %r11 ; \
+        testl   imm, (%r11)
+
+/* Push global [label] on stack.  Clobbers %r11. */
+#define PUSH_VAR(srclabel) \
+        movq    GREL(srclabel)(%rip), %r11 ; \
+        pushq   (%r11); CFI_ADJUST (8)
+
+/* Pop global [label] off stack.  Clobbers %r11. */
+#define POP_VAR(dstlabel) \
+        movq    GREL(dstlabel)(%rip), %r11 ; \
+        popq    (%r11);  CFI_ADJUST (-8)
+
+/* Record lowest stack address and return address.  Clobbers %rax. */
+#define RECORD_STACK_FRAME(OFFSET) \
+        pushq   %r11 ; CFI_ADJUST(8); \
+        movq    8+OFFSET(%rsp), %rax ; \
+        STORE_VAR(%rax,caml_last_return_address) ; \
+        leaq    16+OFFSET(%rsp), %rax ; \
+        STORE_VAR(%rax,caml_bottom_of_stack) ; \
+        popq    %r11; CFI_ADJUST(-8)
+
+/* Load address of global [label] in register [dst]. */
+#define LEA_VAR(label,dst) \
+        movq    GREL(label)(%rip), dst
+
+#else
+
+/* Non-PIC operations on global variables.  Slightly faster. */
+
+#define STORE_VAR(srcreg,dstlabel) \
+        movq    srcreg, G(dstlabel)(%rip)
+
+#define STORE_VAR32(srcreg,dstlabel) \
+        movl    srcreg, G(dstlabel)(%rip)
+
+#define LOAD_VAR(srclabel,dstreg) \
+        movq    G(srclabel)(%rip), dstreg
+
+#define CMP_VAR(label,reg) \
+        cmpq    G(label)(%rip), %r15
+
+#define TESTL_VAR(imm,label) \
+        testl   imm, G(label)(%rip)
+
+#define PUSH_VAR(srclabel) \
+        pushq   G(srclabel)(%rip) ; CFI_ADJUST(8)
+
+#define POP_VAR(dstlabel) \
+        popq    G(dstlabel)(%rip); CFI_ADJUST(-8)
+
+#define RECORD_STACK_FRAME(OFFSET) \
+        movq    OFFSET(%rsp), %rax ; \
+        STORE_VAR(%rax,caml_last_return_address) ; \
+        leaq    8+OFFSET(%rsp), %rax ; \
+        STORE_VAR(%rax,caml_bottom_of_stack)
+
+#define LEA_VAR(label,dst) \
+        leaq    G(label)(%rip), dst
+#endif
+
+/* Save and restore all callee-save registers on stack.
+   Keep the stack 16-aligned. */
+
+#if defined(SYS_mingw64) || defined(SYS_cygwin)
+
+/* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */
+
+#define PUSH_CALLEE_SAVE_REGS \
+        pushq   %rbx; CFI_ADJUST (8); CFI_OFFSET(rbx, -16); \
+        pushq   %rbp; CFI_ADJUST (8); CFI_OFFSET(rbp, -24); \
+                      /* Allows debugger to walk the stack */ \
+        pushq   %rsi; CFI_ADJUST (8); CFI_OFFSET(rsi, -32); \
+        pushq   %rdi; CFI_ADJUST (8); CFI_OFFSET(rdi, -40); \
+        pushq   %r12; CFI_ADJUST (8); CFI_OFFSET(r12, -48); \
+        pushq   %r13; CFI_ADJUST (8); CFI_OFFSET(r13, -56); \
+        pushq   %r14; CFI_ADJUST (8); CFI_OFFSET(r14, -64); \
+        pushq   %r15; CFI_ADJUST (8); CFI_OFFSET(r15, -72); \
+        subq    $(8+10*16), %rsp; CFI_ADJUST (8+10*16); \
+        movupd  %xmm6, 0*16(%rsp); \
+        movupd  %xmm7, 1*16(%rsp); \
+        movupd  %xmm8, 2*16(%rsp); \
+        movupd  %xmm9, 3*16(%rsp); \
+        movupd  %xmm10, 4*16(%rsp); \
+        movupd  %xmm11, 5*16(%rsp); \
+        movupd  %xmm12, 6*16(%rsp); \
+        movupd  %xmm13, 7*16(%rsp); \
+        movupd  %xmm14, 8*16(%rsp); \
+        movupd  %xmm15, 9*16(%rsp)
+
+#define POP_CALLEE_SAVE_REGS \
+        movupd  0*16(%rsp), %xmm6; \
+        movupd  1*16(%rsp), %xmm7; \
+        movupd  2*16(%rsp), %xmm8; \
+        movupd  3*16(%rsp), %xmm9; \
+        movupd  4*16(%rsp), %xmm10; \
+        movupd  5*16(%rsp), %xmm11; \
+        movupd  6*16(%rsp), %xmm12; \
+        movupd  7*16(%rsp), %xmm13; \
+        movupd  8*16(%rsp), %xmm14; \
+        movupd  9*16(%rsp), %xmm15; \
+        addq    $(8+10*16), %rsp; CFI_ADJUST (-8-10*16); \
+        popq    %r15; CFI_ADJUST(-8); CFI_SAME_VALUE(r15); \
+        popq    %r14; CFI_ADJUST(-8); CFI_SAME_VALUE(r14); \
+        popq    %r13; CFI_ADJUST(-8); CFI_SAME_VALUE(r13); \
+        popq    %r12; CFI_ADJUST(-8); CFI_SAME_VALUE(r12); \
+        popq    %rdi; CFI_ADJUST(-8); CFI_SAME_VALUE(rdi); \
+        popq    %rsi; CFI_ADJUST(-8); CFI_SAME_VALUE(rsi); \
+        popq    %rbp; CFI_ADJUST(-8); CFI_SAME_VALUE(rbp); \
+        popq    %rbx; CFI_ADJUST(-8); CFI_SAME_VALUE(rbx)
+
+#else
+
+/* Unix API: callee-save regs are rbx, rbp, r12-r15 */
+
+#define PUSH_CALLEE_SAVE_REGS \
+        pushq   %rbx; CFI_ADJUST(8); CFI_OFFSET(rbx, -16); \
+        pushq   %rbp; CFI_ADJUST(8); CFI_OFFSET(rbp, -24); \
+        pushq   %r12; CFI_ADJUST(8); CFI_OFFSET(r12, -32); \
+        pushq   %r13; CFI_ADJUST(8); CFI_OFFSET(r13, -40); \
+        pushq   %r14; CFI_ADJUST(8); CFI_OFFSET(r14, -48); \
+        pushq   %r15; CFI_ADJUST(8); CFI_OFFSET(r15, -56); \
+        subq    $8, %rsp; CFI_ADJUST(8)
+
+#define POP_CALLEE_SAVE_REGS \
+        addq    $8, %rsp; CFI_ADJUST(-8); \
+        popq    %r15; CFI_ADJUST(-8); CFI_SAME_VALUE(r15); \
+        popq    %r14; CFI_ADJUST(-8); CFI_SAME_VALUE(r14); \
+        popq    %r13; CFI_ADJUST(-8); CFI_SAME_VALUE(r13); \
+        popq    %r12; CFI_ADJUST(-8); CFI_SAME_VALUE(r12); \
+        popq    %rbp; CFI_ADJUST(-8); CFI_SAME_VALUE(rbp); \
+        popq    %rbx; CFI_ADJUST(-8); CFI_SAME_VALUE(rbx)
+
+#endif
+
+#if defined(SYS_mingw64) || defined (SYS_cygwin)
+   /* Calls from OCaml to C must reserve 32 bytes of extra stack space */
+#  define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32)
+#  define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32)
+#else
+#  define PREPARE_FOR_C_CALL
+#  define CLEANUP_AFTER_C_CALL
+#endif
+
+        .text
+
+        .globl  G(caml_system__code_begin)
+G(caml_system__code_begin):
+        ret  /* just one instruction, so that debuggers don't display
+        caml_system__code_begin instead of caml_call_gc */
+
+/* Allocation */
+
+FUNCTION(G(caml_call_gc))
+        CFI_STARTPROC
+        RECORD_STACK_FRAME(0)
+LBL(caml_call_gc):
+#if !defined(SYS_mingw64) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subq    $32768, %rsp
+        movq    %rax, 0(%rsp)
+        addq    $32768, %rsp
+#endif
+    /* Build array of registers, save it into caml_gc_regs */
+#ifdef WITH_FRAME_POINTERS
+        ENTER_FUNCTION          ;
+#else
+        pushq   %rbp; CFI_ADJUST(8);
+#endif
+        pushq   %r11; CFI_ADJUST (8);
+        pushq   %r10; CFI_ADJUST (8);
+        pushq   %r13; CFI_ADJUST (8);
+        pushq   %r12; CFI_ADJUST (8);
+        pushq   %r9; CFI_ADJUST (8);
+        pushq   %r8; CFI_ADJUST (8);
+        pushq   %rcx; CFI_ADJUST (8);
+        pushq   %rdx; CFI_ADJUST (8);
+        pushq   %rsi; CFI_ADJUST (8);
+        pushq   %rdi; CFI_ADJUST (8);
+        pushq   %rbx; CFI_ADJUST (8);
+        pushq   %rax; CFI_ADJUST (8);
+        STORE_VAR(%rsp, caml_gc_regs)
+    /* Save caml_young_ptr, caml_exception_pointer */
+        STORE_VAR(%r15, caml_young_ptr)
+        STORE_VAR(%r14, caml_exception_pointer)
+#ifdef WITH_SPACETIME
+        STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
+#endif
+    /* Save floating-point registers */
+        subq    $(16*8), %rsp; CFI_ADJUST (16*8);
+        movsd   %xmm0, 0*8(%rsp)
+        movsd   %xmm1, 1*8(%rsp)
+        movsd   %xmm2, 2*8(%rsp)
+        movsd   %xmm3, 3*8(%rsp)
+        movsd   %xmm4, 4*8(%rsp)
+        movsd   %xmm5, 5*8(%rsp)
+        movsd   %xmm6, 6*8(%rsp)
+        movsd   %xmm7, 7*8(%rsp)
+        movsd   %xmm8, 8*8(%rsp)
+        movsd   %xmm9, 9*8(%rsp)
+        movsd   %xmm10, 10*8(%rsp)
+        movsd   %xmm11, 11*8(%rsp)
+        movsd   %xmm12, 12*8(%rsp)
+        movsd   %xmm13, 13*8(%rsp)
+        movsd   %xmm14, 14*8(%rsp)
+        movsd   %xmm15, 15*8(%rsp)
+    /* Call the garbage collector */
+        PREPARE_FOR_C_CALL
+        call    GCALL(caml_garbage_collection)
+        CLEANUP_AFTER_C_CALL
+    /* Restore caml_young_ptr, caml_exception_pointer */
+        LOAD_VAR(caml_young_ptr, %r15)
+        LOAD_VAR(caml_exception_pointer, %r14)
+    /* Restore all regs used by the code generator */
+        movsd   0*8(%rsp), %xmm0
+        movsd   1*8(%rsp), %xmm1
+        movsd   2*8(%rsp), %xmm2
+        movsd   3*8(%rsp), %xmm3
+        movsd   4*8(%rsp), %xmm4
+        movsd   5*8(%rsp), %xmm5
+        movsd   6*8(%rsp), %xmm6
+        movsd   7*8(%rsp), %xmm7
+        movsd   8*8(%rsp), %xmm8
+        movsd   9*8(%rsp), %xmm9
+        movsd   10*8(%rsp), %xmm10
+        movsd   11*8(%rsp), %xmm11
+        movsd   12*8(%rsp), %xmm12
+        movsd   13*8(%rsp), %xmm13
+        movsd   14*8(%rsp), %xmm14
+        movsd   15*8(%rsp), %xmm15
+        addq    $(16*8), %rsp; CFI_ADJUST(-16*8)
+        popq    %rax; CFI_ADJUST(-8)
+        popq    %rbx; CFI_ADJUST(-8)
+        popq    %rdi; CFI_ADJUST(-8)
+        popq    %rsi; CFI_ADJUST(-8)
+        popq    %rdx; CFI_ADJUST(-8)
+        popq    %rcx; CFI_ADJUST(-8)
+        popq    %r8; CFI_ADJUST(-8)
+        popq    %r9; CFI_ADJUST(-8)
+        popq    %r12; CFI_ADJUST(-8)
+        popq    %r13; CFI_ADJUST(-8)
+        popq    %r10; CFI_ADJUST(-8)
+        popq    %r11; CFI_ADJUST(-8)
+#ifdef WITH_FRAME_POINTERS
+        LEAVE_FUNCTION
+#else
+        popq    %rbp; CFI_ADJUST(-8);
+#endif
+    /* Return to caller */
+        ret
+CFI_ENDPROC
+
+FUNCTION(G(caml_alloc1))
+CFI_STARTPROC
+LBL(caml_alloc1):
+        subq    $16, %r15
+        CMP_VAR(caml_young_limit, %r15)
+        jb      LBL(100)
+        ret
+LBL(100):
+        RECORD_STACK_FRAME(0)
+        ENTER_FUNCTION
+/*        subq    $8, %rsp; CFI_ADJUST (8); */
+        call    LBL(caml_call_gc)
+/*        addq    $8, %rsp; CFI_ADJUST (-8); */
+        LEAVE_FUNCTION
+        jmp     LBL(caml_alloc1)
+CFI_ENDPROC
+
+FUNCTION(G(caml_alloc2))
+CFI_STARTPROC
+LBL(caml_alloc2):
+        subq    $24, %r15
+        CMP_VAR(caml_young_limit, %r15)
+        jb      LBL(101)
+        ret
+LBL(101):
+        RECORD_STACK_FRAME(0)
+        ENTER_FUNCTION
+/*        subq    $8, %rsp; CFI_ADJUST (8); */
+        call    LBL(caml_call_gc)
+/*        addq    $8, %rsp; CFI_ADJUST (-8); */
+        LEAVE_FUNCTION
+        jmp     LBL(caml_alloc2)
+CFI_ENDPROC
+
+FUNCTION(G(caml_alloc3))
+CFI_STARTPROC
+LBL(caml_alloc3):
+        subq    $32, %r15
+        CMP_VAR(caml_young_limit, %r15)
+        jb      LBL(102)
+        ret
+LBL(102):
+        RECORD_STACK_FRAME(0)
+        ENTER_FUNCTION
+/*        subq    $8, %rsp; CFI_ADJUST (8) */
+        call    LBL(caml_call_gc)
+/*        addq    $8, %rsp; CFI_ADJUST (-8) */
+        LEAVE_FUNCTION
+        jmp     LBL(caml_alloc3)
+CFI_ENDPROC
+
+FUNCTION(G(caml_allocN))
+CFI_STARTPROC
+LBL(caml_allocN):
+        pushq   %rax; CFI_ADJUST(8)        /* save desired size */
+        subq    %rax, %r15
+        CMP_VAR(caml_young_limit, %r15)
+        jb      LBL(103)
+        addq    $8, %rsp; CFI_ADJUST (-8)  /* drop desired size */
+        ret
+LBL(103):
+        CFI_ADJUST(8)
+        RECORD_STACK_FRAME(8)
+#ifdef WITH_FRAME_POINTERS
+        /* ensure 16 byte alignment by subq + enter using 16-bytes, PR#7417 */
+        subq    $8, %rsp; CFI_ADJUST (8)
+        ENTER_FUNCTION
+#endif
+        call    LBL(caml_call_gc)
+#ifdef WITH_FRAME_POINTERS
+        /* ensure 16 byte alignment by leave + addq using 16-bytes PR#7417 */
+        LEAVE_FUNCTION
+        addq    $8, %rsp; CFI_ADJUST (-8)
+#endif
+        popq    %rax; CFI_ADJUST(-8)       /* recover desired size */
+        jmp     LBL(caml_allocN)
+CFI_ENDPROC
+
+/* Call a C function from OCaml */
+
+FUNCTION(G(caml_c_call))
+CFI_STARTPROC
+LBL(caml_c_call):
+    /* Record lowest stack address and return address */
+        popq    %r12; CFI_ADJUST(-8)
+        STORE_VAR(%r12, caml_last_return_address)
+        STORE_VAR(%rsp, caml_bottom_of_stack)
+#ifdef WITH_SPACETIME
+    /* Record the trie node hole pointer that corresponds to
+       [caml_last_return_address] */
+        STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
+#endif
+        subq    $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */
+#if !defined(SYS_mingw64) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subq    $32768, %rsp
+        movq    %rax, 0(%rsp)
+        addq    $32768, %rsp
+#endif
+    /* Make the exception handler and alloc ptr available to the C code */
+        STORE_VAR(%r15, caml_young_ptr)
+        STORE_VAR(%r14, caml_exception_pointer)
+    /* Call the function (address in %rax) */
+    /* No need to PREPARE_FOR_C_CALL since the caller already
+       reserved the stack space if needed (cf. amd64/proc.ml) */
+        jmp    *%rax
+CFI_ENDPROC
+
+/* Start the OCaml program */
+
+FUNCTION(G(caml_start_program))
+       CFI_STARTPROC
+    /* Save callee-save registers */
+        PUSH_CALLEE_SAVE_REGS
+    /* Initial entry point is G(caml_program) */
+        LEA_VAR(caml_program, %r12)
+    /* Common code for caml_start_program and caml_callback* */
+LBL(caml_start_program):
+    /* Build a callback link */
+#ifdef WITH_SPACETIME
+        PUSH_VAR(caml_spacetime_trie_node_ptr)
+#else
+        subq    $8, %rsp; CFI_ADJUST (8)        /* stack 16-aligned */
+#endif
+        PUSH_VAR(caml_gc_regs)
+        PUSH_VAR(caml_last_return_address)
+        PUSH_VAR(caml_bottom_of_stack)
+#ifdef WITH_SPACETIME
+        /* Save arguments to caml_callback* */
+        pushq   %rax; CFI_ADJUST (8)
+        pushq   %rbx; CFI_ADJUST (8)
+        pushq   %rdi; CFI_ADJUST (8)
+        pushq   %rsi; CFI_ADJUST (8)
+        /* No need to push %r12: it's callee-save. */
+        movq    %r12, %rdi
+        LEA_VAR(caml_start_program, %rsi)
+        call    GCALL(caml_spacetime_c_to_ocaml)
+        popq    %rsi; CFI_ADJUST (-8)
+        popq    %rdi; CFI_ADJUST (-8)
+        popq    %rbx; CFI_ADJUST (-8)
+        popq    %rax; CFI_ADJUST (-8)
+#endif
+    /* Setup alloc ptr and exception ptr */
+        LOAD_VAR(caml_young_ptr, %r15)
+        LOAD_VAR(caml_exception_pointer, %r14)
+    /* Build an exception handler */
+        lea     LBL(108)(%rip), %r13
+        pushq   %r13; CFI_ADJUST(8)
+        pushq   %r14; CFI_ADJUST(8)
+        movq    %rsp, %r14
+#ifdef WITH_SPACETIME
+        LOAD_VAR(caml_spacetime_trie_node_ptr, %r13)
+#endif
+    /* Call the OCaml code */
+        call    *%r12
+LBL(107):
+    /* Pop the exception handler */
+        popq    %r14; CFI_ADJUST(-8)
+        popq    %r12; CFI_ADJUST(-8)   /* dummy register */
+LBL(109):
+    /* Update alloc ptr and exception ptr */
+        STORE_VAR(%r15,caml_young_ptr)
+        STORE_VAR(%r14,caml_exception_pointer)
+    /* Pop the callback link, restoring the global variables */
+        POP_VAR(caml_bottom_of_stack)
+        POP_VAR(caml_last_return_address)
+        POP_VAR(caml_gc_regs)
+#ifdef WITH_SPACETIME
+        POP_VAR(caml_spacetime_trie_node_ptr)
+#else
+        addq    $8, %rsp; CFI_ADJUST (-8);
+#endif
+    /* Restore callee-save registers. */
+        POP_CALLEE_SAVE_REGS
+    /* Return to caller. */
+        ret
+LBL(108):
+    /* Exception handler*/
+    /* Mark the bucket as an exception result and return it */
+        orq     $2, %rax
+        jmp     LBL(109)
+CFI_ENDPROC
+
+/* Registers holding arguments of C functions. */
+
+#if defined(SYS_mingw64) || defined(SYS_cygwin)
+#define C_ARG_1 %rcx
+#define C_ARG_2 %rdx
+#define C_ARG_3 %r8
+#define C_ARG_4 %r9
+#else
+#define C_ARG_1 %rdi
+#define C_ARG_2 %rsi
+#define C_ARG_3 %rdx
+#define C_ARG_4 %rcx
+#endif
+
+/* Raise an exception from OCaml */
+
+FUNCTION(G(caml_raise_exn))
+CFI_STARTPROC
+        TESTL_VAR($1, caml_backtrace_active)
+        jne     LBL(110)
+        movq    %r14, %rsp
+        popq    %r14
+        ret
+LBL(110):
+        movq    %rax, %r12            /* Save exception bucket */
+        movq    %rax, C_ARG_1         /* arg 1: exception bucket */
+#ifdef WITH_FRAME_POINTERS
+        ENTER_FUNCTION
+        movq    8(%rsp), C_ARG_2      /* arg 2: pc of raise */
+        leaq    16(%rsp), C_ARG_3     /* arg 3: sp at raise */
+#else
+        popq    C_ARG_2               /* arg 2: pc of raise */
+        movq    %rsp, C_ARG_3         /* arg 3: sp at raise */
+#endif
+        movq    %r14, C_ARG_4         /* arg 4: sp of handler */
+        /* PR#5700: thanks to popq above, stack is now 16-aligned */
+        /* Thanks to ENTER_FUNCTION, stack is now 16-aligned */
+        PREPARE_FOR_C_CALL            /* no need to cleanup after */
+        call    GCALL(caml_stash_backtrace)
+        movq    %r12, %rax            /* Recover exception bucket */
+        movq    %r14, %rsp
+        popq    %r14
+        ret
+CFI_ENDPROC
+
+/* Raise an exception from C */
+
+FUNCTION(G(caml_raise_exception))
+CFI_STARTPROC
+        TESTL_VAR($1, caml_backtrace_active)
+        jne     LBL(112)
+        movq    C_ARG_1, %rax
+        LOAD_VAR(caml_exception_pointer, %rsp)  /* Cut stack */
+        popq    %r14                   /* Recover previous exception handler */
+        LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */
+        ret
+LBL(112):
+#ifdef WITH_FRAME_POINTERS
+        ENTER_FUNCTION          ;
+#endif
+        movq    C_ARG_1, %r12            /* Save exception bucket */
+                                      /* arg 1: exception bucket */
+        LOAD_VAR(caml_last_return_address,C_ARG_2)   /* arg 2: pc of raise */
+        LOAD_VAR(caml_bottom_of_stack,C_ARG_3)       /* arg 3: sp of raise */
+        LOAD_VAR(caml_exception_pointer,C_ARG_4)     /* arg 4: sp of handler */
+#ifndef WITH_FRAME_POINTERS
+        subq    $8, %rsp              /* PR#5700: maintain stack alignment */
+#endif
+        PREPARE_FOR_C_CALL            /* no need to cleanup after */
+        call    GCALL(caml_stash_backtrace)
+        movq    %r12, %rax            /* Recover exception bucket */
+        LOAD_VAR(caml_exception_pointer,%rsp)
+        popq    %r14                  /* Recover previous exception handler */
+        LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
+        ret
+CFI_ENDPROC
+
+/* Raise a Stack_overflow exception on return from segv_handler()
+   (in asmrun/signals_asm.c).  On entry, the stack is full, so we
+   cannot record a backtrace.
+   No CFI information here since this function disrupts the stack
+   backtrace anyway. */
+
+FUNCTION(G(caml_stack_overflow))
+        LEA_VAR(caml_exn_Stack_overflow, %rax)
+        movq    %r14, %rsp            /* cut the stack */
+        popq    %r14                  /* recover previous exn handler */
+        ret                           /* jump to handler's code */
+
+/* Callback from C to OCaml */
+
+FUNCTION(G(caml_callback_exn))
+CFI_STARTPROC
+    /* Save callee-save registers */
+        PUSH_CALLEE_SAVE_REGS
+    /* Initial loading of arguments */
+        movq    C_ARG_1, %rbx      /* closure */
+        movq    C_ARG_2, %rax      /* argument */
+        movq    0(%rbx), %r12      /* code pointer */
+        jmp     LBL(caml_start_program)
+CFI_ENDPROC
+
+FUNCTION(G(caml_callback2_exn))
+CFI_STARTPROC
+    /* Save callee-save registers */
+        PUSH_CALLEE_SAVE_REGS
+    /* Initial loading of arguments */
+        movq    C_ARG_1, %rdi      /* closure -- no op with Unix conventions */
+        movq    C_ARG_2, %rax      /* first argument */
+        movq    C_ARG_3, %rbx      /* second argument */
+        LEA_VAR(caml_apply2, %r12) /* code pointer */
+        jmp     LBL(caml_start_program)
+CFI_ENDPROC
+
+FUNCTION(G(caml_callback3_exn))
+CFI_STARTPROC
+    /* Save callee-save registers */
+        PUSH_CALLEE_SAVE_REGS
+    /* Initial loading of arguments */
+        movq    C_ARG_2, %rax      /* first argument */
+        movq    C_ARG_3, %rbx      /* second argument */
+        movq    C_ARG_1, %rsi      /* closure */
+        movq    C_ARG_4, %rdi      /* third argument */
+        LEA_VAR(caml_apply3, %r12) /* code pointer */
+        jmp     LBL(caml_start_program)
+CFI_ENDPROC
+
+FUNCTION(G(caml_ml_array_bound_error))
+CFI_STARTPROC
+        LEA_VAR(caml_array_bound_error, %rax)
+        jmp     LBL(caml_c_call)
+CFI_ENDPROC
+
+        .globl  G(caml_system__code_end)
+G(caml_system__code_end):
+
+        .data
+        .globl  G(caml_system__frametable)
+        .align  EIGHT_ALIGN
+G(caml_system__frametable):
+        .quad   1           /* one descriptor */
+        .quad   LBL(107)    /* return address into callback */
+        .value  -1          /* negative frame size => use callback link */
+        .value  0           /* no roots here */
+        .align  EIGHT_ALIGN
+        .quad   16
+        .quad   0
+        .string "amd64.S"
+
+#ifdef WITH_SPACETIME
+        .data
+        .globl  G(caml_system__spacetime_shapes)
+        .align  EIGHT_ALIGN
+G(caml_system__spacetime_shapes):
+        .quad   G(caml_start_program)
+        .quad   2           /* indirect call point to OCaml code */
+        .quad   LBL(107)    /* in caml_start_program / caml_callback* */
+        .quad   0           /* end of shapes for caml_start_program */
+        .quad   0           /* end of shape table */
+        .align  EIGHT_ALIGN
+#endif
+
+#if defined(SYS_macosx)
+        .literal16
+#elif defined(SYS_mingw64) || defined(SYS_cygwin)
+        .section .rdata,"dr"
+#else
+        .section    .rodata.cst8,"a",@progbits
+#endif
+        .globl  G(caml_negf_mask)
+        .align  SIXTEEN_ALIGN
+G(caml_negf_mask):
+        .quad   0x8000000000000000, 0
+        .globl  G(caml_absf_mask)
+        .align  SIXTEEN_ALIGN
+G(caml_absf_mask):
+        .quad   0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF
+
+#if defined(SYS_linux)
+    /* Mark stack as non-executable, PR#4564 */
+        .section .note.GNU-stack,"",%progbits
+#endif
diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm
new file mode 100644
index 00000000..07ac4508
--- /dev/null
+++ b/asmrun/amd64nt.asm
@@ -0,0 +1,467 @@
+;**************************************************************************
+;*                                                                        *
+;*                                 OCaml                                  *
+;*                                                                        *
+;*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *
+;*                                                                        *
+;*   Copyright 2006 Institut National de Recherche en Informatique et     *
+;*     en Automatique.                                                    *
+;*                                                                        *
+;*   All rights reserved.  This file is distributed under the terms of    *
+;*   the GNU Lesser General Public License version 2.1, with the          *
+;*   special exception on linking described in the file LICENSE.          *
+;*                                                                        *
+;**************************************************************************
+
+; Asm part of the runtime system, AMD64 processor, Intel syntax
+
+; Notes on Win64 calling conventions:
+;     function arguments in RCX, RDX, R8, R9 / XMM0 - XMM3
+;     caller must reserve 32 bytes of stack space
+;     callee must preserve RBX, RBP, RSI, RDI, R12-R15, XMM6-XMM15
+
+        EXTRN  caml_garbage_collection: NEAR
+        EXTRN  caml_apply2: NEAR
+        EXTRN  caml_apply3: NEAR
+        EXTRN  caml_program: NEAR
+        EXTRN  caml_array_bound_error: NEAR
+        EXTRN  caml_young_limit: QWORD
+        EXTRN  caml_young_ptr: QWORD
+        EXTRN  caml_bottom_of_stack: QWORD
+        EXTRN  caml_last_return_address: QWORD
+        EXTRN  caml_gc_regs: QWORD
+        EXTRN  caml_exception_pointer: QWORD
+        EXTRN  caml_backtrace_pos: DWORD
+        EXTRN  caml_backtrace_active: DWORD
+        EXTRN  caml_stash_backtrace: NEAR
+
+        .CODE
+
+; Allocation
+
+        PUBLIC  caml_call_gc
+        ALIGN   16
+caml_call_gc:
+    ; Record lowest stack address and return address
+        mov     rax, [rsp]
+        mov     caml_last_return_address, rax
+        lea     rax, [rsp+8]
+        mov     caml_bottom_of_stack, rax
+L105:
+    ; Save caml_young_ptr, caml_exception_pointer
+        mov     caml_young_ptr, r15
+        mov     caml_exception_pointer, r14
+    ; Build array of registers, save it into caml_gc_regs
+        push    rbp
+        push    r11
+        push    r10
+        push    r13
+        push    r12
+        push    r9
+        push    r8
+        push    rcx
+        push    rdx
+        push    rsi
+        push    rdi
+        push    rbx
+        push    rax
+        mov     caml_gc_regs, rsp
+    ; Save floating-point registers
+        sub     rsp, 16*8
+        movsd   QWORD PTR [rsp + 0*8], xmm0
+        movsd   QWORD PTR [rsp + 1*8], xmm1
+        movsd   QWORD PTR [rsp + 2*8], xmm2
+        movsd   QWORD PTR [rsp + 3*8], xmm3
+        movsd   QWORD PTR [rsp + 4*8], xmm4
+        movsd   QWORD PTR [rsp + 5*8], xmm5
+        movsd   QWORD PTR [rsp + 6*8], xmm6
+        movsd   QWORD PTR [rsp + 7*8], xmm7
+        movsd   QWORD PTR [rsp + 8*8], xmm8
+        movsd   QWORD PTR [rsp + 9*8], xmm9
+        movsd   QWORD PTR [rsp + 10*8], xmm10
+        movsd   QWORD PTR [rsp + 11*8], xmm11
+        movsd   QWORD PTR [rsp + 12*8], xmm12
+        movsd   QWORD PTR [rsp + 13*8], xmm13
+        movsd   QWORD PTR [rsp + 14*8], xmm14
+        movsd   QWORD PTR [rsp + 15*8], xmm15
+    ; Call the garbage collector
+        sub rsp, 32      ; PR#5008: bottom 32 bytes are reserved for callee
+        call caml_garbage_collection
+        add rsp, 32      ; PR#5008
+    ; Restore all regs used by the code generator
+        movsd   xmm0, QWORD PTR [rsp + 0*8]
+        movsd   xmm1, QWORD PTR [rsp + 1*8]
+        movsd   xmm2, QWORD PTR [rsp + 2*8]
+        movsd   xmm3, QWORD PTR [rsp + 3*8]
+        movsd   xmm4, QWORD PTR [rsp + 4*8]
+        movsd   xmm5, QWORD PTR [rsp + 5*8]
+        movsd   xmm6, QWORD PTR [rsp + 6*8]
+        movsd   xmm7, QWORD PTR [rsp + 7*8]
+        movsd   xmm8, QWORD PTR [rsp + 8*8]
+        movsd   xmm9, QWORD PTR [rsp + 9*8]
+        movsd   xmm10, QWORD PTR [rsp + 10*8]
+        movsd   xmm11, QWORD PTR [rsp + 11*8]
+        movsd   xmm12, QWORD PTR [rsp + 12*8]
+        movsd   xmm13, QWORD PTR [rsp + 13*8]
+        movsd   xmm14, QWORD PTR [rsp + 14*8]
+        movsd   xmm15, QWORD PTR [rsp + 15*8]
+        add     rsp, 16*8
+        pop     rax
+        pop     rbx
+        pop     rdi
+        pop     rsi
+        pop     rdx
+        pop     rcx
+        pop     r8
+        pop     r9
+        pop     r12
+        pop     r13
+        pop     r10
+        pop     r11
+        pop     rbp
+    ; Restore caml_young_ptr, caml_exception_pointer
+        mov     r15, caml_young_ptr
+        mov     r14, caml_exception_pointer
+    ; Return to caller
+        ret
+
+        PUBLIC  caml_alloc1
+        ALIGN   16
+caml_alloc1:
+        sub     r15, 16
+        cmp     r15, caml_young_limit
+        jb      L100
+        ret
+L100:
+        mov     rax, [rsp + 0]
+        mov     caml_last_return_address, rax
+        lea     rax, [rsp + 8]
+        mov     caml_bottom_of_stack, rax
+        sub     rsp, 8
+        call    L105
+        add     rsp, 8
+        jmp     caml_alloc1
+
+        PUBLIC  caml_alloc2
+        ALIGN   16
+caml_alloc2:
+        sub     r15, 24
+        cmp     r15, caml_young_limit
+        jb      L101
+        ret
+L101:
+        mov     rax, [rsp + 0]
+        mov     caml_last_return_address, rax
+        lea     rax, [rsp + 8]
+        mov     caml_bottom_of_stack, rax
+        sub     rsp, 8
+        call    L105
+        add     rsp, 8
+        jmp     caml_alloc2
+
+        PUBLIC  caml_alloc3
+        ALIGN   16
+caml_alloc3:
+        sub     r15, 32
+        cmp     r15, caml_young_limit
+        jb      L102
+        ret
+L102:
+        mov     rax, [rsp + 0]
+        mov     caml_last_return_address, rax
+        lea     rax, [rsp + 8]
+        mov     caml_bottom_of_stack, rax
+        sub     rsp, 8
+        call    L105
+        add     rsp, 8
+        jmp     caml_alloc3
+
+        PUBLIC  caml_allocN
+        ALIGN   16
+caml_allocN:
+        sub     r15, rax
+        cmp     r15, caml_young_limit
+        jb      L103
+        ret
+L103:
+        push    rax                       ; save desired size
+        mov     rax, [rsp + 8]
+        mov     caml_last_return_address, rax
+        lea     rax, [rsp + 16]
+        mov     caml_bottom_of_stack, rax
+        call    L105
+        pop     rax                      ; recover desired size
+        jmp     caml_allocN
+
+; Call a C function from OCaml
+
+        PUBLIC  caml_c_call
+        ALIGN   16
+caml_c_call:
+    ; Record lowest stack address and return address
+        pop     r12
+        mov     caml_last_return_address, r12
+        mov     caml_bottom_of_stack, rsp
+    ; Make the exception handler and alloc ptr available to the C code
+        mov     caml_young_ptr, r15
+        mov     caml_exception_pointer, r14
+    ; Call the function (address in rax)
+        call    rax
+    ; Reload alloc ptr
+        mov     r15, caml_young_ptr
+    ; Return to caller
+        push    r12
+        ret
+
+; Start the OCaml program
+
+        PUBLIC  caml_start_program
+        ALIGN   16
+caml_start_program:
+    ; Save callee-save registers
+        push    rbx
+        push    rbp
+        push    rsi
+        push    rdi
+        push    r12
+        push    r13
+        push    r14
+        push    r15
+        sub     rsp, 8+10*16       ; stack 16-aligned + 10 saved xmm regs
+        movapd  OWORD PTR [rsp + 0*16], xmm6
+        movapd  OWORD PTR [rsp + 1*16], xmm7
+        movapd  OWORD PTR [rsp + 2*16], xmm8
+        movapd  OWORD PTR [rsp + 3*16], xmm9
+        movapd  OWORD PTR [rsp + 4*16], xmm10
+        movapd  OWORD PTR [rsp + 5*16], xmm11
+        movapd  OWORD PTR [rsp + 6*16], xmm12
+        movapd  OWORD PTR [rsp + 7*16], xmm13
+        movapd  OWORD PTR [rsp + 8*16], xmm14
+        movapd  OWORD PTR [rsp + 9*16], xmm15
+    ; Initial entry point is caml_program
+        lea     r12, caml_program
+    ; Common code for caml_start_program and caml_callback*
+L106:
+    ; Build a callback link
+        sub     rsp, 8  ; stack 16-aligned
+        push    caml_gc_regs
+        push    caml_last_return_address
+        push    caml_bottom_of_stack
+    ; Setup alloc ptr and exception ptr
+        mov     r15, caml_young_ptr
+        mov     r14, caml_exception_pointer
+    ; Build an exception handler
+        lea     r13, L108
+        push    r13
+        push    r14
+        mov     r14, rsp
+    ; Call the OCaml code
+        call    r12
+L107:
+    ; Pop the exception handler
+        pop     r14
+        pop     r12    ; dummy register
+L109:
+    ; Update alloc ptr and exception ptr
+        mov     caml_young_ptr, r15
+        mov     caml_exception_pointer, r14
+    ; Pop the callback restoring, link the global variables
+        pop     caml_bottom_of_stack
+        pop     caml_last_return_address
+        pop     caml_gc_regs
+        add     rsp, 8
+    ; Restore callee-save registers.
+        movapd  xmm6, OWORD PTR [rsp + 0*16]
+        movapd  xmm7, OWORD PTR [rsp + 1*16]
+        movapd  xmm8, OWORD PTR [rsp + 2*16]
+        movapd  xmm9, OWORD PTR [rsp + 3*16]
+        movapd  xmm10, OWORD PTR [rsp + 4*16]
+        movapd  xmm11, OWORD PTR [rsp + 5*16]
+        movapd  xmm12, OWORD PTR [rsp + 6*16]
+        movapd  xmm13, OWORD PTR [rsp + 7*16]
+        movapd  xmm14, OWORD PTR [rsp + 8*16]
+        movapd  xmm15, OWORD PTR [rsp + 9*16]
+        add     rsp, 8+10*16
+        pop     r15
+        pop     r14
+        pop     r13
+        pop     r12
+        pop     rdi
+        pop     rsi
+        pop     rbp
+        pop     rbx
+    ; Return to caller
+        ret
+L108:
+    ; Exception handler
+    ; Mark the bucket as an exception result and return it
+        or      rax, 2
+        jmp     L109
+
+; Raise an exception from OCaml
+
+        PUBLIC  caml_raise_exn
+        ALIGN   16
+caml_raise_exn:
+        test    caml_backtrace_active, 1
+        jne     L110
+        mov     rsp, r14             ; Cut stack
+        pop     r14                  ; Recover previous exception handler
+        ret                          ; Branch to handler
+L110:
+        mov     r12, rax             ; Save exception bucket in r12
+        mov     rcx, rax             ; Arg 1: exception bucket
+        mov     rdx, [rsp]           ; Arg 2: PC of raise
+        lea     r8, [rsp+8]          ; Arg 3: SP of raise
+        mov     r9, r14              ; Arg 4: SP of handler
+        sub     rsp, 32              ; Reserve 32 bytes on stack
+        call    caml_stash_backtrace
+        mov     rax, r12             ; Recover exception bucket
+        mov     rsp, r14             ; Cut stack
+        pop     r14                  ; Recover previous exception handler
+        ret                          ; Branch to handler
+
+; Raise an exception from C
+
+        PUBLIC  caml_raise_exception
+        ALIGN   16
+caml_raise_exception:
+        test    caml_backtrace_active, 1
+        jne     L112
+        mov     rax, rcx             ; First argument is exn bucket
+        mov     rsp, caml_exception_pointer
+        pop     r14                  ; Recover previous exception handler
+        mov     r15, caml_young_ptr ; Reload alloc ptr
+        ret
+L112:
+        mov     r12, rcx             ; Save exception bucket in r12
+                                     ; Arg 1: exception bucket
+        mov     rdx, caml_last_return_address ; Arg 2: PC of raise
+        mov     r8, caml_bottom_of_stack      ; Arg 3: SP of raise
+        mov     r9, caml_exception_pointer    ; Arg 4: SP of handler
+        sub     rsp, 32              ; Reserve 32 bytes on stack
+        call    caml_stash_backtrace
+        mov     rax, r12             ; Recover exception bucket
+        mov     rsp, caml_exception_pointer
+        pop     r14                  ; Recover previous exception handler
+        mov     r15, caml_young_ptr ; Reload alloc ptr
+        ret
+
+; Callback from C to OCaml
+
+        PUBLIC  caml_callback_exn
+        ALIGN   16
+caml_callback_exn:
+    ; Save callee-save registers
+        push    rbx
+        push    rbp
+        push    rsi
+        push    rdi
+        push    r12
+        push    r13
+        push    r14
+        push    r15
+        sub     rsp, 8+10*16       ; stack 16-aligned + 10 saved xmm regs
+        movapd  OWORD PTR [rsp + 0*16], xmm6
+        movapd  OWORD PTR [rsp + 1*16], xmm7
+        movapd  OWORD PTR [rsp + 2*16], xmm8
+        movapd  OWORD PTR [rsp + 3*16], xmm9
+        movapd  OWORD PTR [rsp + 4*16], xmm10
+        movapd  OWORD PTR [rsp + 5*16], xmm11
+        movapd  OWORD PTR [rsp + 6*16], xmm12
+        movapd  OWORD PTR [rsp + 7*16], xmm13
+        movapd  OWORD PTR [rsp + 8*16], xmm14
+        movapd  OWORD PTR [rsp + 9*16], xmm15
+    ; Initial loading of arguments
+        mov     rbx, rcx      ; closure
+        mov     rax, rdx      ; argument
+        mov     r12, [rbx]    ; code pointer
+        jmp     L106
+
+        PUBLIC  caml_callback2_exn
+        ALIGN   16
+caml_callback2_exn:
+    ; Save callee-save registers
+        push    rbx
+        push    rbp
+        push    rsi
+        push    rdi
+        push    r12
+        push    r13
+        push    r14
+        push    r15
+        sub     rsp, 8+10*16       ; stack 16-aligned + 10 saved xmm regs
+        movapd  OWORD PTR [rsp + 0*16], xmm6
+        movapd  OWORD PTR [rsp + 1*16], xmm7
+        movapd  OWORD PTR [rsp + 2*16], xmm8
+        movapd  OWORD PTR [rsp + 3*16], xmm9
+        movapd  OWORD PTR [rsp + 4*16], xmm10
+        movapd  OWORD PTR [rsp + 5*16], xmm11
+        movapd  OWORD PTR [rsp + 6*16], xmm12
+        movapd  OWORD PTR [rsp + 7*16], xmm13
+        movapd  OWORD PTR [rsp + 8*16], xmm14
+        movapd  OWORD PTR [rsp + 9*16], xmm15
+    ; Initial loading of arguments
+        mov     rdi, rcx        ; closure
+        mov     rax, rdx        ; first argument
+        mov     rbx, r8         ; second argument
+        lea     r12, caml_apply2  ; code pointer
+        jmp     L106
+
+        PUBLIC  caml_callback3_exn
+        ALIGN   16
+caml_callback3_exn:
+    ; Save callee-save registers
+        push    rbx
+        push    rbp
+        push    rsi
+        push    rdi
+        push    r12
+        push    r13
+        push    r14
+        push    r15
+        sub     rsp, 8+10*16       ; stack 16-aligned + 10 saved xmm regs
+        movapd  OWORD PTR [rsp + 0*16], xmm6
+        movapd  OWORD PTR [rsp + 1*16], xmm7
+        movapd  OWORD PTR [rsp + 2*16], xmm8
+        movapd  OWORD PTR [rsp + 3*16], xmm9
+        movapd  OWORD PTR [rsp + 4*16], xmm10
+        movapd  OWORD PTR [rsp + 5*16], xmm11
+        movapd  OWORD PTR [rsp + 6*16], xmm12
+        movapd  OWORD PTR [rsp + 7*16], xmm13
+        movapd  OWORD PTR [rsp + 8*16], xmm14
+        movapd  OWORD PTR [rsp + 9*16], xmm15
+    ; Initial loading of arguments
+        mov     rsi, rcx        ; closure
+        mov     rax, rdx        ; first argument
+        mov     rbx, r8         ; second argument
+        mov     rdi, r9         ; third argument
+        lea     r12, caml_apply3      ; code pointer
+        jmp     L106
+
+        PUBLIC  caml_ml_array_bound_error
+        ALIGN   16
+caml_ml_array_bound_error:
+        lea     rax, caml_array_bound_error
+        jmp     caml_c_call
+
+        .DATA
+        PUBLIC  caml_system__frametable
+caml_system__frametable LABEL QWORD
+        QWORD   1           ; one descriptor
+        QWORD   L107        ; return address into callback
+        WORD    -1          ; negative frame size => use callback link
+        WORD    0           ; no roots here
+        ALIGN   8
+
+        PUBLIC  caml_negf_mask
+        ALIGN   16
+caml_negf_mask LABEL QWORD
+        QWORD   8000000000000000H, 0
+
+        PUBLIC  caml_absf_mask
+        ALIGN   16
+caml_absf_mask LABEL QWORD
+        QWORD   7FFFFFFFFFFFFFFFH, 0FFFFFFFFFFFFFFFFH
+
+        END
diff --git a/asmrun/arm.S b/asmrun/arm.S
new file mode 100644
index 00000000..8305cfe9
--- /dev/null
+++ b/asmrun/arm.S
@@ -0,0 +1,527 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                 Benedikt Meurer, University of Siegen                  */
+/*                                                                        */
+/*   Copyright 1998 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*   Copyright 2012 Benedikt Meurer.                                      */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Asm part of the runtime system, ARM processor */
+/* Must be preprocessed by cpp */
+
+        .syntax unified
+        .text
+#if defined(SYS_linux_eabihf) && defined(MODEL_armv6)
+        .arch   armv6
+        .fpu    vfpv2
+        .arm
+
+    /* Compatibility macros */
+        .macro  cbz reg, lbl
+        cmp     \reg, #0
+        beq     \lbl
+        .endm
+#elif defined(SYS_linux_eabihf)
+        .arch   armv7-a
+        .fpu    vfpv3-d16
+        .thumb
+#elif defined(SYS_linux_eabi)
+        .arch   armv4t
+        .arm
+
+    /* Compatibility macros */
+        .macro  blx reg
+        mov     lr, pc
+        bx      \reg
+        .endm
+        .macro  cbz reg, lbl
+        cmp     \reg, #0
+        beq     \lbl
+        .endm
+#elif defined(SYS_netbsd)
+
+  #if defined(MODEL_armv6)
+        .arch   armv6
+        .fpu    vfpv2
+        .arm
+
+    /* Compatibility macros */
+        .macro  cbz reg, lbl
+        cmp     \reg, #0
+        beq     \lbl
+        .endm
+  #elif defined(MODEL_armv7)
+        .arch   armv7-a
+        .fpu    vfpv3-d16
+        .thumb
+  #else
+    #error "Only NetBSD eabihf supported"
+  #endif
+
+#elif defined(SYS_freebsd)
+        .arch   armv6
+        .arm
+
+    /* Compatibility macros */
+        .macro  cbz reg, lbl
+        cmp     \reg, #0
+        beq     \lbl
+        .endm
+#endif
+
+trap_ptr        .req    r8
+alloc_ptr       .req    r10
+alloc_limit     .req    r11
+
+/* Support for CFI directives */
+
+#if defined(ASM_CFI_SUPPORTED)
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
+/* Support for profiling with gprof */
+
+#if defined(PROFILING) && (defined(SYS_linux_eabihf) \
+        || defined(SYS_linux_eabi) \
+        || defined(SYS_netbsd))
+#define PROFILE \
+        push    {lr}; CFI_ADJUST(4); \
+        bl      __gnu_mcount_nc; CFI_ADJUST(-4)
+#else
+#define PROFILE
+#endif
+
+/* Allocation functions and GC interface */
+
+        .globl  caml_system__code_begin
+caml_system__code_begin:
+
+        .align  2
+        .globl  caml_call_gc
+caml_call_gc:
+        CFI_STARTPROC
+        PROFILE
+    /* Record return address */
+        ldr     r12, =caml_last_return_address
+        str     lr, [r12]
+.Lcaml_call_gc:
+    /* Record lowest stack address */
+        ldr     r12, =caml_bottom_of_stack
+        str     sp, [r12]
+#if defined(SYS_linux_eabihf) || defined(SYS_netbsd)
+    /* Save caller floating-point registers on the stack */
+        vpush   {d0-d7}; CFI_ADJUST(64)
+#endif
+    /* Save integer registers and return address on the stack */
+        push    {r0-r7,r12,lr}; CFI_ADJUST(40)
+    /* Store pointer to saved integer registers in caml_gc_regs */
+        ldr     r12, =caml_gc_regs
+        str     sp, [r12]
+    /* Save current allocation pointer for debugging purposes */
+        ldr     alloc_limit, =caml_young_ptr
+        str     alloc_ptr, [alloc_limit]
+    /* Save trap pointer in case an exception is raised during GC */
+        ldr     r12, =caml_exception_pointer
+        str     trap_ptr, [r12]
+    /* Call the garbage collector */
+        bl      caml_garbage_collection
+    /* Restore integer registers and return address from the stack */
+        pop     {r0-r7,r12,lr}; CFI_ADJUST(-40)
+#if defined(SYS_linux_eabihf) || defined(SYS_netbsd)
+    /* Restore floating-point registers from the stack */
+        vpop    {d0-d7}; CFI_ADJUST(-64)
+#endif
+    /* Reload new allocation pointer and limit */
+    /* alloc_limit still points to caml_young_ptr */
+        ldr     r12, =caml_young_limit
+        ldr     alloc_ptr, [alloc_limit]
+        ldr     alloc_limit, [r12]
+    /* Return to caller */
+        bx      lr
+        CFI_ENDPROC
+        .type   caml_call_gc, %function
+        .size   caml_call_gc, .-caml_call_gc
+
+        .align  2
+        .globl  caml_alloc1
+caml_alloc1:
+        CFI_STARTPROC
+        PROFILE
+.Lcaml_alloc1:
+        sub     alloc_ptr, alloc_ptr, 8
+        cmp     alloc_ptr, alloc_limit
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r7, =caml_last_return_address
+        str     lr, [r7]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     lr, [r7]
+    /* Try again */
+        b       .Lcaml_alloc1
+        CFI_ENDPROC
+        .type   caml_alloc1, %function
+        .size   caml_alloc1, .-caml_alloc1
+
+        .align  2
+        .globl  caml_alloc2
+caml_alloc2:
+        CFI_STARTPROC
+        PROFILE
+.Lcaml_alloc2:
+        sub     alloc_ptr, alloc_ptr, 12
+        cmp     alloc_ptr, alloc_limit
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r7, =caml_last_return_address
+        str     lr, [r7]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     lr, [r7]
+    /* Try again */
+        b       .Lcaml_alloc2
+        CFI_ENDPROC
+        .type   caml_alloc2, %function
+        .size   caml_alloc2, .-caml_alloc2
+
+        .align  2
+        .globl  caml_alloc3
+        .type caml_alloc3, %function
+caml_alloc3:
+        CFI_STARTPROC
+        PROFILE
+.Lcaml_alloc3:
+        sub     alloc_ptr, alloc_ptr, 16
+        cmp     alloc_ptr, alloc_limit
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r7, =caml_last_return_address
+        str     lr, [r7]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     lr, [r7]
+    /* Try again */
+        b       .Lcaml_alloc3
+        CFI_ENDPROC
+        .type   caml_alloc3, %function
+        .size   caml_alloc3, .-caml_alloc3
+
+        .align  2
+        .globl  caml_allocN
+caml_allocN:
+        CFI_STARTPROC
+        PROFILE
+.Lcaml_allocN:
+        sub     alloc_ptr, alloc_ptr, r7
+        cmp     alloc_ptr, alloc_limit
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r12, =caml_last_return_address
+        str     lr, [r12]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     r12, =caml_last_return_address
+        ldr     lr, [r12]
+    /* Try again */
+        b       .Lcaml_allocN
+        CFI_ENDPROC
+        .type   caml_allocN, %function
+        .size   caml_allocN, .-caml_allocN
+
+/* Call a C function from OCaml */
+/* Function to call is in r7 */
+
+        .align  2
+        .globl  caml_c_call
+caml_c_call:
+        CFI_STARTPROC
+        PROFILE
+    /* Record lowest stack address and return address */
+        ldr     r5, =caml_last_return_address
+        ldr     r6, =caml_bottom_of_stack
+        str     lr, [r5]
+        str     sp, [r6]
+    /* Preserve return address in callee-save register r4 */
+        mov     r4, lr
+    /* Make the exception handler alloc ptr available to the C code */
+        ldr     r5, =caml_young_ptr
+        ldr     r6, =caml_exception_pointer
+        str     alloc_ptr, [r5]
+        str     trap_ptr, [r6]
+    /* Call the function */
+        blx     r7
+    /* Reload alloc ptr and alloc limit */
+        ldr     r6, =caml_young_limit
+        ldr     alloc_ptr, [r5]         /* r5 still points to caml_young_ptr */
+        ldr     alloc_limit, [r6]
+    /* Return */
+        bx      r4
+        CFI_ENDPROC
+        .type   caml_c_call, %function
+        .size   caml_c_call, .-caml_c_call
+
+/* Start the OCaml program */
+
+        .align  2
+        .globl  caml_start_program
+caml_start_program:
+        CFI_STARTPROC
+        PROFILE
+        ldr     r12, =caml_program
+
+/* Code shared with caml_callback* */
+/* Address of OCaml code to call is in r12 */
+/* Arguments to the OCaml code are in r0...r3 */
+
+.Ljump_to_caml:
+#if defined(SYS_linux_eabihf) || defined(SYS_netbsd)
+    /* Save callee-save floating-point registers */
+        vpush   {d8-d15}; CFI_ADJUST(64)
+#endif
+    /* Save return address and callee-save registers */
+        push    {r4-r8,r10,r11,lr}; CFI_ADJUST(32)      /* 8-byte alignment */
+    /* Setup a callback link on the stack */
+        sub     sp, sp, 16; CFI_ADJUST(16)              /* 8-byte alignment */
+        ldr     r4, =caml_bottom_of_stack
+        ldr     r5, =caml_last_return_address
+        ldr     r6, =caml_gc_regs
+        ldr     r4, [r4]
+        ldr     r5, [r5]
+        ldr     r6, [r6]
+        str     r4, [sp, 0]
+        str     r5, [sp, 4]
+        str     r6, [sp, 8]
+    /* Setup a trap frame to catch exceptions escaping the OCaml code */
+        sub     sp, sp, 8; CFI_ADJUST(8)
+        ldr     r6, =caml_exception_pointer
+        ldr     r5, =.Ltrap_handler
+        ldr     r4, [r6]
+        str     r4, [sp, 0]
+        str     r5, [sp, 4]
+        mov     trap_ptr, sp
+    /* Reload allocation pointers */
+        ldr     r4, =caml_young_ptr
+        ldr     alloc_ptr, [r4]
+        ldr     r4, =caml_young_limit
+        ldr     alloc_limit, [r4]
+    /* Call the OCaml code */
+        blx     r12
+.Lcaml_retaddr:
+    /* Pop the trap frame, restoring caml_exception_pointer */
+        ldr     r4, =caml_exception_pointer
+        ldr     r5, [sp, 0]
+        str     r5, [r4]
+        add     sp, sp, 8; CFI_ADJUST(-8)
+    /* Pop the callback link, restoring the global variables */
+.Lreturn_result:
+        ldr     r4, =caml_bottom_of_stack
+        ldr     r5, [sp, 0]
+        str     r5, [r4]
+        ldr     r4, =caml_last_return_address
+        ldr     r5, [sp, 4]
+        str     r5, [r4]
+        ldr     r4, =caml_gc_regs
+        ldr     r5, [sp, 8]
+        str     r5, [r4]
+        add     sp, sp, 16; CFI_ADJUST(-16)
+    /* Update allocation pointer */
+        ldr     r4, =caml_young_ptr
+        str     alloc_ptr, [r4]
+    /* Reload callee-save registers and return address */
+        pop     {r4-r8,r10,r11,lr}; CFI_ADJUST(-32)
+#if defined(SYS_linux_eabihf) || defined(SYS_netbsd)
+    /* Reload callee-save floating-point registers */
+        vpop    {d8-d15}; CFI_ADJUST(-64)
+#endif
+        bx      lr
+        CFI_ENDPROC
+        .type   .Lcaml_retaddr, %function
+        .size   .Lcaml_retaddr, .-.Lcaml_retaddr
+        .type   caml_start_program, %function
+        .size   caml_start_program, .-caml_start_program
+
+/* The trap handler */
+
+        .align  2
+.Ltrap_handler:
+        CFI_STARTPROC
+    /* Save exception pointer */
+        ldr     r12, =caml_exception_pointer
+        str     trap_ptr, [r12]
+    /* Encode exception bucket as an exception result */
+        orr     r0, r0, 2
+    /* Return it */
+        b       .Lreturn_result
+        CFI_ENDPROC
+        .type   .Ltrap_handler, %function
+        .size   .Ltrap_handler, .-.Ltrap_handler
+
+/* Raise an exception from OCaml */
+
+        .align  2
+        .globl  caml_raise_exn
+caml_raise_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Test if backtrace is active */
+        ldr     r1, =caml_backtrace_active
+        ldr     r1, [r1]
+        cbz     r1, 1f
+    /* Preserve exception bucket in callee-save register r4 */
+        mov     r4, r0
+    /* Stash the backtrace */
+        mov     r1, lr                          /* arg2: pc of raise */
+        mov     r2, sp                          /* arg3: sp of raise */
+        mov     r3, trap_ptr                    /* arg4: sp of handler */
+        bl      caml_stash_backtrace
+    /* Restore exception bucket */
+        mov     r0, r4
+1:  /* Cut stack at current trap handler */
+        mov     sp, trap_ptr
+    /* Pop previous handler and addr of trap, and jump to it */
+        pop     {trap_ptr, pc}
+        CFI_ENDPROC
+        .type   caml_raise_exn, %function
+        .size   caml_raise_exn, .-caml_raise_exn
+
+/* Raise an exception from C */
+
+        .align  2
+        .globl  caml_raise_exception
+caml_raise_exception:
+        CFI_STARTPROC
+        PROFILE
+    /* Reload trap ptr, alloc ptr and alloc limit */
+        ldr     trap_ptr, =caml_exception_pointer
+        ldr     alloc_ptr, =caml_young_ptr
+        ldr     alloc_limit, =caml_young_limit
+        ldr     trap_ptr, [trap_ptr]
+        ldr     alloc_ptr, [alloc_ptr]
+        ldr     alloc_limit, [alloc_limit]
+    /* Test if backtrace is active */
+        ldr     r1, =caml_backtrace_active
+        ldr     r1, [r1]
+        cbz     r1, 1f
+    /* Preserve exception bucket in callee-save register r4 */
+        mov     r4, r0
+        ldr     r1, =caml_last_return_address   /* arg2: pc of raise */
+        ldr     r1, [r1]
+        ldr     r2, =caml_bottom_of_stack       /* arg3: sp of raise */
+        ldr     r2, [r2]
+        mov     r3, trap_ptr                    /* arg4: sp of handler */
+        bl      caml_stash_backtrace
+    /* Restore exception bucket */
+        mov     r0, r4
+1:  /* Cut stack at current trap handler */
+        mov     sp, trap_ptr
+    /* Pop previous handler and addr of trap, and jump to it */
+        pop     {trap_ptr, pc}
+        CFI_ENDPROC
+        .type   caml_raise_exception, %function
+        .size   caml_raise_exception, .-caml_raise_exception
+
+/* Callback from C to OCaml */
+
+        .align  2
+        .globl  caml_callback_exn
+caml_callback_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */
+        mov     r12, r0
+        mov     r0, r1          /* r0 = first arg */
+        mov     r1, r12         /* r1 = closure environment */
+        ldr     r12, [r12]      /* code pointer */
+        b       .Ljump_to_caml
+        CFI_ENDPROC
+        .type   caml_callback_exn, %function
+        .size   caml_callback_exn, .-caml_callback_exn
+
+        .align  2
+        .globl  caml_callback2_exn
+caml_callback2_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */
+        mov     r12, r0
+        mov     r0, r1          /* r0 = first arg */
+        mov     r1, r2          /* r1 = second arg */
+        mov     r2, r12         /* r2 = closure environment */
+        ldr     r12, =caml_apply2
+        b       .Ljump_to_caml
+        CFI_ENDPROC
+        .type   caml_callback2_exn, %function
+        .size   caml_callback2_exn, .-caml_callback2_exn
+
+        .align  2
+        .globl  caml_callback3_exn
+caml_callback3_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Initial shuffling of arguments */
+    /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */
+        mov     r12, r0
+        mov     r0, r1          /* r0 = first arg */
+        mov     r1, r2          /* r1 = second arg */
+        mov     r2, r3          /* r2 = third arg */
+        mov     r3, r12         /* r3 = closure environment */
+        ldr     r12, =caml_apply3
+        b       .Ljump_to_caml
+        CFI_ENDPROC
+        .type   caml_callback3_exn, %function
+        .size   caml_callback3_exn, .-caml_callback3_exn
+
+        .align  2
+        .globl  caml_ml_array_bound_error
+caml_ml_array_bound_error:
+        CFI_STARTPROC
+        PROFILE
+    /* Load address of [caml_array_bound_error] in r7 */
+        ldr     r7, =caml_array_bound_error
+    /* Call that function */
+        b       caml_c_call
+        CFI_ENDPROC
+        .type   caml_ml_array_bound_error, %function
+        .size   caml_ml_array_bound_error, .-caml_ml_array_bound_error
+
+        .globl  caml_system__code_end
+caml_system__code_end:
+
+/* GC roots for callback */
+
+        .data
+        .align  2
+        .globl  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 */
+        .short  0               /* no roots */
+        .align  2
+        .type   caml_system__frametable, %object
+        .size   caml_system__frametable, .-caml_system__frametable
+
+/* Mark stack as non-executable */
+        .section .note.GNU-stack,"",%progbits
diff --git a/asmrun/arm64.S b/asmrun/arm64.S
new file mode 100644
index 00000000..2115be36
--- /dev/null
+++ b/asmrun/arm64.S
@@ -0,0 +1,560 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2013 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Asm part of the runtime system, ARM processor, 64-bit mode */
+/* Must be preprocessed by cpp */
+
+/* Special registers */
+
+#define TRAP_PTR x26
+#define ALLOC_PTR x27
+#define ALLOC_LIMIT x28
+#define ARG x15
+#define TMP x16
+#define TMP2 x17
+
+/* Support for CFI directives */
+
+#if defined(ASM_CFI_SUPPORTED)
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
+/* Support for profiling with gprof */
+
+#define PROFILE
+
+/* Macros to load and store global variables.  Destroy TMP2 */
+
+#if defined(__PIC__)
+
+#define ADDRGLOBAL(reg,symb) \
+        adrp    TMP2, :got:symb; \
+        ldr     reg, [TMP2, #:got_lo12:symb]
+
+#define LOADGLOBAL(reg,symb) \
+        ADDRGLOBAL(TMP2,symb); \
+        ldr     reg, [TMP2]
+
+#define STOREGLOBAL(reg,symb) \
+        ADDRGLOBAL(TMP2,symb); \
+        str     reg, [TMP2]
+
+#else
+
+#define ADDRGLOBAL(reg,symb) \
+        adrp    reg, symb; \
+        add     reg, reg, #:lo12:symb
+
+#define LOADGLOBAL(reg,symb) \
+        adrp    TMP2, symb; \
+        ldr     reg, [TMP2, #:lo12:symb]
+
+#define STOREGLOBAL(reg,symb) \
+        adrp    TMP2, symb; \
+        str     reg, [TMP2, #:lo12:symb]
+
+#endif
+
+/* Allocation functions and GC interface */
+
+        .globl  caml_system__code_begin
+caml_system__code_begin:
+
+        .align  2
+        .globl  caml_call_gc
+caml_call_gc:
+        CFI_STARTPROC
+        PROFILE
+    /* Record return address */
+        STOREGLOBAL(x30, caml_last_return_address)
+    /* Record lowest stack address */
+        mov     TMP, sp
+        STOREGLOBAL(TMP, caml_bottom_of_stack)
+.Lcaml_call_gc:
+    /* Set up stack space, saving return address and frame pointer */
+    /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */
+        stp     x29, x30, [sp, -400]!
+        CFI_ADJUST(400)
+        add     x29, sp, #0
+    /* Save allocatable integer registers on the stack, in the order
+       given in proc.ml */
+        stp     x0, x1, [sp, 16]
+        stp     x2, x3, [sp, 32]
+        stp     x4, x5, [sp, 48]
+        stp     x6, x7, [sp, 64]
+        stp     x8, x9, [sp, 80]
+        stp     x10, x11, [sp, 96]
+        stp     x12, x13, [sp, 112]
+        stp     x14, x15, [sp, 128]
+        stp     x19, x20, [sp, 144]
+        stp     x21, x22, [sp, 160]
+        stp     x23, x24, [sp, 176]
+        str     x25, [sp, 192]
+     /* Save caller-save floating-point registers on the stack
+        (callee-saves are preserved by caml_garbage_collection) */
+        stp     d0, d1, [sp, 208]
+        stp     d2, d3, [sp, 224]
+        stp     d4, d5, [sp, 240]
+        stp     d6, d7, [sp, 256]
+        stp     d16, d17, [sp, 272]
+        stp     d18, d19, [sp, 288]
+        stp     d20, d21, [sp, 304]
+        stp     d22, d23, [sp, 320]
+        stp     d24, d25, [sp, 336]
+        stp     d26, d27, [sp, 352]
+        stp     d28, d29, [sp, 368]
+        stp     d30, d31, [sp, 384]
+    /* Store pointer to saved integer registers in caml_gc_regs */
+        add     TMP, sp, #16
+        STOREGLOBAL(TMP, caml_gc_regs)
+    /* Save current allocation pointer for debugging purposes */
+        STOREGLOBAL(ALLOC_PTR, caml_young_ptr)
+    /* Save trap pointer in case an exception is raised during GC */
+        STOREGLOBAL(TRAP_PTR, caml_exception_pointer)
+    /* Call the garbage collector */
+        bl      caml_garbage_collection
+    /* Restore registers */
+        ldp     x0, x1, [sp, 16]
+        ldp     x2, x3, [sp, 32]
+        ldp     x4, x5, [sp, 48]
+        ldp     x6, x7, [sp, 64]
+        ldp     x8, x9, [sp, 80]
+        ldp     x10, x11, [sp, 96]
+        ldp     x12, x13, [sp, 112]
+        ldp     x14, x15, [sp, 128]
+        ldp     x19, x20, [sp, 144]
+        ldp     x21, x22, [sp, 160]
+        ldp     x23, x24, [sp, 176]
+        ldr     x25, [sp, 192]
+        ldp     d0, d1, [sp, 208]
+        ldp     d2, d3, [sp, 224]
+        ldp     d4, d5, [sp, 240]
+        ldp     d6, d7, [sp, 256]
+        ldp     d16, d17, [sp, 272]
+        ldp     d18, d19, [sp, 288]
+        ldp     d20, d21, [sp, 304]
+        ldp     d22, d23, [sp, 320]
+        ldp     d24, d25, [sp, 336]
+        ldp     d26, d27, [sp, 352]
+        ldp     d28, d29, [sp, 368]
+        ldp     d30, d31, [sp, 384]
+    /* Reload new allocation pointer and allocation limit */
+        LOADGLOBAL(ALLOC_PTR, caml_young_ptr)
+        LOADGLOBAL(ALLOC_LIMIT, caml_young_limit)
+    /* Free stack space and return to caller */
+        ldp     x29, x30, [sp], 400
+        ret
+        CFI_ENDPROC
+        .type   caml_call_gc, %function
+        .size   caml_call_gc, .-caml_call_gc
+
+        .align  2
+        .globl  caml_alloc1
+caml_alloc1:
+        CFI_STARTPROC
+        PROFILE
+1:      sub     ALLOC_PTR, ALLOC_PTR, #16
+        cmp     ALLOC_PTR, ALLOC_LIMIT
+        b.lo    2f
+        ret
+2:      stp     x29, x30, [sp, -16]!
+        CFI_ADJUST(16)
+    /* Record the lowest address of the caller's stack frame.  This is the
+       address immediately above the pair of words (x29 and x30) we just
+       pushed.  Those must not be included since otherwise the distance from
+       [caml_bottom_of_stack] to the highest address in the caller's stack
+       frame won't match the frame size contained in the relevant frame
+       descriptor. */
+        add     x29, sp, #16
+        STOREGLOBAL(x29, caml_bottom_of_stack)
+        add     x29, sp, #0
+    /* Record return address */
+        STOREGLOBAL(x30, caml_last_return_address)
+    /* Call GC */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldp     x29, x30, [sp], 16
+        CFI_ADJUST(-16)
+    /* Try again */
+        b       1b
+        CFI_ENDPROC
+        .type   caml_alloc1, %function
+        .size   caml_alloc1, .-caml_alloc1
+
+        .align  2
+        .globl  caml_alloc2
+caml_alloc2:
+        CFI_STARTPROC
+        PROFILE
+1:      sub     ALLOC_PTR, ALLOC_PTR, #24
+        cmp     ALLOC_PTR, ALLOC_LIMIT
+        b.lo    2f
+        ret
+2:      stp     x29, x30, [sp, -16]!
+        CFI_ADJUST(16)
+    /* Record the lowest address of the caller's stack frame.
+       See comment above. */
+        add     x29, sp, #16
+        STOREGLOBAL(x29, caml_bottom_of_stack)
+        add     x29, sp, #0
+    /* Record return address */
+        STOREGLOBAL(x30, caml_last_return_address)
+    /* Call GC */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldp     x29, x30, [sp], 16
+        CFI_ADJUST(-16)
+    /* Try again */
+        b       1b
+        CFI_ENDPROC
+        .type   caml_alloc2, %function
+        .size   caml_alloc2, .-caml_alloc2
+
+        .align  2
+        .globl  caml_alloc3
+caml_alloc3:
+        CFI_STARTPROC
+        PROFILE
+1:      sub     ALLOC_PTR, ALLOC_PTR, #32
+        cmp     ALLOC_PTR, ALLOC_LIMIT
+        b.lo    2f
+        ret
+2:      stp     x29, x30, [sp, -16]!
+        CFI_ADJUST(16)
+    /* Record the lowest address of the caller's stack frame.
+       See comment above. */
+        add     x29, sp, #16
+        STOREGLOBAL(x29, caml_bottom_of_stack)
+        add     x29, sp, #0
+    /* Record return address */
+        STOREGLOBAL(x30, caml_last_return_address)
+    /* Call GC */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldp     x29, x30, [sp], 16
+        CFI_ADJUST(-16)
+    /* Try again */
+        b       1b
+        CFI_ENDPROC
+        .type   caml_alloc3, %function
+        .size   caml_alloc3, .-caml_alloc3
+
+        .align  2
+        .globl  caml_allocN
+caml_allocN:
+        CFI_STARTPROC
+        PROFILE
+1:      sub     ALLOC_PTR, ALLOC_PTR, ARG
+        cmp     ALLOC_PTR, ALLOC_LIMIT
+        b.lo    2f
+        ret
+2:      stp     x29, x30, [sp, -16]!
+        CFI_ADJUST(16)
+    /* Record the lowest address of the caller's stack frame.
+       See comment above. */
+        add     x29, sp, #16
+        STOREGLOBAL(x29, caml_bottom_of_stack)
+        add     x29, sp, #0
+    /* Record return address */
+        STOREGLOBAL(x30, caml_last_return_address)
+    /* Call GC.  This preserves ARG */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldp     x29, x30, [sp], 16
+        CFI_ADJUST(-16)
+    /* Try again */
+        b       1b
+        CFI_ENDPROC
+        .type   caml_allocN, %function
+        .size   caml_allocN, .-caml_allocN
+
+/* Call a C function from OCaml */
+/* Function to call is in ARG */
+
+        .align  2
+        .globl  caml_c_call
+caml_c_call:
+        CFI_STARTPROC
+        PROFILE
+    /* Preserve return address in callee-save register x19 */
+        mov     x19, x30
+    /* Record lowest stack address and return address */
+        STOREGLOBAL(x30, caml_last_return_address)
+        add     TMP, sp, #0
+        STOREGLOBAL(TMP, caml_bottom_of_stack)
+    /* Make the exception handler alloc ptr available to the C code */
+        STOREGLOBAL(ALLOC_PTR, caml_young_ptr)
+        STOREGLOBAL(TRAP_PTR, caml_exception_pointer)
+    /* Call the function */
+        blr     ARG
+    /* Reload alloc ptr and alloc limit */
+        LOADGLOBAL(ALLOC_PTR, caml_young_ptr)
+        LOADGLOBAL(ALLOC_LIMIT, caml_young_limit)
+    /* Return */
+        ret     x19
+        CFI_ENDPROC
+        .type   caml_c_call, %function
+        .size   caml_c_call, .-caml_c_call
+
+/* Start the OCaml program */
+
+        .align  2
+        .globl  caml_start_program
+caml_start_program:
+        CFI_STARTPROC
+        PROFILE
+        ADDRGLOBAL(ARG, caml_program)
+
+/* Code shared with caml_callback* */
+/* Address of OCaml code to call is in ARG */
+/* Arguments to the OCaml code are in x0...x7 */
+
+.Ljump_to_caml:
+    /* Set up stack frame and save callee-save registers */
+        stp     x29, x30, [sp, -160]!
+        CFI_ADJUST(160)
+        add     x29, sp, #0
+        stp     x19, x20, [sp, 16]
+        stp     x21, x22, [sp, 32]
+        stp     x23, x24, [sp, 48]
+        stp     x25, x26, [sp, 64]
+        stp     x27, x28, [sp, 80]
+        stp     d8, d9, [sp, 96]
+        stp     d10, d11, [sp, 112]
+        stp     d12, d13, [sp, 128]
+        stp     d14, d15, [sp, 144]
+    /* Setup a callback link on the stack */
+        LOADGLOBAL(x8, caml_bottom_of_stack)
+        LOADGLOBAL(x9, caml_last_return_address)
+        LOADGLOBAL(x10, caml_gc_regs)
+        stp     x8, x9, [sp, -32]!     /* 16-byte alignment */
+        CFI_ADJUST(32)
+        str     x10, [sp, 16]
+    /* Setup a trap frame to catch exceptions escaping the OCaml code */
+        LOADGLOBAL(x8, caml_exception_pointer)
+        adr     x9, .Ltrap_handler
+        stp     x8, x9, [sp, -16]!
+        CFI_ADJUST(16)
+        add     TRAP_PTR, sp, #0
+    /* Reload allocation pointers */
+        LOADGLOBAL(ALLOC_PTR, caml_young_ptr)
+        LOADGLOBAL(ALLOC_LIMIT, caml_young_limit)
+    /* Call the OCaml code */
+        blr     ARG
+.Lcaml_retaddr:
+    /* Pop the trap frame, restoring caml_exception_pointer */
+        ldr     x8, [sp], 16
+        CFI_ADJUST(-16)
+        STOREGLOBAL(x8, caml_exception_pointer)
+    /* Pop the callback link, restoring the global variables */
+.Lreturn_result:
+        ldr     x10, [sp, 16]
+        ldp     x8, x9, [sp], 32
+        CFI_ADJUST(-32)
+        STOREGLOBAL(x8, caml_bottom_of_stack)
+        STOREGLOBAL(x9, caml_last_return_address)
+        STOREGLOBAL(x10, caml_gc_regs)
+    /* Update allocation pointer */
+        STOREGLOBAL(ALLOC_PTR, caml_young_ptr)
+    /* Reload callee-save registers and return address */
+        ldp     x19, x20, [sp, 16]
+        ldp     x21, x22, [sp, 32]
+        ldp     x23, x24, [sp, 48]
+        ldp     x25, x26, [sp, 64]
+        ldp     x27, x28, [sp, 80]
+        ldp     d8, d9, [sp, 96]
+        ldp     d10, d11, [sp, 112]
+        ldp     d12, d13, [sp, 128]
+        ldp     d14, d15, [sp, 144]
+        ldp     x29, x30, [sp], 160
+        CFI_ADJUST(-160)
+    /* Return to C caller */
+        ret
+        CFI_ENDPROC
+        .type   .Lcaml_retaddr, %function
+        .size   .Lcaml_retaddr, .-.Lcaml_retaddr
+        .type   caml_start_program, %function
+        .size   caml_start_program, .-caml_start_program
+
+/* The trap handler */
+
+        .align  2
+.Ltrap_handler:
+        CFI_STARTPROC
+    /* Save exception pointer */
+        STOREGLOBAL(TRAP_PTR, caml_exception_pointer)
+    /* Encode exception bucket as an exception result */
+        orr     x0, x0, #2
+    /* Return it */
+        b       .Lreturn_result
+        CFI_ENDPROC
+        .type   .Ltrap_handler, %function
+        .size   .Ltrap_handler, .-.Ltrap_handler
+
+/* Raise an exception from OCaml */
+
+        .align  2
+        .globl  caml_raise_exn
+caml_raise_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Test if backtrace is active */
+        LOADGLOBAL(TMP, caml_backtrace_active)
+        cbnz     TMP, 2f
+1:  /* Cut stack at current trap handler */
+        mov     sp, TRAP_PTR
+    /* Pop previous handler and jump to it */
+        ldr     TMP, [sp, 8]
+        ldr     TRAP_PTR, [sp], 16
+        br      TMP
+2:  /* Preserve exception bucket in callee-save register x19 */
+        mov     x19, x0
+    /* Stash the backtrace */
+                               /* arg1: exn bucket, already in x0 */
+        mov     x1, x30        /* arg2: pc of raise */
+        add     x2, sp, #0     /* arg3: sp of raise */
+        mov     x3, TRAP_PTR   /* arg4: sp of handler */
+        bl      caml_stash_backtrace
+    /* Restore exception bucket and raise */
+        mov     x0, x19
+        b       1b
+        CFI_ENDPROC
+        .type   caml_raise_exn, %function
+        .size   caml_raise_exn, .-caml_raise_exn
+
+/* Raise an exception from C */
+
+        .align  2
+        .globl  caml_raise_exception
+caml_raise_exception:
+        CFI_STARTPROC
+        PROFILE
+    /* Reload trap ptr, alloc ptr and alloc limit */
+        LOADGLOBAL(TRAP_PTR, caml_exception_pointer)
+        LOADGLOBAL(ALLOC_PTR, caml_young_ptr)
+        LOADGLOBAL(ALLOC_LIMIT, caml_young_limit)
+    /* Test if backtrace is active */
+        LOADGLOBAL(TMP, caml_backtrace_active)
+        cbnz    TMP, 2f
+1:  /* Cut stack at current trap handler */
+        mov     sp, TRAP_PTR
+    /* Pop previous handler and jump to it */
+        ldr     TMP, [sp, 8]
+        ldr     TRAP_PTR, [sp], 16
+        br      TMP
+2:  /* Preserve exception bucket in callee-save register x19 */
+        mov     x19, x0
+    /* Stash the backtrace */
+                               /* arg1: exn bucket, already in x0 */
+        LOADGLOBAL(x1, caml_last_return_address)   /* arg2: pc of raise */
+        LOADGLOBAL(x2, caml_bottom_of_stack)       /* arg3: sp of raise */
+        mov     x3, TRAP_PTR   /* arg4: sp of handler */
+        bl      caml_stash_backtrace
+    /* Restore exception bucket and raise */
+        mov     x0, x19
+        b       1b
+        CFI_ENDPROC
+        .type   caml_raise_exception, %function
+        .size   caml_raise_exception, .-caml_raise_exception
+
+/* Callback from C to OCaml */
+
+        .align  2
+        .globl  caml_callback_exn
+caml_callback_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */
+        mov     TMP, x0
+        mov     x0, x1          /* x0 = first arg */
+        mov     x1, TMP         /* x1 = closure environment */
+        ldr     ARG, [TMP]      /* code pointer */
+        b       .Ljump_to_caml
+        CFI_ENDPROC
+        .type   caml_callback_exn, %function
+        .size   caml_callback_exn, .-caml_callback_exn
+
+        .align  2
+        .globl  caml_callback2_exn
+caml_callback2_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */
+        mov     TMP, x0
+        mov     x0, x1          /* x0 = first arg */
+        mov     x1, x2          /* x1 = second arg */
+        mov     x2, TMP         /* x2 = closure environment */
+        ADDRGLOBAL(ARG, caml_apply2)
+        b       .Ljump_to_caml
+        CFI_ENDPROC
+        .type   caml_callback2_exn, %function
+        .size   caml_callback2_exn, .-caml_callback2_exn
+
+        .align  2
+        .globl  caml_callback3_exn
+caml_callback3_exn:
+        CFI_STARTPROC
+        PROFILE
+    /* Initial shuffling of arguments */
+    /* (x0 = closure, x1 = arg1, x2 = arg2, x3 = arg3) */
+        mov     TMP, x0
+        mov     x0, x1          /* x0 = first arg */
+        mov     x1, x2          /* x1 = second arg */
+        mov     x2, x3          /* x2 = third arg */
+        mov     x3, TMP         /* x3 = closure environment */
+        ADDRGLOBAL(ARG, caml_apply3)
+        b       .Ljump_to_caml
+        CFI_ENDPROC
+        .type   caml_callback3_exn, %function
+        .size   caml_callback3_exn, .-caml_callback3_exn
+
+        .align  2
+        .globl  caml_ml_array_bound_error
+caml_ml_array_bound_error:
+        CFI_STARTPROC
+        PROFILE
+    /* Load address of [caml_array_bound_error] in ARG */
+        ADDRGLOBAL(ARG, caml_array_bound_error)
+    /* Call that function */
+        b       caml_c_call
+        CFI_ENDPROC
+        .type   caml_ml_array_bound_error, %function
+        .size   caml_ml_array_bound_error, .-caml_ml_array_bound_error
+
+        .globl  caml_system__code_end
+caml_system__code_end:
+
+/* GC roots for callback */
+
+        .data
+        .align  3
+        .globl  caml_system__frametable
+caml_system__frametable:
+        .quad   1               /* one descriptor */
+        .quad   .Lcaml_retaddr  /* return address into callback */
+        .short  -1              /* negative frame size => use callback link */
+        .short  0               /* no roots */
+        .align  3
+        .type   caml_system__frametable, %object
+        .size   caml_system__frametable, .-caml_system__frametable
+
+/* Mark stack as non-executable */
+        .section .note.GNU-stack,"",%progbits
diff --git a/asmrun/backtrace_prim.c b/asmrun/backtrace_prim.c
new file mode 100644
index 00000000..682e082e
--- /dev/null
+++ b/asmrun/backtrace_prim.c
@@ -0,0 +1,249 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2006 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Stack backtrace for uncaught exceptions */
+
+#include 
+#include 
+#include 
+
+#include "caml/alloc.h"
+#include "caml/backtrace.h"
+#include "caml/backtrace_prim.h"
+#include "caml/memory.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/stack.h"
+
+/* Returns the next frame descriptor (or NULL if none is available),
+   and updates *pc and *sp to point to the following one.  */
+frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
+{
+  frame_descr * d;
+  uintnat h;
+
+  while (1) {
+    h = Hash_retaddr(*pc);
+    while (1) {
+      d = caml_frame_descriptors[h];
+      if (d == NULL) return NULL; /* happens if some code compiled without -g */
+      if (d->retaddr == *pc) break;
+      h = (h+1) & caml_frame_descriptors_mask;
+    }
+    /* Skip to next frame */
+    if (d->frame_size != 0xFFFF) {
+      /* Regular frame, update sp/pc and return the frame descriptor */
+#ifndef Stack_grows_upwards
+      *sp += (d->frame_size & 0xFFFC);
+#else
+      *sp -= (d->frame_size & 0xFFFC);
+#endif
+      *pc = Saved_return_address(*sp);
+#ifdef Mask_already_scanned
+      *pc = Mask_already_scanned(*pc);
+#endif
+      return d;
+    } else {
+      /* Special frame marking the top of a stack chunk for an ML callback.
+         Skip C portion of stack and continue with next ML stack chunk. */
+      struct caml_context * next_context = Callback_link(*sp);
+      *sp = next_context->bottom_of_stack;
+      *pc = next_context->last_retaddr;
+      /* A null sp means no more ML stack chunks; stop here. */
+      if (*sp == NULL) return NULL;
+    }
+  }
+}
+
+int caml_alloc_backtrace_buffer(void){
+  Assert(caml_backtrace_pos == 0);
+  caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE
+                                 * sizeof(backtrace_slot));
+  if (caml_backtrace_buffer == NULL) return -1;
+  return 0;
+}
+
+/* Stores the return addresses contained in the given stack fragment
+   into the backtrace array ; this version is performance-sensitive as
+   it is called at each [raise] in a program compiled with [-g], so we
+   preserved the global, statically bounded buffer of the old
+   implementation -- before the more flexible
+   [caml_get_current_callstack] was implemented. */
+void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+{
+  if (exn != caml_backtrace_last_exn) {
+    caml_backtrace_pos = 0;
+    caml_backtrace_last_exn = exn;
+  }
+
+  if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1)
+    return;
+
+  /* iterate on each frame  */
+  while (1) {
+    frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+    if (descr == NULL) return;
+    /* store its descriptor in the backtrace buffer */
+    if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
+    caml_backtrace_buffer[caml_backtrace_pos++] = (backtrace_slot) descr;
+
+    /* Stop when we reach the current exception handler */
+#ifndef Stack_grows_upwards
+    if (sp > trapsp) return;
+#else
+    if (sp < trapsp) return;
+#endif
+  }
+}
+
+/* Stores upto [max_frames_value] frames of the current call stack to
+   return to the user. This is used not in an exception-raising
+   context, but only when the user requests to save the trace
+   (hopefully less often). Instead of using a bounded buffer as
+   [caml_stash_backtrace], we first traverse the stack to compute the
+   right size, then allocate space for the trace. */
+CAMLprim value caml_get_current_callstack(value max_frames_value)
+{
+  CAMLparam1(max_frames_value);
+  CAMLlocal1(trace);
+
+  /* we use `intnat` here because, were it only `int`, passing `max_int`
+     from the OCaml side would overflow on 64bits machines. */
+  intnat max_frames = Long_val(max_frames_value);
+  intnat trace_size;
+
+  /* first compute the size of the trace */
+  {
+    uintnat pc = caml_last_return_address;
+    /* note that [caml_bottom_of_stack] always points to the most recent
+     * frame, independently of the [Stack_grows_upwards] setting */
+    char * sp = caml_bottom_of_stack;
+    char * limitsp = caml_top_of_stack;
+
+    trace_size = 0;
+    while (1) {
+      frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+      if (descr == NULL) break;
+      if (trace_size >= max_frames) break;
+      ++trace_size;
+
+#ifndef Stack_grows_upwards
+      if (sp > limitsp) break;
+#else
+      if (sp < limitsp) break;
+#endif
+    }
+  }
+
+  trace = caml_alloc((mlsize_t) trace_size, 0);
+
+  /* then collect the trace */
+  {
+    uintnat pc = caml_last_return_address;
+    char * sp = caml_bottom_of_stack;
+    intnat trace_pos;
+
+    for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
+      frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+      Assert(descr != NULL);
+      Field(trace, trace_pos) = Val_backtrace_slot((backtrace_slot) descr);
+    }
+  }
+
+  CAMLreturn(trace);
+}
+
+
+debuginfo caml_debuginfo_extract(backtrace_slot slot)
+{
+  uintnat infoptr;
+  frame_descr * d = (frame_descr *)slot;
+
+  if ((d->frame_size & 1) == 0) {
+    return NULL;
+  }
+  /* Recover debugging info */
+  infoptr = ((uintnat) d +
+             sizeof(char *) + sizeof(short) + sizeof(short) +
+             sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
+            & -sizeof(frame_descr *);
+  return *((debuginfo*)infoptr);
+}
+
+debuginfo caml_debuginfo_next(debuginfo dbg)
+{
+  uint32_t * infoptr;
+
+  if (dbg == NULL)
+    return NULL;
+
+  infoptr = dbg;
+  infoptr += 2; /* Two packed info fields */
+  return *((debuginfo*)infoptr);
+}
+
+/* Extract location information for the given frame descriptor */
+void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li)
+{
+  uint32_t info1, info2;
+
+  /* If no debugging information available, print nothing.
+     When everything is compiled with -g, this corresponds to
+     compiler-inserted re-raise operations. */
+  if (dbg == NULL) {
+    li->loc_valid = 0;
+    li->loc_is_raise = 1;
+    li->loc_is_inlined = 0;
+    return;
+  }
+  /* Recover debugging info */
+  info1 = ((uint32_t *)dbg)[0];
+  info2 = ((uint32_t *)dbg)[1];
+  /* Format of the two info words:
+       llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
+                          44       36         26                       2  0
+                       (32+12)    (32+4)
+     k ( 2 bits): 0 if it's a call
+                  1 if it's a raise
+     n (24 bits): offset (in 4-byte words) of file name relative to dbg
+     l (20 bits): line number
+     a ( 8 bits): beginning of character range
+     b (10 bits): end of character range */
+  li->loc_valid = 1;
+  li->loc_is_raise = (info1 & 3) == 1;
+  li->loc_is_inlined = caml_debuginfo_next(dbg) != NULL;
+  li->loc_filename = (char *) dbg + (info1 & 0x3FFFFFC);
+  li->loc_lnum = info2 >> 12;
+  li->loc_startchr = (info2 >> 4) & 0xFF;
+  li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26);
+}
+
+CAMLprim value caml_add_debug_info(backtrace_slot start, value size,
+                                   value events)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_remove_debug_info(backtrace_slot start)
+{
+  return Val_unit;
+}
+
+int caml_debug_info_available(void)
+{
+  return 1;
+}
diff --git a/asmrun/clambda_checks.c b/asmrun/clambda_checks.c
new file mode 100644
index 00000000..1d25ecbc
--- /dev/null
+++ b/asmrun/clambda_checks.c
@@ -0,0 +1,89 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                       Pierre Chambart, OCamlPro                        */
+/*                   Mark Shinwell, Jane Street Europe                    */
+/*                                                                        */
+/*   Copyright 2013--2016 OCamlPro SAS                                    */
+/*   Copyright 2014--2016 Jane Street Group LLC                           */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Runtime checks to try to catch errors in code generation.
+   See flambda_to_clambda.ml for more information. */
+
+#include 
+#include 
+
+#include 
+
+value caml_check_value_is_closure(value v, value v_descr)
+{
+  const char* descr = String_val(v_descr);
+  value orig_v = v;
+
+  if (v == (value) 0) {
+    fprintf(stderr, "NULL is not a closure: %s\n",
+      descr);
+    abort();
+  }
+  if (!Is_block(v)) {
+    fprintf(stderr,
+      "Expecting a closure, got a non-boxed value %p: %s\n",
+      (void*) v, descr);
+    abort();
+  }
+  if (!(Tag_val(v) == Closure_tag || Tag_val(v) == Infix_tag)) {
+    fprintf(stderr,
+      "Expecting a closure, got a boxed value with tag %i: %s\n",
+      Tag_val(v), descr);
+    abort();
+  }
+  if (Tag_val(v) == Infix_tag) {
+    v -= Infix_offset_val(v);
+    assert(Tag_val(v) == Closure_tag);
+  }
+  assert(Wosize_val(v) >= 2);
+
+  return orig_v;
+}
+
+value caml_check_field_access(value v, value pos, value v_descr)
+{
+  const char* descr = String_val(v_descr);
+  value orig_v = v;
+  if (v == (value) 0) {
+    fprintf(stderr,
+      "Access to field %" ARCH_INT64_PRINTF_FORMAT
+      "u of NULL: %s\n", (ARCH_UINT64_TYPE) Long_val(pos), descr);
+    abort();
+  }
+  if (!Is_block(v)) {
+    fprintf(stderr,
+      "Access to field %" ARCH_INT64_PRINTF_FORMAT
+      "u of non-boxed value %p is illegal: %s\n",
+      (ARCH_UINT64_TYPE) Long_val(pos), (void*) v, descr);
+    abort();
+  }
+  if (Tag_val(v) == Infix_tag) {
+    uintnat offset = Infix_offset_val(v);
+    v -= offset;
+    pos += offset / sizeof(value);
+  }
+  assert(Long_val(pos) >= 0);
+  if (Long_val(pos) >= Wosize_val(v)) {
+    fprintf(stderr,
+      "Access to field %" ARCH_INT64_PRINTF_FORMAT
+      "u of value %p of size %" ARCH_INT64_PRINTF_FORMAT "u is illegal: %s\n",
+      (ARCH_UINT64_TYPE) Long_val(pos), (void*) v,
+      (ARCH_UINT64_TYPE) Wosize_val(v),
+      descr);
+    abort();
+  }
+  return orig_v;
+}
diff --git a/asmrun/fail.c b/asmrun/fail.c
new file mode 100644
index 00000000..d73cb885
--- /dev/null
+++ b/asmrun/fail.c
@@ -0,0 +1,198 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Raising exceptions from C. */
+
+#include 
+#include 
+#include "caml/alloc.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/gc.h"
+#include "caml/memory.h"
+#include "caml/mlvalues.h"
+#include "caml/printexc.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/roots.h"
+#include "caml/callback.h"
+
+/* The globals holding predefined exceptions */
+
+typedef value caml_generated_constant[1];
+
+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,
+  caml_exn_Assert_failure,
+  caml_exn_Undefined_recursive_module;
+
+/* Exception raising */
+
+CAMLnoreturn_start
+  extern void caml_raise_exception (value bucket)
+CAMLnoreturn_end;
+
+char * caml_exception_pointer = NULL;
+
+void caml_raise(value v)
+{
+  Unlock_exn();
+  if (caml_exception_pointer == NULL) caml_fatal_uncaught_exception(v);
+
+#ifndef Stack_grows_upwards
+#define PUSHED_AFTER <
+#else
+#define PUSHED_AFTER >
+#endif
+  while (caml_local_roots != NULL &&
+         (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) {
+    caml_local_roots = caml_local_roots->next;
+  }
+#undef PUSHED_AFTER
+
+  caml_raise_exception(v);
+}
+
+void caml_raise_constant(value tag)
+{
+  caml_raise(tag);
+}
+
+void caml_raise_with_arg(value tag, value arg)
+{
+  CAMLparam2 (tag, arg);
+  CAMLlocal1 (bucket);
+
+  bucket = caml_alloc_small (2, 0);
+  Field(bucket, 0) = tag;
+  Field(bucket, 1) = arg;
+  caml_raise(bucket);
+  CAMLnoreturn;
+}
+
+void caml_raise_with_args(value tag, int nargs, value args[])
+{
+  CAMLparam1 (tag);
+  CAMLxparamN (args, nargs);
+  value bucket;
+  int i;
+
+  Assert(1 + nargs <= Max_young_wosize);
+  bucket = caml_alloc_small (1 + nargs, 0);
+  Field(bucket, 0) = tag;
+  for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
+  caml_raise(bucket);
+  CAMLnoreturn;
+}
+
+void caml_raise_with_string(value tag, char const *msg)
+{
+  CAMLparam1(tag);
+  value v_msg = caml_copy_string(msg);
+  caml_raise_with_arg(tag, v_msg);
+  CAMLnoreturn;
+}
+
+void caml_failwith (char const *msg)
+{
+  caml_raise_with_string((value) caml_exn_Failure, msg);
+}
+
+void caml_failwith_value (value msg)
+{
+  caml_raise_with_arg((value) caml_exn_Failure, msg);
+}
+
+void caml_invalid_argument (char const *msg)
+{
+  caml_raise_with_string((value) caml_exn_Invalid_argument, msg);
+}
+
+void caml_invalid_argument_value (value msg)
+{
+  caml_raise_with_arg((value) caml_exn_Invalid_argument, msg);
+}
+
+void caml_raise_out_of_memory(void)
+{
+  caml_raise_constant((value) caml_exn_Out_of_memory);
+}
+
+void caml_raise_stack_overflow(void)
+{
+  caml_raise_constant((value) caml_exn_Stack_overflow);
+}
+
+void caml_raise_sys_error(value msg)
+{
+  caml_raise_with_arg((value) caml_exn_Sys_error, msg);
+}
+
+void caml_raise_end_of_file(void)
+{
+  caml_raise_constant((value) caml_exn_End_of_file);
+}
+
+void caml_raise_zero_divide(void)
+{
+  caml_raise_constant((value) caml_exn_Division_by_zero);
+}
+
+void caml_raise_not_found(void)
+{
+  caml_raise_constant((value) caml_exn_Not_found);
+}
+
+void caml_raise_sys_blocked_io(void)
+{
+  caml_raise_constant((value) caml_exn_Sys_blocked_io);
+}
+
+/* We use a pre-allocated exception because we can't
+   do a GC before the exception is raised (lack of stack descriptors
+   for the ccall to [caml_array_bound_error]).  */
+
+static value * caml_array_bound_error_exn = NULL;
+
+void caml_array_bound_error(void)
+{
+  if (caml_array_bound_error_exn == NULL) {
+    caml_array_bound_error_exn =
+      caml_named_value("Pervasives.array_bound_error");
+    if (caml_array_bound_error_exn == NULL) {
+      fprintf(stderr, "Fatal error: exception "
+                      "Invalid_argument(\"index out of bounds\")\n");
+      exit(2);
+    }
+  }
+  caml_raise(*caml_array_bound_error_exn);
+}
+
+int caml_is_special_exception(value exn) {
+  return exn == (value) caml_exn_Match_failure
+    || exn == (value) caml_exn_Assert_failure
+    || exn == (value) caml_exn_Undefined_recursive_module;
+}
diff --git a/asmrun/i386.S b/asmrun/i386.S
new file mode 100644
index 00000000..9e0f2bdb
--- /dev/null
+++ b/asmrun/i386.S
@@ -0,0 +1,488 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Asm part of the runtime system, Intel 386 processor */
+/* Must be preprocessed by cpp */
+
+#include "../config/m.h"
+
+/* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _.
+   Linux/BSD with a.out binaries and NextStep do. */
+
+#if (defined(SYS_solaris) && !defined(__GNUC__))
+#define CONCAT(a,b) a/**/b
+#else
+#define CONCAT(a,b) a##b
+#endif
+
+#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
+ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu)
+#define G(x) x
+#define LBL(x) CONCAT(.L,x)
+#else
+#define G(x) CONCAT(_,x)
+#define LBL(x) CONCAT(L,x)
+#endif
+
+#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
+ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_cygwin) \
+ || defined(SYS_mingw) || defined(SYS_gnu)
+#define FUNCTION_ALIGN 4
+#else
+#define FUNCTION_ALIGN 2
+#endif
+
+#define FUNCTION(name) \
+        .globl G(name); \
+        .align FUNCTION_ALIGN; \
+        G(name):
+
+#ifdef ASM_CFI_SUPPORTED
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
+#if defined(PROFILING)
+#if defined(SYS_linux_elf) || defined(SYS_gnu)
+#define PROFILE_CAML \
+        pushl %ebp; CFI_ADJUST(4); \
+        movl %esp, %ebp; \
+        pushl %eax; CFI_ADJUST(4); \
+        pushl %ecx; CFI_ADJUST(4); \
+        pushl %edx; CFI_ADJUST(4); \
+        call mcount; \
+        popl %edx; CFI_ADJUST(-4); \
+        popl %ecx; CFI_ADJUST(-4); \
+        popl %eax; CFI_ADJUST(-4); \
+        popl %ebp; CFI_ADJUST(-4)
+#define PROFILE_C \
+        pushl %ebp; CFI_ADJUST(4); \
+        movl %esp, %ebp; \
+        call mcount; \
+        popl %ebp; CFI_ADJUST(-4)
+#elif defined(SYS_bsd_elf)
+#define PROFILE_CAML \
+        pushl %ebp; CFI_ADJUST(4); \
+        movl %esp, %ebp; \
+        pushl %eax; CFI_ADJUST(4); \
+        pushl %ecx; CFI_ADJUST(4); \
+        pushl %edx; CFI_ADJUST(4); \
+        call .mcount; \
+        popl %edx; CFI_ADJUST(-4); \
+        popl %ecx; CFI_ADJUST(-4); \
+        popl %eax; CFI_ADJUST(-4); \
+        popl %ebp; CFI_ADJUST(-4)
+#define PROFILE_C \
+        pushl %ebp; CFI_ADJUST(4); \
+        movl %esp, %ebp; \
+        call .mcount; \
+        popl %ebp; CFI_ADJUST(-4)
+#elif defined(SYS_macosx)
+#define PROFILE_CAML \
+        pushl %ebp; CFI_ADJUST(4); \
+        movl %esp, %ebp; \
+        pushl %eax; CFI_ADJUST(4); \
+        pushl %ecx; CFI_ADJUST(4); \
+        pushl %edx; CFI_ADJUST(4); \
+        call Lmcount$stub;  \
+        popl %edx; CFI_ADJUST(-4); \
+        popl %ecx; CFI_ADJUST(-4); \
+        popl %eax; CFI_ADJUST(-4); \
+        popl %ebp; CFI_ADJUST(-4)
+#define PROFILE_C \
+        pushl %ebp; CFI_ADJUST(4); \
+        movl %esp, %ebp; \
+        call Lmcount$stub; \
+        popl %ebp; CFI_ADJUST(-4)
+#endif
+#else
+#define PROFILE_CAML
+#define PROFILE_C
+#endif
+
+/* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays,
+   even if only MacOS X's ABI formally requires it. */
+#define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount)
+#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount)
+
+/* Allocation */
+
+        .text
+        .globl  G(caml_system__code_begin)
+G(caml_system__code_begin):
+
+FUNCTION(caml_call_gc)
+        CFI_STARTPROC
+        PROFILE_CAML
+    /* Record lowest stack address and return address */
+        movl    0(%esp), %eax
+        movl    %eax, G(caml_last_return_address)
+        leal    4(%esp), %eax
+        movl    %eax, G(caml_bottom_of_stack)
+LBL(105):
+#if !defined(SYS_mingw) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subl    $16384, %esp
+        movl    %eax, 0(%esp)
+        addl    $16384, %esp
+#endif
+    /* Build array of registers, save it into caml_gc_regs */
+        pushl   %ebp; CFI_ADJUST(4)
+        pushl   %edi; CFI_ADJUST(4)
+        pushl   %esi; CFI_ADJUST(4)
+        pushl   %edx; CFI_ADJUST(4)
+        pushl   %ecx; CFI_ADJUST(4)
+        pushl   %ebx; CFI_ADJUST(4)
+        pushl   %eax; CFI_ADJUST(4)
+        movl    %esp, G(caml_gc_regs)
+        /* MacOSX note: 16-alignment of stack preserved at this point */
+    /* Call the garbage collector */
+        call    G(caml_garbage_collection)
+    /* Restore all regs used by the code generator */
+        popl    %eax; CFI_ADJUST(-4)
+        popl    %ebx; CFI_ADJUST(-4)
+        popl    %ecx; CFI_ADJUST(-4)
+        popl    %edx; CFI_ADJUST(-4)
+        popl    %esi; CFI_ADJUST(-4)
+        popl    %edi; CFI_ADJUST(-4)
+        popl    %ebp; CFI_ADJUST(-4)
+    /* Return to caller */
+        ret
+        CFI_ENDPROC
+
+FUNCTION(caml_alloc1)
+        CFI_STARTPROC
+        PROFILE_CAML
+        movl    G(caml_young_ptr), %eax
+        subl    $8, %eax
+        movl    %eax, G(caml_young_ptr)
+        cmpl    G(caml_young_limit), %eax
+        jb      LBL(100)
+        ret
+LBL(100):
+        movl    0(%esp), %eax
+        movl    %eax, G(caml_last_return_address)
+        leal    4(%esp), %eax
+        movl    %eax, G(caml_bottom_of_stack)
+        ALIGN_STACK(12)
+        call    LBL(105)
+        UNDO_ALIGN_STACK(12)
+        jmp     G(caml_alloc1)
+        CFI_ENDPROC
+
+FUNCTION(caml_alloc2)
+        CFI_STARTPROC
+        PROFILE_CAML
+        movl    G(caml_young_ptr), %eax
+        subl    $12, %eax
+        movl    %eax, G(caml_young_ptr)
+        cmpl    G(caml_young_limit), %eax
+        jb      LBL(101)
+        ret
+LBL(101):
+        movl    0(%esp), %eax
+        movl    %eax, G(caml_last_return_address)
+        leal    4(%esp), %eax
+        movl    %eax, G(caml_bottom_of_stack)
+        ALIGN_STACK(12)
+        call    LBL(105)
+        UNDO_ALIGN_STACK(12)
+        jmp     G(caml_alloc2)
+        CFI_ENDPROC
+
+FUNCTION(caml_alloc3)
+        CFI_STARTPROC
+        PROFILE_CAML
+        movl    G(caml_young_ptr), %eax
+        subl    $16, %eax
+        movl    %eax, G(caml_young_ptr)
+        cmpl    G(caml_young_limit), %eax
+        jb      LBL(102)
+        ret
+LBL(102):
+        movl    0(%esp), %eax
+        movl    %eax, G(caml_last_return_address)
+        leal    4(%esp), %eax
+        movl    %eax, G(caml_bottom_of_stack)
+        ALIGN_STACK(12)
+        call    LBL(105)
+        UNDO_ALIGN_STACK(12)
+        jmp     G(caml_alloc3)
+        CFI_ENDPROC
+
+FUNCTION(caml_allocN)
+        CFI_STARTPROC
+        PROFILE_CAML
+        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(caml_young_ptr)
+        ret
+LBL(103):
+        subl    G(caml_young_ptr), %eax /* eax = - size */
+        negl    %eax                    /* eax = size */
+        pushl   %eax; CFI_ADJUST(4)     /* save desired size */
+        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)
+        ALIGN_STACK(8)
+        call    LBL(105)
+        UNDO_ALIGN_STACK(8)
+        popl    %eax; CFI_ADJUST(-4)    /* recover desired size */
+        jmp     G(caml_allocN)
+        CFI_ENDPROC
+
+/* Call a C function from OCaml */
+
+FUNCTION(caml_c_call)
+        CFI_STARTPROC
+        PROFILE_CAML
+    /* Record lowest stack address and return address */
+        movl    (%esp), %edx
+        movl    %edx, G(caml_last_return_address)
+        leal    4(%esp), %edx
+        movl    %edx, G(caml_bottom_of_stack)
+#if !defined(SYS_mingw) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subl    $16384, %esp
+        movl    %eax, 0(%esp)
+        addl    $16384, %esp
+#endif
+    /* Call the function (address in %eax) */
+        jmp     *%eax
+        CFI_ENDPROC
+
+/* Start the OCaml program */
+
+FUNCTION(caml_start_program)
+        CFI_STARTPROC
+        PROFILE_C
+    /* Save callee-save registers */
+        pushl   %ebx; CFI_ADJUST(4)
+        pushl   %esi; CFI_ADJUST(4)
+        pushl   %edi; CFI_ADJUST(4)
+        pushl   %ebp; CFI_ADJUST(4)
+    /* Initial entry point is caml_program */
+        movl    $ G(caml_program), %esi
+    /* Common code for caml_start_program and caml_callback* */
+LBL(106):
+    /* Build a callback link */
+        pushl   G(caml_gc_regs); CFI_ADJUST(4)
+        pushl   G(caml_last_return_address); CFI_ADJUST(4)
+        pushl   G(caml_bottom_of_stack); CFI_ADJUST(4)
+        /* Note: 16-alignment preserved on MacOSX at this point */
+    /* Build an exception handler */
+        pushl   $ LBL(108); CFI_ADJUST(4)
+        ALIGN_STACK(8)
+        pushl   G(caml_exception_pointer); CFI_ADJUST(4)
+        movl    %esp, G(caml_exception_pointer)
+    /* Call the OCaml code */
+        call    *%esi
+LBL(107):
+    /* Pop the exception handler */
+        popl    G(caml_exception_pointer); CFI_ADJUST(-4)
+        addl    $12, %esp       ; CFI_ADJUST(-12)
+LBL(109):
+    /* Pop the callback link, restoring the global variables */
+        popl    G(caml_bottom_of_stack); CFI_ADJUST(-4)
+        popl    G(caml_last_return_address); CFI_ADJUST(-4)
+        popl    G(caml_gc_regs); CFI_ADJUST(-4)
+    /* Restore callee-save registers. */
+        popl    %ebp; CFI_ADJUST(-4)
+        popl    %edi; CFI_ADJUST(-4)
+        popl    %esi; CFI_ADJUST(-4)
+        popl    %ebx; CFI_ADJUST(-4)
+    /* Return to caller. */
+        ret
+LBL(108):
+    /* Exception handler*/
+    /* Mark the bucket as an exception result and return it */
+        orl     $2, %eax
+        jmp     LBL(109)
+        CFI_ENDPROC
+
+/* Raise an exception from OCaml */
+
+FUNCTION(caml_raise_exn)
+        CFI_STARTPROC
+        testl   $1, G(caml_backtrace_active)
+        jne     LBL(110)
+        movl    G(caml_exception_pointer), %esp
+        popl    G(caml_exception_pointer); CFI_ADJUST(-4)
+        UNDO_ALIGN_STACK(8)
+        ret
+LBL(110):
+        movl    %eax, %esi          /* Save exception bucket in esi */
+        movl    G(caml_exception_pointer), %edi /* SP of handler */
+        movl    0(%esp), %eax       /* PC of raise */
+        leal    4(%esp), %edx       /* SP of raise */
+        ALIGN_STACK(12)
+        pushl   %edi; CFI_ADJUST(4)         /* arg 4: sp of handler */
+        pushl   %edx; CFI_ADJUST(4)         /* arg 3: sp of raise */
+        pushl   %eax; CFI_ADJUST(4)         /* arg 2: pc of raise */
+        pushl   %esi; CFI_ADJUST(4)         /* arg 1: exception bucket */
+        call    G(caml_stash_backtrace)
+        movl    %esi, %eax              /* Recover exception bucket */
+        movl    %edi, %esp
+        popl    G(caml_exception_pointer); CFI_ADJUST(-4)
+        UNDO_ALIGN_STACK(8)
+        ret
+        CFI_ENDPROC
+
+/* Raise an exception from C */
+
+FUNCTION(caml_raise_exception)
+        CFI_STARTPROC
+        PROFILE_C
+        testl   $1, G(caml_backtrace_active)
+        jne     LBL(112)
+        movl    4(%esp), %eax
+        movl    G(caml_exception_pointer), %esp
+        popl    G(caml_exception_pointer); CFI_ADJUST(-4)
+        UNDO_ALIGN_STACK(8)
+        ret
+LBL(112):
+        movl    4(%esp), %esi          /* Save exception bucket in esi */
+        ALIGN_STACK(12)
+        pushl   G(caml_exception_pointer); CFI_ADJUST(4)  /* 4: sp of handler */
+        pushl   G(caml_bottom_of_stack); CFI_ADJUST(4)    /* 3: sp of raise */
+        pushl   G(caml_last_return_address); CFI_ADJUST(4)/* 2: pc of raise */
+        pushl   %esi; CFI_ADJUST(4)                    /* 1: exception bucket */
+        call    G(caml_stash_backtrace)
+        movl    %esi, %eax              /* Recover exception bucket */
+        movl    G(caml_exception_pointer), %esp
+        popl    G(caml_exception_pointer); CFI_ADJUST(-4)
+        UNDO_ALIGN_STACK(8)
+        ret
+        CFI_ENDPROC
+
+/* Callback from C to OCaml */
+
+FUNCTION(caml_callback_exn)
+        CFI_STARTPROC
+        PROFILE_C
+    /* Save callee-save registers */
+        pushl   %ebx; CFI_ADJUST(4)
+        pushl   %esi; CFI_ADJUST(4)
+        pushl   %edi; CFI_ADJUST(4)
+        pushl   %ebp; CFI_ADJUST(4)
+    /* Initial loading of arguments */
+        movl    20(%esp), %ebx   /* closure */
+        movl    24(%esp), %eax   /* argument */
+        movl    0(%ebx), %esi    /* code pointer */
+        jmp     LBL(106)
+        CFI_ENDPROC
+
+FUNCTION(caml_callback2_exn)
+        CFI_STARTPROC
+        PROFILE_C
+    /* Save callee-save registers */
+        pushl   %ebx; CFI_ADJUST(4)
+        pushl   %esi; CFI_ADJUST(4)
+        pushl   %edi; CFI_ADJUST(4)
+        pushl   %ebp; CFI_ADJUST(4)
+    /* Initial loading of arguments */
+        movl    20(%esp), %ecx   /* closure */
+        movl    24(%esp), %eax   /* first argument */
+        movl    28(%esp), %ebx   /* second argument */
+        movl    $ G(caml_apply2), %esi   /* code pointer */
+        jmp     LBL(106)
+        CFI_ENDPROC
+
+FUNCTION(caml_callback3_exn)
+        CFI_STARTPROC
+        PROFILE_C
+    /* Save callee-save registers */
+        pushl   %ebx; CFI_ADJUST(4)
+        pushl   %esi; CFI_ADJUST(4)
+        pushl   %edi; CFI_ADJUST(4)
+        pushl   %ebp; CFI_ADJUST(4)
+    /* Initial loading of arguments */
+        movl    20(%esp), %edx   /* closure */
+        movl    24(%esp), %eax   /* first argument */
+        movl    28(%esp), %ebx   /* second argument */
+        movl    32(%esp), %ecx   /* third argument */
+        movl    $ G(caml_apply3), %esi   /* code pointer */
+        jmp     LBL(106)
+        CFI_ENDPROC
+
+FUNCTION(caml_ml_array_bound_error)
+        CFI_STARTPROC
+    /* Empty the floating-point stack */
+        ffree   %st(0)
+        ffree   %st(1)
+        ffree   %st(2)
+        ffree   %st(3)
+        ffree   %st(4)
+        ffree   %st(5)
+        ffree   %st(6)
+        ffree   %st(7)
+    /* Record lowest stack address and return address */
+        movl    (%esp), %edx
+        movl    %edx, G(caml_last_return_address)
+        leal    4(%esp), %edx
+        movl    %edx, G(caml_bottom_of_stack)
+    /* Re-align the stack */
+        andl    $-16, %esp
+    /* Branch to [caml_array_bound_error] (never returns) */
+        call    G(caml_array_bound_error)
+        CFI_ENDPROC
+
+        .globl  G(caml_system__code_end)
+G(caml_system__code_end):
+
+        .data
+        .globl  G(caml_system__frametable)
+G(caml_system__frametable):
+        .long   1               /* one descriptor */
+        .long   LBL(107)        /* return address into callback */
+#ifndef SYS_solaris
+        .word   -1              /* negative frame size => use callback link */
+        .word   0               /* no roots here */
+#else
+        .value  -1              /* negative frame size => use callback link */
+        .value  0               /* no roots here */
+#endif
+
+        .globl  G(caml_extra_params)
+G(caml_extra_params):
+#ifndef SYS_solaris
+        .space  64
+#else
+        .zero   64
+#endif
+
+#if defined(PROFILING) && defined(SYS_macosx)
+        .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5
+Lmcount$stub:
+        .indirect_symbol mcount
+        hlt ; hlt ; hlt ; hlt ; hlt
+        .subsections_via_symbols
+#endif
+
+#if defined(SYS_linux_elf)
+    /* Mark stack as non-executable, PR#4564 */
+        .section .note.GNU-stack,"",%progbits
+#endif
diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm
new file mode 100644
index 00000000..b6730676
--- /dev/null
+++ b/asmrun/i386nt.asm
@@ -0,0 +1,323 @@
+;**************************************************************************
+;*                                                                        *
+;*                                 OCaml                                  *
+;*                                                                        *
+;*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *
+;*   special exception on linking described in the file LICENSE.          *
+;*                                                                        *
+;**************************************************************************
+
+; Asm part of the runtime system, Intel 386 processor, Intel syntax
+
+        .386
+        .MODEL FLAT
+
+        EXTERN  _caml_garbage_collection: PROC
+        EXTERN  _caml_apply2: PROC
+        EXTERN  _caml_apply3: PROC
+        EXTERN  _caml_program: PROC
+        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
+        EXTERN  _caml_exception_pointer: DWORD
+        EXTERN  _caml_backtrace_pos: DWORD
+        EXTERN  _caml_backtrace_active: DWORD
+        EXTERN  _caml_stash_backtrace: PROC
+
+; Allocation
+
+        .CODE
+        PUBLIC  _caml_alloc1
+        PUBLIC  _caml_alloc2
+        PUBLIC  _caml_alloc3
+        PUBLIC  _caml_allocN
+        PUBLIC  _caml_call_gc
+
+_caml_call_gc:
+    ; Record lowest stack address and return address
+        mov     eax, [esp]
+        mov     _caml_last_return_address, eax
+        lea     eax, [esp+4]
+        mov     _caml_bottom_of_stack, eax
+    ; Save all regs used by the code generator
+L105:   push    ebp
+        push    edi
+        push    esi
+        push    edx
+        push    ecx
+        push    ebx
+        push    eax
+        mov     _caml_gc_regs, esp
+    ; Call the garbage collector
+        call    _caml_garbage_collection
+    ; Restore all regs used by the code generator
+        pop     eax
+        pop     ebx
+        pop     ecx
+        pop     edx
+        pop     esi
+        pop     edi
+        pop     ebp
+    ; Return to caller
+        ret
+
+        ALIGN  4
+_caml_alloc1:
+        mov     eax, _caml_young_ptr
+        sub     eax, 8
+        mov     _caml_young_ptr, eax
+        cmp     eax, _caml_young_limit
+        jb      L100
+        ret
+L100:   mov     eax, [esp]
+        mov     _caml_last_return_address, eax
+        lea     eax, [esp+4]
+        mov     _caml_bottom_of_stack, eax
+        call    L105
+        jmp     _caml_alloc1
+
+        ALIGN  4
+_caml_alloc2:
+        mov     eax, _caml_young_ptr
+        sub     eax, 12
+        mov     _caml_young_ptr, eax
+        cmp     eax, _caml_young_limit
+        jb      L101
+        ret
+L101:   mov     eax, [esp]
+        mov     _caml_last_return_address, eax
+        lea     eax, [esp+4]
+        mov     _caml_bottom_of_stack, eax
+        call    L105
+        jmp     _caml_alloc2
+
+        ALIGN  4
+_caml_alloc3:
+        mov     eax, _caml_young_ptr
+        sub     eax, 16
+        mov     _caml_young_ptr, eax
+        cmp     eax, _caml_young_limit
+        jb      L102
+        ret
+L102:   mov     eax, [esp]
+        mov     _caml_last_return_address, eax
+        lea     eax, [esp+4]
+        mov     _caml_bottom_of_stack, eax
+        call    L105
+        jmp     _caml_alloc3
+
+        ALIGN  4
+_caml_allocN:
+        sub     eax, _caml_young_ptr         ; eax = size - young_ptr
+        neg     eax                     ; eax = young_ptr - size
+        cmp     eax, _caml_young_limit
+        jb      L103
+        mov     _caml_young_ptr, eax
+        ret
+L103:   sub     eax, _caml_young_ptr         ; eax = - size
+        neg     eax                     ; eax = size
+        push    eax                     ; save desired size
+        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_allocN
+
+; Call a C function from OCaml
+
+        PUBLIC  _caml_c_call
+        ALIGN  4
+_caml_c_call:
+    ; Record lowest stack address and return address
+        mov     edx, [esp]
+        mov     _caml_last_return_address, edx
+        lea     edx, [esp+4]
+        mov     _caml_bottom_of_stack, edx
+    ; Call the function (address in %eax)
+        jmp     eax
+
+; Start the OCaml program
+
+        PUBLIC  _caml_start_program
+        ALIGN  4
+_caml_start_program:
+    ; Save callee-save registers
+        push    ebx
+        push    esi
+        push    edi
+        push    ebp
+    ; Initial code pointer is caml_program
+        mov     esi, offset _caml_program
+
+; Code shared between caml_start_program and callback*
+
+L106:
+    ; Build a callback link
+        push    _caml_gc_regs
+        push    _caml_last_return_address
+        push    _caml_bottom_of_stack
+    ; Build an exception handler
+        push    L108
+        push    _caml_exception_pointer
+        mov     _caml_exception_pointer, esp
+    ; Call the OCaml code
+        call    esi
+L107:
+    ; Pop the exception handler
+        pop     _caml_exception_pointer
+        pop     esi             ; dummy register
+L109:
+    ; Pop the callback link, restoring the global variables
+    ; used by caml_c_call
+        pop     _caml_bottom_of_stack
+        pop     _caml_last_return_address
+        pop     _caml_gc_regs
+    ; Restore callee-save registers.
+        pop     ebp
+        pop     edi
+        pop     esi
+        pop     ebx
+    ; Return to caller.
+        ret
+L108:
+    ; Exception handler
+    ; Mark the bucket as an exception result and return it
+        or      eax, 2
+        jmp     L109
+
+; Raise an exception for OCaml
+
+        PUBLIC  _caml_raise_exn
+        ALIGN   4
+_caml_raise_exn:
+        test    _caml_backtrace_active, 1
+        jne     L110
+        mov     esp, _caml_exception_pointer
+        pop     _caml_exception_pointer
+        ret
+L110:
+        mov     esi, eax                ; Save exception bucket in esi
+        mov     edi, _caml_exception_pointer ; SP of handler
+        mov     eax, [esp]              ; PC of raise
+        lea     edx, [esp+4]
+        push    edi                     ; arg 4: SP of handler
+        push    edx                     ; arg 3: SP of raise
+        push    eax                     ; arg 2: PC of raise
+        push    esi                     ; arg 1: exception bucket
+        call    _caml_stash_backtrace
+        mov     eax, esi                ; recover exception bucket
+        mov     esp, edi                ; cut the stack
+        pop     _caml_exception_pointer
+        ret
+
+; Raise an exception from C
+
+        PUBLIC  _caml_raise_exception
+        ALIGN  4
+_caml_raise_exception:
+        test    _caml_backtrace_active, 1
+        jne     L112
+        mov     eax, [esp+4]
+        mov     esp, _caml_exception_pointer
+        pop     _caml_exception_pointer
+        ret
+L112:
+        mov     esi, [esp+4]            ; Save exception bucket in esi
+        push    _caml_exception_pointer ; arg 4: SP of handler
+        push    _caml_bottom_of_stack   ; arg 3: SP of raise
+        push    _caml_last_return_address ; arg 2: PC of raise
+        push    esi                     ; arg 1: exception bucket
+        call    _caml_stash_backtrace
+        mov     eax, esi                ; recover exception bucket
+        mov     esp, _caml_exception_pointer ; cut the stack
+        pop     _caml_exception_pointer
+        ret
+
+; Callback from C to OCaml
+
+        PUBLIC  _caml_callback_exn
+        ALIGN  4
+_caml_callback_exn:
+    ; Save callee-save registers
+        push    ebx
+        push    esi
+        push    edi
+        push    ebp
+    ; Initial loading of arguments
+        mov     ebx, [esp+20]   ; closure
+        mov     eax, [esp+24]   ; argument
+        mov     esi, [ebx]      ; code pointer
+        jmp     L106
+
+        PUBLIC  _caml_callback2_exn
+        ALIGN  4
+_caml_callback2_exn:
+    ; Save callee-save registers
+        push    ebx
+        push    esi
+        push    edi
+        push    ebp
+    ; Initial loading of arguments
+        mov     ecx, [esp+20]   ; closure
+        mov     eax, [esp+24]   ; first argument
+        mov     ebx, [esp+28]   ; second argument
+        mov     esi, offset _caml_apply2   ; code pointer
+        jmp     L106
+
+        PUBLIC  _caml_callback3_exn
+        ALIGN   4
+_caml_callback3_exn:
+    ; Save callee-save registers
+        push    ebx
+        push    esi
+        push    edi
+        push    ebp
+    ; Initial loading of arguments
+        mov     edx, [esp+20]   ; closure
+        mov     eax, [esp+24]   ; first argument
+        mov     ebx, [esp+28]   ; second argument
+        mov     ecx, [esp+32]   ; third argument
+        mov     esi, offset _caml_apply3   ; code pointer
+        jmp     L106
+
+        PUBLIC  _caml_ml_array_bound_error
+        ALIGN   4
+_caml_ml_array_bound_error:
+    ; Empty the floating-point stack
+        ffree   st(0)
+        ffree   st(1)
+        ffree   st(2)
+        ffree   st(3)
+        ffree   st(4)
+        ffree   st(5)
+        ffree   st(6)
+        ffree   st(7)
+    ; Branch to caml_array_bound_error
+        mov     eax, offset _caml_array_bound_error
+        jmp     _caml_c_call
+
+        .DATA
+        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
+        WORD    0               ; no roots here
+
+        PUBLIC  _caml_extra_params
+_caml_extra_params LABEL DWORD
+        BYTE    64 DUP (?)
+
+        END
diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c
new file mode 100644
index 00000000..e2599e65
--- /dev/null
+++ b/asmrun/natdynlink.c
@@ -0,0 +1,185 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Alain Frisch, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2007 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/stack.h"
+#include "caml/callback.h"
+#include "caml/alloc.h"
+#include "caml/intext.h"
+#include "caml/osdeps.h"
+#include "caml/fail.h"
+#include "caml/signals.h"
+#ifdef WITH_SPACETIME
+#include "caml/spacetime.h"
+#endif
+
+#include "caml/hooks.h"
+
+CAMLexport void (*caml_natdynlink_hook)(void* handle, char* unit) = NULL;
+
+#include 
+#include 
+#include 
+
+#define Handle_val(v) (*((void **) Data_abstract_val(v)))
+static value Val_handle(void* handle) {
+  value res = caml_alloc_small(1, Abstract_tag);
+  Handle_val(res) = handle;
+  return res;
+}
+
+static void *getsym(void *handle, char *module, char *name){
+  char *fullname = caml_strconcat(3, "caml", module, name);
+  void *sym;
+  sym = caml_dlsym (handle, fullname);
+  /*  printf("%s => %lx\n", fullname, (uintnat) sym); */
+  caml_stat_free(fullname);
+  return sym;
+}
+
+CAMLprim value caml_natdynlink_getmap(value unit)
+{
+  return caml_input_value_from_block(caml_globals_map, INT_MAX);
+}
+
+CAMLprim value caml_natdynlink_globals_inited(value unit)
+{
+  return Val_int(caml_globals_inited);
+}
+
+CAMLprim value caml_natdynlink_open(value filename, value global)
+{
+  CAMLparam2 (filename, global);
+  CAMLlocal3 (res, handle, header);
+  void *sym;
+  void *dlhandle;
+  char *p;
+
+  /* TODO: dlclose in case of error... */
+
+  p = caml_strdup(String_val(filename));
+  caml_enter_blocking_section();
+  dlhandle = caml_dlopen(p, 1, Int_val(global));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+
+  if (NULL == dlhandle)
+    caml_failwith(caml_dlerror());
+
+  sym = caml_dlsym(dlhandle, "caml_plugin_header");
+  if (NULL == sym)
+    caml_failwith("not an OCaml plugin");
+
+  handle = Val_handle(dlhandle);
+  header = caml_input_value_from_block(sym, INT_MAX);
+
+  res = caml_alloc_tuple(2);
+  Field(res, 0) = handle;
+  Field(res, 1) = header;
+  CAMLreturn(res);
+}
+
+CAMLprim value caml_natdynlink_run(value handle_v, value symbol) {
+  CAMLparam2 (handle_v, symbol);
+  CAMLlocal1 (result);
+  void *sym,*sym2;
+  void* handle = Handle_val(handle_v);
+  struct code_fragment * cf;
+
+#define optsym(n) getsym(handle,unit,n)
+  char *unit;
+  void (*entrypoint)(void);
+
+  unit = String_val(symbol);
+
+  sym = optsym("__frametable");
+  if (NULL != sym) caml_register_frametable(sym);
+
+#ifdef WITH_SPACETIME
+  sym = optsym("__spacetime_shapes");
+  if (NULL != sym) caml_spacetime_register_shapes(sym);
+#endif
+
+  sym = optsym("__gc_roots");
+  if (NULL != sym) caml_register_dyn_global(sym);
+
+  sym = optsym("__data_begin");
+  sym2 = optsym("__data_end");
+  if (NULL != sym && NULL != sym2)
+    caml_page_table_add(In_static_data, sym, sym2);
+
+  sym = optsym("__code_begin");
+  sym2 = optsym("__code_end");
+  if (NULL != sym && NULL != sym2) {
+    caml_page_table_add(In_code_area, sym, sym2);
+    cf = caml_stat_alloc(sizeof(struct code_fragment));
+    cf->code_start = (char *) sym;
+    cf->code_end = (char *) sym2;
+    cf->digest_computed = 0;
+    caml_ext_table_add(&caml_code_fragments_table, cf);
+  }
+
+  if( caml_natdynlink_hook != NULL ) caml_natdynlink_hook(handle,unit);
+
+  entrypoint = optsym("__entry");
+  if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0);
+  else result = Val_unit;
+
+#undef optsym
+
+  CAMLreturn (result);
+}
+
+CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol)
+{
+  CAMLparam2 (filename, symbol);
+  CAMLlocal3 (res, v, handle_v);
+  void *handle;
+  char *p;
+
+  /* TODO: dlclose in case of error... */
+
+  p = caml_strdup(String_val(filename));
+  caml_enter_blocking_section();
+  handle = caml_dlopen(p, 1, 1);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+
+  if (NULL == handle) {
+    res = caml_alloc(1,1);
+    v = caml_copy_string(caml_dlerror());
+    Store_field(res, 0, v);
+  } else {
+    handle_v = Val_handle(handle);
+    res = caml_alloc(1,0);
+    v = caml_natdynlink_run(handle_v, symbol);
+    Store_field(res, 0, v);
+  }
+  CAMLreturn(res);
+}
+
+CAMLprim value caml_natdynlink_loadsym(value symbol)
+{
+  CAMLparam1 (symbol);
+  CAMLlocal1 (sym);
+
+  sym = (value) caml_globalsym(String_val(symbol));
+  if (!sym) caml_failwith(String_val(symbol));
+  CAMLreturn(sym);
+}
diff --git a/asmrun/power.S b/asmrun/power.S
new file mode 100644
index 00000000..b58391ed
--- /dev/null
+++ b/asmrun/power.S
@@ -0,0 +1,680 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#if defined(MODEL_ppc64le)
+        .abiversion 2
+#endif
+
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+#define EITHER(a,b) b
+#else
+#define EITHER(a,b) a
+#endif
+
+#define WORD EITHER(4,8)
+#define lg EITHER(lwz,ld)
+#define lgu EITHER(lwzu,ldu)
+#define stg EITHER(stw,std)
+#define stgu EITHER(stwu,stdu)
+#define datag EITHER(.long,.quad)
+#define wordalign EITHER(2,3)
+
+/* Stack layout */
+#if defined(MODEL_ppc)
+#define RESERVED_STACK 16
+#define PARAM_SAVE_AREA 0
+#define LR_SAVE 4
+#define TRAP_SIZE 16
+#define TRAP_HANDLER_OFFSET 0
+#define TRAP_PREVIOUS_OFFSET 4
+#define CALLBACK_LINK_SIZE 16
+#define CALLBACK_LINK_OFFSET 0
+#endif
+#if defined(MODEL_ppc64)
+#define RESERVED_STACK 48
+#define PARAM_SAVE_AREA (8*8)
+#define LR_SAVE 16
+#define TOC_SAVE 40
+#define TOC_SAVE_PARENT 8
+#define TRAP_SIZE 32
+#define TRAP_HANDLER_OFFSET 56
+#define TRAP_PREVIOUS_OFFSET 64
+#define CALLBACK_LINK_SIZE 32
+#define CALLBACK_LINK_OFFSET 48
+#endif
+#if defined(MODEL_ppc64le)
+#define RESERVED_STACK 32
+#define PARAM_SAVE_AREA 0
+#define LR_SAVE 16
+#define TOC_SAVE_PARENT 8
+#define TOC_SAVE 24
+#define TRAP_SIZE 32
+#define TRAP_HANDLER_OFFSET 40
+#define TRAP_PREVIOUS_OFFSET 48
+#define CALLBACK_LINK_SIZE 32
+#define CALLBACK_LINK_OFFSET 32
+#endif
+
+/* Function definitions */
+
+#if defined(MODEL_ppc)
+#define FUNCTION(name) \
+  .section ".text"; \
+  .globl name; \
+  .type name, @function; \
+  .align 2; \
+  name:
+
+#define ENDFUNCTION(name) \
+  .size name, . - name
+
+#endif
+
+#if defined(MODEL_ppc64)
+#define FUNCTION(name) \
+  .section ".opd","aw"; \
+  .align 3; \
+  .globl name; \
+  .type name, @function; \
+  name: .quad .L.name,.TOC.@tocbase; \
+  .text; \
+  .align 2; \
+  .L.name:
+
+#define ENDFUNCTION(name) \
+  .size name, . - .L.name
+
+#endif
+
+#if defined(MODEL_ppc64le)
+#define FUNCTION(name) \
+  .section ".text"; \
+  .globl name; \
+  .type name, @function; \
+  .align 2; \
+  name: ; \
+  0: addis 2, 12, (.TOC. - 0b)@ha; \
+  addi 2, 2, (.TOC. - 0b)@l; \
+  .localentry name, . - 0b
+
+#define ENDFUNCTION(name) \
+  .size name, . - name
+
+#endif
+
+/* Accessing global variables.  */
+
+#if defined(MODEL_ppc)
+
+#define Addrglobal(reg,glob) \
+        addis   reg, 0, glob@ha; \
+        addi    reg, reg, glob@l
+#define Loadglobal(reg,glob,tmp) \
+        addis   tmp, 0, glob@ha; \
+        lg      reg, glob@l(tmp)
+#define Storeglobal(reg,glob,tmp) \
+        addis   tmp, 0, glob@ha; \
+        stg     reg, glob@l(tmp)
+#define Loadglobal32(reg,glob,tmp) \
+        addis   tmp, 0, glob@ha; \
+        lwz     reg, glob@l(tmp)
+#define Storeglobal32(reg,glob,tmp) \
+        addis   tmp, 0, glob@ha; \
+        stw     reg, glob@l(tmp)
+
+#endif
+
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+
+#define LSYMB(glob) .L##glob
+
+#define Addrglobal(reg,glob) \
+        ld      reg, LSYMB(glob)@toc(2)
+#define Loadglobal(reg,glob,tmp) \
+        Addrglobal(tmp,glob); \
+        lg      reg, 0(tmp)
+#define Storeglobal(reg,glob,tmp) \
+        Addrglobal(tmp,glob); \
+        stg     reg, 0(tmp)
+#define Loadglobal32(reg,glob,tmp) \
+        Addrglobal(tmp,glob); \
+        lwz     reg, 0(tmp)
+#define Storeglobal32(reg,glob,tmp) \
+        Addrglobal(tmp,glob); \
+        stw     reg, 0(tmp)
+
+#endif
+
+#if defined(MODEL_ppc64)
+        .section ".opd","aw"
+#else
+        .section ".text"
+#endif
+        .globl  caml_system__code_begin
+caml_system__code_begin:
+
+/* Invoke the garbage collector. */
+
+FUNCTION(caml_call_gc)
+#define STACKSIZE (WORD*32 + 8*32 + PARAM_SAVE_AREA + RESERVED_STACK)
+    /* 32 integer registers + 32 float registers + space for C call */
+    /* Set up stack frame */
+        stwu    1, -STACKSIZE(1)
+    /* Record return address into OCaml code */
+        mflr    0
+        Storeglobal(0, caml_last_return_address, 11)
+    /* Record lowest stack address */
+        addi    0, 1, STACKSIZE
+        Storeglobal(0, caml_bottom_of_stack, 11)
+    /* Record pointer to register array */
+        addi    0, 1, 8*32 + PARAM_SAVE_AREA + RESERVED_STACK
+        Storeglobal(0, caml_gc_regs, 11)
+    /* Save current allocation pointer for debugging purposes */
+        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 */
+        addi    11, 1, 8*32 + PARAM_SAVE_AREA + RESERVED_STACK - WORD
+        stgu    3, WORD(11)
+        stgu    4, WORD(11)
+        stgu    5, WORD(11)
+        stgu    6, WORD(11)
+        stgu    7, WORD(11)
+        stgu    8, WORD(11)
+        stgu    9, WORD(11)
+        stgu    10, WORD(11)
+        stgu    14, WORD(11)
+        stgu    15, WORD(11)
+        stgu    16, WORD(11)
+        stgu    17, WORD(11)
+        stgu    18, WORD(11)
+        stgu    19, WORD(11)
+        stgu    20, WORD(11)
+        stgu    21, WORD(11)
+        stgu    22, WORD(11)
+        stgu    23, WORD(11)
+        stgu    24, WORD(11)
+        stgu    25, WORD(11)
+        stgu    26, WORD(11)
+        stgu    27, WORD(11)
+        stgu    28, WORD(11)
+        addi    11, 1, PARAM_SAVE_AREA + RESERVED_STACK - 8
+        stfdu   1, 8(11)
+        stfdu   2, 8(11)
+        stfdu   3, 8(11)
+        stfdu   4, 8(11)
+        stfdu   5, 8(11)
+        stfdu   6, 8(11)
+        stfdu   7, 8(11)
+        stfdu   8, 8(11)
+        stfdu   9, 8(11)
+        stfdu   10, 8(11)
+        stfdu   11, 8(11)
+        stfdu   12, 8(11)
+        stfdu   13, 8(11)
+        stfdu   14, 8(11)
+        stfdu   15, 8(11)
+        stfdu   16, 8(11)
+        stfdu   17, 8(11)
+        stfdu   18, 8(11)
+        stfdu   19, 8(11)
+        stfdu   20, 8(11)
+        stfdu   21, 8(11)
+        stfdu   22, 8(11)
+        stfdu   23, 8(11)
+        stfdu   24, 8(11)
+        stfdu   25, 8(11)
+        stfdu   26, 8(11)
+        stfdu   27, 8(11)
+        stfdu   28, 8(11)
+        stfdu   29, 8(11)
+        stfdu   30, 8(11)
+        stfdu   31, 8(11)
+    /* Call the GC */
+        bl      caml_garbage_collection
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+        nop
+#endif
+    /* Reload new allocation pointer and allocation limit */
+        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 + PARAM_SAVE_AREA + RESERVED_STACK - WORD
+        lgu     3, WORD(11)
+        lgu     4, WORD(11)
+        lgu     5, WORD(11)
+        lgu     6, WORD(11)
+        lgu     7, WORD(11)
+        lgu     8, WORD(11)
+        lgu     9, WORD(11)
+        lgu     10, WORD(11)
+        lgu     14, WORD(11)
+        lgu     15, WORD(11)
+        lgu     16, WORD(11)
+        lgu     17, WORD(11)
+        lgu     18, WORD(11)
+        lgu     19, WORD(11)
+        lgu     20, WORD(11)
+        lgu     21, WORD(11)
+        lgu     22, WORD(11)
+        lgu     23, WORD(11)
+        lgu     24, WORD(11)
+        lgu     25, WORD(11)
+        lgu     26, WORD(11)
+        lgu     27, WORD(11)
+        lgu     28, WORD(11)
+        addi    11, 1, PARAM_SAVE_AREA + RESERVED_STACK - 8
+        lfdu    1, 8(11)
+        lfdu    2, 8(11)
+        lfdu    3, 8(11)
+        lfdu    4, 8(11)
+        lfdu    5, 8(11)
+        lfdu    6, 8(11)
+        lfdu    7, 8(11)
+        lfdu    8, 8(11)
+        lfdu    9, 8(11)
+        lfdu    10, 8(11)
+        lfdu    11, 8(11)
+        lfdu    12, 8(11)
+        lfdu    13, 8(11)
+        lfdu    14, 8(11)
+        lfdu    15, 8(11)
+        lfdu    16, 8(11)
+        lfdu    17, 8(11)
+        lfdu    18, 8(11)
+        lfdu    19, 8(11)
+        lfdu    20, 8(11)
+        lfdu    21, 8(11)
+        lfdu    22, 8(11)
+        lfdu    23, 8(11)
+        lfdu    24, 8(11)
+        lfdu    25, 8(11)
+        lfdu    26, 8(11)
+        lfdu    27, 8(11)
+        lfdu    28, 8(11)
+        lfdu    29, 8(11)
+        lfdu    30, 8(11)
+        lfdu    31, 8(11)
+    /* Return to caller, restarting the allocation */
+        Loadglobal(11, caml_last_return_address, 11)
+        addi    11, 11, -16     /* Restart the allocation (4 instructions) */
+        mtlr    11
+    /* For PPC64: restore the TOC that the caller saved at the usual place */
+#ifdef TOC_SAVE
+        ld      2, (STACKSIZE + TOC_SAVE)(1)
+#endif
+    /* Deallocate stack frame */
+        addi    1, 1, STACKSIZE
+        blr
+#undef STACKSIZE
+ENDFUNCTION(caml_call_gc)
+
+/* Call a C function from OCaml */
+
+FUNCTION(caml_c_call)
+        .cfi_startproc
+    /* Save return address in a callee-save register */
+        mflr    27
+        .cfi_register 65, 27
+    /* Record lowest stack address and return address */
+        Storeglobal(1, caml_bottom_of_stack, 11)
+        Storeglobal(27, caml_last_return_address, 11)
+    /* Make the exception handler and alloc ptr available to the C code */
+        Storeglobal(31, caml_young_ptr, 11)
+        Storeglobal(29, caml_exception_pointer, 11)
+    /* Call C function (address in r28) */
+#if defined(MODEL_ppc)
+        mtctr   28
+        bctrl
+#elif defined(MODEL_ppc64)
+        ld      0, 0(28)
+        mr      26, 2   /* save current TOC in a callee-save register */
+        mtctr   0
+        ld      2, 8(28)
+        bctrl
+        mr      2, 26   /* restore current TOC */
+#elif defined(MODEL_ppc64le)
+        mtctr   28
+        mr      12, 28
+        mr      26, 2   /* save current TOC in a callee-save register */
+        bctrl
+        mr      2, 26   /* restore current TOC */
+#else
+#error "wrong MODEL"
+#endif
+    /* Restore return address (in 27, preserved by the C function) */
+        mtlr    27
+    /* Reload allocation pointer and allocation limit*/
+        Loadglobal(31, caml_young_ptr, 11)
+        Loadglobal(30, caml_young_limit, 11)
+    /* Return to caller */
+        blr
+        .cfi_endproc
+ENDFUNCTION(caml_c_call)
+
+/* Raise an exception from OCaml */
+
+FUNCTION(caml_raise_exn)
+        Loadglobal32(0, caml_backtrace_active, 11)
+        cmpwi   0, 0
+        bne     .L111
+.L110:
+    /* Pop trap frame */
+        lg      0, TRAP_HANDLER_OFFSET(29)
+        mr      1, 29
+        mtctr   0
+        lg      29, TRAP_PREVIOUS_OFFSET(1)
+        addi    1, 1, TRAP_SIZE
+    /* Branch to handler */
+        bctr
+.L111:
+        mr      28, 3           /* preserve exn bucket in callee-save reg */
+                                /* arg1: exception bucket, already in r3 */
+        mflr    4               /* arg2: PC of raise */
+        mr      5, 1            /* arg3: SP of raise */
+        mr      6, 29           /* arg4: SP of handler */
+        addi    1, 1, -(PARAM_SAVE_AREA + RESERVED_STACK)
+                                /* reserve stack space for C call */
+        bl      caml_stash_backtrace
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+        nop
+#endif
+        mr      3, 28           /* restore exn bucket */
+        b       .L110           /* raise the exn */
+ENDFUNCTION(caml_raise_exn)
+
+/* Raise an exception from C */
+
+FUNCTION(caml_raise_exception)
+        Loadglobal32(0, caml_backtrace_active, 11)
+        cmpwi   0, 0
+        bne     .L121
+.L120:
+    /* Reload OCaml global registers */
+        Loadglobal(1, caml_exception_pointer, 11)
+        Loadglobal(31, caml_young_ptr, 11)
+        Loadglobal(30, caml_young_limit, 11)
+    /* Pop trap frame */
+        lg      0, TRAP_HANDLER_OFFSET(1)
+        mtctr   0
+        lg      29, TRAP_PREVIOUS_OFFSET(1)
+        addi    1, 1, TRAP_SIZE
+    /* Branch to handler */
+        bctr
+.L121:
+        li      0, 0
+        Storeglobal32(0, caml_backtrace_pos, 11)
+        mr      28, 3           /* preserve exn bucket in callee-save reg */
+                                /* arg1: exception bucket, already in r3 */
+        Loadglobal(4, caml_last_return_address, 11) /* arg2: PC of raise */
+        Loadglobal(5, caml_bottom_of_stack, 11)     /* arg3: SP of raise */
+        Loadglobal(6, caml_exception_pointer, 11)   /* arg4: SP of handler */
+        addi    1, 1, -(PARAM_SAVE_AREA + RESERVED_STACK)
+                                         /* reserve stack space for C call */
+        bl      caml_stash_backtrace
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+        nop
+#endif
+        mr      3, 28           /* restore exn bucket */
+        b       .L120           /* raise the exn */
+ENDFUNCTION(caml_raise_exception)
+
+/* Start the OCaml program */
+
+FUNCTION(caml_start_program)
+        .cfi_startproc
+#define STACKSIZE (WORD*18 + 8*18 + CALLBACK_LINK_SIZE + RESERVED_STACK)
+  /* 18 callee-save GPR14...GPR31 + 18 callee-save FPR14...FPR31 */
+        Addrglobal(12, caml_program)
+/* Code shared between caml_start_program and caml_callback */
+.L102:
+    /* Allocate and link stack frame */
+        stgu    1, -STACKSIZE(1)
+        .cfi_adjust_cfa_offset STACKSIZE
+    /* Save return address */
+        mflr    0
+        stg     0, (STACKSIZE + LR_SAVE)(1)
+        .cfi_offset 65, LR_SAVE
+    /* Save TOC pointer if applicable */
+#ifdef TOC_SAVE_PARENT
+        std     2, (STACKSIZE + TOC_SAVE_PARENT)(1)
+#endif
+    /* Save all callee-save registers */
+        addi    11, 1, CALLBACK_LINK_SIZE + RESERVED_STACK - WORD
+        stgu    14, WORD(11)
+        stgu    15, WORD(11)
+        stgu    16, WORD(11)
+        stgu    17, WORD(11)
+        stgu    18, WORD(11)
+        stgu    19, WORD(11)
+        stgu    20, WORD(11)
+        stgu    21, WORD(11)
+        stgu    22, WORD(11)
+        stgu    23, WORD(11)
+        stgu    24, WORD(11)
+        stgu    25, WORD(11)
+        stgu    26, WORD(11)
+        stgu    27, WORD(11)
+        stgu    28, WORD(11)
+        stgu    29, WORD(11)
+        stgu    30, WORD(11)
+        stgu    31, WORD(11)
+        stfdu   14, 8(11)
+        stfdu   15, 8(11)
+        stfdu   16, 8(11)
+        stfdu   17, 8(11)
+        stfdu   18, 8(11)
+        stfdu   19, 8(11)
+        stfdu   20, 8(11)
+        stfdu   21, 8(11)
+        stfdu   22, 8(11)
+        stfdu   23, 8(11)
+        stfdu   24, 8(11)
+        stfdu   25, 8(11)
+        stfdu   26, 8(11)
+        stfdu   27, 8(11)
+        stfdu   28, 8(11)
+        stfdu   29, 8(11)
+        stfdu   30, 8(11)
+        stfdu   31, 8(11)
+    /* Set up a callback link */
+        Loadglobal(11, caml_bottom_of_stack, 11)
+        stg     11, CALLBACK_LINK_OFFSET(1)
+        Loadglobal(11, caml_last_return_address, 11)
+        stg     11, (CALLBACK_LINK_OFFSET + WORD)(1)
+        Loadglobal(11, caml_gc_regs, 11)
+        stg     11, (CALLBACK_LINK_OFFSET + 2 * WORD)(1)
+    /* Build an exception handler to catch exceptions escaping out of OCaml */
+        bl      .L103
+        b       .L104
+.L103:
+        addi    1, 1, -TRAP_SIZE
+        .cfi_adjust_cfa_offset TRAP_SIZE
+        mflr    0
+        stg     0, TRAP_HANDLER_OFFSET(1)
+        Loadglobal(11, caml_exception_pointer, 11)
+        stg     11, TRAP_PREVIOUS_OFFSET(1)
+        mr      29, 1
+    /* Reload allocation pointers */
+        Loadglobal(31, caml_young_ptr, 11)
+        Loadglobal(30, caml_young_limit, 11)
+    /* Call the OCaml code (address in r12) */
+#if defined(MODEL_ppc)
+        mtctr   12
+.L105:  bctrl
+#elif defined(MODEL_ppc64)
+        ld      0, 0(12)
+        mtctr   0
+        std     2, TOC_SAVE(1)
+        ld      2, 8(12)
+.L105:  bctrl
+        ld      2, TOC_SAVE(1)
+#elif defined(MODEL_ppc64le)
+        mtctr   12
+        std     2, TOC_SAVE(1)
+.L105:  bctrl
+        ld      2, TOC_SAVE(1)
+#else
+#error "wrong MODEL"
+#endif
+    /* Pop the trap frame, restoring caml_exception_pointer */
+        lg      0, TRAP_PREVIOUS_OFFSET(1)
+        Storeglobal(0, caml_exception_pointer, 11)
+        addi    1, 1, TRAP_SIZE
+        .cfi_adjust_cfa_offset -TRAP_SIZE
+    /* Pop the callback link, restoring the global variables */
+.L106:
+        lg      0, CALLBACK_LINK_OFFSET(1)
+        Storeglobal(0, caml_bottom_of_stack, 11)
+        lg      0, (CALLBACK_LINK_OFFSET + WORD)(1)
+        Storeglobal(0, caml_last_return_address, 11)
+        lg      0, (CALLBACK_LINK_OFFSET + 2 * WORD)(1)
+        Storeglobal(0, caml_gc_regs, 11)
+    /* Update allocation pointer */
+        Storeglobal(31, caml_young_ptr, 11)
+    /* Restore callee-save registers */
+        addi    11, 1, CALLBACK_LINK_SIZE + RESERVED_STACK - WORD
+        lgu     14, WORD(11)
+        lgu     15, WORD(11)
+        lgu     16, WORD(11)
+        lgu     17, WORD(11)
+        lgu     18, WORD(11)
+        lgu     19, WORD(11)
+        lgu     20, WORD(11)
+        lgu     21, WORD(11)
+        lgu     22, WORD(11)
+        lgu     23, WORD(11)
+        lgu     24, WORD(11)
+        lgu     25, WORD(11)
+        lgu     26, WORD(11)
+        lgu     27, WORD(11)
+        lgu     28, WORD(11)
+        lgu     29, WORD(11)
+        lgu     30, WORD(11)
+        lgu     31, WORD(11)
+        lfdu    14, 8(11)
+        lfdu    15, 8(11)
+        lfdu    16, 8(11)
+        lfdu    17, 8(11)
+        lfdu    18, 8(11)
+        lfdu    19, 8(11)
+        lfdu    20, 8(11)
+        lfdu    21, 8(11)
+        lfdu    22, 8(11)
+        lfdu    23, 8(11)
+        lfdu    24, 8(11)
+        lfdu    25, 8(11)
+        lfdu    26, 8(11)
+        lfdu    27, 8(11)
+        lfdu    28, 8(11)
+        lfdu    29, 8(11)
+        lfdu    30, 8(11)
+        lfdu    31, 8(11)
+    /* Reload return address */
+        lg      0, (STACKSIZE + LR_SAVE)(1)
+        mtlr    0
+    /* Return */
+        addi    1, 1, STACKSIZE
+        blr
+
+    /* The trap handler: */
+.L104:
+    /* Restore TOC pointer */
+#ifdef TOC_SAVE_PARENT
+        ld      2, (STACKSIZE + TOC_SAVE_PARENT)(1)
+#endif
+    /* Update caml_exception_pointer */
+        Storeglobal(29, caml_exception_pointer, 11)
+    /* Encode exception bucket as an exception result and return it */
+        ori     3, 3, 2
+        b       .L106
+#undef STACKSIZE
+        .cfi_endproc
+ENDFUNCTION(caml_start_program)
+
+/* Callback from C to OCaml */
+
+FUNCTION(caml_callback_exn)
+    /* Initial shuffling of arguments */
+        mr      0, 3            /* Closure */
+        mr      3, 4            /* Argument */
+        mr      4, 0
+        lg      12, 0(4)        /* Code pointer */
+        b       .L102
+ENDFUNCTION(caml_callback_exn)
+
+FUNCTION(caml_callback2_exn)
+        mr      0, 3            /* Closure */
+        mr      3, 4            /* First argument */
+        mr      4, 5            /* Second argument */
+        mr      5, 0
+        Addrglobal(12, caml_apply2)
+        b       .L102
+ENDFUNCTION(caml_callback2_exn)
+
+FUNCTION(caml_callback3_exn)
+        mr      0, 3            /* Closure */
+        mr      3, 4            /* First argument */
+        mr      4, 5            /* Second argument */
+        mr      5, 6            /* Third argument */
+        mr      6, 0
+        Addrglobal(12, caml_apply3)
+        b       .L102
+ENDFUNCTION(caml_callback3_exn)
+
+#if defined(MODEL_ppc64)
+        .section ".opd","aw"
+#else
+        .section ".text"
+#endif
+
+        .globl  caml_system__code_end
+caml_system__code_end:
+
+/* Frame table */
+
+        .section ".data"
+        .globl  caml_system__frametable
+        .type   caml_system__frametable, @object
+caml_system__frametable:
+        datag   1               /* one descriptor */
+        datag   .L105 + 4       /* return address into callback */
+        .short  -1              /* negative size count => use callback link */
+        .short  0               /* no roots here */
+
+/* TOC entries */
+
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+
+        .section ".toc", "aw"
+
+#define TOCENTRY(glob) LSYMB(glob): .quad glob
+
+TOCENTRY(caml_apply2)
+TOCENTRY(caml_apply3)
+TOCENTRY(caml_backtrace_active)
+TOCENTRY(caml_backtrace_pos)
+TOCENTRY(caml_bottom_of_stack)
+TOCENTRY(caml_exception_pointer)
+TOCENTRY(caml_gc_regs)
+TOCENTRY(caml_last_return_address)
+TOCENTRY(caml_program)
+TOCENTRY(caml_young_limit)
+TOCENTRY(caml_young_ptr)
+
+#endif
+
+/* Mark stack as non-executable */
+        .section .note.GNU-stack,"",%progbits
diff --git a/asmrun/roots.c b/asmrun/roots.c
new file mode 100644
index 00000000..6307fd09
--- /dev/null
+++ b/asmrun/roots.c
@@ -0,0 +1,521 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* To walk the memory roots for garbage collection */
+
+#include "caml/finalise.h"
+#include "caml/globroots.h"
+#include "caml/memory.h"
+#include "caml/major_gc.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/stack.h"
+#include "caml/roots.h"
+#include 
+#include 
+
+/* Roots registered from C functions */
+
+struct caml__roots_block *caml_local_roots = NULL;
+
+void (*caml_scan_roots_hook) (scanning_action) = NULL;
+
+/* The hashtable of frame descriptors */
+frame_descr ** caml_frame_descriptors = NULL;
+int caml_frame_descriptors_mask = 0;
+
+/* Linked-list */
+
+typedef struct link {
+  void *data;
+  struct link *next;
+} link;
+
+static link *cons(void *data, link *tl) {
+  link *lnk = caml_stat_alloc(sizeof(link));
+  lnk->data = data;
+  lnk->next = tl;
+  return lnk;
+}
+
+#define iter_list(list,lnk) \
+  for (lnk = list; lnk != NULL; lnk = lnk->next)
+
+/* Linked-list of frametables */
+
+static link *frametables = NULL;
+static intnat num_descr = 0;
+
+static int count_descriptors(link *list) {
+  intnat num_descr = 0;
+  link *lnk;
+  iter_list(list,lnk) {
+    num_descr += *((intnat*) lnk->data);
+  }
+  return num_descr;
+}
+
+static link* frametables_list_tail(link *list) {
+  link *lnk, *tail = NULL;
+  iter_list(list,lnk) {
+    tail = lnk;
+  }
+  return tail;
+}
+
+static frame_descr * next_frame_descr(frame_descr * d) {
+  uintnat nextd;
+  nextd =
+    ((uintnat)d +
+     sizeof(char *) + sizeof(short) + sizeof(short) +
+     sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
+    & -sizeof(frame_descr *);
+  if (d->frame_size & 1) nextd += sizeof(void *); /* pointer to debuginfo */
+  return((frame_descr *) nextd);
+}
+
+static void fill_hashtable(link *frametables) {
+  intnat len, j;
+  intnat * tbl;
+  frame_descr * d;
+  uintnat h;
+  link *lnk = NULL;
+
+  iter_list(frametables,lnk) {
+    tbl = (intnat*) lnk->data;
+    len = *tbl;
+    d = (frame_descr *)(tbl + 1);
+    for (j = 0; j < len; j++) {
+      h = Hash_retaddr(d->retaddr);
+      while (caml_frame_descriptors[h] != NULL) {
+        h = (h+1) & caml_frame_descriptors_mask;
+      }
+      caml_frame_descriptors[h] = d;
+      d = next_frame_descr(d);
+    }
+  }
+}
+
+static void init_frame_descriptors(link *new_frametables)
+{
+  intnat tblsize, increase, i;
+  link *tail = NULL;
+
+  Assert(new_frametables);
+
+  tail = frametables_list_tail(new_frametables);
+  increase = count_descriptors(new_frametables);
+  tblsize = caml_frame_descriptors_mask + 1;
+
+  /* Reallocate the caml_frame_descriptor table if it is too small */
+  if(tblsize < (num_descr + increase) * 2) {
+
+    /* Merge both lists */
+    tail->next = frametables;
+    frametables = NULL;
+
+    /* [num_descr] can be less than [num_descr + increase] if frame
+       tables where unregistered */
+    num_descr = count_descriptors(new_frametables);
+
+    tblsize = 4;
+    while (tblsize < 2 * num_descr) tblsize *= 2;
+
+    caml_frame_descriptors_mask = tblsize - 1;
+    if(caml_frame_descriptors) caml_stat_free(caml_frame_descriptors);
+    caml_frame_descriptors =
+      (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *));
+    for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL;
+
+    fill_hashtable(new_frametables);
+  } else {
+    num_descr += increase;
+    fill_hashtable(new_frametables);
+    tail->next = frametables;
+  }
+
+  frametables = new_frametables;
+}
+
+void caml_init_frame_descriptors(void) {
+  intnat i;
+  link *new_frametables = NULL;
+  for (i = 0; caml_frametable[i] != 0; i++)
+    new_frametables = cons(caml_frametable[i],new_frametables);
+  init_frame_descriptors(new_frametables);
+}
+
+void caml_register_frametable(intnat *table) {
+  link *new_frametables = cons(table,NULL);
+  init_frame_descriptors(new_frametables);
+}
+
+static void remove_entry(frame_descr * d) {
+  uintnat i;
+  uintnat r;
+  uintnat j;
+
+  i = Hash_retaddr(d->retaddr);
+  while (caml_frame_descriptors[i] != d) {
+    i = (i+1) & caml_frame_descriptors_mask;
+  }
+
+ r1:
+  j = i;
+  caml_frame_descriptors[i] = NULL;
+ r2:
+  i = (i+1) & caml_frame_descriptors_mask;
+  // r3
+  if(caml_frame_descriptors[i] == NULL) return;
+  r = Hash_retaddr(caml_frame_descriptors[i]->retaddr);
+  /* If r is between i and j (cyclically), i.e. if
+     caml_frame_descriptors[i]->retaddr don't need to be moved */
+  if(( ( j < r )  && ( r <= i ) ) ||
+     ( ( i < j )  && ( j < r )  ) ||      /* i cycled, r not */
+     ( ( r <= i ) && ( i < j ) )     ) {  /* i and r cycled */
+    goto r2;
+  }
+  // r4
+  caml_frame_descriptors[j] = caml_frame_descriptors[i];
+  goto r1;
+}
+
+void caml_unregister_frametable(intnat *table) {
+  intnat len, j;
+  link *lnk;
+  link *previous = frametables;
+  frame_descr * d;
+
+  len = *table;
+  d = (frame_descr *)(table + 1);
+  for (j = 0; j < len; j++) {
+    remove_entry(d);
+    d = next_frame_descr(d);
+  }
+
+  iter_list(frametables,lnk) {
+    if(lnk->data == table) {
+      previous->next = lnk->next;
+      caml_stat_free(lnk);
+      break;
+    }
+    previous = lnk;
+  }
+}
+
+/* Communication with [caml_start_program] and [caml_call_gc]. */
+
+char * caml_top_of_stack;
+char * caml_bottom_of_stack = NULL; /* no stack initially */
+uintnat caml_last_return_address = 1; /* not in OCaml code initially */
+value * caml_gc_regs;
+intnat caml_globals_inited = 0;
+static intnat caml_globals_scanned = 0;
+static link * caml_dyn_globals = NULL;
+
+void caml_register_dyn_global(void *v) {
+  caml_dyn_globals = cons((void*) v,caml_dyn_globals);
+}
+
+/* Call [caml_oldify_one] on (at least) all the roots that point to the minor
+   heap. */
+void caml_oldify_local_roots (void)
+{
+  char * sp;
+  uintnat retaddr;
+  value * regs;
+  frame_descr * d;
+  uintnat h;
+  int i, j, n, ofs;
+#ifdef Stack_grows_upwards
+  short * p;  /* PR#4339: stack offsets are negative in this case */
+#else
+  unsigned short * p;
+#endif
+  value * glob;
+  value * root;
+  struct caml__roots_block *lr;
+  link *lnk;
+
+  /* The global roots */
+  for (i = caml_globals_scanned;
+       i <= caml_globals_inited && caml_globals[i] != 0;
+       i++) {
+    for(glob = caml_globals[i]; *glob != 0; glob++) {
+      for (j = 0; j < Wosize_val(*glob); j++){
+        Oldify (&Field (*glob, j));
+      }
+    }
+  }
+  caml_globals_scanned = caml_globals_inited;
+
+  /* Dynamic global roots */
+  iter_list(caml_dyn_globals, lnk) {
+    for(glob = (value *) lnk->data; *glob != 0; glob++) {
+      for (j = 0; j < Wosize_val(*glob); j++){
+        Oldify (&Field (*glob, j));
+      }
+    }
+  }
+
+  /* The stack and local roots */
+  sp = caml_bottom_of_stack;
+  retaddr = caml_last_return_address;
+  regs = caml_gc_regs;
+  if (sp != NULL) {
+    while (1) {
+      /* Find the descriptor corresponding to the return address */
+      h = Hash_retaddr(retaddr);
+      while(1) {
+        d = caml_frame_descriptors[h];
+        if (d->retaddr == retaddr) break;
+        h = (h+1) & caml_frame_descriptors_mask;
+      }
+      if (d->frame_size != 0xFFFF) {
+        /* Scan the roots in this frame */
+        for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
+          ofs = *p;
+          if (ofs & 1) {
+            root = regs + (ofs >> 1);
+          } else {
+            root = (value *)(sp + ofs);
+          }
+          Oldify (root);
+        }
+        /* Move to next frame */
+#ifndef Stack_grows_upwards
+        sp += (d->frame_size & 0xFFFC);
+#else
+        sp -= (d->frame_size & 0xFFFC);
+#endif
+        retaddr = Saved_return_address(sp);
+#ifdef Already_scanned
+        /* Stop here if the frame has been scanned during earlier GCs  */
+        if (Already_scanned(sp, retaddr)) break;
+        /* Mark frame as already scanned */
+        Mark_scanned(sp, retaddr);
+#endif
+      } else {
+        /* This marks the top of a stack chunk for an ML callback.
+           Skip C portion of stack and continue with next ML stack chunk. */
+        struct caml_context * next_context = Callback_link(sp);
+        sp = next_context->bottom_of_stack;
+        retaddr = next_context->last_retaddr;
+        regs = next_context->gc_regs;
+        /* A null sp means no more ML stack chunks; stop here. */
+        if (sp == NULL) break;
+      }
+    }
+  }
+  /* Local C roots */
+  for (lr = 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]);
+        Oldify (root);
+      }
+    }
+  }
+  /* Global C roots */
+  caml_scan_global_young_roots(&caml_oldify_one);
+  /* Finalised values */
+  caml_final_oldify_young_roots ();
+  /* Hook */
+  if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
+}
+
+uintnat caml_incremental_roots_count = 0;
+
+/* Call [caml_darken] on all roots, incrementally:
+   [caml_darken_all_roots_start] does the non-incremental part and
+   sets things up for [caml_darken_all_roots_slice].
+*/
+void caml_darken_all_roots_start (void)
+{
+  caml_do_roots (caml_darken, 0);
+}
+
+/* Call [caml_darken] on at most [work] global roots. Return the
+   amount of work not done, if any. If this is strictly positive,
+   the darkening is done.
+ */
+intnat caml_darken_all_roots_slice (intnat work)
+{
+  static int i, j;
+  static value *glob;
+  static int do_resume = 0;
+  static mlsize_t roots_count = 0;
+  intnat remaining_work = work;
+  CAML_INSTR_SETUP (tmr, "");
+
+  /* If the loop was started in a previous call, resume it. */
+  if (do_resume) goto resume;
+
+  /* This is the same loop as in [caml_do_roots], but we make it
+     suspend itself when [work] reaches 0. */
+  for (i = 0; caml_globals[i] != 0; i++) {
+    for(glob = caml_globals[i]; *glob != 0; glob++) {
+      for (j = 0; j < Wosize_val(*glob); j++){
+        caml_darken (Field (*glob, j), &Field (*glob, j));
+        -- remaining_work;
+        if (remaining_work == 0){
+          roots_count += work;
+          do_resume = 1;
+          goto suspend;
+        }
+      resume: ;
+      }
+    }
+  }
+
+  /* The loop finished normally, so all roots are now darkened. */
+  caml_incremental_roots_count = roots_count + work - remaining_work;
+  /* Prepare for the next run. */
+  do_resume = 0;
+  roots_count = 0;
+
+ suspend:
+  /* Do this in both cases. */
+  CAML_INSTR_TIME (tmr, "major/mark/global_roots_slice");
+  return remaining_work;
+}
+
+void caml_do_roots (scanning_action f, int do_globals)
+{
+  int i, j;
+  value * glob;
+  link *lnk;
+  CAML_INSTR_SETUP (tmr, "major_roots");
+
+  if (do_globals){
+    /* The global roots */
+    for (i = 0; caml_globals[i] != 0; i++) {
+      for(glob = caml_globals[i]; *glob != 0; glob++) {
+        for (j = 0; j < Wosize_val(*glob); j++)
+          f (Field (*glob, j), &Field (*glob, j));
+      }
+    }
+  }
+  /* Dynamic global roots */
+  iter_list(caml_dyn_globals, lnk) {
+    for(glob = (value *) lnk->data; *glob != 0; glob++) {
+      for (j = 0; j < Wosize_val(*glob); j++){
+        f (Field (*glob, j), &Field (*glob, j));
+      }
+    }
+  }
+  CAML_INSTR_TIME (tmr, "major_roots/dynamic_global");
+  /* The stack and local roots */
+  caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address,
+                      caml_gc_regs, caml_local_roots);
+  CAML_INSTR_TIME (tmr, "major_roots/local");
+  /* Global C roots */
+  caml_scan_global_roots(f);
+  CAML_INSTR_TIME (tmr, "major_roots/C");
+  /* Finalised values */
+  caml_final_do_roots (f);
+  CAML_INSTR_TIME (tmr, "major_roots/finalised");
+  /* Hook */
+  if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);
+  CAML_INSTR_TIME (tmr, "major_roots/hook");
+}
+
+void caml_do_local_roots(scanning_action f, char * bottom_of_stack,
+                         uintnat last_retaddr, value * gc_regs,
+                         struct caml__roots_block * local_roots)
+{
+  char * sp;
+  uintnat retaddr;
+  value * regs;
+  frame_descr * d;
+  uintnat h;
+  int i, j, n, ofs;
+#ifdef Stack_grows_upwards
+  short * p;  /* PR#4339: stack offsets are negative in this case */
+#else
+  unsigned short * p;
+#endif
+  value * root;
+  struct caml__roots_block *lr;
+
+  sp = bottom_of_stack;
+  retaddr = last_retaddr;
+  regs = gc_regs;
+  if (sp != NULL) {
+    while (1) {
+      /* Find the descriptor corresponding to the return address */
+      h = Hash_retaddr(retaddr);
+      while(1) {
+        d = caml_frame_descriptors[h];
+        if (d->retaddr == retaddr) break;
+        h = (h+1) & caml_frame_descriptors_mask;
+      }
+      if (d->frame_size != 0xFFFF) {
+        /* Scan the roots in this frame */
+        for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
+          ofs = *p;
+          if (ofs & 1) {
+            root = regs + (ofs >> 1);
+          } else {
+            root = (value *)(sp + ofs);
+          }
+          f (*root, root);
+        }
+        /* Move to next frame */
+#ifndef Stack_grows_upwards
+        sp += (d->frame_size & 0xFFFC);
+#else
+        sp -= (d->frame_size & 0xFFFC);
+#endif
+        retaddr = Saved_return_address(sp);
+#ifdef Mask_already_scanned
+        retaddr = Mask_already_scanned(retaddr);
+#endif
+      } else {
+        /* This marks the top of a stack chunk for an ML callback.
+           Skip C portion of stack and continue with next ML stack chunk. */
+        struct caml_context * next_context = Callback_link(sp);
+        sp = next_context->bottom_of_stack;
+        retaddr = next_context->last_retaddr;
+        regs = next_context->gc_regs;
+        /* A null sp means no more ML stack chunks; stop here. */
+        if (sp == NULL) break;
+      }
+    }
+  }
+  /* Local C roots */
+  for (lr = local_roots; lr != NULL; lr = lr->next) {
+    for (i = 0; i < lr->ntables; i++){
+      for (j = 0; j < lr->nitems; j++){
+        root = &(lr->tables[i][j]);
+        f (*root, root);
+      }
+    }
+  }
+}
+
+uintnat (*caml_stack_usage_hook)(void) = NULL;
+
+uintnat caml_stack_usage (void)
+{
+  uintnat sz;
+  sz = (value *) caml_top_of_stack - (value *) caml_bottom_of_stack;
+  if (caml_stack_usage_hook != NULL)
+    sz += (*caml_stack_usage_hook)();
+  return sz;
+}
diff --git a/asmrun/s390x.S b/asmrun/s390x.S
new file mode 100644
index 00000000..0af41994
--- /dev/null
+++ b/asmrun/s390x.S
@@ -0,0 +1,340 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Xavier Leroy, projet Gallium, INRIA Rocquencourt            */
+/*                          Bill O'Farrell, IBM                           */
+/*                                                                        */
+/*   Copyright 2015 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*   Copyright 2015 IBM (Bill O'Farrell with help from Tristan Amini).    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+#define Addrglobal(reg,glob) \
+        larl    reg, glob
+#define Loadglobal(reg,glob) \
+        lgrl    reg, glob
+#define Storeglobal(reg,glob) \
+        stgrl   reg, glob
+#define Loadglobal32(reg,glob) \
+        lgfrl   reg, glob
+#define Storeglobal32(reg,glob) \
+        strl   reg, glob
+
+
+        .section ".text"
+
+/* Invoke the garbage collector. */
+
+        .globl  caml_system__code_begin
+caml_system__code_begin:
+
+        .globl  caml_call_gc
+        .type   caml_call_gc, @function
+caml_call_gc:
+    /* Set up stack frame */
+#define FRAMESIZE (16*8 + 16*8)
+        lay     %r15, -FRAMESIZE(%r15)
+    /* Record return address into OCaml code */
+        Storeglobal(%r14, caml_last_return_address)
+    /* Record lowest stack address */
+        lay     %r0, FRAMESIZE(%r15)
+        Storeglobal(%r0, caml_bottom_of_stack)
+    /* Record pointer to register array */
+        lay     %r0, (8*16)(%r15)
+        Storeglobal(%r0, caml_gc_regs)
+    /* Save current allocation pointer for debugging purposes */
+        Storeglobal(%r11, caml_young_ptr)
+    /* Save exception pointer (if e.g. a sighandler raises) */
+        Storeglobal(%r13, caml_exception_pointer)
+    /* Save all registers used by the code generator */
+        stmg    %r2,%r9, (8*16)(%r15)
+        stg     %r12, (8*16 + 8*8)(%r15)
+        std     %f0, 0(%r15)
+        std     %f1, 8(%r15)
+        std     %f2, 16(%r15)
+        std     %f3, 24(%r15)
+        std     %f4, 32(%r15)
+        std     %f5, 40(%r15)
+        std     %f6, 48(%r15)
+        std     %f7, 56(%r15)
+        std     %f8, 64(%r15)
+        std     %f9, 72(%r15)
+        std     %f10, 80(%r15)
+        std     %f11, 88(%r15)
+        std     %f12, 96(%r15)
+        std     %f13, 108(%r15)
+        std     %f14, 112(%r15)
+        std     %f15, 120(%r15)
+    /* Call the GC */
+        lay %r15, -160(%r15)
+        stg     %r15, 0(%r15)
+        brasl   %r14, caml_garbage_collection@PLT
+        lay %r15, 160(%r15)
+    /* Reload new allocation pointer and allocation limit */
+        Loadglobal(%r11, caml_young_ptr)
+        Loadglobal(%r10, caml_young_limit)
+    /* Restore all regs used by the code generator */
+        lmg     %r2,%r9, (8*16)(%r15)
+        lg      %r12, (8*16 + 8*8)(%r15)
+        ld      %f0, 0(%r15)
+        ld      %f1, 8(%r15)
+        ld      %f2, 16(%r15)
+        ld      %f3, 24(%r15)
+        ld      %f4, 32(%r15)
+        ld      %f5, 40(%r15)
+        ld      %f6, 48(%r15)
+        ld      %f7, 56(%r15)
+        ld      %f8, 64(%r15)
+        ld      %f9, 72(%r15)
+        ld      %f10, 80(%r15)
+        ld      %f11, 88(%r15)
+        ld      %f12, 96(%r15)
+        ld      %f13, 108(%r15)
+        ld      %f14, 112(%r15)
+        ld      %f15, 120(%r15)
+    /* Return to caller */
+        Loadglobal(%r1, caml_last_return_address)
+    /* Deallocate stack frame */
+        lay     %r15, FRAMESIZE(%r15)
+    /* Return */
+        br    %r1
+
+/* Call a C function from OCaml */
+
+        .globl  caml_c_call
+        .type   caml_c_call, @function
+caml_c_call:
+        Storeglobal(%r15, caml_bottom_of_stack)
+.L101:
+    /* Save return address */
+        ldgr    %f15, %r14
+    /* Get ready to call C function (address in r7) */
+    /* Record lowest stack address and return address */
+        Storeglobal(%r14, caml_last_return_address)
+    /* Make the exception handler and alloc ptr available to the C code */
+        Storeglobal(%r11, caml_young_ptr)
+        Storeglobal(%r13, caml_exception_pointer)
+    /* Call the function */
+        basr %r14, %r7
+    /* restore return address */
+        lgdr    %r14,%f15
+    /* Reload allocation pointer and allocation limit*/
+        Loadglobal(%r11, caml_young_ptr)
+        Loadglobal(%r10, caml_young_limit)
+    /* Return to caller */
+        br %r14
+
+/* Raise an exception from OCaml */
+        .globl  caml_raise_exn
+        .type   caml_raise_exn, @function
+caml_raise_exn:
+        Loadglobal32(%r0, caml_backtrace_active)
+        cgfi    %r0, 0
+        jne     .L110
+.L111:
+    /* Pop trap frame */
+        lg      %r1, 0(%r13)
+        lgr     %r15, %r13
+        lg     %r13, 8(13)
+        agfi   %r15, 16
+    /* Branch to handler */
+        br      %r1
+.L110:
+        ldgr    %f15, %r2       /* preserve exn bucket in callee-save reg */
+                                /* arg1: exception bucket, already in r3 */
+        lgr     %r3,%r14        /* arg2: PC of raise */
+        lgr     %r4, %r15       /* arg3: SP of raise */
+        lgr     %r5, %r13           /* arg4: SP of handler */
+        agfi    %r15, -160       /* reserve stack space for C call */
+        brasl   %r14, caml_stash_backtrace@PLT
+        agfi    %r15, 160
+        lgdr    %r2,%f15        /* restore exn bucket */
+        j       .L111           /* raise the exn */
+
+/* Raise an exception from C */
+
+        .globl  caml_raise_exception
+        .type   caml_raise_exception, @function
+caml_raise_exception:
+        Loadglobal32(%r0, caml_backtrace_active)
+        cgfi    %r0, 0
+        jne    .L112
+.L113:
+    /* Reload OCaml global registers */
+        Loadglobal(%r15, caml_exception_pointer)
+        Loadglobal(%r11, caml_young_ptr)
+        Loadglobal(%r10, caml_young_limit)
+    /* Pop trap frame */
+        lg      %r1, 0(%r15)
+        lg      %r13, 8(%r15)
+        agfi    %r15, 16
+    /* Branch to handler */
+        br      %r1;
+.L112:
+        lgfi      %r0, 0
+        Storeglobal32(%r0, caml_backtrace_pos)
+        ldgr    %f15,%r2        /* preserve exn bucket in callee-save reg */
+                                /* arg1: exception bucket, already in r2 */
+        Loadglobal(%r3, caml_last_return_address) /* arg2: PC of raise */
+        Loadglobal(%r4, caml_bottom_of_stack)     /* arg3: SP of raise */
+        Loadglobal(%r5, caml_exception_pointer)   /* arg4: SP of handler */
+             /* reserve stack space for C call */
+        lay %r15, -160(%r15)
+        brasl   %r14, caml_stash_backtrace@PLT
+        lay %r15, 160(%r15)
+        lgdr    %r2,%f15        /* restore exn bucket */
+        j       .L113           /* raise the exn */
+
+/* Start the OCaml program */
+
+        .globl  caml_start_program
+        .type   caml_start_program, @function
+caml_start_program:
+        Addrglobal(%r0, caml_program)
+
+/* Code shared between caml_start_program and caml_callback */
+.L102:
+    /* Allocate stack frame */
+        lay     %r15, -144(%r15)
+    /* Save all callee-save registers + return address */
+    /* GPR 6..14 at sp + 0 ... sp + 64
+       FPR 10..15 at sp + 72 ... sp + 128 */
+        stmg    %r6,%r14, 0(%r15)
+        std     %f8, 72(%r15)
+        std     %f9, 80(%r15)
+        std     %f10, 88(%r15)
+        std     %f11, 96(%r15)
+        std     %f12, 104(%r15)
+        std     %f13, 112(%r15)
+        std     %f14, 120(%r15)
+        std     %f15, 128(%r15)
+
+    /* Set up a callback link */
+        lay     %r15, -32(%r15)
+        Loadglobal(%r1, caml_bottom_of_stack)
+        stg     %r1, 0(%r15)
+        Loadglobal(%r1, caml_last_return_address)
+        stg     %r1, 8(%r15)
+        Loadglobal(%r1, caml_gc_regs)
+        stg     %r1, 16(%r15)
+    /* Build an exception handler to catch exceptions escaping out of OCaml */
+        brasl   %r14, .L103
+        j       .L104
+.L103:
+        lay     %r15, -16(%r15)
+        stg     %r14, 0(%r15)
+        Loadglobal(%r1, caml_exception_pointer)
+        stg     %r1, 8(%r15)
+        lgr     %r13, %r15
+    /* Reload allocation pointers */
+        Loadglobal(%r11, caml_young_ptr)
+        Loadglobal(%r10, caml_young_limit)
+    /* Call the OCaml code */
+        lgr %r1,%r0
+        basr %r14, %r1
+.L105:
+    /* Pop the trap frame, restoring caml_exception_pointer */
+        lg     %r0, 8(%r15)
+        Storeglobal(%r0, caml_exception_pointer)
+        la      %r15, 16(%r15)
+    /* Pop the callback link, restoring the global variables */
+.L106:
+        lg      %r5, 0(%r15)
+        lg      %r6, 8(%r15)
+        lg      %r1, 16(%r15)
+        Storeglobal(%r5, caml_bottom_of_stack)
+        Storeglobal(%r6, caml_last_return_address)
+        Storeglobal(%r1, caml_gc_regs)
+        la      %r15, 32(%r15)
+
+    /* Update allocation pointer */
+        Storeglobal(%r11, caml_young_ptr)
+
+        /* Restore registers */
+        lmg    %r6,%r14, 0(%r15)
+        ld     %f8, 72(%r15)
+        ld     %f9, 80(%r15)
+        ld     %f10, 88(%r15)
+        ld     %f11, 96(%r15)
+        ld     %f12, 104(%r15)
+        ld     %f13, 112(%r15)
+        ld     %f14, 120(%r15)
+        ld     %f15, 128(%r15)
+
+    /* Return */
+        lay     %r15, 144(%r15)
+        br      %r14
+
+    /* The trap handler: */
+.L104:
+    /* Update caml_exception_pointer */
+        Storeglobal(%r13, caml_exception_pointer)
+    /* Encode exception bucket as an exception result and return it */
+        oill     %r2,  2
+        j       .L106
+
+/* Callback from C to OCaml */
+
+        .globl  caml_callback_exn
+        .type   caml_callback_exn, @function
+caml_callback_exn:
+    /* Initial shuffling of arguments */
+        lgr     %r0, %r2            /* Closure */
+        lgr     %r2, %r3            /* Argument */
+        lgr     %r3, %r0
+        lg      %r0, 0(%r3)        /* Code pointer */
+        j       .L102
+
+        .globl  caml_callback2_exn
+        .type   caml_callback2_exn, @function
+caml_callback2_exn:
+        lgr      %r0, %r2            /* Closure */
+        lgr      %r2, %r3            /* First argument */
+        lgr      %r3, %r4            /* Second argument */
+        lgr      %r4, %r0
+        Addrglobal(%r0, caml_apply2)
+        j       .L102
+
+        .globl  caml_callback3_exn
+        .type   caml_callback3_exn, @function
+caml_callback3_exn:
+        lgr      %r0, %r2            /* Closure */
+        lgr      %r2, %r3            /* First argument */
+        lgr      %r3, %r4            /* Second argument */
+        lgr      %r4, %r5            /* Third argument */
+        lgr      %r5, %r0
+        Addrglobal(%r0, caml_apply3)
+        j        .L102
+
+        .globl  caml_ml_array_bound_error
+        .type   caml_ml_array_bound_error, @function
+caml_ml_array_bound_error:
+        /* Save return address before decrementing SP, otherwise
+           the frame descriptor for the call site is not correct */
+        Storeglobal(%r15, caml_bottom_of_stack)
+        lay     %r15, -160(%r15)    /* Reserve stack space for C call */
+        larl    %r7, caml_array_bound_error
+        j       .L101
+        .globl  caml_system__code_end
+caml_system__code_end:
+
+/* Frame table */
+
+        .section ".data"
+        .align 8
+        .globl  caml_system__frametable
+        .type   caml_system__frametable, @object
+caml_system__frametable:
+        .quad   1               /* one descriptor */
+        .quad   .L105           /* return address into callback */
+        .short  -1              /* negative size count => use callback link */
+        .short  0               /* no roots here */
+        .align  8
+
+/* Mark stack as non-executable */
+        .section .note.GNU-stack,"",%progbits
diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c
new file mode 100644
index 00000000..f124a076
--- /dev/null
+++ b/asmrun/signals_asm.c
@@ -0,0 +1,311 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2007 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Signal handling, code specific to the native-code compiler */
+
+#if defined(TARGET_amd64) && defined (SYS_linux)
+#define _GNU_SOURCE
+#endif
+#include 
+#include 
+#include 
+#include "caml/fail.h"
+#include "caml/memory.h"
+#include "caml/osdeps.h"
+#include "caml/signals.h"
+#include "caml/signals_machdep.h"
+#include "signals_osdep.h"
+#include "caml/stack.h"
+#include "caml/spacetime.h"
+
+#ifdef HAS_STACK_OVERFLOW_DETECTION
+#include 
+#include 
+#endif
+
+#ifndef NSIG
+#define NSIG 64
+#endif
+
+typedef void (*signal_handler)(int signo);
+
+#ifdef _WIN32
+extern signal_handler caml_win32_signal(int sig, signal_handler action);
+#define signal(sig,act) caml_win32_signal(sig,act)
+extern void caml_win32_overflow_detection();
+#endif
+
+extern char * caml_code_area_start, * caml_code_area_end;
+extern char caml_system__code_begin, caml_system__code_end;
+
+/* Do not use the macro from address_class.h here. */
+#undef Is_in_code_area
+#define Is_in_code_area(pc) \
+ ( ((char *)(pc) >= caml_code_area_start && \
+    (char *)(pc) <= caml_code_area_end)     \
+|| ((char *)(pc) >= &caml_system__code_begin && \
+    (char *)(pc) <= &caml_system__code_end)     \
+|| (Classify_addr(pc) & In_code_area) )
+
+/* This routine is the common entry point for garbage collection
+   and signal handling.  It can trigger a callback to OCaml code.
+   With system threads, this callback can cause a context switch.
+   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 [caml_garbage_collection],
+   via the caml_call_gc assembly stubs.  */
+
+void caml_garbage_collection(void)
+{
+  caml_young_limit = caml_young_trigger;
+  if (caml_requested_major_slice || caml_requested_minor_gc ||
+      caml_young_ptr - caml_young_trigger < Max_young_whsize){
+    caml_gc_dispatch ();
+  }
+
+#ifdef WITH_SPACETIME
+  if (caml_young_ptr == caml_young_alloc_end) {
+    caml_spacetime_automatic_snapshot();
+  }
+#endif
+
+  caml_process_pending_signals();
+}
+
+DECLARE_SIGNAL_HANDLER(handle_signal)
+{
+  int saved_errno;
+  /* Save the value of errno (PR#5982). */
+  saved_errno = errno;
+#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
+  signal(sig, handle_signal);
+#endif
+  if (sig < 0 || sig >= NSIG) return;
+  if (caml_try_leave_blocking_section_hook ()) {
+    caml_execute_signal(sig, 1);
+    caml_enter_blocking_section_hook();
+  } else {
+    caml_record_signal(sig);
+  /* Some ports cache [caml_young_limit] in a register.
+     Use the signal context to modify that register too, but only if
+     we are inside OCaml code (not inside C code). */
+#if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT)
+    if (Is_in_code_area(CONTEXT_PC))
+      CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit;
+#endif
+  }
+  errno = saved_errno;
+}
+
+int caml_set_signal_action(int signo, int action)
+{
+  signal_handler oldact;
+#ifdef POSIX_SIGNALS
+  struct sigaction sigact, oldsigact;
+#else
+  signal_handler act;
+#endif
+
+#ifdef POSIX_SIGNALS
+  switch(action) {
+  case 0:
+    sigact.sa_handler = SIG_DFL;
+    sigact.sa_flags = 0;
+    break;
+  case 1:
+    sigact.sa_handler = SIG_IGN;
+    sigact.sa_flags = 0;
+    break;
+  default:
+    SET_SIGACT(sigact, handle_signal);
+    break;
+  }
+  sigemptyset(&sigact.sa_mask);
+  if (sigaction(signo, &sigact, &oldsigact) == -1) return -1;
+  oldact = oldsigact.sa_handler;
+#else
+  switch(action) {
+  case 0:  act = SIG_DFL; break;
+  case 1:  act = SIG_IGN; break;
+  default: act = handle_signal; break;
+  }
+  oldact = signal(signo, act);
+  if (oldact == SIG_ERR) return -1;
+#endif
+  if (oldact == (signal_handler) handle_signal)
+    return 2;
+  else if (oldact == SIG_IGN)
+    return 1;
+  else
+    return 0;
+}
+
+/* Machine- and OS-dependent handling of bound check trap */
+
+#if defined(TARGET_power) \
+  || defined(TARGET_s390x) \
+  || (defined(TARGET_sparc) && defined(SYS_solaris))
+DECLARE_SIGNAL_HANDLER(trap_handler)
+{
+#if defined(SYS_solaris)
+  if (info->si_code != ILL_ILLTRP) {
+    /* Deactivate our exception handler and return. */
+    struct sigaction act;
+    act.sa_handler = SIG_DFL;
+    act.sa_flags = 0;
+    sigemptyset(&act.sa_mask);
+    sigaction(sig, &act, NULL);
+    return;
+  }
+#endif
+#if defined(SYS_rhapsody)
+  /* Unblock SIGTRAP */
+  { sigset_t mask;
+    sigemptyset(&mask);
+    sigaddset(&mask, SIGTRAP);
+    sigprocmask(SIG_UNBLOCK, &mask, NULL);
+  }
+#endif
+  caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
+  caml_young_ptr = (value *) CONTEXT_YOUNG_PTR;
+  caml_bottom_of_stack = (char *) CONTEXT_SP;
+  caml_last_return_address = (uintnat) CONTEXT_PC;
+  caml_array_bound_error();
+}
+#endif
+
+/* Machine- and OS-dependent handling of stack overflow */
+
+#ifdef HAS_STACK_OVERFLOW_DETECTION
+
+static char * system_stack_top;
+static char sig_alt_stack[SIGSTKSZ];
+
+#if defined(SYS_linux)
+/* PR#4746: recent Linux kernels with support for stack randomization
+   silently add 2 Mb of stack space on top of RLIMIT_STACK.
+   2 Mb = 0x200000, to which we add 8 kB (=0x2000) for overshoot. */
+#define EXTRA_STACK 0x202000
+#else
+#define EXTRA_STACK 0x2000
+#endif
+
+#ifdef RETURN_AFTER_STACK_OVERFLOW
+extern void caml_stack_overflow(void);
+#endif
+
+DECLARE_SIGNAL_HANDLER(segv_handler)
+{
+  struct rlimit limit;
+  struct sigaction act;
+  char * fault_addr;
+
+  /* Sanity checks:
+     - faulting address is word-aligned
+     - faulting address is within the stack
+     - we are in OCaml code */
+  fault_addr = CONTEXT_FAULTING_ADDRESS;
+  if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0
+      && getrlimit(RLIMIT_STACK, &limit) == 0
+      && fault_addr < system_stack_top
+      && fault_addr >= system_stack_top - limit.rlim_cur - EXTRA_STACK
+#ifdef CONTEXT_PC
+      && Is_in_code_area(CONTEXT_PC)
+#endif
+      ) {
+#ifdef RETURN_AFTER_STACK_OVERFLOW
+    /* Tweak the PC part of the context so that on return from this
+       handler, we jump to the asm function [caml_stack_overflow]
+       (from $ARCH.S). */
+#ifdef CONTEXT_PC
+    CONTEXT_PC = (context_reg) &caml_stack_overflow;
+#else
+#error "CONTEXT_PC must be defined if RETURN_AFTER_STACK_OVERFLOW is"
+#endif
+#else
+    /* Raise a Stack_overflow exception straight from this signal handler */
+#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER)
+    caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
+    caml_young_ptr = (value *) CONTEXT_YOUNG_PTR;
+#endif
+    caml_raise_stack_overflow();
+#endif
+  } else {
+    /* Otherwise, deactivate our exception handler and return,
+       causing fatal signal to be generated at point of error. */
+    act.sa_handler = SIG_DFL;
+    act.sa_flags = 0;
+    sigemptyset(&act.sa_mask);
+    sigaction(SIGSEGV, &act, NULL);
+  }
+}
+
+#endif
+
+/* Initialization of signal stuff */
+
+void caml_init_signals(void)
+{
+  /* Bound-check trap handling */
+#if defined(TARGET_sparc) && defined(SYS_solaris)
+  { struct sigaction act;
+    sigemptyset(&act.sa_mask);
+    SET_SIGACT(act, trap_handler);
+    act.sa_flags |= SA_NODEFER;
+    sigaction(SIGILL, &act, NULL);
+  }
+#endif
+
+#if defined(TARGET_power)
+  { struct sigaction act;
+    sigemptyset(&act.sa_mask);
+    SET_SIGACT(act, trap_handler);
+#if !defined(SYS_rhapsody)
+    act.sa_flags |= SA_NODEFER;
+#endif
+    sigaction(SIGTRAP, &act, NULL);
+  }
+#endif
+
+#if defined(TARGET_s390x)
+  { struct sigaction act;
+    sigemptyset(&act.sa_mask);
+    SET_SIGACT(act, trap_handler);
+    sigaction(SIGFPE, &act, NULL);
+  }
+#endif
+
+  /* Stack overflow handling */
+#ifdef HAS_STACK_OVERFLOW_DETECTION
+  {
+    stack_t stk;
+    struct sigaction act;
+    stk.ss_sp = sig_alt_stack;
+    stk.ss_size = SIGSTKSZ;
+    stk.ss_flags = 0;
+    SET_SIGACT(act, segv_handler);
+    act.sa_flags |= SA_ONSTACK | SA_NODEFER;
+    sigemptyset(&act.sa_mask);
+    system_stack_top = (char *) &act;
+    if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); }
+  }
+#endif
+#if defined(_WIN32) && !defined(_WIN64)
+  caml_win32_overflow_detection();
+#endif
+}
diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h
new file mode 100644
index 00000000..03196167
--- /dev/null
+++ b/asmrun/signals_osdep.h
@@ -0,0 +1,376 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Processor- and OS-dependent signal interface */
+
+/****************** AMD64, Linux */
+
+#if defined(TARGET_amd64) && defined (SYS_linux)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+     sigact.sa_flags = SA_SIGINFO
+
+  typedef greg_t context_reg;
+  #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
+  #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
+  #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
+  #define CONTEXT_FAULTING_ADDRESS ((char *)context->uc_mcontext.gregs[REG_CR2])
+
+/****************** AMD64, MacOSX */
+
+#elif defined(TARGET_amd64) && defined (SYS_macosx)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, void * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (name); \
+     sigact.sa_flags = SA_SIGINFO | SA_64REGSET
+
+  #include 
+  #include 
+
+  #if !defined(MAC_OS_X_VERSION_10_5) \
+      || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
+    #define CONTEXT_REG(r) r
+  #else
+    #define CONTEXT_REG(r) __##r
+  #endif
+
+  typedef unsigned long long context_reg;
+  #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss))
+  #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(rip))
+  #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r14))
+  #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r15))
+  #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp))
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+  #define RETURN_AFTER_STACK_OVERFLOW
+
+/****************** ARM, Linux */
+
+#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) \
+      || defined(SYS_linux_eabihf))
+
+  #include 
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+     sigact.sa_flags = SA_SIGINFO
+
+  typedef unsigned long context_reg;
+  #define CONTEXT_PC (context->uc_mcontext.arm_pc)
+  #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.arm_fp)
+  #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8)
+  #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address)
+
+/****************** ARM64, Linux */
+
+#elif defined(TARGET_arm64) && defined(SYS_linux)
+
+  #include 
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+     sigact.sa_flags = SA_SIGINFO
+
+  typedef unsigned long context_reg;
+  #define CONTEXT_PC (context->uc_mcontext.pc)
+  #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.regs[26])
+  #define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27])
+  #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address)
+
+/****************** AMD64, Solaris x86 */
+
+#elif defined(TARGET_amd64) && defined (SYS_solaris)
+
+  #include 
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+  #define SET_SIGACT(sigact,name) \
+    sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+    sigact.sa_flags = SA_SIGINFO
+
+  typedef greg_t context_reg;
+  #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
+  #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
+  #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** AMD64, OpenBSD */
+
+#elif defined(TARGET_amd64) && defined (SYS_openbsd)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #define CONTEXT_PC (context->sc_rip)
+ #define CONTEXT_EXCEPTION_POINTER (context->sc_r14)
+ #define CONTEXT_YOUNG_PTR (context->sc_r15)
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** AMD64, NetBSD */
+
+#elif defined(TARGET_amd64) && defined (SYS_netbsd)
+
+ #include 
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #define CONTEXT_PC (_UC_MACHINE_PC(context))
+ #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
+ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** I386, Linux */
+
+#elif defined(TARGET_i386) && defined(SYS_linux_elf)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, struct sigcontext context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_handler = (void (*)(int)) (name); \
+     sigact.sa_flags = 0
+
+  #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2)
+
+/****************** I386, BSD_ELF */
+
+#elif defined(TARGET_i386) && defined(SYS_bsd_elf)
+
+ #if defined (__NetBSD__)
+  #include 
+  #define DECLARE_SIGNAL_HANDLER(name) \
+  static void name(int sig, siginfo_t * info, ucontext_t * context)
+ #else
+  #define DECLARE_SIGNAL_HANDLER(name) \
+  static void name(int sig, siginfo_t * info, struct sigcontext * context)
+ #endif
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #if defined (__NetBSD__)
+  #define CONTEXT_PC (_UC_MACHINE_PC(context))
+ #else
+  #define CONTEXT_PC (context->sc_eip)
+ #endif
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** I386, BSD */
+
+#elif defined(TARGET_i386) && defined(SYS_bsd)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, void * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (name); \
+     sigact.sa_flags = SA_SIGINFO
+
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** I386, MacOS X */
+
+#elif defined(TARGET_i386) && defined(SYS_macosx)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, void * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (name); \
+     sigact.sa_flags = SA_SIGINFO
+
+  #include 
+  #include 
+
+  #if !defined(MAC_OS_X_VERSION_10_5) \
+      || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
+    #define CONTEXT_REG(r) r
+  #else
+    #define CONTEXT_REG(r) __##r
+  #endif
+
+  #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss))
+  #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip))
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** I386, Solaris x86 */
+
+#elif defined(TARGET_i386) && defined(SYS_solaris)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, void * context)
+
+  #define SET_SIGACT(sigact,name) \
+    sigact.sa_sigaction = (name); \
+    sigact.sa_flags = SA_SIGINFO
+
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** PowerPC, MacOS X */
+
+#elif defined(TARGET_power) && defined(SYS_rhapsody)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+     static void name(int sig, siginfo_t * info, void * context)
+
+  #include 
+  #include 
+
+  #ifdef __LP64__
+    #define SET_SIGACT(sigact,name) \
+       sigact.sa_sigaction = (name); \
+       sigact.sa_flags = SA_SIGINFO | SA_64REGSET
+
+    typedef unsigned long long context_reg;
+
+    #define CONTEXT_MCONTEXT (((ucontext64_t *)context)->uc_mcontext64)
+  #else
+    #define SET_SIGACT(sigact,name) \
+       sigact.sa_sigaction = (name); \
+       sigact.sa_flags = SA_SIGINFO
+
+    typedef unsigned long context_reg;
+
+    #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext)
+  #endif
+
+  #if !defined(MAC_OS_X_VERSION_10_5) \
+      || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
+    #define CONTEXT_REG(r) r
+  #else
+    #define CONTEXT_REG(r) __##r
+  #endif
+
+  #define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss))
+  #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(srr0))
+  #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r29))
+  #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.CONTEXT_REG(r30))
+  #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r31))
+  #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(r1))
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** PowerPC, ELF (Linux) */
+
+#elif defined(TARGET_power) && defined(SYS_elf)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, struct sigcontext * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_handler = (void (*)(int)) (name); \
+     sigact.sa_flags = 0
+
+  typedef unsigned long context_reg;
+  #define CONTEXT_PC (context->regs->nip)
+  #define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29])
+  #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30])
+  #define CONTEXT_YOUNG_PTR (context->regs->gpr[31])
+  #define CONTEXT_SP (context->regs->gpr[1])
+
+/****************** s390x, ELF (Linux) */
+#elif defined(TARGET_s390x) && defined(SYS_elf)
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, struct sigcontext * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_handler = (void (*)(int)) (name); \
+     sigact.sa_flags = 0
+
+  typedef unsigned long context_reg;
+  #define CONTEXT_PC (context->sregs->regs.psw.addr)
+  #define CONTEXT_EXCEPTION_POINTER (context->sregs->regs.gprs[13])
+  #define CONTEXT_YOUNG_LIMIT (context->sregs->regs.gprs[10])
+  #define CONTEXT_YOUNG_PTR (context->sregs->regs.gprs[11])
+  #define CONTEXT_SP (context->sregs->regs.gprs[15])
+
+/****************** PowerPC, BSD */
+
+#elif defined(TARGET_power) && \
+    (defined(SYS_bsd) || defined(SYS_bsd_elf) || defined(SYS_netbsd))
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, int code, struct sigcontext * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_handler = (void (*)(int)) (name); \
+     sigact.sa_flags = 0
+
+  typedef unsigned long context_reg;
+  #define CONTEXT_PC (context->sc_frame.srr0)
+  #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29])
+  #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30])
+  #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31])
+  #define CONTEXT_SP (context->sc_frame.fixreg[1])
+
+/****************** SPARC, Solaris */
+
+#elif defined(TARGET_sparc) && defined(SYS_solaris)
+
+  #include 
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+     sigact.sa_flags = SA_SIGINFO
+
+  typedef long context_reg;
+  #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC])
+    /* Local register number N is saved on the stack N words
+       after the stack pointer */
+  #define CONTEXT_SP (context->uc_mcontext.gregs[REG_SP])
+  #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n]
+  #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5))
+  #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7))
+  #define CONTEXT_YOUNG_PTR (SPARC_L_REG(6))
+
+/******************** Default */
+
+#else
+
+  #define DECLARE_SIGNAL_HANDLER(name) \
+    static void name(int sig)
+
+  #define SET_SIGACT(sigact,name) \
+     sigact.sa_handler = (name); \
+     sigact.sa_flags = 0
+
+#endif
diff --git a/asmrun/spacetime.c b/asmrun/spacetime.c
new file mode 100644
index 00000000..e95cf687
--- /dev/null
+++ b/asmrun/spacetime.c
@@ -0,0 +1,1123 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include "caml/config.h"
+#ifdef HAS_UNISTD
+#include 
+#endif
+
+#include "caml/alloc.h"
+#include "caml/backtrace_prim.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/osdeps.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "caml/spacetime.h"
+
+#ifdef WITH_SPACETIME
+
+/* We force "noinline" in certain places to be sure we know how many
+   frames there will be on the stack. */
+#define NOINLINE __attribute__((noinline))
+
+#ifdef HAS_LIBUNWIND
+#define UNW_LOCAL_ONLY
+#include "libunwind.h"
+#endif
+
+static int automatic_snapshots = 0;
+static double snapshot_interval = 0.0;
+static double next_snapshot_time = 0.0;
+static struct channel *snapshot_channel;
+static int pid_when_snapshot_channel_opened;
+
+extern value caml_spacetime_debug(value);
+
+static char* start_of_free_node_block;
+static char* end_of_free_node_block;
+
+typedef struct per_thread {
+  value* trie_node_root;
+  value* finaliser_trie_node_root;
+  struct per_thread* next;
+} per_thread;
+
+/* List of tries corresponding to threads that have been created. */
+/* CR-soon mshinwell: just include the main trie in this list. */
+static per_thread* per_threads = NULL;
+static int num_per_threads = 0;
+
+/* [caml_spacetime_shapes] is defined in the startup file. */
+extern uint64_t* caml_spacetime_shapes;
+
+uint64_t** caml_spacetime_static_shape_tables = NULL;
+shape_table* caml_spacetime_dynamic_shape_tables = NULL;
+
+static uintnat caml_spacetime_profinfo = (uintnat) 0;
+
+value caml_spacetime_trie_root = Val_unit;
+value* caml_spacetime_trie_node_ptr = &caml_spacetime_trie_root;
+
+static value caml_spacetime_finaliser_trie_root_main_thread = Val_unit;
+value* caml_spacetime_finaliser_trie_root
+  = &caml_spacetime_finaliser_trie_root_main_thread;
+
+/* CR-someday mshinwell: think about thread safety of the manipulation of
+   this list for multicore */
+allocation_point* caml_all_allocation_points = NULL;
+
+static const uintnat chunk_size = 1024 * 1024;
+
+static void reinitialise_free_node_block(void)
+{
+  size_t index;
+
+  start_of_free_node_block = (char*) malloc(chunk_size);
+  end_of_free_node_block = start_of_free_node_block + chunk_size;
+
+  for (index = 0; index < chunk_size / sizeof(value); index++) {
+    ((value*) start_of_free_node_block)[index] = Val_unit;
+  }
+}
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#if defined (_WIN32) || defined (_WIN64)
+extern value val_process_id;
+#endif
+
+static uint32_t version_number = 0;
+static uint32_t magic_number_base = 0xace00ace;
+
+static void caml_spacetime_write_magic_number_internal(struct channel* chan)
+{
+  value magic_number =
+    Val_long(((uint64_t) magic_number_base)
+             | (((uint64_t) version_number) << 32));
+
+  Lock(chan);
+  caml_output_val(chan, magic_number, Val_long(0));
+  Unlock(chan);
+}
+
+CAMLprim value caml_spacetime_write_magic_number(value v_channel)
+{
+  caml_spacetime_write_magic_number_internal(Channel(v_channel));
+  return Val_unit;
+}
+
+static char* automatic_snapshot_dir;
+
+static void open_snapshot_channel(void)
+{
+  int fd;
+  char filename[8192];
+  int pid;
+#if defined (_WIN32) || defined (_WIN64)
+  pid = Int_val(val_process_id);
+#else
+  pid = getpid();
+#endif
+  snprintf(filename, 8192, "%s/spacetime-%d", automatic_snapshot_dir, pid);
+  filename[8191] = '\0';
+  fd = open(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666);
+  if (fd == -1) {
+    automatic_snapshots = 0;
+  }
+  else {
+    snapshot_channel = caml_open_descriptor_out(fd);
+    snapshot_channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE;
+    pid_when_snapshot_channel_opened = pid;
+    caml_spacetime_write_magic_number_internal(snapshot_channel);
+  }
+}
+
+static void maybe_reopen_snapshot_channel(void)
+{
+  /* This function should be used before writing to the automatic snapshot
+     channel.  It detects whether we have forked since the channel was opened.
+     If so, we close the old channel (ignoring any errors just in case the
+     old fd has been closed, e.g. in a double-fork situation where the middle
+     process has a loop to manually close all fds and no Spacetime snapshot
+     was written during that time) and then open a new one. */
+
+  int pid;
+#if defined (_WIN32) || defined (_WIN64)
+  pid = Int_val(val_process_id);
+#else
+  pid = getpid();
+#endif
+
+  if (pid != pid_when_snapshot_channel_opened) {
+    caml_close_channel(snapshot_channel);
+    open_snapshot_channel();
+  }
+}
+
+extern void caml_spacetime_automatic_save(void);
+
+void caml_spacetime_initialize(void)
+{
+  /* Note that this is called very early (even prior to GC initialisation). */
+
+  char *ap_interval;
+
+  reinitialise_free_node_block();
+
+  caml_spacetime_static_shape_tables = &caml_spacetime_shapes;
+
+  ap_interval = caml_secure_getenv ("OCAML_SPACETIME_INTERVAL");
+  if (ap_interval != NULL) {
+    unsigned int interval = 0;
+    sscanf(ap_interval, "%u", &interval);
+    if (interval != 0) {
+      double time;
+      char cwd[4096];
+      char* user_specified_automatic_snapshot_dir;
+      int dir_ok = 1;
+
+      user_specified_automatic_snapshot_dir =
+        caml_secure_getenv("OCAML_SPACETIME_SNAPSHOT_DIR");
+
+      if (user_specified_automatic_snapshot_dir == NULL) {
+#ifdef HAS_GETCWD
+        if (getcwd(cwd, sizeof(cwd)) == NULL) {
+          dir_ok = 0;
+        }
+#else
+        if (getwd(cwd) == NULL) {
+          dir_ok = 0;
+        }
+#endif
+        if (dir_ok) {
+          automatic_snapshot_dir = strdup(cwd);
+        }
+      }
+      else {
+        automatic_snapshot_dir =
+          strdup(user_specified_automatic_snapshot_dir);
+      }
+
+      if (dir_ok) {
+        automatic_snapshots = 1;
+        open_snapshot_channel();
+        if (automatic_snapshots) {
+#ifdef SIGINT
+          /* Catch interrupt so that the profile can be completed.
+             We do this by marking the signal as handled without
+             specifying an actual handler. This causes the signal
+             to be handled by a call to exit. */
+          caml_set_signal_action(SIGINT, 2);
+#endif
+          snapshot_interval = interval / 1e3;
+          time = caml_sys_time_unboxed(Val_unit);
+          next_snapshot_time = time + snapshot_interval;
+          atexit(&caml_spacetime_automatic_save);
+        }
+      }
+    }
+  }
+}
+
+void caml_spacetime_register_shapes(void* dynlinked_table)
+{
+  shape_table* table;
+  table = (shape_table*) malloc(sizeof(shape_table));
+  if (table == NULL) {
+    fprintf(stderr, "Out of memory whilst registering shape table");
+    abort();
+  }
+  table->table = (uint64_t*) dynlinked_table;
+  table->next = caml_spacetime_dynamic_shape_tables;
+  caml_spacetime_dynamic_shape_tables = table;
+}
+
+CAMLprim value caml_spacetime_trie_is_initialized (value v_unit)
+{
+  return (caml_spacetime_trie_root == Val_unit) ? Val_false : Val_true;
+}
+
+CAMLprim value caml_spacetime_get_trie_root (value v_unit)
+{
+  return caml_spacetime_trie_root;
+}
+
+void caml_spacetime_register_thread(
+  value* trie_node_root, value* finaliser_trie_node_root)
+{
+  per_thread* thr;
+
+  thr = (per_thread*) malloc(sizeof(per_thread));
+  if (thr == NULL) {
+    fprintf(stderr, "Out of memory while registering thread for profiling\n");
+    abort();
+  }
+  thr->next = per_threads;
+  per_threads = thr;
+
+  thr->trie_node_root = trie_node_root;
+  thr->finaliser_trie_node_root = finaliser_trie_node_root;
+
+  /* CR-soon mshinwell: record thread ID (and for the main thread too) */
+
+  num_per_threads++;
+}
+
+static void caml_spacetime_save_event_internal (value v_time_opt,
+                                                struct channel* chan,
+                                                value v_event_name)
+{
+  value v_time;
+  double time_override = 0.0;
+  int use_time_override = 0;
+
+  if (Is_block(v_time_opt)) {
+    time_override = Double_field(Field(v_time_opt, 0), 0);
+    use_time_override = 1;
+  }
+  v_time = caml_spacetime_timestamp(time_override, use_time_override);
+
+  Lock(chan);
+  caml_output_val(chan, Val_long(2), Val_long(0));
+  caml_output_val(chan, v_event_name, Val_long(0));
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, v_time, Val_long(0));
+  caml_extern_allow_out_of_heap = 0;
+  Unlock(chan);
+
+  caml_stat_free(Hp_val(v_time));
+}
+
+CAMLprim value caml_spacetime_save_event (value v_time_opt,
+                                          value v_channel,
+                                          value v_event_name)
+{
+  struct channel* chan = Channel(v_channel);
+
+  caml_spacetime_save_event_internal(v_time_opt, chan, v_event_name);
+
+  return Val_unit;
+}
+
+
+void save_trie (struct channel *chan, double time_override,
+                int use_time_override)
+{
+  value v_time, v_frames, v_shapes;
+  /* CR-someday mshinwell: The commented-out changes here are for multicore,
+     where we think we should have one trie per domain. */
+  /* int num_marshalled = 0;
+  per_thread* thr = per_threads; */
+
+  Lock(chan);
+
+  caml_output_val(chan, Val_long(1), Val_long(0));
+
+  v_time = caml_spacetime_timestamp(time_override, use_time_override);
+  v_frames = caml_spacetime_frame_table();
+  v_shapes = caml_spacetime_shape_table();
+
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, v_time, Val_long(0));
+  caml_output_val(chan, v_frames, Val_long(0));
+  caml_output_val(chan, v_shapes, Val_long(0));
+  caml_extern_allow_out_of_heap = 0;
+
+  caml_output_val(chan, Val_long(1) /* Val_long(num_per_threads + 1) */,
+    Val_long(0));
+
+  /* Marshal both the main and finaliser tries, for all threads that have
+     been created, to an [out_channel].  This can be done by using the
+     extern.c code as usual, since the trie looks like standard OCaml values;
+     but we must allow it to traverse outside the heap. */
+
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, caml_spacetime_trie_root, Val_long(0));
+  caml_output_val(chan,
+    caml_spacetime_finaliser_trie_root_main_thread, Val_long(0));
+  /* while (thr != NULL) {
+    caml_output_val(chan, *(thr->trie_node_root), Val_long(0));
+    caml_output_val(chan, *(thr->finaliser_trie_node_root),
+      Val_long(0));
+    thr = thr->next;
+    num_marshalled++;
+  }
+  Assert(num_marshalled == num_per_threads); */
+  caml_extern_allow_out_of_heap = 0;
+
+  Unlock(chan);
+}
+
+CAMLprim value caml_spacetime_save_trie (value v_time_opt, value v_channel)
+{
+  struct channel* channel = Channel(v_channel);
+  double time_override = 0.0;
+  int use_time_override = 0;
+
+  if (Is_block(v_time_opt)) {
+    time_override = Double_field(Field(v_time_opt, 0), 0);
+    use_time_override = 1;
+  }
+
+  save_trie(channel, time_override, use_time_override);
+
+  return Val_unit;
+}
+
+c_node_type caml_spacetime_classify_c_node(c_node* node)
+{
+  return (node->pc & 2) ? CALL : ALLOCATION;
+}
+
+c_node* caml_spacetime_c_node_of_stored_pointer(value node_stored)
+{
+  Assert(node_stored == Val_unit || Is_c_node(node_stored));
+  return (node_stored == Val_unit) ? NULL : (c_node*) Hp_val(node_stored);
+}
+
+c_node* caml_spacetime_c_node_of_stored_pointer_not_null(
+      value node_stored)
+{
+  Assert(Is_c_node(node_stored));
+  return (c_node*) Hp_val(node_stored);
+}
+
+value caml_spacetime_stored_pointer_of_c_node(c_node* c_node)
+{
+  value node;
+  Assert(c_node != NULL);
+  node = Val_hp(c_node);
+  Assert(Is_c_node(node));
+  return node;
+}
+
+#ifdef HAS_LIBUNWIND
+static int pc_inside_c_node_matches(c_node* node, void* pc)
+{
+  return Decode_c_node_pc(node->pc) == pc;
+}
+#endif
+
+static value allocate_uninitialized_ocaml_node(int size_including_header)
+{
+  void* node;
+  uintnat size;
+
+  Assert(size_including_header >= 3);
+  node = caml_stat_alloc(sizeof(uintnat) * size_including_header);
+
+  size = size_including_header * sizeof(value);
+
+  node = (void*) start_of_free_node_block;
+  if (end_of_free_node_block - start_of_free_node_block < size) {
+    reinitialise_free_node_block();
+    node = (void*) start_of_free_node_block;
+    Assert(end_of_free_node_block - start_of_free_node_block >= size);
+  }
+
+  start_of_free_node_block += size;
+
+  /* We don't currently rely on [uintnat] alignment, but we do need some
+     alignment, so just be sure. */
+  Assert (((uintnat) node) % sizeof(uintnat) == 0);
+  return Val_hp(node);
+}
+
+static value find_tail_node(value node, void* callee)
+{
+  /* Search the tail chain within [node] (which corresponds to an invocation
+     of a caller of [callee]) to determine whether it contains a tail node
+     corresponding to [callee].  Returns any such node, or [Val_unit] if no
+     such node exists. */
+
+  value starting_node;
+  value pc;
+  value found = Val_unit;
+
+  starting_node = node;
+  pc = Encode_node_pc(callee);
+
+  do {
+    Assert(Is_ocaml_node(node));
+    if (Node_pc(node) == pc) {
+      found = node;
+    }
+    else {
+      node = Tail_link(node);
+    }
+  } while (found == Val_unit && starting_node != node);
+
+  return found;
+}
+
+CAMLprim value caml_spacetime_allocate_node(
+      int size_including_header, void* pc, value* node_hole)
+{
+  value node;
+  value caller_node = Val_unit;
+
+  node = *node_hole;
+  /* The node hole should either contain [Val_unit], indicating that this
+     function was not tail called and we have not been to this point in the
+     trie before; or it should contain a value encoded using
+     [Encoded_tail_caller_node] that points at the node of a caller
+     that tail called the current function.  (Such a value is necessary to
+     be able to find the start of the caller's node, and hence its tail
+     chain, so we as a tail-called callee can link ourselves in.) */
+  Assert(Is_tail_caller_node_encoded(node));
+
+  if (node != Val_unit) {
+    value tail_node;
+    /* The callee was tail called.  Find whether there already exists a node
+       for it in the tail call chain within the caller's node.  The caller's
+       node must always be an OCaml node. */
+    caller_node = Decode_tail_caller_node(node);
+    tail_node = find_tail_node(caller_node, pc);
+    if (tail_node != Val_unit) {
+      /* This tail calling sequence has happened before; just fill the hole
+         with the existing node and return. */
+      *node_hole = tail_node;
+      return 0;  /* indicates an existing node was returned */
+    }
+  }
+
+  node = allocate_uninitialized_ocaml_node(size_including_header);
+  Hd_val(node) =
+    Make_header(size_including_header - 1, OCaml_node_tag, Caml_black);
+  Assert((((uintnat) pc) % 1) == 0);
+  Node_pc(node) = Encode_node_pc(pc);
+  /* If the callee was tail called, then the tail link field will link this
+     new node into an existing tail chain.  Otherwise, it is initialized with
+     the empty tail chain, i.e. the one pointing directly at [node]. */
+  if (caller_node == Val_unit) {
+    Tail_link(node) = node;
+  }
+  else {
+    Tail_link(node) = Tail_link(caller_node);
+    Tail_link(caller_node) = node;
+  }
+
+  /* The callee node pointers for direct tail call points are
+     initialized from code emitted by the OCaml compiler.  This is done to
+     avoid having to pass this function a description of which nodes are
+     direct tail call points.  (We cannot just count them and put them at the
+     beginning of the node because we need the indexes of elements within the
+     node during instruction selection before we have found all call points.)
+
+     All other fields have already been initialised by
+     [reinitialise_free_node_block].
+  */
+
+  *node_hole = node;
+
+  return 1;  /* indicates a new node was created */
+}
+
+static c_node* allocate_c_node(void)
+{
+  c_node* node;
+  size_t index;
+
+  node = (c_node*) start_of_free_node_block;
+  if (end_of_free_node_block - start_of_free_node_block < sizeof(c_node)) {
+    reinitialise_free_node_block();
+    node = (c_node*) start_of_free_node_block;
+    Assert(end_of_free_node_block - start_of_free_node_block
+      >= sizeof(c_node));
+  }
+  start_of_free_node_block += sizeof(c_node);
+
+  Assert((sizeof(c_node) % sizeof(uintnat)) == 0);
+
+  /* CR-soon mshinwell: remove this and pad the structure properly */
+  for (index = 0; index < sizeof(c_node) / sizeof(value); index++) {
+    ((value*) node)[index] = Val_unit;
+  }
+
+  node->gc_header =
+    Make_header(sizeof(c_node)/sizeof(uintnat) - 1, C_node_tag, Caml_black);
+  node->data.callee_node = Val_unit;
+  node->next = Val_unit;
+
+  return node;
+}
+
+/* Since a given indirect call site either always yields tail calls or
+   always yields non-tail calls, the output of
+   [caml_spacetime_indirect_node_hole_ptr] is uniquely determined by its
+   first two arguments (the callee and the node hole).  We cache these
+   to increase performance of recursive functions containing an indirect
+   call (e.g. [List.map] when not inlined). */
+static void* last_indirect_node_hole_ptr_callee;
+static value* last_indirect_node_hole_ptr_node_hole;
+static value* last_indirect_node_hole_ptr_result;
+
+CAMLprim value* caml_spacetime_indirect_node_hole_ptr
+      (void* callee, value* node_hole, value caller_node)
+{
+  /* Find the address of the node hole for an indirect call to [callee].
+     If [caller_node] is not [Val_unit], it is a pointer to the caller's
+     node, and indicates that this is a tail call site. */
+
+  c_node* c_node;
+  value encoded_callee;
+
+  if (callee == last_indirect_node_hole_ptr_callee
+      && node_hole == last_indirect_node_hole_ptr_node_hole) {
+    return last_indirect_node_hole_ptr_result;
+  }
+
+  last_indirect_node_hole_ptr_callee = callee;
+  last_indirect_node_hole_ptr_node_hole = node_hole;
+
+  encoded_callee = Encode_c_node_pc_for_call(callee);
+
+  while (*node_hole != Val_unit) {
+    Assert(((uintnat) *node_hole) % sizeof(value) == 0);
+
+    c_node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole);
+
+    Assert(c_node != NULL);
+    Assert(caml_spacetime_classify_c_node(c_node) == CALL);
+
+    if (c_node->pc == encoded_callee) {
+      last_indirect_node_hole_ptr_result = &(c_node->data.callee_node);
+      return last_indirect_node_hole_ptr_result;
+    }
+    else {
+      node_hole = &c_node->next;
+    }
+  }
+
+  c_node = allocate_c_node();
+  c_node->pc = encoded_callee;
+
+  if (caller_node != Val_unit) {
+    /* This is a tail call site.
+       Perform the initialization equivalent to that emitted by
+       [Spacetime.code_for_function_prologue] for direct tail call
+       sites. */
+    c_node->data.callee_node = Encode_tail_caller_node(caller_node);
+  }
+
+  *node_hole = caml_spacetime_stored_pointer_of_c_node(c_node);
+
+  Assert(((uintnat) *node_hole) % sizeof(value) == 0);
+  Assert(*node_hole != Val_unit);
+
+  last_indirect_node_hole_ptr_result = &(c_node->data.callee_node);
+
+  return last_indirect_node_hole_ptr_result;
+}
+
+/* Some notes on why caml_call_gc doesn't need a distinguished node.
+   (Remember that thread switches are irrelevant here because each thread
+   has its own trie.)
+
+   caml_call_gc only invokes OCaml functions in the following circumstances:
+   1. running an OCaml finaliser;
+   2. executing an OCaml signal handler.
+   Both of these are done on the finaliser trie.  Furthermore, both of
+   these invocations start via caml_callback; the code in this file for
+   handling that (caml_spacetime_c_to_ocaml) correctly copes with that by
+   attaching a single "caml_start_program" node that can cope with any
+   number of indirect OCaml calls from that point.
+
+   caml_call_gc may also invoke C functions that cause allocation.  All of
+   these (assuming libunwind support is present) will cause a chain of
+   c_node structures to be attached to the trie, starting at the node hole
+   passed to caml_call_gc from OCaml code.  These structures are extensible
+   and can thus accommodate any number of C backtraces leading from
+   caml_call_gc.
+*/
+/* CR-soon mshinwell: it might in fact be the case now that nothing called
+   from caml_call_gc will do any allocation that ends up on the trie.  We
+   can revisit this after the first release. */
+
+static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
+    uintnat wosize, struct ext_table** cached_frames)
+{
+#ifdef HAS_LIBUNWIND
+  /* Given that [caml_last_return_address] is the most recent call site in
+     OCaml code, and that we are now in C (or other) code called from that
+     site, obtain a backtrace using libunwind and graft the most recent
+     portion (everything back to but not including [caml_last_return_address])
+     onto the trie.  See the important comment below regarding the fact that
+     call site, and not callee, addresses are recorded during this process.
+
+     If [for_allocation] is non-zero, the final node recorded will be for
+     an allocation, and the returned pointer is to the allocation node.
+     Otherwise, no node is recorded for the innermost frame, and the
+     returned pointer is a pointer to the *node hole* where a node for that
+     frame should be attached.
+
+     If [for_allocation] is non-zero then [wosize] must give the size in
+     words, excluding the header, of the value being allocated.
+
+     If [cached_frames != NULL] then:
+     1. If [*cached_frames] is NULL then save the captured backtrace in a
+        newly-allocated table and store the pointer to that table in
+        [*cached_frames];
+     2. Otherwise use [*cached_frames] as the unwinding information.
+     The intention is that when the context is known (e.g. a function such
+     as [caml_make_vect] known to have been directly invoked from OCaml),
+     we can avoid expensive calls to libunwind.
+  */
+
+  unw_cursor_t cur;
+  unw_context_t ctx;
+  int ret;
+  int innermost_frame;
+  int frame;
+  static struct ext_table frames_local;
+  struct ext_table* frames;
+  static int ext_table_initialised = 0;
+  int have_frames_already = 0;
+  value* node_hole;
+  c_node* node = NULL;
+  int initial_table_size = 1000;
+  int must_initialise_node_for_allocation = 0;
+
+  if (!cached_frames) {
+    if (!ext_table_initialised) {
+      caml_ext_table_init(&frames_local, initial_table_size);
+      ext_table_initialised = 1;
+    }
+    else {
+      caml_ext_table_clear(&frames_local, 0);
+    }
+    frames = &frames_local;
+  } else {
+    if (*cached_frames) {
+      frames = *cached_frames;
+      have_frames_already = 1;
+    }
+    else {
+      frames = (struct ext_table*) malloc(sizeof(struct ext_table));
+      if (!frames) {
+        caml_fatal_error("Not enough memory for ext_table allocation");
+      }
+      caml_ext_table_init(frames, initial_table_size);
+      *cached_frames = frames;
+    }
+  }
+
+  if (!have_frames_already) {
+    /* Get the stack backtrace as far as [caml_last_return_address]. */
+
+    ret = unw_getcontext(&ctx);
+    if (ret != UNW_ESUCCESS) {
+      return NULL;
+    }
+
+    ret = unw_init_local(&cur, &ctx);
+    if (ret != UNW_ESUCCESS) {
+      return NULL;
+    }
+
+    while ((ret = unw_step(&cur)) > 0) {
+      unw_word_t ip;
+      unw_get_reg(&cur, UNW_REG_IP, &ip);
+      if (caml_last_return_address == (uintnat) ip) {
+        break;
+      }
+      else {
+        /* Inlined some of [caml_ext_table_add] for speed. */
+        if (frames->size < frames->capacity) {
+          frames->contents[frames->size++] = (void*) ip;
+        } else {
+          caml_ext_table_add(frames, (void*) ip);
+        }
+      }
+    }
+  }
+
+  /* We always need to ignore the frames for:
+      #0  find_trie_node_from_libunwind
+      #1  caml_spacetime_c_to_ocaml
+     Further, if this is not an allocation point, we should not create the
+     node for the current C function that triggered us (i.e. frame #2). */
+  innermost_frame = for_allocation ? 1 : 2;
+
+  if (frames->size - 1 < innermost_frame) {
+    /* Insufficiently many frames (maybe no frames) returned from
+       libunwind; just don't do anything. */
+    return NULL;
+  }
+
+  node_hole = caml_spacetime_trie_node_ptr;
+  /* Note that if [node_hole] is filled, then it must point to a C node,
+     since it is not possible for there to be a call point in an OCaml
+     function that sometimes calls C and sometimes calls OCaml. */
+
+  for (frame = frames->size - 1; frame >= innermost_frame; frame--) {
+    c_node_type expected_type;
+    void* pc = frames->contents[frame];
+    Assert (pc != (void*) caml_last_return_address);
+
+    if (!for_allocation) {
+      expected_type = CALL;
+    }
+    else {
+      expected_type = (frame > innermost_frame ? CALL : ALLOCATION);
+    }
+
+    if (*node_hole == Val_unit) {
+      node = allocate_c_node();
+      /* Note: for CALL nodes, the PC is the program counter at each call
+         site.  We do not store program counter addresses of the start of
+         callees, unlike for OCaml nodes.  This means that some trie nodes
+         will become conflated.  These can be split during post-processing by
+         working out which function each call site was in. */
+      node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc)
+        : Encode_c_node_pc_for_alloc_point(pc));
+      *node_hole = caml_spacetime_stored_pointer_of_c_node(node);
+      if (expected_type == ALLOCATION) {
+        must_initialise_node_for_allocation = 1;
+      }
+    }
+    else {
+      c_node* prev;
+      int found = 0;
+
+      node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole);
+      Assert(node != NULL);
+      Assert(node->next == Val_unit
+        || (((uintnat) (node->next)) % sizeof(value) == 0));
+
+      prev = NULL;
+
+      while (!found && node != NULL) {
+        if (caml_spacetime_classify_c_node(node) == expected_type
+            && pc_inside_c_node_matches(node, pc)) {
+          found = 1;
+        }
+        else {
+          prev = node;
+          node = caml_spacetime_c_node_of_stored_pointer(node->next);
+        }
+      }
+      if (!found) {
+        Assert(prev != NULL);
+        node = allocate_c_node();
+        node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc)
+          : Encode_c_node_pc_for_alloc_point(pc));
+        if (expected_type == ALLOCATION) {
+          must_initialise_node_for_allocation = 1;
+        }
+        prev->next = caml_spacetime_stored_pointer_of_c_node(node);
+      }
+    }
+
+    Assert(node != NULL);
+
+    Assert(caml_spacetime_classify_c_node(node) == expected_type);
+    Assert(pc_inside_c_node_matches(node, pc));
+    node_hole = &node->data.callee_node;
+  }
+
+  if (must_initialise_node_for_allocation) {
+    caml_spacetime_profinfo++;
+    if (caml_spacetime_profinfo > PROFINFO_MASK) {
+      /* Profiling counter overflow. */
+      caml_spacetime_profinfo = PROFINFO_MASK;
+    }
+    node->data.allocation.profinfo =
+      Make_header_with_profinfo(
+        /* "-1" because [c_node] has the GC header as its first
+           element. */
+        offsetof(c_node, data.allocation.count)/sizeof(value) - 1,
+        Infix_tag,
+        Caml_black,
+        caml_spacetime_profinfo);
+    node->data.allocation.count = Val_long(0);
+
+    /* Add the new allocation point into the linked list of all allocation
+       points. */
+    if (caml_all_allocation_points != NULL) {
+      node->data.allocation.next =
+        (value) &caml_all_allocation_points->count;
+    } else {
+      node->data.allocation.next = Val_unit;
+    }
+    caml_all_allocation_points = &node->data.allocation;
+  }
+
+  if (for_allocation) {
+    Assert(caml_spacetime_classify_c_node(node) == ALLOCATION);
+    Assert(caml_spacetime_c_node_of_stored_pointer(node->next) != node);
+    Assert(Profinfo_hd(node->data.allocation.profinfo) > 0);
+    node->data.allocation.count =
+      Val_long(Long_val(node->data.allocation.count) + (1 + wosize));
+  }
+
+  Assert(node->next != (value) NULL);
+
+  return for_allocation ? (void*) node : (void*) node_hole;
+#else
+  return NULL;
+#endif
+}
+
+void caml_spacetime_c_to_ocaml(void* ocaml_entry_point,
+      void* identifying_pc_for_caml_start_program)
+{
+  /* Called in [caml_start_program] and [caml_callback*] when we are about
+     to cross from C into OCaml.  [ocaml_entry_point] is the branch target.
+     This situation is handled by ensuring the presence of a new OCaml node
+     for the callback veneer; the node contains a single indirect call point
+     which accumulates the [ocaml_entry_point]s.
+
+     The layout of the node is described in the "system shape table"; see
+     asmrun/amd64.S.
+  */
+
+  value node;
+
+  /* Update the trie with the current backtrace, as far back as
+     [caml_last_return_address], and leave the node hole pointer at
+     the correct place for attachment of a [caml_start_program] node. */
+
+#ifdef HAS_LIBUNWIND
+  value* node_temp;
+  node_temp = (value*) find_trie_node_from_libunwind(0, 0, NULL);
+  if (node_temp != NULL) {
+    caml_spacetime_trie_node_ptr = node_temp;
+  }
+#endif
+
+  if (*caml_spacetime_trie_node_ptr == Val_unit) {
+    uintnat size_including_header;
+
+    size_including_header =
+      1 /* GC header */ + Node_num_header_words + Indirect_num_fields;
+
+    node = allocate_uninitialized_ocaml_node(size_including_header);
+    Hd_val(node) =
+      Make_header(size_including_header - 1, OCaml_node_tag, Caml_black);
+    Assert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0);
+    Node_pc(node) = Encode_node_pc(identifying_pc_for_caml_start_program);
+    Tail_link(node) = node;
+    Indirect_pc_linked_list(node, Node_num_header_words) = Val_unit;
+    *caml_spacetime_trie_node_ptr = node;
+  }
+  else {
+    node = *caml_spacetime_trie_node_ptr;
+    /* If there is a node here already, it should never be an initialized
+       (but as yet unused) tail call point, since calls from OCaml into C
+       are never tail calls (and no C -> C call is marked as tail). */
+    Assert(!Is_tail_caller_node_encoded(node));
+  }
+
+  Assert(Is_ocaml_node(node));
+  Assert(Decode_node_pc(Node_pc(node))
+    == identifying_pc_for_caml_start_program);
+  Assert(Tail_link(node) == node);
+  Assert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields);
+
+  /* Search the node to find the node hole corresponding to the indirect
+     call to the OCaml function. */
+  caml_spacetime_trie_node_ptr =
+    caml_spacetime_indirect_node_hole_ptr(
+      ocaml_entry_point,
+      &Indirect_pc_linked_list(node, Node_num_header_words),
+      Val_unit);
+  Assert(*caml_spacetime_trie_node_ptr == Val_unit
+    || Is_ocaml_node(*caml_spacetime_trie_node_ptr));
+}
+
+extern void caml_garbage_collection(void);  /* signals_asm.c */
+extern void caml_array_bound_error(void);  /* fail.c */
+
+CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words,
+                                                   uintnat index_within_node)
+{
+  /* Called from code that creates a value's header inside an OCaml
+     function. */
+
+  value node;
+  uintnat profinfo;
+
+  caml_spacetime_profinfo++;
+  if (caml_spacetime_profinfo > PROFINFO_MASK) {
+    /* Profiling counter overflow. */
+    caml_spacetime_profinfo = PROFINFO_MASK;
+  }
+  profinfo = caml_spacetime_profinfo;
+
+  /* CR-someday mshinwell: we could always use the [struct allocation_point]
+     overlay instead of the macros now. */
+
+  /* [node] isn't really a node; it points into the middle of
+     one---specifically to the "profinfo" word of an allocation point.
+     It's done like this to avoid re-calculating the place in the node
+     (which already has to be done in the OCaml-generated code run before
+     this function). */
+  node = (value) profinfo_words;
+  Assert(Alloc_point_profinfo(node, 0) == Val_unit);
+
+  /* The profinfo value is stored shifted to reduce the number of
+     instructions required on the OCaml side.  It also enables us to use
+     [Infix_tag] to obtain valid value pointers into the middle of nodes,
+     which is used for the linked list of all allocation points. */
+  profinfo = Make_header_with_profinfo(
+    index_within_node, Infix_tag, Caml_black, profinfo);
+
+  Assert(!Is_block(profinfo));
+  Alloc_point_profinfo(node, 0) = profinfo;
+  /* The count is set to zero by the initialisation when the node was
+     created (see above). */
+  Assert(Alloc_point_count(node, 0) == Val_long(0));
+
+  /* Add the new allocation point into the linked list of all allocation
+     points. */
+  if (caml_all_allocation_points != NULL) {
+    Alloc_point_next_ptr(node, 0) = (value) &caml_all_allocation_points->count;
+  }
+  else {
+    Assert(Alloc_point_next_ptr(node, 0) == Val_unit);
+  }
+  caml_all_allocation_points = (allocation_point*) node;
+
+  return profinfo;
+}
+
+uintnat caml_spacetime_my_profinfo (struct ext_table** cached_frames,
+                                    uintnat wosize)
+{
+  /* Return the profinfo value that should be written into a value's header
+     during an allocation from C.  This may necessitate extending the trie
+     with information obtained from libunwind. */
+
+  c_node* node;
+  uintnat profinfo = 0;
+
+  node = find_trie_node_from_libunwind(1, wosize, cached_frames);
+  if (node != NULL) {
+    profinfo = ((uintnat) (node->data.allocation.profinfo)) >> PROFINFO_SHIFT;
+  }
+
+  return profinfo;  /* N.B. not shifted by PROFINFO_SHIFT */
+}
+
+void caml_spacetime_automatic_snapshot (void)
+{
+  if (automatic_snapshots) {
+    double start_time, end_time;
+    start_time = caml_sys_time_unboxed(Val_unit);
+    if (start_time >= next_snapshot_time) {
+      maybe_reopen_snapshot_channel();
+      caml_spacetime_save_snapshot(snapshot_channel, 0.0, 0);
+      end_time = caml_sys_time_unboxed(Val_unit);
+      next_snapshot_time = end_time + snapshot_interval;
+    }
+  }
+}
+
+CAMLprim value caml_spacetime_save_event_for_automatic_snapshots
+  (value v_event_name)
+{
+  if (automatic_snapshots) {
+    maybe_reopen_snapshot_channel();
+    caml_spacetime_save_event_internal (Val_unit, snapshot_channel,
+                                        v_event_name);
+  }
+  return Val_unit;
+}
+
+void caml_spacetime_automatic_save (void)
+{
+  /* Called from [atexit]. */
+
+  if (automatic_snapshots) {
+    automatic_snapshots = 0;
+    maybe_reopen_snapshot_channel();
+    save_trie(snapshot_channel, 0.0, 0);
+    caml_flush(snapshot_channel);
+    caml_close_channel(snapshot_channel);
+  }
+}
+
+CAMLprim value caml_spacetime_enabled (value v_unit)
+{
+  return Val_true;
+}
+
+CAMLprim value caml_register_channel_for_spacetime (value v_channel)
+{
+  struct channel* channel = Channel(v_channel);
+  channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE;
+  return Val_unit;
+}
+
+#else
+
+/* Functions for when the compiler was not configured with "-spacetime". */
+
+CAMLprim value caml_spacetime_write_magic_number(value v_channel)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_enabled (value v_unit)
+{
+  return Val_false;
+}
+
+CAMLprim value caml_spacetime_save_event (value v_time_opt,
+                                          value v_channel,
+                                          value v_event_name)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_save_event_for_automatic_snapshots
+  (value v_event_name)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_save_trie (value ignored)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_register_channel_for_spacetime (value v_channel)
+{
+  return Val_unit;
+}
+
+#endif
diff --git a/asmrun/spacetime_offline.c b/asmrun/spacetime_offline.c
new file mode 100644
index 00000000..8191a300
--- /dev/null
+++ b/asmrun/spacetime_offline.c
@@ -0,0 +1,228 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+#include "caml/alloc.h"
+#include "caml/config.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "caml/spacetime.h"
+
+#include "../config/s.h"
+
+#ifdef ARCH_SIXTYFOUR
+
+/* CR-someday lwhite: The following two definitions are copied from spacetime.c
+   because they are needed here, but must be inlined in spacetime.c
+   for performance. Perhaps a macro or "static inline" would be
+   more appropriate. */
+
+c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null
+          (value node_stored)
+{
+  Assert(Is_c_node(node_stored));
+  return (c_node*) Hp_val(node_stored);
+}
+
+c_node_type caml_spacetime_offline_classify_c_node(c_node* node)
+{
+  return (node->pc & 2) ? CALL : ALLOCATION;
+}
+
+CAMLprim value caml_spacetime_compare_node(
+      value node1, value node2)
+{
+  Assert(!Is_in_value_area(node1));
+  Assert(!Is_in_value_area(node2));
+
+  if (node1 == node2) {
+    return Val_long(0);
+  }
+  if (node1 < node2) {
+    return Val_long(-1);
+  }
+  return Val_long(1);
+}
+
+CAMLprim value caml_spacetime_unmarshal_trie (value v_channel)
+{
+  return caml_input_value_to_outside_heap(v_channel);
+}
+
+CAMLprim value caml_spacetime_node_num_header_words(value unit)
+{
+  unit = Val_unit;
+  return Val_long(Node_num_header_words);
+}
+
+CAMLprim value caml_spacetime_is_ocaml_node(value node)
+{
+  Assert(Is_ocaml_node(node) || Is_c_node(node));
+  return Val_bool(Is_ocaml_node(node));
+}
+
+CAMLprim value caml_spacetime_ocaml_function_identifier(value node)
+{
+  Assert(Is_ocaml_node(node));
+  return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node)));
+}
+
+CAMLprim value caml_spacetime_ocaml_tail_chain(value node)
+{
+  Assert(Is_ocaml_node(node));
+  return Tail_link(node);
+}
+
+CAMLprim value caml_spacetime_classify_direct_call_point
+      (value node, value offset)
+{
+  uintnat field;
+  value callee_node;
+
+  Assert(Is_ocaml_node(node));
+
+  field = Long_val(offset);
+
+  callee_node = Direct_callee_node(node, field);
+  if (!Is_block(callee_node)) {
+    /* An unused call point (may be a tail call point). */
+    return Val_long(0);
+  } else if (Is_ocaml_node(callee_node)) {
+    return Val_long(1);  /* direct call point to OCaml code */
+  } else {
+    return Val_long(2);  /* direct call point to non-OCaml code */
+  }
+}
+
+CAMLprim value caml_spacetime_ocaml_allocation_point_annotation
+      (value node, value offset)
+{
+  uintnat profinfo_shifted;
+  profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset));
+  return Val_long(Profinfo_hd(profinfo_shifted));
+}
+
+CAMLprim value caml_spacetime_ocaml_allocation_point_count
+      (value node, value offset)
+{
+  value count = Alloc_point_count(node, Long_val(offset));
+  Assert(!Is_block(count));
+  return count;
+}
+
+CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node
+      (value node, value offset)
+{
+  return Direct_callee_node(node, Long_val(offset));
+}
+
+CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees
+      (value node, value offset)
+{
+  value callees = Indirect_pc_linked_list(node, Long_val(offset));
+  Assert(Is_block(callees));
+  Assert(Is_c_node(callees));
+  return callees;
+}
+
+CAMLprim value caml_spacetime_c_node_is_call(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  switch (caml_spacetime_offline_classify_c_node(c_node)) {
+    case CALL: return Val_true;
+    case ALLOCATION: return Val_false;
+  }
+  Assert(0);
+  return Val_unit;  /* silence compiler warning */
+}
+
+CAMLprim value caml_spacetime_c_node_next(value node)
+{
+  c_node* c_node;
+
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(c_node->next == Val_unit || Is_c_node(c_node->next));
+  return c_node->next;
+}
+
+CAMLprim value caml_spacetime_c_node_call_site(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc));
+}
+
+CAMLprim value caml_spacetime_c_node_callee_node(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
+  /* This might be an uninitialised tail call point: for example if an OCaml
+     callee was indirectly called but the callee wasn't instrumented (e.g. a
+     leaf function that doesn't allocate). */
+  if (Is_tail_caller_node_encoded(c_node->data.callee_node)) {
+    return Val_unit;
+  }
+  return c_node->data.callee_node;
+}
+
+CAMLprim value caml_spacetime_c_node_profinfo(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+  Assert(!Is_block(c_node->data.allocation.profinfo));
+  return Val_long(Profinfo_hd(c_node->data.allocation.profinfo));
+}
+
+CAMLprim value caml_spacetime_c_node_allocation_count(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+  Assert(!Is_block(c_node->data.allocation.count));
+  return c_node->data.allocation.count;
+}
+
+#endif
diff --git a/asmrun/spacetime_snapshot.c b/asmrun/spacetime_snapshot.c
new file mode 100644
index 00000000..0f425e19
--- /dev/null
+++ b/asmrun/spacetime_snapshot.c
@@ -0,0 +1,600 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+#include "caml/alloc.h"
+#include "caml/backtrace_prim.h"
+#include "caml/config.h"
+#include "caml/custom.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/gc_ctrl.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "caml/spacetime.h"
+
+#ifdef WITH_SPACETIME
+
+/* The following structures must match the type definitions in the
+   [Spacetime] module. */
+
+typedef struct {
+  /* (GC header here.) */
+  value minor_words;
+  value promoted_words;
+  value major_words;
+  value minor_collections;
+  value major_collections;
+  value heap_words;
+  value heap_chunks;
+  value compactions;
+  value top_heap_words;
+} gc_stats;
+
+typedef struct {
+  value profinfo;
+  value num_blocks;
+  value num_words_including_headers;
+} snapshot_entry;
+
+typedef struct {
+  /* (GC header here.) */
+  snapshot_entry entries[0];
+} snapshot_entries;
+
+typedef struct {
+  /* (GC header here.) */
+  value time;
+  value gc_stats;
+  value entries;
+  value words_scanned;
+  value words_scanned_with_profinfo;
+  value total_allocations;
+} snapshot;
+
+typedef struct {
+  uintnat num_blocks;
+  uintnat num_words_including_headers;
+} raw_snapshot_entry;
+
+static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag)
+{
+  /* CR-soon mshinwell: this function should live somewhere else */
+  header_t* block;
+
+  Assert(size_in_bytes % sizeof(value) == 0);
+  block = caml_stat_alloc(sizeof(header_t) + size_in_bytes);
+  *block = Make_header(size_in_bytes / sizeof(value), tag, Caml_black);
+  return (value) &block[1];
+}
+
+static value allocate_outside_heap(mlsize_t size_in_bytes)
+{
+  Assert(size_in_bytes > 0);
+  return allocate_outside_heap_with_tag(size_in_bytes, 0);
+}
+
+static value take_gc_stats(void)
+{
+  value v_stats;
+  gc_stats* stats;
+
+  v_stats = allocate_outside_heap(sizeof(gc_stats));
+  stats = (gc_stats*) v_stats;
+
+  stats->minor_words = Val_long(caml_stat_minor_words);
+  stats->promoted_words = Val_long(caml_stat_promoted_words);
+  stats->major_words =
+    Val_long(((uintnat) caml_stat_major_words)
+             + ((uintnat) caml_allocated_words));
+  stats->minor_collections = Val_long(caml_stat_minor_collections);
+  stats->major_collections = Val_long(caml_stat_major_collections);
+  stats->heap_words = Val_long(caml_stat_heap_wsz / sizeof(value));
+  stats->heap_chunks = Val_long(caml_stat_heap_chunks);
+  stats->compactions = Val_long(caml_stat_compactions);
+  stats->top_heap_words = Val_long(caml_stat_top_heap_wsz / sizeof(value));
+
+  return v_stats;
+}
+
+static value get_total_allocations(void)
+{
+  value v_total_allocations = Val_unit;
+  allocation_point* total = caml_all_allocation_points;
+
+  while (total != NULL) {
+    value v_total;
+    v_total = allocate_outside_heap_with_tag(3 * sizeof(value), 0);
+
+    /* [v_total] is of type [Raw_spacetime_lib.total_allocations]. */
+    Field(v_total, 0) = Val_long(Profinfo_hd(total->profinfo));
+    Field(v_total, 1) = total->count;
+    Field(v_total, 2) = v_total_allocations;
+    v_total_allocations = v_total;
+
+    Assert (total->next == Val_unit
+      || (Is_block(total->next) && Tag_val(total->next) == Infix_tag));
+    if (total->next == Val_unit) {
+      total = NULL;
+    }
+    else {
+      total = (allocation_point*) Hp_val(total->next);
+    }
+  }
+
+  return v_total_allocations;
+}
+
+static value take_snapshot(double time_override, int use_time_override)
+{
+  value v_snapshot;
+  snapshot* heap_snapshot;
+  value v_entries;
+  snapshot_entries* entries;
+  char* chunk;
+  value gc_stats;
+  uintnat index;
+  uintnat target_index;
+  value v_time;
+  double time;
+  uintnat profinfo;
+  uintnat num_distinct_profinfos;
+  /* Fixed size buffer to avoid needing a hash table: */
+  static raw_snapshot_entry* raw_entries = NULL;
+  uintnat words_scanned = 0;
+  uintnat words_scanned_with_profinfo = 0;
+  value v_total_allocations;
+
+  if (!use_time_override) {
+    time = caml_sys_time_unboxed(Val_unit);
+  }
+  else {
+    time = time_override;
+  }
+
+  gc_stats = take_gc_stats();
+
+  if (raw_entries == NULL) {
+    size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry);
+    raw_entries = caml_stat_alloc(size);
+    memset(raw_entries, '\0', size);
+  } else {
+    size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry);
+    memset(raw_entries, '\0', size);
+  }
+
+  num_distinct_profinfos = 0;
+
+  /* CR-someday mshinwell: consider reintroducing minor heap scanning,
+     properly from roots, which would then give a snapshot function
+     that doesn't do a minor GC.  Although this may not be that important
+     and potentially not worth the effort (it's quite tricky). */
+
+  /* Scan the major heap. */
+  chunk = caml_heap_start;
+  while (chunk != NULL) {
+    char* hp;
+    char* limit;
+
+    hp = chunk;
+    limit = chunk + Chunk_size (chunk);
+
+    while (hp < limit) {
+      header_t hd = Hd_hp (hp);
+      switch (Color_hd(hd)) {
+        case Caml_blue:
+          break;
+
+        default:
+          if (Wosize_hd(hd) > 0) { /* ignore atoms */
+            profinfo = Profinfo_hd(hd);
+            words_scanned += Whsize_hd(hd);
+            if (profinfo > 0 && profinfo < PROFINFO_MASK) {
+              words_scanned_with_profinfo += Whsize_hd(hd);
+              Assert (raw_entries[profinfo].num_blocks >= 0);
+              if (raw_entries[profinfo].num_blocks == 0) {
+                num_distinct_profinfos++;
+              }
+              raw_entries[profinfo].num_blocks++;
+              raw_entries[profinfo].num_words_including_headers +=
+                Whsize_hd(hd);
+            }
+          }
+          break;
+      }
+      hp += Bhsize_hd (hd);
+      Assert (hp <= limit);
+    }
+
+    chunk = Chunk_next (chunk);
+  }
+
+  if (num_distinct_profinfos > 0) {
+    v_entries = allocate_outside_heap(
+      num_distinct_profinfos*sizeof(snapshot_entry));
+    entries = (snapshot_entries*) v_entries;
+    target_index = 0;
+    for (index = 0; index <= PROFINFO_MASK; index++) {
+      Assert(raw_entries[index].num_blocks >= 0);
+      if (raw_entries[index].num_blocks > 0) {
+        Assert(target_index < num_distinct_profinfos);
+        entries->entries[target_index].profinfo = Val_long(index);
+        entries->entries[target_index].num_blocks
+          = Val_long(raw_entries[index].num_blocks);
+        entries->entries[target_index].num_words_including_headers
+          = Val_long(raw_entries[index].num_words_including_headers);
+        target_index++;
+      }
+    }
+  } else {
+    v_entries = Atom(0);
+  }
+
+  Assert(sizeof(double) == sizeof(value));
+  v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
+  Double_field(v_time, 0) = time;
+
+  v_snapshot = allocate_outside_heap(sizeof(snapshot));
+  heap_snapshot = (snapshot*) v_snapshot;
+
+  v_total_allocations = get_total_allocations();
+
+  heap_snapshot->time = v_time;
+  heap_snapshot->gc_stats = gc_stats;
+  heap_snapshot->entries = v_entries;
+  heap_snapshot->words_scanned
+    = Val_long(words_scanned);
+  heap_snapshot->words_scanned_with_profinfo
+    = Val_long(words_scanned_with_profinfo);
+  heap_snapshot->total_allocations = v_total_allocations;
+
+  return v_snapshot;
+}
+
+void caml_spacetime_save_snapshot (struct channel *chan, double time_override,
+                                   int use_time_override)
+{
+  value v_snapshot;
+  value v_total_allocations;
+  snapshot* heap_snapshot;
+
+  Lock(chan);
+
+  v_snapshot = take_snapshot(time_override, use_time_override);
+
+  caml_output_val(chan, Val_long(0), Val_long(0));
+
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, v_snapshot, Val_long(0));
+  caml_extern_allow_out_of_heap = 0;
+
+  Unlock(chan);
+
+  heap_snapshot = (snapshot*) v_snapshot;
+  caml_stat_free(Hp_val(heap_snapshot->time));
+  caml_stat_free(Hp_val(heap_snapshot->gc_stats));
+  if (Wosize_val(heap_snapshot->entries) > 0) {
+    caml_stat_free(Hp_val(heap_snapshot->entries));
+  }
+  v_total_allocations = heap_snapshot->total_allocations;
+  while (v_total_allocations != Val_unit) {
+    value next = Field(v_total_allocations, 2);
+    caml_stat_free(Hp_val(v_total_allocations));
+    v_total_allocations = next;
+  }
+
+  caml_stat_free(Hp_val(v_snapshot));
+}
+
+CAMLprim value caml_spacetime_take_snapshot(value v_time_opt, value v_channel)
+{
+  struct channel * channel = Channel(v_channel);
+  double time_override = 0.0;
+  int use_time_override = 0;
+
+  if (Is_block(v_time_opt)) {
+    time_override = Double_field(Field(v_time_opt, 0), 0);
+    use_time_override = 1;
+  }
+
+  caml_spacetime_save_snapshot(channel, time_override, use_time_override);
+
+  return Val_unit;
+}
+
+extern struct custom_operations caml_int64_ops;  /* ints.c */
+
+static value
+allocate_int64_outside_heap(uint64_t i)
+{
+  value v;
+
+  v = allocate_outside_heap_with_tag(2 * sizeof(value), Custom_tag);
+  Custom_ops_val(v) = &caml_int64_ops;
+  Int64_val(v) = i;
+
+  return v;
+}
+
+static value
+copy_string_outside_heap(char const *s)
+{
+  int len;
+  mlsize_t wosize, offset_index;
+  value result;
+
+  len = strlen(s);
+  wosize = (len + sizeof (value)) / sizeof (value);
+  result = allocate_outside_heap_with_tag(wosize * sizeof(value), String_tag);
+
+  Field (result, wosize - 1) = 0;
+  offset_index = Bsize_wsize (wosize) - 1;
+  Byte (result, offset_index) = offset_index - len;
+  memmove(String_val(result), s, len);
+
+  return result;
+}
+
+static value
+allocate_loc_outside_heap(struct caml_loc_info li)
+{
+  value result;
+
+  if (li.loc_valid) {
+    result = allocate_outside_heap_with_tag(5 * sizeof(value), 0);
+    Field(result, 0) = Val_bool(li.loc_is_raise);
+    Field(result, 1) = copy_string_outside_heap(li.loc_filename);
+    Field(result, 2) = Val_int(li.loc_lnum);
+    Field(result, 3) = Val_int(li.loc_startchr);
+    Field(result, 4) = Val_int(li.loc_endchr);
+  } else {
+    result = allocate_outside_heap_with_tag(sizeof(value), 1);
+    Field(result, 0) = Val_bool(li.loc_is_raise);
+  }
+
+  return result;
+}
+
+value caml_spacetime_timestamp(double time_override, int use_time_override)
+{
+  double time;
+  value v_time;
+
+  if (!use_time_override) {
+    time = caml_sys_time_unboxed(Val_unit);
+  }
+  else {
+    time = time_override;
+  }
+
+  v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
+  Double_field(v_time, 0) = time;
+
+  return v_time;
+}
+
+value caml_spacetime_frame_table(void)
+{
+  /* Flatten the frame table into a single associative list. */
+
+  value list = Val_long(0);  /* the empty list */
+  uintnat i;
+
+  if (!caml_debug_info_available()) {
+    return list;
+  }
+
+  if (caml_frame_descriptors == NULL) {
+    caml_init_frame_descriptors();
+  }
+
+  for (i = 0; i <= caml_frame_descriptors_mask; i++) {
+    frame_descr* descr = caml_frame_descriptors[i];
+    if (descr != NULL) {
+      value location, return_address, pair, new_list_element, location_list;
+      struct caml_loc_info li;
+      debuginfo dbg;
+      if (descr->frame_size != 0xffff) {
+        dbg = caml_debuginfo_extract(descr);
+        if (dbg != NULL) {
+          location_list = Val_unit;
+          while (dbg != NULL) {
+            value list_element;
+
+            caml_debuginfo_location(dbg, &li);
+            location = allocate_loc_outside_heap(li);
+
+            list_element =
+              allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+            Field(list_element, 0) = location;
+            Field(list_element, 1) = location_list;
+            location_list = list_element;
+
+            dbg = caml_debuginfo_next(dbg);
+          }
+
+          return_address = allocate_int64_outside_heap(descr->retaddr);
+          pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0);
+          Field(pair, 0) = return_address;
+          Field(pair, 1) = location_list;
+
+          new_list_element =
+            allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+          Field(new_list_element, 0) = pair;
+          Field(new_list_element, 1) = list;
+          list = new_list_element;
+        }
+      }
+    }
+  }
+
+  return list;
+}
+
+static void add_unit_to_shape_table(uint64_t *unit_table, value *list)
+{
+  /* This function reverses the order of the lists giving the layout of each
+     node; however, spacetime_profiling.ml ensures they are emitted in
+     reverse order, so at the end of it all they're not reversed. */
+
+  uint64_t* ptr = unit_table;
+
+  while (*ptr != (uint64_t) 0) {
+    value new_list_element, pair, function_address, layout;
+
+    function_address =
+      allocate_int64_outside_heap(*ptr++);
+
+    layout = Val_long(0);  /* the empty list */
+    while (*ptr != (uint64_t) 0) {
+      int tag;
+      int stored_tag;
+      value part_of_shape;
+      value new_part_list_element;
+      value location;
+      int has_extra_argument = 0;
+
+      stored_tag = *ptr++;
+      /* CR-soon mshinwell: share with emit.mlp */
+      switch (stored_tag) {
+        case 1:  /* direct call to given location */
+          tag = 0;
+          has_extra_argument = 1;  /* the address of the callee */
+          break;
+
+        case 2:  /* indirect call to given location */
+          tag = 1;
+          break;
+
+        case 3:  /* allocation at given location */
+          tag = 2;
+          break;
+
+        default:
+          Assert(0);
+          abort();  /* silence compiler warning */
+      }
+
+      location = allocate_int64_outside_heap(*ptr++);
+
+      part_of_shape = allocate_outside_heap_with_tag(
+        sizeof(value) * (has_extra_argument ? 2 : 1), tag);
+      Field(part_of_shape, 0) = location;
+      if (has_extra_argument) {
+        Field(part_of_shape, 1) =
+          allocate_int64_outside_heap(*ptr++);
+      }
+
+      new_part_list_element =
+        allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+      Field(new_part_list_element, 0) = part_of_shape;
+      Field(new_part_list_element, 1) = layout;
+      layout = new_part_list_element;
+    }
+
+    pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0);
+    Field(pair, 0) = function_address;
+    Field(pair, 1) = layout;
+
+    new_list_element =
+      allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+    Field(new_list_element, 0) = pair;
+    Field(new_list_element, 1) = *list;
+    *list = new_list_element;
+
+    ptr++;
+  }
+}
+
+value caml_spacetime_shape_table(void)
+{
+  value list;
+  uint64_t* unit_table;
+  shape_table *dynamic_table;
+  uint64_t** static_table;
+
+  /* Flatten the hierarchy of shape tables into a single associative list
+     mapping from function symbols to node layouts.  The node layouts are
+     themselves lists. */
+
+  list = Val_long(0);  /* the empty list */
+
+  /* Add static shape tables */
+  static_table = caml_spacetime_static_shape_tables;
+  while (*static_table != (uint64_t) 0) {
+    unit_table = *static_table++;
+    add_unit_to_shape_table(unit_table, &list);
+  }
+
+  /* Add dynamic shape tables */
+  dynamic_table = caml_spacetime_dynamic_shape_tables;
+
+  while (dynamic_table != NULL) {
+    unit_table = dynamic_table->table;
+    add_unit_to_shape_table(unit_table, &list);
+    dynamic_table = dynamic_table->next;
+  }
+
+  return list;
+}
+
+#else
+
+static value spacetime_disabled()
+{
+  caml_failwith("Spacetime profiling not enabled");
+  Assert(0);  /* unreachable */
+}
+
+CAMLprim value caml_spacetime_take_snapshot(value ignored)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_marshal_frame_table ()
+{
+  return spacetime_disabled();
+}
+
+CAMLprim value caml_spacetime_frame_table ()
+{
+  return spacetime_disabled();
+}
+
+CAMLprim value caml_spacetime_marshal_shape_table ()
+{
+  return spacetime_disabled();
+}
+
+CAMLprim value caml_spacetime_shape_table ()
+{
+  return spacetime_disabled();
+}
+
+#endif
diff --git a/asmrun/sparc.S b/asmrun/sparc.S
new file mode 100644
index 00000000..b46e71f0
--- /dev/null
+++ b/asmrun/sparc.S
@@ -0,0 +1,360 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Asm part of the runtime system for the Sparc processor.  */
+/* Must be preprocessed by cpp */
+
+#ifndef SYS_solaris
+#define INDIRECT_LIMIT
+#endif
+
+#define Exn_ptr %l5
+#define Alloc_ptr %l6
+#define Alloc_limit %l7
+
+#define Load(symb,reg)  sethi %hi(symb), %g1; ld [%g1 + %lo(symb)], reg
+#define Store(reg,symb) sethi %hi(symb), %g1; st reg, [%g1 + %lo(symb)]
+#define Address(symb,reg) sethi %hi(symb), reg; or reg, %lo(symb), reg
+
+/* Allocation functions */
+
+        .text
+
+        .global  caml_system__code_begin
+caml_system__code_begin:
+
+        .global caml_allocN
+        .global caml_call_gc
+
+/* Required size in %g2 */
+caml_allocN:
+#ifdef INDIRECT_LIMIT
+        ld      [Alloc_limit], %g1
+        sub     Alloc_ptr, %g2, Alloc_ptr
+        cmp     Alloc_ptr, %g1
+#else
+        sub     Alloc_ptr, %g2, Alloc_ptr
+        cmp     Alloc_ptr, Alloc_limit
+#endif
+        /*blu,pt  %icc, caml_call_gc*/
+        blu     caml_call_gc
+        nop
+        retl
+        nop
+
+/* Required size in %g2 */
+caml_call_gc:
+    /* Save exception pointer if GC raises */
+        Store(Exn_ptr, caml_exception_pointer)
+    /* Save current allocation pointer for debugging purposes */
+        Store(Alloc_ptr, caml_young_ptr)
+    /* Record lowest stack address */
+        Store(%sp, caml_bottom_of_stack)
+    /* Record last return address */
+        Store(%o7, caml_last_return_address)
+    /* Allocate space on stack for caml_context structure and float regs */
+        sub     %sp, 20*4 + 15*8, %sp
+    /* Save int regs on stack and save it into caml_gc_regs */
+L100:   add     %sp, 96 + 15*8, %g1
+        st      %o0, [%g1]
+        st      %o1, [%g1 + 0x4]
+        st      %o2, [%g1 + 0x8]
+        st      %o3, [%g1 + 0xc]
+        st      %o4, [%g1 + 0x10]
+        st      %o5, [%g1 + 0x14]
+        st      %i0, [%g1 + 0x18]
+        st      %i1, [%g1 + 0x1c]
+        st      %i2, [%g1 + 0x20]
+        st      %i3, [%g1 + 0x24]
+        st      %i4, [%g1 + 0x28]
+        st      %i5, [%g1 + 0x2c]
+        st      %l0, [%g1 + 0x30]
+        st      %l1, [%g1 + 0x34]
+        st      %l2, [%g1 + 0x38]
+        st      %l3, [%g1 + 0x3c]
+        st      %l4, [%g1 + 0x40]
+        st      %g3, [%g1 + 0x44]
+        st      %g4, [%g1 + 0x48]
+        st      %g2, [%g1 + 0x4C]       /* Save required size */
+        mov     %g1, %g2
+        Store(%g2, caml_gc_regs)
+    /* Save the floating-point registers */
+        add     %sp, 96, %g1
+        std     %f0, [%g1]
+        std     %f2, [%g1 + 0x8]
+        std     %f4, [%g1 + 0x10]
+        std     %f6, [%g1 + 0x18]
+        std     %f8, [%g1 + 0x20]
+        std     %f10, [%g1 + 0x28]
+        std     %f12, [%g1 + 0x30]
+        std     %f14, [%g1 + 0x38]
+        std     %f16, [%g1 + 0x40]
+        std     %f18, [%g1 + 0x48]
+        std     %f20, [%g1 + 0x50]
+        std     %f22, [%g1 + 0x58]
+        std     %f24, [%g1 + 0x60]
+        std     %f26, [%g1 + 0x68]
+        std     %f28, [%g1 + 0x70]
+    /* Call the garbage collector */
+        call    caml_garbage_collection
+        nop
+    /* Restore all regs used by the code generator */
+        add     %sp, 96 + 15*8, %g1
+        ld      [%g1], %o0
+        ld      [%g1 + 0x4], %o1
+        ld      [%g1 + 0x8], %o2
+        ld      [%g1 + 0xc], %o3
+        ld      [%g1 + 0x10], %o4
+        ld      [%g1 + 0x14], %o5
+        ld      [%g1 + 0x18], %i0
+        ld      [%g1 + 0x1c], %i1
+        ld      [%g1 + 0x20], %i2
+        ld      [%g1 + 0x24], %i3
+        ld      [%g1 + 0x28], %i4
+        ld      [%g1 + 0x2c], %i5
+        ld      [%g1 + 0x30], %l0
+        ld      [%g1 + 0x34], %l1
+        ld      [%g1 + 0x38], %l2
+        ld      [%g1 + 0x3c], %l3
+        ld      [%g1 + 0x40], %l4
+        ld      [%g1 + 0x44], %g3
+        ld      [%g1 + 0x48], %g4
+        ld      [%g1 + 0x4C], %g2     /* Recover desired size */
+        add     %sp, 96, %g1
+        ldd     [%g1], %f0
+        ldd     [%g1 + 0x8], %f2
+        ldd     [%g1 + 0x10], %f4
+        ldd     [%g1 + 0x18], %f6
+        ldd     [%g1 + 0x20], %f8
+        ldd     [%g1 + 0x28], %f10
+        ldd     [%g1 + 0x30], %f12
+        ldd     [%g1 + 0x38], %f14
+        ldd     [%g1 + 0x40], %f16
+        ldd     [%g1 + 0x48], %f18
+        ldd     [%g1 + 0x50], %f20
+        ldd     [%g1 + 0x58], %f22
+        ldd     [%g1 + 0x60], %f24
+        ldd     [%g1 + 0x68], %f26
+        ldd     [%g1 + 0x70], %f28
+    /* Reload alloc ptr */
+        Load(caml_young_ptr, Alloc_ptr)
+    /* Allocate space for block */
+#ifdef INDIRECT_LIMIT
+        ld      [Alloc_limit], %g1
+        sub     Alloc_ptr, %g2, Alloc_ptr
+        cmp     Alloc_ptr, %g1      /* Check that we have enough free space */
+#else
+        Load(caml_young_limit,Alloc_limit)
+        sub     Alloc_ptr, %g2, Alloc_ptr
+        cmp     Alloc_ptr, Alloc_limit
+#endif
+        blu     L100                /* If not, call GC again */
+        nop
+    /* Return to caller */
+        Load(caml_last_return_address, %o7)
+        retl
+        add     %sp, 20*4 + 15*8, %sp       /* in delay slot */
+
+/* Call a C function from Ocaml */
+
+        .global caml_c_call
+/* Function to call is in %g2 */
+caml_c_call:
+    /* Record lowest stack address and return address */
+        Store(%sp, caml_bottom_of_stack)
+        Store(%o7, caml_last_return_address)
+    /* Save the exception handler and alloc pointer */
+        Store(Exn_ptr, caml_exception_pointer)
+        sethi   %hi(caml_young_ptr), %g1
+    /* Call the C function */
+        call    %g2
+        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(caml_young_ptr), %g1
+    /* Return to caller */
+        retl
+        ld      [%g1 + %lo(caml_young_ptr)], Alloc_ptr   /* in delay slot */
+
+/* Start the Ocaml program */
+
+        .global caml_start_program
+caml_start_program:
+    /* Save all callee-save registers */
+        save    %sp, -96, %sp
+    /* Address of code to call */
+        Address(caml_program, %l2)
+
+    /* Code shared with caml_callback* */
+L108:
+    /* Set up a callback link on the stack. */
+        sub     %sp, 16, %sp
+        Load(caml_bottom_of_stack, %l0)
+        Load(caml_last_return_address, %l1)
+        Load(caml_gc_regs, %l3)
+        st      %l0, [%sp + 96]
+        st      %l1, [%sp + 100]
+    /* Set up a trap frame to catch exceptions escaping the Ocaml code */
+        call    L111
+        st      %l3, [%sp + 104]
+        b       L110
+        nop
+L111:   sub     %sp, 8, %sp
+        Load(caml_exception_pointer, Exn_ptr)
+        st      %o7, [%sp + 96]
+        st      Exn_ptr, [%sp + 100]
+        mov     %sp, Exn_ptr
+    /* Reload allocation pointers */
+        Load(caml_young_ptr, Alloc_ptr)
+#ifdef INDIRECT_LIMIT
+        Address(caml_young_limit, Alloc_limit)
+#else
+        Load(caml_young_limit, Alloc_limit)
+#endif
+    /* Call the Ocaml code */
+L109:   call    %l2
+        nop
+    /* Pop trap frame and restore caml_exception_pointer */
+        ld      [%sp + 100], Exn_ptr
+        add     %sp, 8, %sp
+        Store(Exn_ptr, caml_exception_pointer)
+    /* Pop callback link, restoring the global variables */
+L112:   ld      [%sp + 96], %l0
+        ld      [%sp + 100], %l1
+        ld      [%sp + 104], %l2
+        Store(%l0, caml_bottom_of_stack)
+        Store(%l1, caml_last_return_address)
+        Store(%l2, caml_gc_regs)
+        add     %sp, 16, %sp
+    /* Save allocation pointer */
+        Store(Alloc_ptr, caml_young_ptr)
+    /* Reload callee-save registers and return */
+        ret
+        restore %o0, 0, %o0     /* copy %o0 in this window to caller's %o0 */
+L110:
+    /* The trap handler */
+        Store(Exn_ptr, caml_exception_pointer)
+    /* Encode exception bucket as an exception result */
+        b       L112
+        or      %o0, 2, %o0
+
+/* Raise an exception from C */
+
+        .global 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 */
+        Load(caml_exception_pointer, %g3)
+    /* Pop some frames until the trap pointer is in the current frame. */
+        cmp     %g3, %fp
+        blt     L107                    /* if Exn_ptr < %fp, over */
+        nop
+L106:   restore
+        cmp     %fp, %g3                /* if %fp <= Exn_ptr, loop */
+        ble     L106
+        nop
+L107:
+    /* Reload allocation registers */
+        Load(caml_young_ptr, Alloc_ptr)
+#ifdef INDIRECT_LIMIT
+        Address(caml_young_limit, Alloc_limit)
+#else
+        Load(caml_young_limit, Alloc_limit)
+#endif
+    /* Branch to exception handler */
+        mov     %g3, %sp
+        ld      [%sp + 96], %g1
+        ld      [%sp + 100], Exn_ptr
+        add     %sp, 8, %sp
+        jmp     %g1 + 8
+    /* Restore bucket, in delay slot */
+        mov     %g2, %o0
+
+/* Callbacks C -> ML */
+
+        .global caml_callback_exn
+caml_callback_exn:
+    /* Save callee-save registers and return address */
+        save    %sp, -96, %sp
+    /* Initial shuffling of arguments */
+        mov     %i0, %g1
+        mov     %i1, %i0        /* first arg */
+        mov     %g1, %i1        /* environment */
+        b       L108
+        ld      [%g1], %l2      /* code pointer */
+
+        .global caml_callback2_exn
+caml_callback2_exn:
+    /* Save callee-save registers and return address */
+        save    %sp, -104, %sp
+    /* Initial shuffling of arguments */
+        mov     %i0, %g1
+        mov     %i1, %i0        /* first arg */
+        mov     %i2, %i1        /* second arg */
+        mov     %g1, %i2        /* environment */
+        sethi   %hi(caml_apply2), %l2
+        b       L108
+        or      %l2, %lo(caml_apply2), %l2
+
+        .global caml_callback3_exn
+caml_callback3_exn:
+    /* Save callee-save registers and return address */
+        save    %sp, -104, %sp
+    /* Initial shuffling of arguments */
+        mov     %i0, %g1
+        mov     %i1, %i0        /* first arg */
+        mov     %i2, %i1        /* second arg */
+        mov     %i3, %i2        /* third arg */
+        mov     %g1, %i3        /* environment */
+        sethi   %hi(caml_apply3), %l2
+        b       L108
+        or      %l2, %lo(caml_apply3), %l2
+
+#ifndef SYS_solaris
+/* Glue code to call [caml_array_bound_error] */
+
+        .global caml_ml_array_bound_error
+caml_ml_array_bound_error:
+        Address(caml_array_bound_error, %g2)
+        b       caml_c_call
+        nop
+#endif
+
+        .global caml_system__code_end
+caml_system__code_end:
+
+#ifdef SYS_solaris
+        .section ".rodata"
+#else
+        .data
+#endif
+        .global caml_system__frametable
+        .align  4               /* required for gas? */
+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_allocN, #function
+        .type caml_call_gc, #function
+        .type caml_c_call, #function
+        .type caml_start_program, #function
+        .type caml_raise_exception, #function
+        .type caml_system__frametable, #object
+#endif
diff --git a/asmrun/startup.c b/asmrun/startup.c
new file mode 100644
index 00000000..70bbc436
--- /dev/null
+++ b/asmrun/startup.c
@@ -0,0 +1,159 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Start-up code */
+
+#include 
+#include 
+#include "caml/callback.h"
+#include "caml/backtrace.h"
+#include "caml/custom.h"
+#include "caml/debugger.h"
+#include "caml/fail.h"
+#include "caml/freelist.h"
+#include "caml/gc.h"
+#include "caml/gc_ctrl.h"
+#include "caml/intext.h"
+#include "caml/memory.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/osdeps.h"
+#include "caml/printexc.h"
+#include "caml/stack.h"
+#include "caml/startup_aux.h"
+#include "caml/sys.h"
+#ifdef WITH_SPACETIME
+#include "caml/spacetime.h"
+#endif
+#ifdef HAS_UI
+#include "caml/ui.h"
+#endif
+
+extern int caml_parser_trace;
+CAMLexport header_t caml_atom_table[256];
+char * caml_code_area_start, * caml_code_area_end;
+
+/* Initialize the atom table and the static data and code area limits. */
+
+struct segment { char * begin; char * end; };
+
+static void init_static(void)
+{
+  extern struct segment caml_data_segments[], caml_code_segments[];
+  int i;
+  struct code_fragment * cf;
+
+  caml_init_atom_table ();
+
+  for (i = 0; caml_data_segments[i].begin != 0; i++) {
+    /* PR#5509: we must include the zero word at end of data segment,
+       because pointers equal to caml_data_segments[i].end are static data. */
+    if (caml_page_table_add(In_static_data,
+                            caml_data_segments[i].begin,
+                            caml_data_segments[i].end + sizeof(value)) != 0)
+      caml_fatal_error("Fatal error: not enough memory for initial page table");
+  }
+
+  caml_code_area_start = caml_code_segments[0].begin;
+  caml_code_area_end = caml_code_segments[0].end;
+  for (i = 1; caml_code_segments[i].begin != 0; i++) {
+    if (caml_code_segments[i].begin < caml_code_area_start)
+      caml_code_area_start = caml_code_segments[i].begin;
+    if (caml_code_segments[i].end > caml_code_area_end)
+      caml_code_area_end = caml_code_segments[i].end;
+  }
+  /* Register the code in the table of code fragments */
+  cf = caml_stat_alloc(sizeof(struct code_fragment));
+  cf->code_start = caml_code_area_start;
+  cf->code_end = caml_code_area_end;
+  cf->digest_computed = 0;
+  caml_ext_table_init(&caml_code_fragments_table, 8);
+  caml_ext_table_add(&caml_code_fragments_table, cf);
+}
+
+/* These are termination hooks used by the systhreads library */
+struct longjmp_buffer caml_termination_jmpbuf;
+void (*caml_termination_hook)(void *) = NULL;
+
+extern value caml_start_program (void);
+extern void caml_init_ieee_floats (void);
+extern void caml_init_signals (void);
+
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
+
+/* PR 4887: avoid crash box of windows runtime on some system calls */
+extern void caml_install_invalid_parameter_handler();
+
+#endif
+
+value caml_startup_exn(char **argv)
+{
+  char * exe_name, * proc_self_exe;
+  char tos;
+
+#ifdef WITH_SPACETIME
+  caml_spacetime_initialize();
+#endif
+  caml_init_frame_descriptors();
+  caml_init_ieee_floats();
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
+  caml_install_invalid_parameter_handler();
+#endif
+  caml_init_custom_operations();
+  caml_top_of_stack = &tos;
+#ifdef DEBUG
+  caml_verb_gc = 0x3F;
+#endif
+  caml_parse_ocamlrunparam();
+#ifdef DEBUG
+  caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
+#endif
+  caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
+                caml_init_heap_chunk_sz, caml_init_percent_free,
+                caml_init_max_percent_free, caml_init_major_window);
+  init_static();
+  caml_init_signals();
+  caml_init_backtrace();
+  caml_debugger_init (); /* force debugger.o stub to be linked */
+  exe_name = argv[0];
+  if (exe_name == NULL) exe_name = "";
+  proc_self_exe = caml_executable_name();
+  if (proc_self_exe != NULL)
+    exe_name = proc_self_exe;
+  else
+    exe_name = caml_search_exe_in_path(exe_name);
+  caml_sys_init(exe_name, argv);
+  if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) {
+    if (caml_termination_hook != NULL) caml_termination_hook(NULL);
+    return Val_unit;
+  }
+  return caml_start_program();
+}
+
+void caml_startup(char **argv)
+{
+  value res = caml_startup_exn(argv);
+
+  if (Is_exception_result(res)) {
+    caml_fatal_uncaught_exception(Extract_exception(res));
+  }
+}
+
+void caml_main(char **argv)
+{
+  caml_startup(argv);
+}
diff --git a/boot/ocamlc b/boot/ocamlc
new file mode 100755
index 0000000000000000000000000000000000000000..6096b0c99c3c605688c806fd2a6ee18afb0d1e98
GIT binary patch
literal 2152368
zcmeF)3%KQ1Ss(r+lgk+g1tJNFkj$Jj_e&rQB$5D`6K0YS0!9J>On@ZLKqe3p5NRY3
zf+kF&paK=)k4o(yDqbqumU^pJ0Y$tO6+{sVR;^WAte2{IO~0Q#>mAoD_CDuKG68&^
zt|#BD^{(}<_rBKexA!?S^NeGTIp!0`<$r0<3XVPIfyX>3{g(z04>ksm2);a63@#0>
z2(AvU556|IEjSQ-Yw*@!Z?GjeHqdqlUli;N=7U{JoYcgvuXuA$FG3r
zgcb0dxB{M&2A(~k*979EuQ(Ym26F))`Jr7D%;JAQ)-DWI2mPLDIgpd(Vn@$%JajI{
z^TjLR`I3%jYsTAxs-dwq&&b;5;8DTj0x`Kf_^M!U@RHy)!8Zlp7Q8+9-e6iyvA^QJ
zka1t16?5^M##i!|~efnx6AQW?G|5OyK*c>>Q@}c`en0L
z^=mKw-GSWOUwh3%U(0;a@LL;mR`p!A&El(?UXG8BmE@vodpUVk-}t82_vy!cS=Rd6
zz995v!8O6lg1dt62!1H|@!c+k_>r`6H4=g~C2@eIqS{E{no_EbL2F9!O)CRVbCoPN)d
z-brk+zwV?X-CuV>?VlAlHB8T{K%2$qovr6vNemv`_BaFDO7@%_zCLcV?D78C+jFGx
zc}Uw|@mYy&r>xMnQwQ5tBKx6(>?8H(w9cO$8M`mFg@3r`o}PaHK;QC@_uPZ8?yUhjanVDB>+DiPySNW|w-924$>4et?T2vl--#4~aw(749J{UOH
zcLo~1b6W3ngr?4K4xDA23JUPIl>ge>XQv)^AUd^&8#3X|nca(mU9^#WXQ^LXuZ8
zsP)~M-x#p7=Ik+kSWs*3B)sb1Io%%E^B4Era}Pb229@X0k3Ctl$9_H9nL_K&Z9O>)
z0iGILM?bdpbmCbIG&<`YfZTfS;wvBcLtgn}9&KJ+t_b?L@O!yE@9y@vhskk{#i_n;
zV8itRo9L@^jHmcZZ>A_p#Srx;F)@0r;WTJKcMZ=Y(ejnfmJj`6FxO@$A?f
ztPV8x$Z^?lY{perzmzdOcLo~S*4byjv2*2_#4g`G$Pf9>(m4VDuMV`k4|Wq>hPMYf
z_V?6Yw$>b9>ik}t@dpFvt!(>+MpwMNyRnBYHw7i9&i!KMG&;yFon`Nw#k4H}o3$4Q
z#b+OSmR+S=E=HYV?rez3jsUNAM|{__r{?+d_RRCOblH1C(C3JZvP~}527JJ0pInKF
zbGt4mpSEP&=i8Xhy8=!8%oQ#F=!)5=GA5X8?Mdz2Lo}anC#E^+`w6~SN)D_70X&H+r>^U)Cd2s34FI8H@_V4-I{yvlYv&c
z$2;N!S-UFm?n*zqyw{RH^8Re*@RDU6uQ7Wx`pMIb@fUB|Zr|QOZh`H`XR_oJ-_gv^
z$bN9)ra^Ly>C;nRN!=(9)8wHt#U$tLH+XHapgGmzn7
z>+J5=D+WuQkzdK4<<1D-`M}02f?a`jRZu>;r^Jb!^zq{rfq3@*^Ggig6lnNQ4V=#_
zgQ^QMe8wf`)d4vt1?L3j-DP+;1r;lEi>
zCcahdZqJzAmDAE$wMdpT%%;jOo)5MBR$j$I9rZDNcj%)XQ=jj}Lfk4xVt0DL7Hen4
zA?xh6#`b%^KUB3;EE<^o%2O
zT~K?`^BtYxp=T+6?e5^7;KTs`LNLlNd0Vr#Es%Sy@-1dHuH4_$=Ddel-{19~U)Kd<
zLzXjFJSS&77u0%&6MxuyeUK8mNBmyi=F1lKt*I%kY&L#zNB2J1Te*2j#^TuTuX-oT
zc-G$ctYB|gCgD1=;q#;x!#U%ALwr!=$i-n>d<|BE)U(?y(cs~wstz#HW_`)e&KHqem22t
zp5M;nU;O>y@;?!}xA%hseL-k4PH8gK$)nqxcXex?rzL-LTXSDo^Bk$QhYf3XT+V9tA>-m|52{6Sl*IrjeMl(}DSbEh^LXLK@trmeA^e9xSc
z|DIuuU3i?!vhSUZr~F&jc%1Fx`L@PW{#6X*==Qc&b9{J7o2!_+&*<%CUK^gicCHM)
zrt$SPaB1crka@O{eL-l?6Y|UfJ9cJXZJZzUHL^MLc->DWtL3ErL
zXua%LWQ`4;J^lQP2O0YY`s#tce4sBH=*JKAqeIhsR-k`m>vwi^Z_h&Ge{5U-^46c1
zzUO;T<9k9|m(PCvxWSIU`J2OI{prx`*)#0>%YDAZ*KitTK~4ze`o98-umxu{X4qeS@BM$xu>5Js57E-J=MzzIg#_l25IED8|2WO@nWEnT{4|(I!b1S6FKe~t(QZF
zee;2_^TaRDi?VNT#$=J%+lS_-=c6&X>|h^%*+{NAy6IU6db`OLgVNE*z!>N_rH$zz
zx7XngC6^v!=;ORT^r%yeO6RJKr};(CQhr&()5pDJ&hkU7tS#jSx#9)AAKstmg3{63
zO(uwyeWMQkL&ayI@v*(+(kmaMT=ON@xX&|PeSX)6rpLVcIVoVvEV<%`pM0OAHRH9D
z(c!g
zI^mO8^!7V58vDJoY3yYqdskxrs_^lvd}6=+nA2w2`^c;w`Y-8$ydMom$z>7O@sju|7K(ZC5uHYy4xZ%U-t62ij7$s|7VB?`nk~
z&Z5tAY(|Uqx`55)YxyGw=Ctxdt@M68D)dr*@B!Go+?|O>eDKrDHs{G4oow9K#`0RR
zIuafHSWd^@DLSUr{?RzQe3l#emJhK<^S#ah-{n%PJX9R&?BXBuz|V@&{bfIU?v4Ew
z80;z={PO2MxUHpKGMU-
zy2r}LJ2R&pAK0r-SN&HLi=fZD!cNZ>I+hVCUD&L+Xa^P$&7jN(O)8gIh?Q8tL=$chyy{>7s
zO=tPj>tD#cbGR62#j~8xvvS?rQ8`vyM_d2NkvT2q@;o0@O=mdqsp@-tCN6iTr`?nN
zXB2wWu-2d5S^E08+GBq`1NUTH_tbcAmEC+B*X(guEe6_1FHU9;#$hgFK0hXqYccHa
zvXGN{AcJl4tQpsPUvDS7(9TZfUOhQSYRh_GUyGqNy4j+6zKB=F#+Z%p*x;-{+ZZ^H
zWv`lIKOJSScS4Q5__U?$t!I#WVh@{N8))R31AN89xAg&?i-EQ!SRJeiim&?OCvP#(
zil6=RiLN^8>GBnycIUzFu=~2=z-N2$^4XZ(w+H!=#XaoU6o{eNp4)(LG0?_mo4JY+
z`QCfA(q&8+o{F=$lrFK`7x3@+K(m((*9YvXwLbr&-@Ogus@-w0o8-Z;x1oGq&X$s4
zuiV{DP}(&6dOxPwDi2z3>jej=CO(U~R&m;$v6?{F`Ki6m+Cm^VcLo|?#8aK&TMRU3
zzn)$F=ZyoC)q}j#_K71|S{5?;(P`OmjYc
z52W?ybKAkG!_KEz!mK#dnd|Q_w#+qIRXfx2Hf;}o`}sakCAWN{0`Cn08^11~$K1_<
zy~f^o-6!H`?$M35r>FOat~vgm7ah6Jy*pqROnX*u%)E2Mmuc&jqrQ&Bl05D1gWV){;@{WUv^{wG`JR88+{?qilzmkj
zy-dC=2HG^4)|aw%+Wxu|r^Tpj=zZz!VS`%IDqhoU=+ES|{Y%;0?=5}eM({7cON(ueXn3`7teS{hr?UY5T>k=kIy?y`|3`QTL#qKi8e%9(4XS_u$!+
z(c$ONS=V+4Vy|E7{MGrwyBKKfn466Lsa~qa`gl*~Gq8^z-u=C?Q-vze?-!RnyyX8f9X;E~@)2AVN`&7EsqUipqDukvlJYW=ktYh=nN
zSYHe@@9O5rsn04sZ=X9liofR-H}y>Jef?Z>U;Vv1HfX&MUnu^HlUDh?BV###LtyRB
zU{&y*K$G)-HyIs%zF#wC&hLC^RRj8}3I0R>4pepFb2b~;G;Lk}_Xd3(;9U%~KDJvz
zt7r0N=_`4?j9&IMdGz=EJx{;)Nc8vndU?H`UY_}-;?v9MWlxjGpPs+x>GziY{#kHV
z_SW6$S>W!_#{0n?WNxj+H1$A_o^F`tPu=moO}(vbs^>*N-}4tw*_ka9-8ZDS=kxiV
z`?~1w&)T~~Yhv{SlhNU4?UhsJzNXFfF&)oZ-M@D?-bbgeb2hHYxti#6-^a6$bJawh
zv01YE{k`02vgq#ld!BypN_F>pdRe`WUY7Y;e)Ri$xzl9vqv!8=`n{#QKUX`lx9Zio
z!lS7RpHDQ;**aIwj@H)z-7xy{`8-qi_j}W?=l#cd;S$F^
z?|AfT`1*MLm&AhI`y1Hg-PQYIzt?^~JTx%oC;O)Pxw`R?)%(DH?~-JbVZEOVIk8XO
zvt1kQ{Y32Dn|VGLU)jlzl53s4rw3Z)$e8Wc+0F*E_!iCPlLNW%erb&z3&CQbRW9&q
zR|dxiY!G|(>*RGr`a>j=E^BM?BoBaiyx;1+L*&T4^B^N
z%Wzkt*)1>R-5$im$)73c{iA!Df8uo@(B=a9l*=)nWLF$AJm$kK4q`AX4*2-v?$>7d
z!**>Yez5PnpzLG+ct*@k^XvR>UxtVF^?v=@48QR6MO|xrao1H$+4Zkdi=9=FV1@T
zeOlzN4to8s8uVY#;HuI93#gwi44B>ed(z6
zQ`@@pgU?ykd*{-7C)TfPz4)LvwB9>F&tLo2w)y$i^8?>mt$$?e#lpPLQhN89-m_ir
z&egl8^cS?g{+!N*jdr(Le^Tq8-1?^u^OrUHilKK;+W+jOc;}+1>hzU`udZpnkRm_=@-DjB7o^
z$)8idF1?!4UK`vR)bqo0`gd|y*+YibkM9b7VbJftDs;bpUFd#KKenHK?SKUOxMK{XY}BU;k+6UjJ`}?)85%bgzG1=-%gk
z%zm`PAz)=rflA
z9(C&;DBds2n2yDubfDEmPd{;>oxxhqa1z5C(|gZyew=l*cgAt!v!qbA>4Ur+ah
zo(sfmPaxOsJ#Ax9dn;D%M(uwM?-Vx<^pgg9!$3c1p#Q!-ze@g}wdWk#+5g?PPPh1|
zg$D)df&F@M)?3%(QLEN9_nNVL?V>gU%~ylu8qY+?$nF;S|eMd$Jv42
z7POqaH&7R#P8WimfwSSP&_!m?E6$Z4<5fY~C*QyZ@6pEWqp!EmK21DIcGa8?r+d_o&pvwjU3~QBNFMr3tVY>dK2OtE{`PW4ePqzr``hy`r`KLk
zqt6T01#D-JW^7&S$L=v_9G|ndDWF%YHT0~tBiUCm8f{%0`DJVIR2=Iro?}p2od@x&
zdbXyXFAm0gSsp!K#YK#rTj0<7U~jN5xGG=+U(XHj+S8u}ym-je-V~I*<?&N?kY+4tvfArhja(>gP
z^?vtxaxU1Q^*)YydQ#R$f9NNRAAS79WsEUjN`8MXX2o1?#CfImT^iocrF~I%$RED1
zq$Zv`#YXv2zjc>;UWmztKz!w*B|w0yeUz&dcgX-Y=@vXX<73ZtMTegX(IP=??Ul(i-
zH2Xgp-PT?goFDK@E7{gwAE;^dT(S1PPEJp6YqWe>SFakqY_9#a{?N?XU$k29Y3rK(
zYl4#yX=;&dG(GA>I}pqT^jsgP1MBGLx3N0e7nB}yb_X{F#+L@{S+4fJcgUGNl^3>>
zSpVpz^Ht`aG`>%?|C30N*N^Aamx4WOgR?un3p180_VHnN>z|%p{$3M^
z9iFcaMjm#(wym#3#@Eh}VSc4{sFi7U>^%Y*Uo%67_-W4FjRBv0ZW9;1xSSZgCaAcm
zXSsf9V2}8+ak+h^L$9vvXV;O+pnJJ}&YQC*U#ABviFMef#@RX0*zMUNHhQt4M_j63
zmGNuZocZO>^^W0OXUk_j>)x9=ckwQZX=L)tIhQZ(H35B4_rWVOc4o?cc01>C{_tQv
zaIXJ%v%%gv`^)LdmdWp4kXicbow(QM437Hh`9t5d{q~G&H)oD*=GBgU&cwrl&A~~*
zDM3AtGo0|}M-7wb&Fe!SAMjthBXHk~VdYLt$?R#iX!zCB$nR_v|K5!0XQMMxn`xpzNZ5LqIm26?gF&b&*+hA^zHy0Pi`$Q-bl`dsXIoIpWH`vbAb-b(_B}
zy*d^H=Yfw^clH@Cw0V1~jvkURJMiBcknyMOEU=Ni_r?x+8to9*`GBtFZ1}SoHn0co
z3N(2kuW0pbUChPmQ-O0M1{EW*5Z~IP?(AV-#n&Eu_NWy(maC@*W3JS{{rG!a7y67q
z9Qzu?3#ETKAKn|@qv^v}MBb73pw>qp#IKJ#ztvIsB&O)f!{|dF)62s*+9O_c$VuVa
zj4unux}*o>xIZJ_{T71i*(AS@3idZVFuiv!jStS5bN}K1e}6uV+2r1!&t1tswvx9T
zzj)Chm-f-q*IUJa4tA4A?kj`-873a=Cd+wumaYrr$zJi93;J_QH=Q@No?Nv}R*l83
zA6Go}cLW+4WEIU0?aqVUWL;eB!B_KQq!q3HotrHI`<<Ywt>)7i^yo=n}W52jt1mN}d;WF2X+Xdnvokp|AJxt>|y=)+t1<3
zmY*8vy9fH|1O14B_ItX${eRwm$7DydpAV%FXzv)r;ow!hpt?T`+Gw7xqMe>GEVJmd0U(7WBV;_uJTIOH?+A^y1oA*
zbG`hV2U;BZ_2-0U9~(|QHl6vh}=xjAsO2mIuYw^xFc@2=F{w*T!s9%ew=0WQ}Z1e4S_Tj4&?;X!qo&
z0?&SsvxR_u&rdm~i_D%^OzXLA?0zZxJkx*;Vra}h`g;59)6_x9E<5*UPCZ-~oDq1A
z_cri@z4-C+iLJ%YW_47xWR1MiQ~YEAK0a><_$8KF@!JcdUG(tdq(C#azhWUS#|Gr}
zpYy!a@Ja6RSeK_Og8H6P+)BQ2@!g(r$+WNR#xoZzr+aUB*xAb*b+e7`U4b_8uha%I
z*m{7FG&+0VtCB&kuRPb8Eo9kEMq8rmy!>YxKKg^n7y1
zjQZr1PyBNi+XwbNFIXP}&#b&}%G!LeTs}R!R>HSog?wT*$}1l#HuX73oVCic{M6lL
z&H45IKkf66XPQ{JKg6$(p?L2Lt_s9xRd8;A*Pi~~!;43(wKoN2Z$dnY`Tq256HCvk
z{@$(l_db+=^l9qlw!m|${PL_F{UVoNYGrLeCw|W@by>ZdL-U1A>jL(Vew$m)Z#uQ!
z?>~Rv9EjEd0iOj`Oq3Y>@R+{
z;I|iw=7)x#A15Kw?hM2VZC{W^P*1G=4IK8x%AKwPZr=K^!`w?44{QGwcC7uZ|*a~7PFs{%DCR$GH@LD?ez{aqIF
z5U;&g2jjim*9Dm%Pf&GLHRZl#XKz!;&*CFJtMQtQ(fG9Q3ZMIaM^JXZ
zFW>nUjmN(Yr>9p9=r>~`zxW@iBDbX
zq3rn1tWR4LpI0|oy-)wA`D8!8A3lZWi}H72Woe=V&xzq-Ywh{{d`DZcu>QW#V$tjQ
zvO&hb4bPfR#y3ydvvt^W%dqF!q50a&IWu$OQ?@-gw6k3Fe~V0e)&+XCYfXGU)Yj%R
zw&uLl+JA0q_^oZ|)_$<9;kV{FS^K^-Ykgh3q0><|)xVLrsqJ@1)czffe{);g+O5^U
zhlrnEXQuYanK}G=^R@Oj?YnIEQg7S;%)D6PH?LpQ`o1=o<2j}6Ic@0ONo2ZT^?kh1
z>)O27qRV!5gnne}-LvS&wEo=IJKN^ZZ~fz2e_`u)xBjBmU()(ZTYp*l3j%g&-hJpk
zFYp}lK4x8W-~U`7_QwXAx!($EP8{6ZTD`yc4niL6`Ap9JuJoGNxSQ3$s$g$0&WVQ{
z+Y55zo$J;BKfUVM`JD=X#X~A4-DmEI-JKe>yo
zue+rBr?&a0wEinve_88m{qjb;Q^<4n^y5DFhj}@po86kb$=Ka=O+e0f1a(Ka2SD5b
z&+$1oThhy|M&>Pnxhx&pYYfi!V}mOKahwn8j&e_wuHwHdbDEsH`|PLVy}``^J8ld3
zsy@8eUK`MHR-kPR*jM`1-hU3rr2D3ToL;VH(w=2M=nLE3zY9U>
z#cTh_dvE;y>c|=Go96eZlMiB3I-Msr6)jHamBfB;_(mH%59lDbhj^Y4#q2pD*dAyf
zZ}*JzOSgIU{aEJFa%GN9eqX+5JTGlLwdcCfs~a!f?g+W{K5V{pJ}rFC#F}CLiJ5ms
z<^s(b;g2)2FK|Xa9cbzYFMrrF=9FwTa$zv$06!GZ6Q}U-7x)X#-=2Uhd7h>3;>Kg|
zES@J!;gPdhd3#*rmp6^?yMpq)<`%oTS-N*O9`tKDhynLcz^%xCPbQ3swY_}P10l6Px*YjUH}?F`B5Nx>*z?UbE$7nOXq
zI?Av2sadkjyZ@da^kBH-?tyX)(tqo^&q+e7~vn#$4M|)pLCw5Fhti@6ROz{e*#jbfdHN(7UZ#7qec@{IKt#1N|ifecV8QrhO++
zasS@~{W}Bw;er0ZK>yf4`}?wcd*2>fY#tEo9(;LY*4*39oQBWY)1Ma9a|1os=H;X0
z>G9~*roP}AX57m|d;aV1>pSQpnjG(K@rZ%>}&P2_#e_cS2{q6~4I`G=--Ha^zd;a1R5B$YrkG*nUc`tqP
z${+V4Keqp~qr)1b$a@E;F@Y+E8oyg#8&p%D48g<9x
zV}J2DJ2ii6#$xjmP3D%2*;jFuqg4U>>K(i6ctqyNRx4))YPk2e^jRyPUzss~?ZIC>
zXpk2%XZoEZ`Bp<@$s2h)0(<%Ojmfw3SbTlG
z)j8yEp9?(nRV%7`eNAbutAHbSDzk!@ULaZH?SrfrbaHvH6t&KhF;E)}H>3!r#*szx|o_
z9?-|B_Ot!cpk&h3%djrq{oHbL$tbxQPWFq5+O<}G(OG_Zrz;!uy}ns~9SEORu`ZuR
zU8RG5vTI$A)zM<0T^&@N-~)c(*&g8kmUe&3AM6P5S^G%t?sSuPo_^0)XAd9LO7V-s
zpEUmBHRrQa)nw26*Wq{#n?8Pfzd1E{PQcES1AFU^!sjkF
zZ{PX=pK-~Y_Ri${{=MO;_pA&L@xL(R(T0tgn`MLgq@OKim)M%qUlXuV!&~;wWxNoG
zm%ctzuEhTTI>r7QBBN@>XS97m#ii^jTb?*E`={0LCt6(CWWPIfIUAi_{Jov*-5%T-
zX#6_bw*K}CZ5{RYc8ceG;BIujv}rNyb8>&jlMSUz2ud>`!jZ5^fuGQruuB$-;ceW
z?4x5Td+E9__Sz5X&%3bko`8LH*Ev+69&z{jsU0}W5v&o}bKv}_U=w79UVVpB0FJI7jbSJrc`
zuO+tCbIMpv_W2~I@;R-Z{9K)l{qt5#M_;GKWweouvXLF-bJ@jbFo$+_U1;D+F_!C8UknWK*FpO!1nBR)ElWw%`QG@tlDU!OO&%*xxtvsN+j
zoMm6hCuf{X2p~&GLO{9Y43;A
z>O`%m4?6T?eY`MpV|}RkmDG9fS6?4=^>o#XcrRD;F+gr_&Y0?^_=711A}@NR9>H!IXO{}WEf9-_SSQ5
zys!CD_Svgdyr%hh;2_JPXP-J8b17fyhmG?=@9zz5emQ^H!e9H#SNW=U$9wB9+qCBf
zKN-j|UE2d~{JFQEtI$>J_1#H7_jTb>i+IR-=CJ2c13mtp`TO#{NH6cZ2Kog9y>*~J
zl3$?g_rH6fZyxC9HhM?1H{CJs&o5W%%ZG(w&u{=3p`SOwh;ksriM_8#Ct&nD_iq$82?`elK1W}dc$+_~t)JccovnXN>&4}Qz-MWV
z-*lZ9yd-!=Abwi|I@BMm3D~v}h_mlo)Vg?0<8`k%lg0B@8MD_NAV+rxy8`X103SW#
zx;tPe+4R!od1kMB0Ize0|4o60|D^%F-w>2M&*HBM$g%c@pkI4gx5od{li?vgV>Z9G
zn1fv9
zn^B?n+EzoX!@*+?=5XT!~5l~bccHG
zUJ$rrHFu`5JJZ=#vro?@=h?{5rv@hkML#8D?UKOy{?=cV-n-47z#Y6hpvQAoqlb?r
zQ(rPK%ed~i3=hc`8@M(gx8-1zsUxBscZTp&*T
zJtc4sRtM(?Hw62qz_F@JTvfFn7nDcRR<5wx_xTIUhhx#
z`b@MoI4w9SD1JWA1+_=4D&O=}u6us=S*!f>cU^Eoz|SWJUmjc&h{*$k-sTsEeo0XI
zc1|j8`1#Q5>+S2~!4J>kHw7h2jm!sHP@+K*RG-JyIieoCMj;}bu5L#q$8`Y4(_t@zbb&tGT7dii5~SwI#Ye3xT6
zygax)$dQ_Smf^2jyD~U4cupXm{B~bk=ZF1OSK`So^4Nm+fq~rX>v=~G-SinhBoHIx
zTLU`%*-ZZ0L#CXuUwz02UHmd8Yfr!yG`ptNW2Pr|*eC965|1r`m~0KU1#AI60{j0q
z82uF&_J}2)za)?=eB*rOl+Mb#J#3+a{o=JdaM$oztC*E+do(uVS<2=g$@&+f&Ccn+
z4CHNlpna&-UD0nJ=mL#ZGx!4=jIK#=a
zUd?X|+Lp=Od}!xn&)KV(c)7y-F456HY~T-nI89^k~#b6VDBvX
zug#i4+4E7|O?d)0hziyB#qx3`IYb;6Io3%obDZ{$!sRt54!SB~mEJJZV{9(L~t
z@WL-jHAl4xS&J
z9$2?_LNMRP=E@eb-R*Nh@mph4t+`{g8v^mz6p+F9s{^&_Op$N=!l3x*9oJtpWqp6<
z==rL^IXyL?pDprL{_oECd2Noq8v}6>4`-EK$F}iF>78M5y((~i*{oLh_liLN-4|>m
zi@halRmLTY4zkRVqu1UP;32PkruUrS+k>*3AMP+V_qu8iy_)Cy^^?&-UiR@{Jm_%m
z__M6z8Q_cDv!!_PRE?3*^HiPj1K5VA?3GXP-w}{0u2-ery^`q~Hq;q6r!L7;n`)!x$TBA$^y_P_YDh26>gwcx?1exbh!bB+FL`*#EIIru
zJK14>`A~M1uV}uik=l<}T#F`49Tv@Raort^^=L0%xnl==J3DOXv1i)6IM%!zvfUiJfR4(QF@MCc?6+rKARem%>*7)|=;e6lC>ebWdKqF&#*=5r
zke8BiQO48kkOML<3#Qqj7D~p&8Bddu>4}V|q!)McZ_67ZV%~d{^S|e-ZpEh?v_{3auHk6mL8ZTx@$fA!7~+S%>*JhjR7%&_hmsxN+i
zq6;fo?{ie|^XEmz+XBzd?Q8PCG&MXQ@X4L@n81?pBLlV@pB0FWvG}pgcxxap#%Bj?
zHQpS^hp~0G&oz2eqs74b#zvP7^y4o(%%jT|`_N?%x#+TKL!-;Cg+`Zc{Ka4Pt!uP7
z_P8I6#SMLCqs1M4Mx*Nv-q~pRv+ns~e?6x?!_lV&*2NrsdZYDd^VX{l>fMVT>*QLm
z{IdgH`DG{CeT1JM?lR+bfi+_g19Y7|F+z)x+F2iHTY}>PdEOQr+wjcvk85LhuH5Vi
zjL@
zf>927mYgh2>?W(1voG}ifPB3eu|Z?QtQd(WU#7)~tOCCBRm|8w7ijEoM))!<56kJ`
zOUW*ME78FxP2A;E+%F3><0no=2W!mwG#|xU4YJX?dfOAILH?-?bGHZdvGulqe0uS)
z8Na@KS>I@Ll_xsHsAQFnUY?r42iD1}erLwy_VPykcNxszkI
zR4uR8{m!|JBcU_Sg)Cwd{E>&`$^Z>xeE0(&kDG%=NP?ZClq@|>VYj^v_STw@~5z47eH=;%Bf*z@WpcU^ktR7}OmSPc2=E_SZu
z)E@I}t9Xy+V|QD(ug;J7;P2-urfOXNM%|@j)Lk~o^)%geX6P&ZHCMg7*II7}-^o|E
zCj?qg_xF;uK2Pp3O`gcstUGV??FqzBe9+cTEnn21yJwpJje>sL%h2W{e)*z${Be(=*gTg}U>dA8ym{k=1Dnsqkesk1>JzrlL>
zXv}WB+JS@JGHYTc$zMLt3AEAtq=Hzrd!TyZF9z}1G4$H
zDky#Am%h{6c$z-C$`^5{{FYC2R!z`T^W`hOCj=E=Jom*0?_JYuFt0Y2vSC`>`#7AH
z{j=ge=D1=$pFMnbwyKWBOibjl?5TGl`Oxs!oSIV?Vl@|Na!797yJTweTX#5{mh>F|`k$IQ4w?
z_wp7)Yqih&{&zK6%r&;yqp9ukOV0;>_2b(^(|=Py?y8{TYkpeYvenwOv%}Z^JT5eP
zF}=oyIwxp4**;Crz4@$iC!uNTi(K-Z5$(XiZnDPyr9QKWt$kMqWgB@Q#=dVf76bmO
zA+@81#8*Ac2YA)FW)80y^!Jo`=;uQo%17yEGmz;sx$(3d(9f1pzd8Ere9dLd2lIVi
zz7Txh6`QoG$I{fa={AOYlYjfB_Oc<2inEK$e)4jXvwo2V~cK0{$9{X^qJ<-V~6h
zW~`ITF0xCWIMlvrvdN&QWGuHAKmGWp@mgnt#s>b&x96feTO8`%G}hQi=Ier0fjY7F
ztiWEdE~ZZmG`jZ(i-AVAcx!TGO;Zc@R-A9h*qT`A`_D^@p*6BjoQw|2@;YSy2F1+`GH+2&RS@41%u6vJ9ntCv{k32H=b>rTSOiyH29jO(K
z40G(Rd$aD|`OF!!T};G^4mChu`QOu@51o7#SFzIf_e#a3?2=QB-*c1E!JirMq0XoC
zicehK5ydM;7YDO=%{zDYvgNkG-aUaiayMuAf*-=9k
zC$?6c#P;}rua9qIcDsYbsoojbT(J?u8dsdmRSv|3e{8CL^o0!?z4dcldd<^IhWxMt
zrp1Zu(p9;b7O#IDzA+{hum69_ns{ksmVbQ=#ZtYBnpLw~jJ4;qj9
z>Uq}Y9|goe?%kRBOi%Rm&*$1JXHN`I(RjaYpx-&rKQhoC2<;x@U&&$1M>C&pQU_I=
z{8$ydHGZr~-`iAcUz;`O-5%>DQ!IWrGR3!#<@3Ui7mAnu&G|cK)S3B`*S{;U2}HCZ}Ym=h9>S_p+`Q>=g%nZ#SNY=kMsLJt2>|DzqN2ciCFw^|lY77&(Vsi}>D51=^?1<5XABQ%{i&@#t@Y}_dii~3qt~^5q4j0&
zrbcgR{TQD|w0ZF*cW3J#(|U0;&rkjNt$%#$J#Wk}w*HB&-_v?`w)H2q{>iO>O6$L(
z^sq^FqHPVBcfb99)!>`9N+j3DA~|ool%^cAvTXjP-JFjMthm8`Ofa
z-u+;FQXmdBB1z8v-$4yT0UB-^&++rQ~OM;ve}i%HNl{{Q=!zJo>#VbComxf_TcS
zu{=317X@VO3D{nFqIXuF_(#5Y$d^{}wMM=>L~Wq?%l}P*IJ&1!46Y8!M)H7-XSOjL
zm#QVT%pZHm)y&xgbZ!XPz*q9E7shpVtI@?kOTpZ`a)7vPvWuq9E
zjcSXH)+=6f8UJ&MS3OU@P~x^Xv15xmtQ?9j+?P7Df2lgl@}U~T_xY$ZHZE0XZ2Vl+
z+0l;I{aI)CCT@EZ%dyV-yJCITS9({>x^vx^Z0mi$H+S!Hwt6qv^I>=3Zgg*r
zHtx@y=h>A3UhTlaZgPK;SI+}JjCCh={OfHCIXR==sWkfCkIrp9-<_+C0hx4ombr`B
z%+_gld4HFNWg_oXgS7jqqtA`!M)|`wjqT-+=LY+Fo7rCexwFbY{*rN|{@hm`EAhv3
zQ0rso&SNkA1tok1qV9
zJoGGiSvn+-%u(Ln%+Wn7R?fh3vEmci>XMISv6WqDIjVJW;^%UD?W6aSpyGUS#$w`Z
z$kU#HT=`-{9~XS;Z9c$razJm{Xibib&))G}nat(v+z_7oY9|}YK7Jok2^+*)6J&7cG!&8s)oeK{D}cw
zHD9&G25b8QV|E=adpygg*<*e=d-jHBw1;g_xiP*t5bJ4mUU{fq-MDwESKso}pL4ks
zcfI>eoZK@Nlimh*)=F%U`^rCkWsm+ybjzQnp4cZ2HwK#VS5HR&bPwPWA2|>o`rHF`
zZ?mcH3}+l~oh|$oCwq+5?e1>=_Kf+jrt0T*V&eUW&bh$8X^@AV!Mfo1U{*{#>#dir
zvZM5!o;7+(SKrgo+aezJvvKTuTl$>PPiEaS)B66oi@#!m*XMBdJNN8SOXk5DulcGk
zwFmNfRU0prLq3r;>)9)3^vn6KKojc=C!>RB?4&k6(0VarL)Gj;#^k68`t}6!s}^R(
zxME$s7>etIca;lcaUhR;Iav(M
z)wyAZ{NNEEaTXsr>CcM%%(wYhrzeXZap40w>S3u^g39d@yP%81m_0od@<0j4wkBgw@$bY`u(kKTy??srOxery?gmn
zb>v-MF8R8Wxbo3{ae<0U#Zo<*m-~KAe$A~4y?(5#m}Js+%X
z2-H~J?`)H+<<3aSD|^s8gR+I3s)?2OXTMm9tFgT4d;hG%EdNTMewu&o6ER|sv9nfZ
zs-HJ@-cAgvF7bohJi3jSs=LaCn7C`iqhgEZhd9@|IFilZ;{x{A=O?l>{58jJwFqpL
zQ%&4}{64>QYkKk96wtXhu%FIpzFwAjejkai>~#;3uYN0U^2tvA^QGvD!MKmDVsdK0
z27a;KesVlN=}^C9_4!9z6N7aDp2a}pFWKXMbM{p~?nn1FEQZ!fp8M@xjUMBPk1yU^
zH1Q;F+Py7aRl|Cp0okwFBVO`17l=#cFT;rrHfp6q4r<^0FupxB88-#wtO}|o%ulO{
zm3&^4OSZFxy>eDQEoQ7OPX2$mKc;$r_J@{3{<5vNC*9_|K=Xr5bq?`5i~aL}ezfN}nN_ppf6k(*@5%38*-uaD=0i`@EygDXCDVS*TE+PBlbM4tKDUj<(E8Dg
zvHH2A$*)-O+1X^HzJEqdw|=H$v-c?R33id
zUgkj#$yE#DY`i<*A6gIcz9A4VzS?J{$XxD81Lqaoi+6VVl3YBQg+a<
zj_j8|anyQxsd}4c6MtseME5kC`q-?*CN_>|j~`VV#$~rSYxu=otM^lW_U{{Vw>OZl
z;+L=G_{nis+b`Djxty%3jjw8B=h69a9_iT=c&6+Q%vVmup~m%&drIa!7wM48%Inzk
zQy$g@>?gNienXq5Uwrtwt&Q1do_*|MpL${+xxIe#>T2v~>975Kb5GdIuCecJ@9o9s
zIsU!D_}x93*1m7bn!8?2RF3dgj`n4&?#1A$HWmXuiNUnzj(k^c#Hz-9p2W3cKFx2j
z
zomB4hJ{KGxX!2=Ju6lSUlT*#TM#k1)TYz8A_Xm|9<8hC3TYKbEt33BP7t{O0Ui##_
zV$$D1e5$+3m`~dS?a%WZV-wo^uZEWATL0;I7TOdWa-
zt<4zULQry?)sx%rSzCJmI*@~k#rxau5L>I7^zUdC@5aoRJa*mEWJs;Rw_U@0pYuY^inm;D<&Q&kt
zwn65%HktOY`};zZUvbxyq4C-M!+tzfcU4Q)&EwG*pE3B1t3S2%r?p<~nJ=Akjb7J!
zIYn=1y_lo7w0>Lb`Dy+Utv|co05lQ(J#|>z~&8r?>vf)<3KD-pk0jy7kX({Wa-56WFiub7vq&+B>KGF7yXx{4Vsr
z4Zr8si-WC!Sg9@Gmz;rTW%<835t;ol$lOgzr38P6Dc
zG`!~UtqR;r;-b|WerH6Zi!IjlYEC}vwRU@u$IU(FpB!jpv$bSbJlNa&w-{Oz7c#At
zOk?w8k|&N@Z_nan=AV4t8=8$|)wuSPXKsJ67-;0yyqZui=LSC*EC!zmRtMVyZTxpP
z{To;P`fm-if9F+P?5F2lp}h+h{g#3Mn+N)}1AWUtU*G76oWzQ*x(mcX&8r=~oa@C@
zk5^xCXE+P?Y2E>io!xf_YWuE0BTKxFi&JX!`am4;t3ma1QXt;+Jujd~yjKP81$*4Z
z_S_oSqh`dZ_~hK3<=J3O`+VuHdMaPorIy6kJtBU^GoLX#t&4N5m)~M#A6dt8IIVnk
zX5JK(tfln1*G_G`>Z;c(-gCh;-OhHeTdtXLRlp8$XaDxV{Kr#gqc54B*jZjy%sfztIo1AWIpUmIHdG_}>&y!i_Pb*1sky{CqMI8ehMTJ_oY
zGv8hrsKNEY+JJ0w$am+6@9seC)cje&CBeEtZSv6`yf?M+lhbQ=9_%K3=VXk(?p*S3
z4%7qe3^oVOk6gsuL(dbrfV%>1?qGN5GYkE<1^lo^*S`zO-V6`>9Y}F!BRz7yHP{x=
zaeBZ8GAlOwGq!eSAg*d?VjSp$
z39RjIG#)bMgVOu3jKz%YqrN&5=EbGIheIBcA@1TRHe=q|3(oPU0(SAez+N_xu_Isy
zpZwcAd()Rq56GAfYgJPv+uEyxy6@GfSU3;liNW)NzOLA*9yNJakM12ZEB@rNZy_kV
z%{g1nE;t8bvnp60ECw3+W4^?5Z9oQo&sFvB{PSO4P7dY*FJEtc;47cCz@SFmyOn7
zPq06re|PKa+2q}5L%?1!uD#*__R)1^U>(0Y@Fu;uI+cuOy1NrUkTNN6tL+vlW%7zVD
zvu`da-|QRni{E^ob9>D3wc>Dd#(2x;%KdvXH|E}6{_t7Oji<$oeRT9Ob7sia+b?#z
z1Mynj_2u^%H}WcOVp+b+k49#1Pu*X5_XWK@RiFH3!_xz;zq3jgpGRGMmg8N4#(wv=
z_KB3$VG)jx*`sa^IW2KbQ8}Q~5b0G^WHXJd&%qfl4nk1XVF_T-WFJcy8=xdG`#AgYGy8D_ur2M6`u@0>%E^Z?jCy7
zROvZBV<Ei&--G?v
z1)k-6kc;wxKfTR#n=6}EH+q^6y*)n`zR@1Gki}bUhy^F9%%nHXI%`7
z9{=s{_YUjdG0-m<=qC;Iu7N&xpw|!d2iwnC*dspQ7g`L8e!;N*^w4~)_07ZjLqm&2
zt)Cd0zdHi*wLi_z67=qnxd5+Re7OBA0ImJZK)-XKzjdH52wk~Q@8md7Ka`&rn6Eoa
z-><)+{XD_*yzKsq*vM|pygg_=|J;MdwdVVhY4k(eyt}}Z__bhfz!rHT*WPo3p9sXGp7|M0=$+~L;BM*p|5ICEDgRF%A^%SuA^(3qLjIpV
zLjIpQLjL!zkbh6(t313fv~$_V6)g{H%QNErLC+&E#UoelJ98HWa$2%~HsgL@$V2-|
zwmRu~X2~v@9|-@E)XmQyA^!)DkpCBskpCA~z#o>$Guqvw@!eQX=7Sr8n}Rx5d)rv-
zwDIh^J2nQ72%O)=;L_lVpw95W$oTf)?%<8V+k#Q$8+2Ycvh`|
z$1`&|UGA3Uc+~WAJl++09%pM!AO`x%m+@jS7vSfI=Db+z&!pP!_cGmVG7<#^bz91pve9VJ_xy5K
zJpFvn-}8*~&NLhT-~1P59OTa3EJw?Y!*bYjWkcx2;5ot91>Y9@aPZ5)9|p%q@Veld
z;FZB!g8vZwMzB5W+8+*|DgN6)|MozCIP~}#DdHw=cmCf$BaJT(+;{F-cba?Fy@gj_
zU=KO}G4jn7?RVEleeQhiXz2612faQ&cfCLLJ%7-5_5G~x34^{z-_QC^8T75WpY?ru
z_)PnIq3_T9{oJ7MKi$vzzH89;FPG5gY~9!M_wqsCi|C*&%1M)599o%8S}pPa0iV1b5nfx-GO#A?w&u+cOL!S^E;vM&)R+8pzp`-
zXMJxQ^u6II>#JwP*A9AKIMCM)^fT`#JI){UoITK+2KwPM?AV(6+7{Gv)pK)A(0`^p
zEA)-Q4+MW4Yz_1N;9bEV1RHY@_60u^{6X-=tMXlGaDAYatcPY?=Wtg4E7|k$;I81!
z!8?L~7yNYKyNO>4e4pgpE(Y4w!QQ|-jn7LlX>w*pKOU0#S$fT%87u^w0x|LV*=IBQ
zd?!Y(@6UcXwv-Nbh#5Y6`_ITeQ}+A5Is1D0Ed#x4pf4Thrw{aV2U@(#uF-e?E#?18
zeSc}EW18>u%fsmVR}8j3d!T*r=wtIm1O1SJK69YAgkH+`rTky1?>jpk(|k|qPxbwQ
zgRQ3z^n0_h_x+a!`ZospQv>}+p_lW0mj5gD{VzHl(|nIhQ+@x{!Peg%=x-S4*AMi!
z5A=5r^!JBeiSN_=U#ai!>2yr<-JLV7=HEEj`W*wkd!U~>(9as^>jwHop;zkr=>JN6
ze|e{4n(y`9+IZft7;JscKp#KQUoz0A4fMi5?+AS)zW4sG)c12c9n*a0^R&Ew>0s*_
z1O0O`yg%G$^4D=fY
z`fUUK&Vhb+==}Ft-=Wq!#w_3a`Faj+h#dLb5u6=7CXkn;Yx10Di?Po--ko;`o~yp+
ztmpkmFJ^5nAXneZyQKM2@}D-)R}b{_2m0pF`ETa;8%G+0(<00J3coH1E(`pekInA$
zX9U+b8;X8TXk(wp#6fI)P9Z~`7}xiI6(jSH3g!djivw}9cYhmOGZts#lLPV7_wQHz
zJQ)`T^#jmz54C=l!W*+Rzd19R+N74&|NvfRrjWViR0Qv&a*YlF?fjzH`^BOezm
z25f$EaCz{I;M(B%0UdnIuSnjrF@5Ph(z%Lzy&H)C(UN^%>^joDG5gS6T`}OBJWZ?P
zmHId>f5+woinlw;xh1P=b{yBUqSi-wU!T3|%lXmnIM_{OlQr%i;ieL9DA
z)=D4S@$GKwFM7c&_RZ~c$Q9f;aLohYkj&&4X{n2Z05f{<4F`#6}dd+m4gFjxximZjFo
za<93c^zKkt?r!rw;0|02G>4qptkQIxs#Z3Oa{*6{
zm)nyijwf0pzM~oi+Hz~e_b=|zs+0D9-IDdK!Ky&xubDad8oSk(7}p)IW{och)&>22
zdvzx-MpJaox44c1t)2~|jLFe!Y!XB5pUN)x_$U~%Ybc)e{o+~S@mX+Va8=-W=f90V
z5WF&YO>legrob8e#^61{`vR@%x;^)6j&2>--m36ceQ(J4cp-0ORX*5R-}$Y}c&Iky
zozJ5{T=bg!@=1+O2fjnl9%7#9rea@x
z=^&dfwN$9{I?5Uy`hIT6(aN@!)M9%!Rz(J0w&u?)A6b{aZzEfwo{xQ7d=_nGW;(VD
zPt~>B{Feb=Um5)C;3tCr8l0Acd|}}Cj=m}Q+!*!b;0J@3245Ly>|z63^QW}Owk~8m
z3bf4uTeQ;q_2H#ke>@3
zw|WWtemeFIfsI4!{k0Rd@8l)ydnooz0vjjo)%uCr*Z-cae?Go6_ALfBF1CN7_IVzS
z2uT|{zgNY+rNG8XG~~9=H_sdMddGJU);;HLta1Cf*%>)I@D5>I&o{D`xoh@Z;=Ux(<(@)?E?{3GAJ#ZT*=JJ#`AXM6v%fB8jL%bIc&}NvY>ok=*ISp`DiR(X!QKot?u>oz7zLXA
zo<1J^fBAiT=F0^e`?SQ#TjiBM=**Y0TVDA)3N-eaYgK=*&v+%EyQL@VMC{|wh>)})
z`<|Qi;{iMIX(wWzS{f0OHe{dAV#ffW>5UYZBsB6w04wCHp8}HRp8%5T8@s&fx1BNS*f>99=+>=y2r>i
zM^ibLqq4uB+xhI3jU`u)XVmq@+tvoz#m9g8cLbhw?%U98q1o7gcIxTl@%g1eqQeELZ0
z$XPdDj9yHf8GK}acaLvR*2t&t)Bv6K*3g}n-rXm+1)pE11FD==2@qO874e
zJv;UW{r44dAk&$vSg^-4n2vtWMm%g}t2>sB%h7RG=pJny?zl%=hco(U>QEOTw&E||
z{azl_hdj8yBl9UOvz%2YgcR
z=%oZ#+^o>fyfxL-p`T>G!^}g%ARjYck`|p&_
zhy9h(SKa4za7DcC{2^V|>vKVd$37Q4k~R3!)r!F9nag4YIb3cfaYXYk{}e+WJv{CYrM-IMw{Q`X&+bj<~xM|8F4k3RP^
z|9`gooMF6Np7$IF&$k{2&ppS%vv3?dR~-kBzaif~`AfA#N^0q$7dS+_Ygm~-jLq;vRC|`1t8wyHXBqf(D@!?ePG{nXB3cO
zE>1;jt)5e*hdiy7Z7e7H6O~WDR<^L+m@T8OH)l6H%f3n9&7i~UeX#yJE%(mmz@FH)
z5LZ8A-u|S
z-zITm)3$)j?VW9&L8WU*7Fz2=eXFBn%gv{|cM?99YBU1YeeAv`PKC&G{hdt=G98TJa%-w$tG}X?%P)=1
z71y#~toc!Wtq=8!`9a5HJAHDtCDA=FvaJA3Zm^#Q)BxAyLL=4#JmyY#0TlmmO$Y{TsS{eC4zA38mxF@|RqVO=WYdtNhce
zhZBu&J$oj_w6)`rimMz{T&tEo6TZ@`@kvbe*4h}Z^f}m%Uq4smmv3lCLDgPcb8XF|
zn-rfDwHJTMriU#<&+Spxza`M_3EZE~g;w_`KK_Dn3-^kDk6w)3L)!wn|6}*uQM=3K
z6&w8M>u16EwYvMsLKn+J2Hw{?PF=-LnJ_
zePV08=^yA6K7j?3YwW=TU%2~au
zl`lj6Vm^?yw$nqV#ujIJwi`QV*82C0XQFy_j?uSw0a|x~Ja~UHmLK|tz7N=$^=$ze
zpXlnycq&jUay$yisrNm8`CTIVt&_ba*c!;Y#=eaKIcEjpQ+A)1F}_Lb*&5qi@u(Px
z6S?bx`Wb^WY>tLZ=Yk$O#G>p%2S-2C9Q_>|JofqXvfzQ>ZNU!&?+rd0{A%#Y;E#g8
z3_czByLEmSc75=~;NoC^@QUEof&b3<{@|@a{x|krEZE0}%16ah4%P?k5qq?3KVI6S
zJ|6v>Lh|>7Kpyr4a%ByM^s1*vnszoaTi@ttefwX<-pgXQob3(7PdwE%nAhjr`niQ1
z+T-j0ZoDU2_smVeTDLyNA>t$P%l7j-PJ+X8j`%iSGrt*z-v
zy835fxqKTVzi5|=N5$T`VimhSKd5u9CX1%}y6e?2Klz9LE%DD>yv6W%WW1>-!_P22
z8F&XHa};Pd1Z>?KEH__6u~;Ae_P(jOm9LX>(~mJaJmLilLA@J`kGp*?zR{%?HUxCB
zz5FN{);zzemOOJ-2YB?}Y3f;JF3xD_ZSO}kR|VQVf#Yl$K1$w%Mry4UE#vnmi9c{w>i&xg7%iq3lJvxZ(ymy+M|h5TW9
z+PsuLIVm4npGtS-WRh=uSxSa_tN1LZ)@}*?-9hzLYcI>%d~l+*=3SrvmH&QB`LmK*
z`@PUtt(EMGrS+B6+NVNawbqwad8%0U?LMAbBdhALUmu=jL-m;D6RNB7YcW5Tsw*?aR
z#AP9bp*c^zd?>XE}w+G${$n#9V=iT}b
z1A491`+J6uc`#_thqa|_nK)J6_0Ar&HnsBkxLlr!0edP=W#3BTC7xm^CeH9|K%Ti=^<%U@Yiynm
ztbah7j6I1toc*=63RdqURO(AJH4t*bXSY3i%Bhuq)JJFM6~5U5YQpC9ny>fo9{
z^DM7-WH|k)uw=tjQx^?!}m@PG?r^a$scME>8a#w5!@RPSC*c!+u;C1g!1!n~>
z?&fN1Z6Fu+)Xl!Y`L<`Sp8q&dM>7F^2Le1-1e*gnES==c2fG4oAy~=C2Q!Aw8~e)iqi
zjZaOlmEKklyXDeZE5G=$GuRi@J%4}3a0oYXt-?sjo@-o#>Cz^)JG+{hif<#}JwzpL1%)m`5aa5N4+MNzs+Jbpr%z5xPUW5cGXuG|e{~=~?HrFg=ShL*
zh&z>^C6m9`1o+4}6zmA(sEtD_!`K=B^MHJ{bfSIhle0qpe+$?nhy6QoXV%=Q{P9dt
zca>-M$bI$VWL`C^zRZVe+q#;r_^4@TM@^F_PgT?8EmqU)u9`+GM$7Go&VU%PZ+oyU
zV9$qBhb8x(%;oqg0Us(S{I5OwwR?|t+1QQ&=GSDc8Wm|BC{$%LX)a0UOYg58}mtcJ2w-B3EQ+
zt-XBX|NjW&x8hbY*pM|e(?QAW`)t4VmZR&hLcf$QHvM%Vev@qC&r&gCzc>xW?Eb8?
zTTS-ucW-G2gONcR8GL2i-vmqfKqekJX>(P2)#4d}+;}#S`?o>ynE%hf`I{62cD8!v
zJ6iH)gN1G`R_5Xfa(GWbcb&I;GuH637Y$qRn)mB*Q`YE1Q#^AS<0~K4;&Nll7e0SF
za2C%GCi%?=a?3`%Z0zfIxAtTFcUddH==*vYum4>#-HM{E7NvRL<~Db!f$^_4BT*o!03p
zn_r!^vXhVG>Ps#H3<;{;f{eg&DVK_55`T+5GPtyJ~+!4tI^K|F(|a-0xM^y1xAQmaNnN
z&h+S8-Nvnq(ywpV|1i9#W^GSzy`{M}d(*MoU8HXG>gLZ<)9cc!zqzh=2bkAg;GPWo
z`18%Troe8>*u6oHGgUo#=Ifg^HGFq~e@LIZ0Kd-=L;LJ-4mSp~fqMzPb71ZnRqx2|
z>HUFyeD+5Hzuhft83mp@t#1k6vG3&)@-ZD*n**}&k+nM@r{#4oTn&lKV(~@u>?LR_
z2j!#K(96eq4j;^T6tq5&%?^!i{Aq0zdo
z%^9P*n5j`>c88sh(`
z8Bpb8_zLgrC21#g6vAcxC3Jpv^Cv+WUe%Lvddl{qxzY
zIMMNFp2>(G*W+pFM?q_I8#8ujD>;*L()t+J#?KACc>Hb%hR$R^)>W(W+sY%KoR4SV
zzPT%4XaCMJUmuWD`xj;0*JIC_=i}W0`9pMaE+;4Qd~`>XvsB#Cs8w`_f;$6tnyb6r
z0ejoH)bsIyIIuQ*aw^Uw#xAsSYxbttR*zip&`C>(W%_~N7wI!$;*qgCE&k{UyU2hC*bEjMyxGSKIuetbC
z9q)|6)0ww-#_gHAx5%@1dccmY!M?zE^J1yq*o^jLL0`^L{jrbl_S}c9&uxq!&3A{t
ziv4U52R6?H3jy2uwPlTsdiGY&eleK|+`rb3r`qi1Y&mpv}9nKz_yE^?oyDld$?$$cL
zY-wfIIa!FzwH;m64B70fvvG08KI@rp3T6W5jZH6ZY`Q;ldH&6SEOy=(+!|ck(A}N+
zH|Fye`(6~V1#S!u2JFF0hO=09?9130t@zd*RdaUF1~pfM=GNVh^oIS|{Gx7sCcXHV
z-_;jAx=HtE)n5PptU9mw^Y3_Sz3z_kscK40PNdeI?OlQ9zUbedo&(m!OP+r|_~)1x
zet$OQMIA1d7x`%O@@1J%2hPjA!E=K7pv_f#miuR@|6HiLt$L%Y&X9MGyMsDI=0j(w
zeO?s(VrQsoynlx3eAgLLv&WOGIy2=H8GJg?Gvs}7v0RCzJczLz%>?cicbd553LO7l
zjrR|C>^}r-YVTO{ZNZBJ@%hexEP0s=YTf-}U9Qp5Nw?TNIXDu~y{_x~&-|IJgY!TR
z+9CODACj*qRw7?)hUEKvIVAt270Ty-E8jC!99DI5JP&pS+P>iLf+4+AE7a?GFr;^N
zC&xJ*(kpNBbwlRJ9(XP4TqcXRjgR3J~w&8K{mQ+$)^H9a5L
z>z|7?U7VK_$FPsT3za9&UgtLKW4Kd%zNlQu;dC}Pr(YFlVqmV`+TR1(ow;~xVr2h(
zleD{ouk7BH9>|z1wa`8T{QDrH@(
zh>>@;xvnQ`6gbPf0*!y3VH#g<2*g2SgTE8gfA5=Q>q6)kv-K~tzg%0%8U>SVJ)Avu
z{cNDIeJ1$zKx2FTKDs#1c2M6fF6qtNy_>teFJFYFrEkYy7oKl!_`W^kcL&S$|KiY|
znmmls55?f~vo1}}$hQT3xp!twZM(l#1yxV|ns#=bMeAg#+Vg9@^
z5Tm|4&m#M`1|_ff`f{g2Q*y<(UxR?YJjZfugYn$3)
zoAzK(b;O_fU?He_{?&~6FaK=4Ca}kT`C1q33)In}^lIpifQ>`BZ|jJkwVq)#Um#4;w!y-G8U(~plZQdpb*2ojtMQ@96KwY9`3mizFg4B9&1o_^{M1t&hgB3JsG1w{C5Q!yPel9
z!PbD@>jKXJcClS9=_z^6^h{891RW=Grsu=2MxGY96XcIh^-wzZWXw0ds98G8*Trl*
z6uPC(P|3PAv}#2h>s+)oH(>Y0>V?+NPk57n;TV;CuO@=2{=_&)mJ&`Y_6z4cff{pX7#(*6AjX
z&a#US^l0L+G2p*O2fut5NyenOtm*dY#IKgLR%bsR7i3>Nu_IFaGjLtj`P7Th-=JtjQ7!pCQQBz985awD06>qEiziaivew+aqgT(Dzdf`x{Z^
zt2oLfeK!T-TXVLQ50#g`yowEd_R98_cajh842=(?KYv
zKSP{PUop(^m<)N~OKTI}Nq5#v_Sit4c%0GA#nRlJye(jZXE-_ib^pzlwE|y?=SQ+f
zmRM9R&177(+cOr!lY{Tg%i)KE{~mmC=i@@w-2wDgUo|3^&Oq5TlQCbcmHqVW3)*@&
zXA7UnWE*<17CZ4WW|wD_wW|X>2ZG|M94*CLHnP+6MV`qh8_&v^-R_@jgQ_>SyPNFM
zF9#ZXM+Rw|19mMp-(-@f8MpWDy_wGh>^&)9Z~3@0W3?qF8olf(y~f2;`H@p=rDrx{
z&0LM_3o0-4{6beN4`l2Nhy#7%G72<$$-OB!KM)J=NrwXQbf#_#ZV8;T{Q(-jIE&&d
zUcO&#_sS;c`}1P7x!T_luz_sNy#Z}p+ym^bSnwI>9Et_s+gQkP8;koh=No?QzTj!W
zC{VNF0iH2*I|tgm!H$3r^1<)2v$exs`O6Nr7M=CJJ@)#!VH-ZW9+yEI6Ee;T*rt})
z+>aaE*9YRdCm?UG>tEINqx71bljF0;zlbh6@r?rQhM;24H?8Ud-Qn@dV;(cp_2z6>
zD^mg8;>m6~S2ylzd+UQyfM!>qu}4kVr>FS#Wvre@-TDxHf33BfP4rZ**tE7=qmR9G
zxtqk`@nJBxJ`n>l|Mo-1g
zcoGkL?+^9|Um9rUcLqC5(wvDm1`nE~kySt6dQryg0{6H3^`^l2Z|jhs{9Yf3A(Y>>
zcV5=mQ=e7b!>wK@?nT(efF1%3H~j?@$!dtY%lxi((Vn&^js?WVtjgH?A~r`
zreZwZ(4r~2${}CM#-aR*h58)gl|%A1y1%b^M$Kd{#%*nE%Un}~vmKnf;mTWmFea?>it#sMb
z%)BxYBmijT1w?M>f4&wrw`sjrhCd?RN~P;y#(OOM#pK6;;3YCaTa
zb}a-I>!CP*VOJZ|p_>%vHmBYXwEKfcBkpolKHb=i`CE5i#lzVu+6<37?tCvfLveR!
z)jm7UXy!w4U&wyNTt5_dzr)9Vx+ldwTgT!&Ym&B{`gZ4PZLO`zT;1}ep3mYqAGE$%
zYv*jMd4|Uw<9fzd?wqrdE2hptJC}!=JFn*^UW?sJ&bda8cLTNJGaa9w613krR2=vw
z9z{p~+UPN7?}n}?YfG>-aQ6W{;Edy&37_wt@TlSGU@4y20Uo}t%Q~IpZ3_5i-M@X+
zUoRcm8sEM4%O-#4p=@%W@u{WHbbK$fRhtXMrac3Eb^r0T;<7Dc>!0lIG;{iYHFNrF
z{&ShjbDz&$DE9sJ`usBV2qXP@
zKK2CSDnFh9&UO7gE&HCc;*W;>-GR0_kaP7zhM1NNatfo2wU&?F_|S`cVOPdnf=()DOMYT>jJcVb3f8$PM5x~i?2TvTpy6(nL)=~
zAeQ`QPt}_I(MO(jHsYHK#P7j?jN&UF(G?HAJA%qVU!I(7jxhGi*N%+Qvd7+*fxRbn
zds_$g)^>Z_2KLVA_O=h~v6DXfTU)Nlni@C|@SR^bc4Ks}=*IHIH#G9x_p{=5Q})!k
zxRW~yG&QMq+Oro^jy(s}!vYiCmFd`Cy!=sX=*bpGa3`@@qpP)zJ$nN-mpye3*?e9=hO-=AP+tqLKIK
zo$a2t^unnD8*9w=vJL-Yb3E<7Sl<+=O}_EPd|Nl?gZWHQXTf>eAG|)0+xr7D@oMt=
zl7Jr@1J5c=9O&miK9EbbBA?DMd&Hd%x!3U3xayBB__qgqC-c>b75Qkk2589Q!xI9H
ztz@Bla^T;)C74@Mi<(h
z&Ae(OOJje;q0TBxAY4B3$7@jHT8l&=?dzOk226)*d<0sqbo
zYJMo=_I@(o7@%`6tqbI$_|%lOn}R2H>qSRr={r5+(x)Eru&0%q>9Nl=bXL7ObIuva
z=^24Ka(|JDRxZ@R1%aGCHTa@#d{GpM7k&1g+?)G%mfQVHdh@6B=1=X-pVpf{y*GbG
zZ~jHSxxY!#>fhCykD7VRAAdGFk$CKGQ76H^00$e^zgPMQ?s(
zZ~pAw{5ie(bDQ}i5sxo!GFX+u**qdM7n_ttLU)!6%s5kewP1^dn
zt~bBFnLiToxS^3J9xv(5U)r1R>&^Xb&DP$R_2w_{&A+5KpYP2N^yWAA=Kg*3R^Ls{
zTs+)Co`dyF@jR;Mm;23KzuRH5R-=ErNL&P4t2kV|?OWClHv1gg*OMNExe0*Bq
z*`t|X9<=XM4>j*oYh{Bv+8FSojn75BIUmG=Og0!-yq=SB`PuH5j%*)018Q-|H+GR5
z*N*+oV>Xp<^20Z=;Tsvt^=(aP%l5KaOk11#wu&nnI@u=o^p;K5`EoqA$kXP4T=Dk~
z%Ri_y%RlExLq8ulOK8d$Htz_?nGM`Apw{$X9@P7-7|_Xn{A!deycGxXr@Hw}dNTTP
zVVCzMbf9K71!5)ljXmUvxec;1}cK7gss3c5AR)Sr3GkPhS;i-qXacu`I)8`u@xM6W@6bM5m-5%WReD>0)gd42-dfCGF%(Pu70bR%
z{Nle?IWI>E;yxg9+@>|dM@}F&^Kw~f6<-5C>zN)w4qjz1PsW)}P_kOI7
z+W&+x|2f&eIJhdfEqHVAuHa+Ar-G>%;%CA>kNOPebA@;1w*)^M{9f=6!Q)m%Pw>p(
z#^5Uge{24o!F=TKA;WRw>!E;s=LXJT`+2?A^!#2I@R^+2D|&1E-x+KQP7bu=)q!uh
zI@%hZ8fp6}pYXW;O37o%;-Mp;@d1!03Vu;>nklL%*$s-+i
z2gW{QIrGMM1a$hjJl}nmvS-|nxBF&mfKMwQ^zLB2bEo&*&^tGJvh?DkuV)my%*9IY
z4%YKYU%sjf&p}h3_cn$5XNAzu1$_hkb$X
zEy=EY+rzh5JpIg@PIo=qTU+oS4&;`f=2cH@N3TX-nGNfFuJsJZpPOY#p4g$y1!AgB
z_4G~!+G2Y?Q>_Ul9{!4_&z^i0fAvlGw&47LU58>9`Rq1-Rd0SvZ+>fUep_$;>fZb{
z%{=0d*-s~*weo3b?O^tOmm!ZDAKdY;ja=(H0(Dw3t=x!vow>>f-ms1Hp#IF+V880r
znpoEwIo9;GrXGt|K4-fz2G-}ZR`D)d
z`SobWjE=H#u^3K=uIws5oUxYopE8&3khOu{J<}iixxBT0ztTLRUmuj;Rp&$bt6IA!
z^w$RN0BeT>ZB5{ezb=d9wRce~56@h1D0pJvPObYg!(->pvu8H2U$W%4@m`WI);S9_X!mfUT@s^Hh6`%rq%a_j7(!};fvbv*K|7Z3Nw
zfo^84<|BSResaku9r9GZ51qHZUlm8R6~{X>Cbv&JDF))C4aI=WHU@o}V#2@D
ze@({T>5Io1u`gcyx89dYhP}MPj{lBVKeod{gib!H_O{l?SrRj>YoO
z_fuZ_e!7nB(;W7t40v8Lr$ItB>;nHB@I~lK$G)tCd!dTx<#4^Yp>t
zfKasN{Ww^!XM|j@56G_Aux(u+=IW}yPG=~j&H3Q}#^8)VGam(Ft&v&JPrCVuzSh@uYolgOoh?S&@)vDuYuLvz
zr+0h67XIFmAGp3F_(<^S;K9Vie^17y8v^IBa%D~P*~Yy_7F*rBa%z8H(DJOw+}WEA
zt`5Z4THUF5JZFlB?P934&tp8L<50%(CI0wt>CL~mnP+(H{hu8LbyMI&f&PM;F1RnA
z*g#Db*l=0U+VqOv{KnpVZ*NXU%YS)qzR;ULtC?pw_R+Z($AbDRco&9qI>-m$q5Jhg
ztN%c6ey}(Hvfli~z4@)pJj3z(As^KEp1`?zL9iw`FKF)(c?EUxi9kKzlRJ4@8@TV)
zuV?05pq|L3Lw!2)bi5>RZf3eZ-B=bLbwlnI0pH1M&x{zTxzfufbG+rp{*2kLS$8iL
zUCCARt=vq>|Kg}NW`j|{o|axc
zX;m+Mdiz84a)TD19E!ERbQxb7$O*JEDo-nsA@3(DL!F(d40pkDWH>9HJ>qU$aS^AA
z%XG%el|{zxKwMYK;~rWm&*>9*+BzA9#@*e@Rxg@6fqxnv=eMO(hx5Vaz`4-yI0sts
z9L#uRAq{PxZ%fv;24ui119kbO!J$CD#O}2LS#Jo~V$B`0FYukO{e|F;fFAY6zBX^<
ztqs_S-`#gjAkXfHn}Q=jU$*B~-G%i|fks~T2kvIJlY4hJ7Jt54XA?cYpLZTMxex4V
zbw7%Oduz&KTCMZLI(jrG8mrmJcwI2$k9d|p6+L*zdrNIJsDzhSKcSt<~_UBbxYRU`O`ATTe@d5KdqVn
z-QPc){!e=I5B27Ud-GRiE`Ht%oN>K5ePVP;_SH`5zcYVhz&ljU5BBEI&s?nPJwspi
zk~fq6p*=DAs|2H^7weB^tzxHc=|)qwmM!ksw}qB2d*#z~#^~|tf$iuIcKYm1fex5BLwOfBeXinrHf$
zPiC$cXST}^9p!7;TX`tE%LaERdhZ>2@4osk?D})Netp+F$M&}dY$xZe&UWkG1@!JC
z`|^Bl{#J#!w08ewXSX%}^X=;Q9XWE<`;Yo3C)#sAbmYjF1n)R80a4-WtI
zkt1&n+->}YlD{|d+d8-*f3u^V-}v7jK7VF!{^`Gb`2LUd<~R4|>oTXma`dFmo}FEP
zQP+zTx~B$g<=1ci#gQXz&Hr5H&WwFI`FFkfyEAX^fbZz>pOJa%>rec*qqc2`EV|vj
z`Y#ITP#@nDn#$2~YS@_|V^Zy^P5V2#{>t=n=}eISUAe^X|Jfr)KAsQoKmPN%C;ros
zBbVim9$)nFBS$XDmzM0(?(FO$tIm^WFU<5`Y&ZYOJn<;Rkk=E&+Kfeyxf%^__lHWRQ@(hJO6OzVp{YMbo06o>-@8qe>Zf!
zGiB}>s(*Pv2H9tJGU|@0JEP)!K}YLM+?+qYb6Wb+)6$U3Z*tM@3@!QMw<)N7{nNU+
zeRFlAuls3lH^02=ukHGxX9IeE>#P1I)y_E`o%bR1-W~L>>iS!|{?)y?b??+?2bvlc
zOK0s3DTJ%je=yKC2WmrOr#NW2Mvtg3F;H7u0=0~m9ixE#?+vus;IRQ8tjJH4
z@uMYsW8kw-E8G5DKn`2XKN(xh7dnVv>2Pm2&*aFNW>1dY`>hX|9^13t-2uFTc6eRh6ZZ~j%i`RjV~1DT6`
z@n4sDD}OHY_Fi0@`Dvj?qdDvL#njlIzUKDK*{Bz{mX2<7_n!LzzvezLb{~9c9CIJM
zAk16RZw)FZ?l1SM`JRBDsw;Cc%-Lh?v*WV@e9j}j&4Jvj9nX-Rfjfn*?t6Rgdv_oi
zo=smCMrT(ovQOI(km;dBjzcYmHwtyd1U&XsCYwjcRuj}^D
zOkewZGbYrCcsFGq8gqUci!B<>bAmi~rW~`OrInYHg6jiuGZqhWTb=SL
zFC|M1=~@Wx4A^C@wTo|40lDI#Js7ld=p#q$OGbucpRMzyc+20ptg&qrXtjPt#;t7k
z4IB8<=8wFJFsXVGFIoTGFomZ*xnUZ^Z>VG=e9-I`Qac;$i
z-Q-#;8=lv#v5P&{J?F_lYp#ay@<$#u&(}``?E0!eJN;;P?B`zWbw+%@a&P*oQ)G7s
zG3y8)t<&Q>l&QddeR9D5%>mmghSoIsVxz`xc2qsd8y_zTb_8mJE#k%}wDi`Qi>0Wm;xYX{@63^e|U1zE5=(AbOjreLNUS1vOh$Byp{
z0lwNJYkk00>tzewV(QHIY1vb?BCqHwH)z{6zNppeTYKpg>wZiQWo;(l5B+Rmcge;>
zpW0=A*_YulJMb2L*(c|Bob->^hhizt{W@Z&eC-MNKNrw*JoTaG+xn<_Ag^+8OGi_F
z@LP?$)3l-^XNcy^tdsY~z&XWlO|2vh<3?|LH_T*S^2Hb3&R}DpjMPsZz7*w9@(MOg$XMdpWI@*o(
z)Y$zYe>GR5YXde-2YgYpdi7y!o&Dzq^v?t*2ktvIxAuz%`QqF9K$iII3DEHK&Me5E
zcMd*?$&EqfRPMxIUhtBue)@9pwsOC`k&BPq`JgYCUwDUN$v1IPW9ZtmEGFjU?GLnt
zKx}6Mu{qwD+|}65Hnu+!F?nMn_kXpR+}+szNXFz%jog*Sq|TulRUexARNL))0DHY_
zJL`oyd*Mz|Jdz&4IjYL$u^B
zMcevJKOM`lr}#>KpJys^w7Eds`|&mBCw<2gK+}(%3sPNGrZN!)1f>usLAonSofT3-PcncV`4|>c+Ju24ta^lbZ8g
z?9if90)CX>hsQLt#sU!@kawOdvBo424W^Q?Bb6(-^&kvS8cSk<%2Ua6{y1pVg$cl6p%{p
zw&1eBJ2wC5VgJ{Lmi^@TUW1S3K-7UT(x1nK5N;d>l->;;6cFQ-P#X(%u@A^QF{&fhg$=|aAITCAo-`Lx$+>%}OXFMCI
z-%+4#4#a7QuC48&6U(gu8}YDHy{Zp60zRl6ddN_Z=FiC8%le|#`MY87X;)~4bYEPuF;6Mn1}&cVr?HUyINi~!~f!S7Z#882ZPFW<$>%s
z1!VGxT+bK!jPDGt2{z;$&ZplTh>bdBD<0?T1wqvYKhcp{eyS-pwD#gHnNt~~XJcRX
z4`uC+e(vOY|eD2=apzJk9*M5#r-||y2B=ap{F8}5;
z2Q}b4JRv~Szw6W{I(u&oKiw67Yu}Q!-RZT_`2Q#0DeACnVjuo*Jwcn^Hel1Yt-vOA
zUvXArX9w#7_mr5{n%uM5-T(H^=26C)v)yc#&r+s#Tm$KWsxr?+k%+=
znBU4>Y2Ufw!}_45r<-4L{+(gq2j87}JZ0-kG8T`rzjAE84fJ8Z
zQ{s12oFDt>N15}f=1=bS`C@HV@EhGTU%YDV!`)i(eSdHMmdyE6_YND;YH!G1JHMef
zA9b?Cm2L8jUSD%HVO}`B8=u+rXQ!u+uTRPEg10`uI=}mTTGp$s`1peE_ouys;UGH7czFhuZehH3^)?59x|JLl6z4W8&+ov|49=bLjr)S>U`?0@0YA?BRc46lB
zOE=p}=T!DuS-+E7Xl4CC=7&OW?O-QkU3zPpoYlE#GP7BR!P(17~N3WTyAF<@K
z`%Z6Ne@?I8(#@+EV|1QdL%lo1x_7io19{ZMfiF)DzBhsLjGRe;$=w==opx2gmNy3O
zq<`>V(UJAN5dD5&K*Ht=jTk2<(WSn@Ix-k-|I837%g;TKDTz@eM5j(eAT$~
zC?D3`fj$Qq&jzOkc=YzflC5;v*W)FJPI->m$G!_v%k-!PZ7yhKo|3tGkvFv>ZzYo+
zGFyAl;{SqxemVYuD6AZdDH-f3Th%I9XIsnr&H>(#4Dw!*bvBVzveh0t_)T~DFD7RN
z{A=~SYd{~HN?vR0a`cH+sNGp=rn7yf!tNi%UjD|H1tfOQ9Eo|6~XtW*UH98Jf*`urPk1m0#IF6kwfipkjL%#ze_T=@9e5mIpW_n0edv}5qkAda@Zm!^wc=R?!ENr-$8TE4mA6H
z+KN-1qjLyIn+u$SZ6;~?Cti;|ceZCvFJJs^0lj;*Y!nmrs}J>QzupDd$)>WS9an6;
zAK@}r?;86q57ZR-mjz6zmyYRR6FZmUtK6_nyox8o
zv8?`D#aezh2Ia3fJu}eo95RR_&g^@Q)5LQj;By;mIkI+FpkB@kyo2)7`$yFj8v54-
zm1}pqMyECB`-j5lo}{}zhpf-Iy>}`uwMG{^c}k)bAh(0zU)aTPChD}MiHbn&OvRk6tO_+0YgjNo1iX~p{^;jP${^`2%vME|4B
zKKdVP=55^R*cN2_F`q~+sK@pU+T*`ES{tkjmpH
zX1)L5SL@pwn(H&Je3V}HvO|vRIb6EYvOj9a&)qf$^$Zp(ab#o3Cy)Q0-_B8uJ#Wxy
zb-w6-U*i{Ee%%-ppV({+*tHTH_}J?Ci2*%}y|;vY?6;l`^*q~?v3SXw8mm~Gm2n#j
zwZrCxpw1?n$T}s^$gn2XV#)t{E}N@6&1aO#Pp!W{{!~8EO;4cvKtsnyI>lX0ws}80
zbNl>b)84?oxjHPqe;0YqygQmL&QqcCU7uk#WRI`-TixUzkM0jPy2&lQ`boOk+UlnF
zcyxd0ICQg%ZvHxt-VYC_*TjE5V2fvfd!*{X`a&RXwO2j*dapCCbE5V(1?oUkGw9p_
zQ9C}%&&_>#M#gf9cVoAnZv4z*=L3N{bT8f*uz?)s@?apIVr{ODJ{;j}sGOgdvAWP+
z6ijufdQ+?aK0JJ-$NVRo`GL&oY;}C3r-PrXgZ4fM$-`pF7k1qgXtTjJfitVI{XY!I
zW&0%oK6Z#x<*v?PE90k@kRe_}GQ>lx{GFMxeDF(5emZi+Nc_}8-SzDLX!h8!Ezmxg
zyz+N@kgYL(Ie%*)!?6$O#QMIDPF>2cb@Kf;W%$kUe{a4!JFS_2MdtK=ESqSw8++fk
zo!x!kRxddsVkzw&B^6wbs`Qdh@lt`KrvFrQ#v?*Yfkg
zT5Io&%A-72OfJn>4m9_+v9ncvy}gs=-L%%eK5L~f%a6G;^ERHhWPVyh|MJY8@5*UQ
z`@(LoY8Rig|Mx*lcWI}C?d;4EYrqzHZ{?xCJfI&v*^AMW
zkv|hKuAc`o7Ed)*?=yT~6OeU&z&E<-th@bZPda+nx@Sg#cEizbe6M~YW3ibD?g*|8
z$aDw(TzKn#%yb+_b*<&kX^icn(;9sbWsNNNhdcX%z&W$#jIba5UBNZM6N37TdvnIO
z1@3{_fL=AKnd7s!KR7RlX=8a}WUOA>QCVH{!)+
zXzA1?Ix*9Ve=g(MfRER8Jv~uB{u@K${lVb+fSuDpEBASsQ=
z$djYVO>tLpUrtZDLWt>)rt&W5VXTQer#*>OhMFBbnP0jd~edh8vhwP}CWKNOVh
z84lX%JmAwx??T4(wlbn}{EnucX9D_-`78e00xf^O<6+M}f8(Lu|3Giwe~aJl`)_#L
z`JKJ_Exq~mnTs9$Z2X+w{!e!AOxYUyoDsT5t6@
zbFI9hX9GWnWZC1_q&;z(v?mvn_SA3fwKkrT^|EnG#&r*5c(`{`OVO6^Eq&|zzX`2ak!8%*io>^LEDj$}9Go$6xG$(Ue0Rq9-W;@X
zsP#4uc*L^eaB9YyII#IZKt^l#Lgu#zXkx;{VrAaav*ULHw2rp>_ZLId(umvhgMKV)
z4XxM#c^7uQx~w_*{aR!T*$)M!Z(XKtzp{wjUp-E_^nPXF{5uCV&+wSdzqSI|H-*pl4}94Z)P3Tv
zv36yk*)yLD#7VrIk+og_gl^3{o%4bA^#L04orjWtcE;peYvtXNIeNa~C&#%`J9wQV
z^!vMUx^W$>PCp-1o#O@fy_(UgUeKwl{_|$J{Nly_R|aAr7Cv{qAwAoj$D4yX|LvZd
zIvCVhsJ(^Wnm82LEyw*jubMnPd$R$5YfYT^ZSL9Z>~0LEf>zG9%r!qFJvDvJ^Jn+Q
z-;-RGwR;hyxogB|mr0uEJ-KAc5n6tTf%}a-@wqFwCiwiIJ`Y%bd>|fkLFJR5`0fsj
z`9_EF9RWG@?{JZ4&pG?`5R_ePAfFxTu41A_)^+Rb6W_j#WU;Z%1Uc$dzU0%Gum2*b
zGf*|jAA59IyCNV*Ew?mu&IaV+p+gKx-s>|~_tx#pYa65TTTGUUm7j6Xhpu>x)#sIg
zx>^%#3AP60tqs^({)=VVZp@zPfIZ@RTfl~ypzb2)l+C3>j_Ac-IpOOEf>EGt4(PA?
z^LNO|t+~%>?fiL}i?tY{q2qDgnmJjgWNx4RMe{ek?-1+v0k?NN_`W0G=cOC-nEN*g
z7mHWX)XT0~_VP@~9_6Z(ol_Uv$RcEb7nf`m?*3pwQzN+n_{j;p2<6FfP{U@_-4XwU%VDA^R$6hkT|6?6(8{?Ay{%#LFIjxWH&R&~0
z`|Q3vC|mXB*6p*^yz*$xoLpn^H!oY{)4cpRqnoQu^zv+99h#rj&E2Es@_$(%$7E{O
zOJ34>e4>y
z^44@?KEbmCzKF3#HtY%bMW=mynwn521@>WjDScV>MCMY7ea$Nl@64S_ubALR!(Mb{Pw6fBC8y}b487;0-g8jz^RC`!O#L}skN?s@
zj5PTrqw*-0phmZMV>!Sl_Wa_z99egs(f)IJUiAGE3;7WzwWW!{&cGR16Fd^ni@sj9
zOYdjmdC}Lc_NM~1cSRru##aXOfmoD%>H@^$yg=O^2+)wBsSh=%sTs1=lG^Oo(luGD
zIFq?CpugmmezB>VH3ojDS!4Ie@8o>x>8S5ojQ0edk;ZH(9VHJB8TN`#O!~am%74$~
z^#NaJ0aKRq#as-H(Own2p_`+v_dz+p&qlsiJ+`&V9(x*I
zK9R|n$^kw78jwd#4rT-Nqd+5n^>}o2U;IuE<^y|TSFtpPer|sKICE3-+T4^+l~Z})
z_p<|S$Z!6*1N(kgUAO1Xnnvb@RjxWBe!C_RF2q6u6{Xk(P_n_Hr0mOs~pi?
zWB%26D&v0cmJ@5Wq|F7D4|Z7B55-yy$)}oWWBjDdwMnuj#kiH%#@4e*TTI?iY+HGY
z#k9TuCyj?+kV!o)L(Jnm#vJ9q?gWK(4(gHv(4)!ond8yX&qnPTk@tN8-D*Y-<-z*?
zfGzmNv8^?93qi@k^ORsmpnlwqdQHt0t@z>fdlTqy3)snKG~|>W?D{~!HZttdM+STR
zjr5X%W?i5e*BNvc_%IiUN!i3FIc|N*bo@N3xZ$CbZZh4wS|Y@i5Uq^EMC7V%rZBOv#Wqia6B&ph_r5#>kStz?uh8IJWA
z{q>oP7h3wsBtr~Zo(D76^jm_h0Xv{_wA@&#Q#Q->Vli{Z#B6Ox%O-IWA37^`;!l=6
zF|FR6Iur1XolC{?_j<9c*wDM&*o1UkL+sGx8gIo&9h>t(yyRQk8Eg#LDmHS$<~G)u
zKCFh>E9c9N`;$UjH7sWASSWyAKxtl|OYB2*I<-IdScNyn~0PVXlDj)2yt{;lE`Vs4XjGvS>
zZIY}>F>d9xu|4~!xJBg+#kQ5VSWKTB`C@oOFloG4Oo#53g~*aG=h7V_hZ_QCY&s};
z&b}CmIhu9BkUX+rcc2xGwLQUS;w~zi*{iwJ?hn+QoN8>b?k>y~@vzTphq87c(6j$#
z!D~CHA+gX(hMe_z`1!ivH9^bc3_c~$hU)IztcyLm)d8FRe5lS2U2S~jO+M<5VlNqZ
zoniFW$g5h#BahDx>Umo__=d+brgBv@mH(1o`*?N+8w2kc^8ugHx4AGEGxmu6%>g@Z
z3&e!HvhB`{*}M>thmJo!msn$C&7FDv&j#Kt?8)>n7kY}9?rmy>mYJ^YsjFsL(e`ou}`eG2V`jyRkIQDtkAZ;#?=QFl*@V_)z72}NW4L%)IT*)C3vSn?x{m@TOHK>
zNw3C!c3Cf;Hb-=liJxvgzh4%-Ho(Kq;xPs?#TZ@|6zx>Tn*GIO(z^{|TK#Ol=AY`G
z2Q|+>hdh2h)chxVbN?OVsgdJ5r0KxD@?WArojf!B_37n#LvV3$N^n|GXHvXd-cJnh
zs*NFDai;IL!&CK~>G(SwJXxN&EQC|G+3V-$#~K~(K|0Ruc-rvc5
zT=ca${vYv&40m4JZ_b?lz75VPx=mfrck_C$RI}#Jh`wwty81bSINLAVXS#XWv9+7;
z==vvh{RQdW<6@xE!y|-t?EsDE1BhdbmuG%WNAEr>y==(xv3GtpzA?BqAjdwx`J?fZ4|EsJ
zfz0a}JD;(dyCtZ&+?_EUJA?BAcXO*Bf6>aPdVG0M_O`KP53o~h8v8j6oxnD-)U2~Z
z*17=wLLesA>Dds71zK$`xGFF|x9exqTKyzUD=5R@$I^y{sW{qjKVtW9sPd_p5OMN1x??3S0AK&;SD2c?4y
zW45jj?4z%Ja>Rw~s2#6Y4T-lr*;fY|zII>Ui=S*fa$oW*R@U2nc2!N5U1%-~?heWp
zYjQjvsC~Ax8SgcL=iy6&l1;B#nhnT6U-C}R*qO6_M}Yq?QsZR1L+!bn$)K0-R|V>#
z*4S5ei)pJ@{5J;r%>g?!ymGrQsJjQRR<^lc@UnqSImA=E`hE^;zs(`N{M!<24cGu^
z`NIZd`Np>=ux4z%YF3V|$-8Hi`BJ^-5<9ED#6iy7W7`9E$@`gI%<1DZ*<~*puy;$q
zA2Au)XZO1rnhcNS3_pMWU-s?=T+^$p4?Zv$I&e`}79
zZwvY?6Su}I!&NTipt|JZO#%Lk1MRT^`FK3H#m4%+Kodi@(Iu8>@xeo$+{`k(A5;e4
zG<(z=8C!vdo@@V{(7OV*h|h9O?K`79F&-;*E&F7)9Rd;ypr_=WaY7aTJdEGssj?L52dh3}bOEbT`
zH~7$d;{r@+_}1MU{MHTz?5Vxz&A@%tcfwi5T(9J6_Q`hL-gT*KYH_I?+M6gT|q<@uZ97kPXpvwo1t7WrlW-GO#`
zAYa~*YO^}r74Ye%fSyZ&bv%5-BeuSF!%i}tiQ5DA@qI@OrWapn=lSx0{C?)`Z9Uv~wXoU-4#vny}-_$(*tWlum39%$UuKfC1McJL(og%uZ96}$&-q^Gr}L!o(^wApx;bcbvp;gXD`*_H%YAdf25ru(xqlgdD}!#i
zC2P)YYg{cI3VI%#SvEz)>iYrw>erQghPg3tub5{)`8SR6CFwgq-$&wjN>E?>eqsL3
z;M%}@7CYP_d^jUu({qB__uP!d+&=AH0sGa!Eo1ENYh2VZ+xSja?>6-`-yicHu>yHw
zGoSdWhTk8Eb?;8}GXnZGw(SU-pV}!#;>w;20{YqXd4apozS{h<_Kw+cm4-
zoy?DofNfp#E^u3Dv2YjSVY78|{hJthVRz^5${Zij?7VG3A6U@8nePkYKQQ?1`Q;du
z?x>8vwfJ75zhgJs`R>rpJKNlYdNRe79pdV9_dmA;4Odu2QG
zJ-Q56`}l32+M-8}z9|nEbMso`Vf~d^XDd4zGrzax)IsyVzh9diP_wg)Z_D>0t5@&&
zKCfSxbvnpj#WOa~@_%xC50YH_#cAGu?^tgfYv+#4i-TsLXRzM6ZEvpgbeiX@zO*qk
z-e(PZBfYxEuc=?pvh#xT1M%a}J%PqPxhc(OjXz|O1Gfh~qq{PGa`68|(8cM=+zPZC
z0`lj5Zx5Z4{jfWW?e45qZKY?+O@ViEGQ`PV<8}8^zZT9%=T;2G$9cXZFmLaxf;pEy
ztIqTfhPIE*`-4@j4tqo1?>s*&=L#R&@M^#Rq5GeuUtQ3@xS)R~wA_&~%lWa)%bhvR
zned+T)Zmxnh`aDD4n^9PfgCkY{5cr#oI+dA2g4Xo`6D$Bms7+bCh%vrxE*cREo1t`
zP^+z#BR9vA<2~dH;)MHdBj6*y?XNwR#ZL9Aj?W0{Ut`mlKOt-6=#PaguXN$HcV{Zu
z_*f7Z>y4SZR?}>egW9e~vrSC+=j_RsvHH@C#gshj}lNW`LiC6r9Uxw;r%YdrWZ9_Ga3KL_^wd5Xu0*2iBQzAfXijOSb*
z_x?GI$I_p;u(m#~-XO0CFuE{#cLfrx7=&pKku=AQQ(d|6jZLe
z)0uZy&U;Tpw;J!~wG5BycXyMo#;Y^Km5tTw{lI-mXZhJZ^WPepeD9_j+xbC;d!{nX
zv1NIuqx+u2Kl1U-@e8@4@u_os;_$7R|Ch9M0J1KJw&I
ze*3vqF3t|fbT`a$L$1E|;*OyI%Ak2PR!d|VtAl3*%*oR}Qs3wnpZe$PPUzb7(fY_f`I_I6>nA<`Y4Wqa9?MVm
zuvHz4x3+HXQ0BLbNxtlQzkHMNK=@l9>Jj9apUXV$%-p^}-#v3pHMUt^`LwK|rF`*G
zFJP})!PB1)_I0FVokzOoXNa7*!^zqmi0OgAz5DcFD-aiTipRRz>|FCO&$XVGyyn@q
zZr=XR-;(iGK&LvH=f!6^&!@`+HFnup$J28)=b$+jGyCN2wqPr;pT5mND^0&To%6>=
z_mw(*U!ZLSYM|#_Ez}M&8?)w|{_a0H3n0cDc0~^Vt8}G{le=moOy8^vCUqkN>#7i9C5!g$X=gy%(
zjyJ}byyhQ|_^sm+8~LP%yd42K2ZK9+X&+t9O@>GF&KACq+gjj*IgJkTe66JlN|E$Pa2QP!ABn3W;r46XTy@7V{uj%#kO|-!KjtezZtqUC7!zjHLphK
zr2Ew1n!tO5*0bCB)>30v{o*KAm2)`bi-Z3fM{i3X)%Vf4Cm;)2H)js|*7RF}wzc~I
zk-g8$m<)FI4%?Nnv!+(`YDKS>=mtKx&$sK@_baha+{K>^Hq59Tev{K)e%%}9JTLTW
zwYuAz=l3%L{%Yq2r>sWD&h3-K^Q*B>tZE~FHUqZ*+GM-=)}DR8evEw|+-Bc)HG5v<
zogZY|3bjSQ5wtec7M}g1@4K>ka=&P;kM0p4ZC#y-lQT2xzd5wn^8dd@nR>r6pxYfk
z-zD=onq`D-wTDgY=>DyYwWVG*@T)e{Wv(wFN`?QFU=Yi|jz3mzY^vw3C{
zd)Y*WHNG1+4m&gMe)`K}-gC#flK0OE8ZY}lccSeRhswSq^;
zkC|S{WzV{G_BOxlq8r`%qkoPm{yAp+GuJaP$83&=abs3JjV;^ApmT3PXKi(^+4JT=
zj;v|c?Xm9N$sOIf+1@Oz{8uZLIj@sJz8r7IlckjmIcluL{!PI;nVCMyziypQF|1GG
zG221Ux_y~GDtES{a?BkH4iCu5o}f8tPU%}GzkB5c@4f(UU0^4+Td*RMSNf@
zu&=q-zcwJhwuuE^_R^^y*ta97ZZb8x@y_vkjD@sg+2uLMKj%<<*2Ts-qo+DrSFKZe
z-8FdD#V^zM+l#NYWv_ND8{KowLEo+CUhQvZyF1_`%_}?U71IYh_hdhqx!fyQ<=iC<&R54a-WviWM(<|9>%)Vtzy6z0DTd#aE*-pmH
zvz?skAwxa&&b=*TIXoOZGtg%L&|*Wbed49bBN^u8M3YN)`sGS%9c`_sBYMegEa;VIdNp)?mwS5k-T}7rzxiC3muy?fWY4X^n**^>6B>Qn
zJ@5K1V&8Ugzd38ID>B(T(;<)Q@4J+Bb;73F{OXM9;A`JIo$sDY^{BDeKC&9a%F5I+
z{qbJPKKo%S*b&f4uKu;b{9ei?yzYv9!OlR#zl@vD0%E%>(D10a#zUUukk9nazVQzq
z-QvhMvhXisoT*jqvTL?|%R<`L>iuE;so-tBCu%=#?m$K$2zf$HZ!|GJMK=H%}7
zK%C5}zmL|Z?d(?va?j^=xo>RM!)zb=@}Mz#e#TnsLchFw?#ef~<)b`uv=M0K_l!{w
zJI9>Zpc|vjjIR$~6gWQ@2W-bPKX>TCvm?;%4f>2}Z=KI#-nmcAm@GNq+dYA1%qDAc
z!ya>U9kWLr@Vl|XhZe8yBct_A-=RPb$bX}VM)<>Twuy}xiwFDgvyp#nx+}28
z4mHwsXR-3klP6x}-4f8z_}!eb{g(ym8MXp#YxVylXZz}m`AI)N4+dhPj`UlBX8&^n
zymXgWysfeEjDTO}_|ba}uXX!oJMdgH=E-HhhSy%GyxA`D8#gwJ8=5TiGOlvmb$-@|
z3|H|XZ&~-|#Ev|=tIvKuG!JS?yX#1|^4sv9fIoab6x6@w)${J0VCR~3e(w!-1m^|k
z2lfGb#D^XHM)Mopb^FPtd%6E`=Gc#CU%)
zmu!BrYqqie)Yj^;zvJ$=*WBS?E70sSe@pP$8OZrlgZ+WF{2l-P=ISY#@A^-MCeJ?a
zR2K)o5jk7wKNRo_FCG1N&85FOd*!k8TSD`_^sS+93;l6F{dG^9b-p+gknqPu@Z1-2PU6-^5IR#i045y4~NZjV)swS+@lAdxv$CG9GiO<^qmX(_67aQ(Be49`!6hbp1PpV49zyN
z(AUq+jM>l6U(XMIcU_$E`D~@%82#Dl@jLTB7=CN+G;@6WmLa3`*DUCFF6hq>O;`C}
z6}mM--nF6YC;DJ$Iv+XhdGeTRKJo1vb7xF^j~;V;s=ialT=Qt}AC2EnG28LMG1v2h
z@869%F=SI?qqcu=tf^aTdjmSHef?PTez{!x{H)FOdN}kPpBu*BePi!==_~ibv3BlQ
zJAYccFF$ZdSM8bC{(aVFoj)^p$+hQ#NzQw-HrMXgFX*pW&~IPRuV2uw4o$~1h7NIk
zVdmIles@s+9yjLE_|96$`jpV8X1?_z)<2(Lb~4-hQw#b#7W7vx=(jKE+e5QU{AYxV!?(BfYD$)WkJ*t?I9do$lV
zd?U1&s4eeH?xT6myCZwevA<)sToP2*ALm7&KH@RY#{ZsqKI4CKKu+(x(v3&y`dZpv
zv6y8Ti@E-qfLvoXEa${zImZ`s2ZQc)r!41c`^;DS=ehdutVv$|@J?7AO6dq?hHxxw?vFUz=V`d1G6=FyX9
z{wyr-M3{9|L2bW4Woa@
z=cR^#z%KMEd3YYck(EMcr6G
zIQlEn({oaAS@`C={hZKvdpA0Z=ss(nopJa6QGRjRy!Stc#>?+M6MSad2+Us>)W07O
z@9h6~j=gN-PxoB8pzD)6o6Nr$kh#Nn$RHQwk1hCm4jw<~i$?E^T5mnHZ(V%;SpUM&
z_dc&3$D@01_71FHdxpHyy$^f0ZI1P`N8dZ8XSZkb3LqwiVx>w|9J`L~VvH;w*_
zNB^ax|FY44#pu6k^j|Xi_iRJ|y)pm&qyGn^|H0A!!02nwcMN*j|BW%<{yPW#_ZR(A
z{`<#z`=1{4&y4a^3gXAe`(NPJNnY)|7&CZHKTv+=zCAJ
zu9kG`>-GhI`Fg*UuKuqd{O=gO^Prx;W%S=R`fnfo-yHqBN59N#{r$?Ze(&hNX7ttf
zO@sc%(SP&kt7q9akKZ-;-aGp59sTz$`qs<)GVi`qubOwA?+%_C{MJK{eC_=Lhb+yz
zhx_8Bz_~g#=-elaxtFAO4_z2&?)`k+SlwgJfW6MPW-VWiS*@x2s9SwrW`n!;MZqJ3
zng00D+Fik;f`*#F@X-831|E4Q??9jqFA1I*JUe)P
zAYLyEZVp}(ygpDs=_v6CbCjKII|cg8mcjYn?K>R7Gp3tF##8a`E~
zdR5_S{Iu2RPwXv^o{hEN82@JQi9u`3*)?B(Ka&08(0%lfy+7Cyd|J+6&n~`W#r|0J
zx|HuM_k7q#FP`R1PWp_P^Rk`(u&?fpErYZZxmWs(pc_9uY|d}3?H@F~pa`5zkkJkj(2JWgi2JZ;o9eic*^#OTe)#nYno5$YcdbynAC&vFL
zudAhF`6ssWUB0>I*4-2CjWfdU+D<4n`HuI3+}Y85}R^v)(`Y*oKc3Dmt@TorgutNj~-R|K~PcLc3@
z_d>q?cVF+2k9M9NI|APa?p^oM%6zbFd$8rGh1R~jsT(=y9q~Z@o^##3?#|w)CujWs
zH&1KR9l6ey!zW2CoY~82oYY2|2hI28SZHXCPvZK9j}B
zGwzYWW?&61zZ*gCMLiq$1nO%m(8!#hQPwKcbMT{;sixh>2LrMjw|8ayU_g%KYdcxu
zG27s-6(4yPAGCG0v9aqux9<;?1xjXkX~>-f-~)4)&q>Tl`UHhg~?w!L+-jjw-}Y`bQ%O?>_=
z+4h*pHns85*w(tbD{|D$;{xrTpzm_dxw@1ibxEf)p!Ql@>e@QAmRjrU&e4g;r2oN|
z$+ia~Q{9VE{d`o$;%%P)?h3S+s1yA~!JfdLtw1|BSUwy3_0OK=>%!w+-x1i$PO|m|
z=6!bj?@>(eNx|NrGUq!EH{$jwS1OdoLey$zX%n=^H=K
zSoW~Zy-6N_(QLEkK6`1vkCOxO>AgpmJ=X^>3giPHJ>JV67SPqNAsg2xe2pDFpEB0S
zVFSK<1M}plU%K_%<+L$-F#J9oJy8Fjk}?0y)qgqTe|TR*$G*z&F2;Yfd48kC
zsyxQ@kT2#-UUk0YWs`SDJ(fFrumf+26=Eb|QS;mn4;^$70pN~Z64cWJ}
z<$>rFUw*OCy{e9P1bkP!T~kM5Ef3~v`<{%gZ3Wu7fx42@-;eNRzU7F{b@u?-^5FXy
z&rAPcz&&~_IgL60`Py@|-Dj1?y7#l%RxkED4|9BcM$&pWsFyQ?-GREtZ@+ml6JK!^
z->pDgyLTR|8F8m;E6~Ki!Snxcl1tR-iej*8VVS%QK-C&I`^D$lVc$2i-@`!^2i{&kFsOf%ZiK
zJI+R=-F2i}<&mEMu|^Mj9u`zTUGrFe@$3okq4~5Cu%~!J#(3Db6===5@xee&8`}#q
zri(mt_U;%oedLRAv7LN-&lP$uYPuqoxR_?pHG_aF?}Eqm$wIeqw{@%
zwh`PGut{9ICRgST1?1Zsb*rDbL%%h+HrN~Ze8Dchy*$_(g1*Y_JGpwjCBQGgOI?{-
zJKy(pI@rY)WAA_bF}^ckkKdcm=Dy3*x1DcUI%)$Md=dA?nrz@Nw0_RWcq5o=VcwIa
zmD~%`s}ps`2CaGG$4dio!XtL#;d@eIga7)#dn|qUoHupDCb?={t+D^Iz?hxvYuuLa
z!i^1HdimXYW}p3J^?b}Rp$G7-i%IvWzd0rkG>+B77J3@%S#Ei*8$4)s;}G>Z`NGuG(q;nE{L1VJ)`OH^MoW-gSEvWjP1%?^Ttp0f>ul3L5%HNcc0qJ
zE;;XBw7q(`AzI@bap=_jXmnfjuO4SZ_7q3L9g
zn5qf++840-(Sf+RZ}@U$u(XlB`hHu+X#DKsBYl-a&n(M6{7($TP#*EJ1cT+XJ2Jkzt1nT
ztuv1t@Tdb3Y(HbOl+CyDZf7&SY`{0`
z-yNEK=bZffGxPh&w~zdup~|0geO}hj56A#@A_jChEA}1;$bx4@$4$YP1wR!0$H2U^
zw>O|eF2$KFYvQ1H?pmw+GRCXj7NGI-XIVFVm}S+EWo~zdZ@XOGm^E@Vvhc3U(>j^!
z_-jLLmY3yTKCjCgU+LHCd+){G3HGvg&RyejqB(PCkn;`6(fb0Q)6DUEZy?rvwq2fa
z^W%Br?;Xk2djh${t3J%J)qb)&cW%aPKM{FngwMN_M%TZXbdd?45;Oz9e`aB8^>teX`40s$Js6
zr`rSV#ettg0`XsByZI$w=_P;Z_T}3fUE=c4fIZJ&&{u>OkKO_M2mS8&bvR>jAbt56T`;`@}Q~FrS5C9pWa!gG2U6fJDCmgyC+aTyQY3S
zTgcY#3Yu&5y8^bdSzDd~b8^fEw!qR)ds|!T`k}$yfu=UJo-20asSI>wcaD$dywllF
z9vkGf^2E~K>cs=}*vsFJZ_C)3d|jY6`6wq^<-I%O`vN&;pWb`cju7*EmYB1XE%a-B
z&!uCYr}q^BTizD%r*W32?@Z45LEkOGGlT7Te`>+2p77ogR7PV#9@Kxnbj&9Hi^X#O
z<}oiu$BPqR&kESUCp3uJNsE~6HWxH*jrlTe=EdRh!R(v7YI4S|O+?ze0{7H8h%_<1
zH*w;hyJzPBS%qi0vHO88yp7*{XE@u|)qB^`r%ZH)t2%#W`r5v0tk-6Hjhh=|Xsz3~
z5y%B}UQG7|jn&;5YpuD;?KA1hu|}4&QaPWHu{pJ8FWvR$j4|(>#`s_$9_)BiU=M%j
zn9u#r&|=Ou^5~1;&05<z8HT*gFoNx2rq*HFq;#dOokrczLcewbH#W{gQX~n@skKpN4*2;GXP0HPL6-j*R7k
zt#ZE15&Dj?rl0RA=bN9MTlQkbwnIVhg!0G>+qC+x-!AX?&JFD2$IQFVe>__K$HP`K
z_@p&ICsOOJ&12<=pYG_5fPTE7zMQ#p0=3Y1>>cyxr9VFqPwj9p-;d_Ei%VtEiH|-u
zYzAVrl(i#sCn9U+o8#;3_!N
z)b7m7-zNp@&Xe=P_hntX%bEjzG%n77dgcdt#{58+zqYE6#`#YxXT5`J--DgEd*Z|M
zf@cJpT>YKJ9k_qBa^$(SJ7fO$yvorfNq`)Pk+_O^Ye|mx1lE?etAX;_vk|O&UwCrn
zAD)76SIC7L5&NE>von^%`I$!U(#}tck+a=sO>I3sV2^fpa8=;>%)gTd9~)2PPT(`$
zC*s>#;Zs+9JbCg_ywr4k+?_EW&9hhA70|Vv9z4!Z&szD&*$Bvz@1L8_tvY*Tpe@hs
z?#wl&F?AIi_Rr__^g#=m*ol|M=4S=n-}RpN(qb{^h>z@-+umQ~(r-_BmvK2(ZDrdk
zE|tA5F6_N95UbjDX~x=IgWWsVdGo_JI`rjR)_ImzaXKgcl6TG%nJ)+)9cbv+1>)U(
z+daR<6dFI{I|8}UH-_ut+O_s`oa-O`$MWyotgqu;=O0;G{cHTmpj+#Gd?II29gu17
zb~YZ$THiy;D@M+qdX*cx%C|RT`PRsFPS-tqtQ`*KXSRJOVu$-+XNtUc9=q7k`{3-1
z#fF`lv-+dcy{%5>*f}q^1g{8g3!WJ?|F>t{=ObVEw<9<&IDd@yr`P^#bnx|M!3P30
z*K@&FG+V;~RM@!&r>_{DcC(8v)#?XKX$fNp%^p)Pt?Y-Oy?
zd&*NA=9uxRwL~7j+0*5d;&6@XJ6xLuIXyb`7eK+oA2S}Jb6q0#&F5Yk0metotxv`
z`r_ke(E6HXFZmk}dN%@RN-aD-=y@imcX;(?YIWw+MrE9w@t$D56WFgcCp$7Ozco7L
zsB_!ZE&H^4fwR{J9Ua<>
z19=0w-2rM%ESK@zmpMMpa!v_-Jbvr*{j@yaXJp;^)vP_x@98?bn!U&Sp02v+^YBo{
z>|)=|(>TMGtoaUVZo5ZJyT@2t`bDl9*=|pBDfVRC9cXOyzO^fp>TPczfB4qr+d16`
zJYVHc(?j{m+%x8y=bjCDZ62*%jE-*4&G~2H)C^n5s_lH#YCC^5apjZs+F*^H&P?aF
zyA$}TsbPBSA78a~^~pc;e7Gn$Cy+Nb+!fpuuz_9koi*QcyRx;?!f2>$pljo1i=H}Uc@){p`=esy8>r2k)!EasOPK~TNZ=0E$^M?0$v1?s4
ze)Zd45MTC@?Y;Y(gXa5qyzhPhyuUT^W_UCv{N4!Y{;Ys*b{$Xm_YB^I=zhE*@Ap1%
zNoa6S><%sn$Zt-nU%VeN;*H076BGCAvG#oYHhXqw-*$TZ4jFk}>gip)&bCk7W{>&kMp_YecYNkJnoDoFWMRHJR4^FoZFf9ED|g6Ncivf
zjCj>F|LSRcOU7c?J@kE2Hmfgr*b1~80=y3o@QS;(F880D{m!X;T@c3W(xb^fZLxN3
z=H%q&pf=1tWO`-Gr)1xDcZ=NG)4SoyjC)R6GqqW6&JWlR_PC=q1HOngdF%MZ3xOt1WT)I!c?=I6cTJM#qj9(@9QY75gHwMdS|^LV|lH-%Z{;rC~NgG!dg4ffq07{p3dW;Q_Yj#
zJ@3evY^}D~=iHG;mVNxttBtb)w)s4CIH+tnY+U7IcVLfow#wgZ_uZkjQ-YfVeDvZI
z8~(~o!gq9?Kh_Tg)%)^{`NV#{oEJF9_L0L6vGojjLcr$cZM$)E;hjXipBC&Iy&R#%
zV1K}7KaXlp`I;*{bL>JMjgi`8_q;BqJqvHkcwPMK6CHf_+_UE$0sl3z;J-N4SGLU0
zQGW1`4?BYYGJLo-ClN#uLYh8bP#&Kcw^O)yktoD|CWUyDOEyi?{YmPjv_Q-2(vSvSfI>%;n{HPqZ
z;1!o^0?4!C
zTI16kT$Z_|&c^tqSyMaoyFZ*TjcsfcC1E6{;lLKV{HHaKwf@y
z+ykY*cR_z+Xf|}+&tCEit$oRYe#e4-#e#nRg1%xwU$UT|u%J(0(2oeMerumgVfOEL
z^F!M+{Y#Qu)`8xl=Po
zp7qLh4_pvDI+(|5;juApE4`elRoD~ofvn!`eE5%leBXWD|E#f2SLY69T%GoU&kXwm
z@_!=xXFt9zv>4Rq#!ao+L+9(l(>fMUYvj^PmS&FK*1fCg&lo)(v_0LgFaN$Vf8OX1
zEP7`e|M`n~_RaIo#7tM-Q^x#LNAKMM-)D|~bM$AY_l)yg)cEWU5g*T6cdLAzm7r{;
z|4<-a>=4`CiPKD<7MjmpKPj}_l>Wm%y8qvk{mszLHF>`rTI}#^KOdU>=2LF|N#^*1
zPu%Q-fB7p%{tYsH*7eri8SwC5z3;x=!Bc`=p_^}e|HhEX7WW(3WZ==yHUGwijhka{
zZ6xnU@=Gx0xO{JDa>Tc>_~y*9vGl#6XPfQ{J;&w^Lx%S(e%0@@<4?$yo$gb5&K$kG
zlJD+)(%A1jR_8|M*l7>Bde1TaV}kDeuKZ)RIWJ!u+CH_hJ4s>pW-#;IHSuhON9`|p
z{H@l?*$j^u;-O!T^yu1q#^7(r$s78-fDF&W_vG)KT5qh$c=I&Z
zJ=K3|*2!ot$avQHTd6(I=Vp$4vL2B&yt7{OzmQ*6QrXtZ{}Y*KPkpd63{DG3jv9iSsU-y%XX0QH9
zfw`T*?fJWt<{mfZ*nPv8d;B!_tNB}XbKQL3g8q)swd10(Pds10;CsQuS3B_S%{)8A
zLI1?jdw#Ih-SGeBZ?>uBJ=wt5jR1XiXn8@KUsq$7WS(62D0$-i!pLKD<5itcA3XB<
zd-+>yWR{1`vm88c9ejM{mv2pmizhsva!~CpN-^f1#Gqdw|@J`e$PX5
z^7ONrn{)ER3;Hh)`apQe&|aAP_iee0p7v`;zGm-iEYD;8==o?Jxu@9W&e5MW`pwZV
zpNEZuc;aWf{+XjcIQlC_|LoCUJ^JU4{sp7=u4@0w0zQeId-CVw%O{P$U)Zxg%Mven
zx;XKW@7AfjS|jJne(Ok{$$!o?e`n?!kJi97V_i&NmG#D{{qv^vYqL&fW84_bGCn;#
zwdwg|FPl!u{G8wKkB|7+Q@g)Cb9_dtiFb#l&p!PNgYv$9tera6`W(7;@bKrx@YqWh
zK0Y=7mD&A`wdW;WrR(b>$NbAj|Jms;8{=1`_Y5!ZD+gU&hX!4lHxIhc%vTM%cjK!E
zeMWk=+%o9;czDpY>DEE3AN-#)==$=SL0f~{0`=-_ssn8v+b53R<@P3dFG_z$E@<-I
zHIEJ4*Lt<+`MoC))0YPPGVkl^&KZ69w*rklTLx)t-!e#ZKVA?#As|n@wgSz0@yvTz
zpl;ajzHDyal<{=|e|7}-1izMnF`jz^OP@2a44tq1mqQ^c(5SzN{DVcBSWcksW0))KkugFTw{KMd3oUF!UAkMTx&ymVMo
zU&eU;!;pVP#`r!jI3+kMkYj$xp}LU2bFYF)o*e5pSBUc4L2RoXJuJ!(GE%5t5K)$)}cUaO|dtD>vUuO+Z
z{i)2}TYO%|y1aNgRfU4bT!a=bsn)!<{mqcAZ;Pi<~4PG
zL*N;u(fv))&HncU-cQ7Men!jJOz#Sf%sPJvUF|{TXY%*E820pWYIP2V3mt
zd(RWz#*02O=k?n{UlMp{p*QXxeYdi=?=t+lCD;t)R6f+r`vQKcsU3l4o$s~5-n#;O
zn=`cBcxGtpWa5_#vDNpS(}O-7JTahK?AFcA=jhDv@V!1cd$Uh$o_(TUqhoJSz3P0O
zZ=T~?eG_js*}oAyEbu-_7JJe4ja?o0zGaX7a{Rh!z4DG{`z(Lfs|Ms&-spX6aBc7@
zft--5=jSpW?6I%5J~Cr^%-=O^I_N|lWZ=jusJTVnpt@3Woxc2SJ_)u_a
zAV%JaZcG2TKwYbcvjXjb?3d^6_w3cWf6gEMJ(sh7ceDMqe_6k?z0Ou`cE_m;>zaAC
zbl%;fnWw`%9cp)}qxO>3@!K*Mlh*7brZsg}zIp7NY*&-&pZ=tC)jl=<-w5bf*3}$0
zde!|C9zdO*NL^j@F{-N*$*UZx!{(?l^4_4yyV^M%JT`F8&3BRbdERJU*QDBC-9Al)%yegK0+NnF^t~BULL4vu@xf_qmu)%==rGs&V~5a
z?)tyXEjio8Ku)dCaj(4U={ppEw8p{NmYZ{e>>yOtNE{8~(}-+sRz!hRt##ch$!x
zD6c&6W4rg7eOY6hc)c$W$IakSKz`$49{tw9{e5~(*N?=8W0er4&XuVjm#`0fw1?~N?_N`J+I-VA+l)}I_j
z`in>Zl=Snyznc$yGyRRB`AjaouU)KPJ?NKaZCBvTenw=<<*(%D7iRkJgq~yjlEwP@gPvpijL3YTvAr~V
zwu|j-&j%Mji|~}tvwgomeSg1k6HjrG-~EBJ^9$h<6Z7Qjoe{mfl<&vFXI*LTU{-w?AtDWL&%*NV3$DeJrn_ab;O|@4H
z*;-rduPx-(7JAvDXRr9UpN;8AIjqKXxW~=YLB25^^csr=dyK__oyI^v7>k85JJ8~R
zt_^b9v;Crs)u8qIjBn0Wb6MZ
z^40i>W#h;8#!oC8KQ=dh>}~w$Z~WNFCtxEOH-3$0n^*;>Q$ydB|e@fQ)OCKH$
zPh~wk>$9#u&d)Z{C8m|}OPS+OZ6^0knPY=kiBWTk2kaMr^N(5doo_FG_{3I!);7KO
z^X=B%QRHZPwWF8wrv{hDX!&|!0)Afl^8>L5{$Cti5gwlz-08k=sGS|CCvvvicjZU8
z@7c%M7nMizlpiI!U!Hy`^js4^6PoS(xGHkRe=`tMb5~Du&X~F9OmpI8?zz+4qeH82
z^Vclq#l!sb7W2-P`R6a@)rt8REauga`MKxv7WiMZm~Tw3UCgT`
z{MSwMPYLZ=UfnOwn!4W%x>kE%GOdY|&%ETlbdqOY?VG=TG5^>xe?#Wkz8Tx;{5MSVo=NVt
z3xbOR`F6H7XT0J{BWW@z8n4Vhm*`fnKhUrT>$
z)|bA2W9B<&|2GZ(Zyx=(jQ(3k|81lH>!bhn^z#`Z<8Ne6tvfIM9PNG(ufMrwP3>6w
zj>X!wne$E}-f9-lcZLUT9{sll-F$pkXf>cd>Tl1TGb2~-A@cOr^v8Pd`U9iCaP*HK{Y9gH(&)vD95K{iGJ5$$KV$UI9R0!3Uq1S)M}N)e
zpFjG)F!~pcUM$ITZ|U7#`Wr^?PD0-_`d6giADkClGrl&rD`U@leCGAbcrEGE2j9~F
z#^1A>9Oq2GT^=fDyL>e6dxxB*oqQqR{i=W5=$|n9CyriCS$7BOpEmlZkA7>>FY|Hb
zSifrY&l!F5v*drtSa)H%W*H)lahZq^tRUO83kYf*BpB`w&&a=ih>wLqD<{O%BYx1xw
zpx<6&{#fstSg1vFY&j*+oX3-bn*;M=QhSYSZ)5V#%xU(NufDuJb9v2Jea57ZJxUtlP%7c@Q&=9pr8Va?ZBqLJ#hltw7sa
z{r`w4eaM9f8P|S6@IddOg!SN&eRLA(;Xzvn)RhU3Zs(-#J8tv>cOHtOIXPP}SPZuqI;+cHR7+I42;WFnR{dC%bSj-v5FK0VV91$^Kmd)^wj+r-?njBICB{dfjBGqWyx
zPgJ$Gp66Vaa7;0?z+~!&IViYpBvzRX+V$X*Y_j<
za`Zrc-r#$)hi>+2_Xe%~i!=V)S?7aX_Vbz;(D!%Nthpqh>=#CZ_U`g$`>#4wR!#}q0NhBdG}A_YsUJ#
z=ec99@fWl6g7bssf*q|HHo6PhtnTDp+`cb?s1J?3`M;a_>(e(@;xC@!@uq+bvctAI
zk9*VCe|cNl^2p51wy2}pLaw&Xj=vWLjps*W51;;iWU+s)ALq*2_pezKZ)-oWSi3fJ
z?%mS^KB$YHfzDmNW)5%p$mRD9fyQ_B(e=tHjYrJSGDxFSjhb_Z$~hV8$K7CVGmy7`
z5c|!$59u^7*SiAy*hN<3-*~sjE4MdKJmkJ_#D(k&f?4Me4xODpC+lQr?j^qi56uSm
z_L+g0{80AQXY>zGbjT00l^yRthOVV=_a
z|M-IbhYR{2E$E+E(EoTr|C5QH&zBswuH75r7uNfo!3VI9MqPrjJ2)R|BvW*&o?){x4Tz=yuJKk7diA9
zpA^iwBEPl4m)3^ydjhd_jx=le5w@fMhRj~_ULD8-9j^-JyXTb9+C71F{5J>X7i;|1
z=oHuegZ|d&5^H(7Adp8f+X^&ymbj`VJnl|0kr#Pb`b)>`uNc;MW8f>DvtBlD2DL*>
z(CnojoU5*jJDc7b$hZCcWY4ZZo6p_4FSv7Tr$daE
zzRhcm5&J4b9?>&jWvr7=hME;;O`O#GxcJ0z5-Ri#ToO|-e1812G
z_jKd&?2OM2#M<3=UT}WEcEGz4kY(@w!2AbeHyN)B%)3*ya|1q94!L3?)?$}!ANDl^
zpO1Pj?S
z>^u>h@~e7QHNqy(#M*QsaXK^nvn|Jqlh4e1f)lYzKILf{D{%t8-W13M-(MfhbK>~9
zV{JY|?v`auu;(d3<&n9RM+bS!)|jEVp@?<=1bz
zswcyvIWfK>5W~j7+~sTLE?YBqaLwFDvzNTa^s0=t+SRinPLB%s`GJ6MZwvaqmf_Jo
zct1UmuYS#4O!~F!FU{E5bFXOD-@VYI42;haloU#8V52O2lb@ctH$mKtoQDBkL(Ec1Y3b7&gRI)_h&6;
zY+J@mT*S=%KCjnrdF8u!9Lsm-QGCT-I}nJ2{2WR>eEYZ`)uuQubAj)rf!xZGnsfis
zDaO|aYT+?~&$9HmNBX`bkM!Bsd^Tt1+&^>9_-FrCpjm%wDDSc4v9)^f
zyBGOsycKAzLAK8|$Zodq^*|sNa`A&x%*fdc$gD5qh~q5J-npjjYfU?+TJM81GM;V5
z%kG)~$)U-=At0NLt!w<fxuY2{_%*7v&n|W
zA;VRCE)SFWjlfY5y_e3eNTJ9>XQ2j>Rn*PR10t>LNsdo$ML`h$Tran#KHR?xZq
zCe!jyA6C!e(tgHXJmuegQQ7u?ebD_Gu4I1mG*=l9MCLoE{TZ%gzI&Q`pfX=O?XA4;
zndY{W=lkAEzvtSltPf;x7b0y}a40x6=$W`X;|qe`E9zr!&^XHF&!kr59iLj1cYJD!
z4dt(XIfTQ(TLN`=X3%#UHE!RV18ZtnGgm$C{Wk{P&vr7q?(AFV3!ZZWCB4puJ2OuY
z85%w82k(lX8@L;`lR<|&*1pdleeEE#aj^D=;BfHP;8^l*&-zjZJ(XWw$CH;WM}L2s
z{bKamz!j%PSYV12WaBk;W@#1k+YDl(v+g-hKA%4!I1tcJ-#?4*
zWb%v5hX>j_k90?Mij6&N^?uP9kXPTyQ~&khMB>6H&nx{6!Led-LDrp<-2r}$PwH=u
zN$XtA*UmW(;t6vc{!!vUX5-)teKh$dOI*c`9S_7W`_}m*{wM0szuG3Rmqi92502ir
zdHOF=!0vqk{~JeoHF=e5e41Q~KNAPC~o-JLY;m@Q)6ycAK|%_K{!a^yb&SV>O2JI~o3&
zx4P<&obi=Rb9B@Weyf4*kq`BzooGJDJ68PZ7mM0M*LLwekTteye=l{cU&i(qGQTdi
zY=4vuX(wX)gJm;&8&AH8$F+gHSlh1d_%O!-Z~Zs+9Ma3%-as5%i}nJacaE`h!zX(2
zv&H__%)HmUy}JgFz2Z!lUQMWfI+pwG?SA@jen;Enp}zP%>jGGtvZcs?>e2ES!aiOs~$ZY&J66a#x^#H
zm+@(V*xPUJu0Ugl#t!rLdxyr)UT4U&h>Y4Rb{d`Ry(LKL-1k6z@!qD9<8IT~E@o_}
z6Yc#5%};ByFZS|lM_|2cwc8xKK9bmH+tGJNdc}r3XYc6&y&J(+pwYt)eC(2UV?Hz=
z@+VUB3AaiO$^Ugu%;ebw%KWD3Tg%{X(`WTC^
z{F}3fj5!zU>}IRFRu6}Q`k#b`dCWY0GLhuF*>Hj4|HCk3?^zjb!8gN+-3IX2qE
ze!aDR=AYxS1}F!+z9v_WxvjCzqV&
zOuodl{^J9_v480|-^_0W&7nAH;zBlG#b+zfn!8;Y$Guezc8+ds_G@owcFs28IS|x7
zzb}rgIgk9;*ugeE+qMGj+`yit+*2~QKhS&)rMB>6Ga#crdw*;V`m8Pv*9X2nr0!?l
zkgIpWPw+`CgM+EL~cl~L>uF>=R8G-uK_-#DP`QYMrjs4pN{o@Pz
zy$ky522K7tJLvEEqu-c*4gZ!wTJK9XtNqr${_P`2@CpD7xY6z^RF?@RrHWw$Tv+(i}`y)&oRC`wDZ@P-yZr{
zF?UYs(37i|7rAhLHD|(jj_n`)!Tn?Z!=dfn466INnVa|QUC?I^I$Mr@W}%B;?&og{
zw2fev^U&k$`|j1Q58wAs^Y_{2dijP0{p!%}{C|}|tb)?Du(uX9)2iyGC6W5ZuQUF&t{Fz%9Z!8$y|9tKIG=mv!2756En}i$EDv2w9XyK
zc*{gu=h(7kBCY!7Gg-ggm8V5t??!fL?3?-d#~1tb^&1bm&jn+6eo8|ugp4m{KboI&iRD)EVS-j2)&ATdUCG_ta+F7{1KNvN6mjEv9-_VP5om>zkBqX
zqxY_4{hZOCJNolSub!-5IQqwr{-V)8DLr3K8nkz@`r?f7#eQE)^K9i8Ud=ony;{{@
zGWyRPJ%00Bqkq=u$ueJE&mQ#Eqkrz`pEvp!jQ+Dme_i^@@D6w|ko)FEF3DEg^-n(e
zBNz6{qkVI(darF|USs3SM^7jEC8PHqidM_|n@0bN(H|Q9t46Q3@!dB1*NpzP>DeI0
z8XKNE@NZJsJ`?<-o%vsyGv}VIuWGsDGcx8kf4wKycjvb?-7|`ZEv;pBtB%c^LmRhl
z=|T5QI9F&o$f*rIL$$-a_1a<|y7rKZriZ+pgRWgC54yHJe9*N|E!q#QB|f%p`QADa
zljd8jwC20^(qCWB%eeE8%eX#Vm~rjDAmiG8AmiG-KjYebZpO8DU&d^0JkJ?)YLD8Oaz8%UbWVD>xI773SF&Tdc=kfF(Y3rE1Msc%}0$7xt>-{8~~3P*+(Zi^pQL3
zqC-x_ou1xnVndhwTB|Oy>~B8t;BEY^qw(m;bfZ-gw6JkWZbv^#>*`F~V{GN;QvxEH_-PWDUgF*MnU-hXKO^&UXue{~s|1E)dAIla$
zr|bRU>4DfRZK?n40&#?`K-*gV|4(9nC^TD63HFaQUyrL@>+IheeC+ry39=dzJF%&M
z$E#_%>=~8=V=+*R#ybOY)ec&ZW+z&YrW374^98L(^Bt{6_dM&-J!d@&wM%b(K5zDj
zQCxn=_a#P^rw40d{^ePtk6)ep!pv1?&!zj@`i|g+A+L7O+r1ZL?bOircix^yXI>mM
z`s}Uj#;b9u|CL|9+TLeJpD}$FsRKOfU*Bio?m=&k{_N48GkRwO|M{aoklr2RnWkCy
z96K+-Bc?Fde(PK==y8shcZ@w6|Lmo|HR~QRr>RFVY<*fISF_g|A2$Me#GdT=XD#@%
zFW4Dq_}N3BT=J>*(0g(4^C<{^_zZg}z5TThkJ?1z{e|$-U4HM#X9w2ZTgzCnnGCjO
z>qGpz6#E;4ng5K;&%FNKUj3%~-$sDiSf{)G+J8lW|KClvE`RUw($*)3|KEq7z2ujF
zGh^{u`te_fAJ*;t#Wj2DW0qIX%}Wi^$p5z0=+EDs)U&Bq7rle@=$=_U+FhU~^=RV)
z-S@w~kM@lBeN@fj*W*_sXg#{`pM4)abFAyFJHPn#X!U{Cqtzl>kM13!NB8}?@1wn2
z^wzyw*sn+L4$yk^Mu4tgdou1>ctvW+T77hmy7siJxfjvu?~#MI`YPAi#QSWT%*WJP9FC6QSAN@t6
zf70lkZ+y;@{*uvu=IGty=C?-wtkGXKdUu5NXOI5s^!BhzV;A&(%JIJ6d!o3g8Gc0>DIfN+m#*@7&e9=IV!tog8K@=m
z;_r^r)5lizK%d{KPNqH9W*_-!Klzo*pUSNq{^U!OYvou2a`5w&ACuKg1!vu&2LQ;_QsYR<4(F=*7=2y4n3J(M>)ZmwC(7O83m~GePTw
z4gWDVh{Mtbve=+q7SLVajT_soj5Tqe<5=IzXAhgrd*07E*vuRs_6AECFU=e~*yDVW
zhyVJ3&X~XUeBrlNyE44r=PYY%X)LbGSbjBQ^BSM!Zs|K4`s}8|IU~>c?0Ix%TbuK|
zu|4wK9J5DjjQ;J&6FXWvYMq|$p-=1jx*Aye=zi1qxN9{!;@fN=yPZFK`Mq3o?zH2{
zkb^@3U&Vo(IcBr}bb&fKB@hSgXA=iG=Q|noUA*Lr4fYtbRlFKAIhu1}4|~{gZQyz0
z9f1t>XG{kDeWr>xf5lC_`s~BQt}6q6UL5>??A-~VrdM4b{$wU(W(c5S7zc#p-q|vl
z$s{3xAY1Yd_fA3}Yytx$5SBY3lZC~KXb2Ge2LnYwO{*dm&{D;}Rq9r2ZR?F_k!Zi0e#?75TkgY{tib`?d%C6MM1LmIATHqc5G}&USUw%OtO!LHsOx
z==$B*Q_r(Hg9kHTabxQb1lnT27W(O~7~m)O;($Gu1oYQ?ExGE!yu8%=tQb|jSYtn$
zpJ+XrPP86PH(HMtd$bttGqxER9wysAz
zb7(!f-naGWZGm+?y56_-X!*6SN6Q~tkFMvu9$oL-_5STW2EX3AGmEaXyU=L8^|HJ8
z)!@EBZC#&w!82S_OUrGo?Anz%`>gF~Yiu&7Cg0uOxr_eR&}CoE-Q4EnvgVdDSGf~I
z^K|$bq24z0wRX3*h91`U+cT$CeUq^e)ZTaJXJpKYzd5%5Nam{E_J+28c3@qc-qiMp
zoi+3NbJ`fs%feGNS+yZ%B};!^<9CMY-!{x}TI=>!&DPneGg7vd{Nf`Ms#Z&H)n3(D
z)l%hoq3tVwb~bu<>)kozRxHkHw3wJbxAo_>{z0w3p!MznE*$RO{V6
z_}w}BN4Nelt-q}Gk8k}GTmO}}n*YEXxv2)nZeO2a4k2UAh
zod)X7dDr?p(c$j-&FnRAY);FMUES_yOYW8Xj{I6bJ3l9PN~7)D*nSR;{q*BgD^F}c
zf0p5N4)3lAXV)aqJoni5(BMM}j0yy=QI8oI8ATThpWII4htRULPOQO?8#swXgW~Y|-P<)2Rn%
zi(HL=?C;}t-5_rM+@@cD;(+$fQ*rfO$??YZ&WvfEj~XCD{Ef*X$5{T=k+GT?){^>?Q}w2X)SukiCw{%HdqPuxX0SI<
zN6!ezCz~ww$u@h*qW8YR_Q1WyhjRmG_vC=h&ikRDD`nuJ#1f1
zFFVKdlILvEQSvjKes|OB9L{ab#4r|{Ge@2{cns@u*;2ZVd)@L~y48m@=kS+JrY#2I_WMy}-t&Y09RWXf1@eHs
zw^2-o@ge)_!1-2ptNW=`}hvw%!;V3dmjw=oJ442OmzH*iOzQ(CE$dG=Ej^bm9Ml
z#&3NRXk&KQe)=nJl?S#}T-YQoVzQpNxNqc;e73zPxGBiBJbmXfwys9jqJO=4DgEkK
ze%PUo&j`e_uO)Wixiawk@SO?q>3Kp(#)ANpCg
zmXG2;j1&L7!}5U*`XfPaL-{w{OP?n1#(q9vOQX}B@V`RSUF$y`njb}f|A7BnL-W7Z
zZwSp6chJ)Uwfct%=p_9o192puU+N5Pub3Rj-dg92dA`0hpJ7f(Uv|jPSGMnQYX7uW
z+Gm|C-=?G9`8H>+^y%54FFT6Q9Gn`69le_Rv`2Hs_6Oz`gR6p?bFX@)u#x?mKjZ7|
z{I1YquHj+(Pv$$Is&99R{SOWPC_PwKfc~qF7OUbN^QG*x}duS~f$*p&%_3O@P$rfL{?!h5X$(JuYo(V&q(y_Vm$N~S#7rIJE
z#X&5Ga%#VP(j|989(Fjx*44vMPt}5TYxbWJ&|moxUr<|g8ZQO**4UQ=e&Ufw3
z^0nm4g}BwbCViD3^TrE-SQ&c{EuOls%zLI({yiTm|DJJ`e|Jaa-@BGvRQ|U$nqB01
z23ao~oI`Zk;Vhxc7CA+$Mf>FxT{am**~JcY*;X}D_Tj5NAjqy=Zoz*@b2&
zn%(HCO@5*IX`SEbs(*1oZwjo78QR%FiznK-LW?!pnM2EivuG?o&Zn`wIkUzKfphE(
zxLdS(hE)96JF$>9nf~`EkE_5r@%cux|E_Xw-gPH_jvU?*C&q6vx-;)XHL@?zZn=Ye
zlXG@!d{U?VU10o$yWr?K`NCar^ln+tU2vqUpD&CPjI_H#94?3*pUj$Z`|Mb-K-h~ba^?7(D<9ffT8nX9qX4HSLyY%@S
z^z@+i_dNZ$`1QrBe%VuW&)@szp7kCnHZkplrzH+0?}4EY1>XC7Zv5LY@Xvc9`u~RJ
z)2Gvm#rXlf-fP7Ne5Mm;>mO?L52nXQuAaQ>+PLP#lWf0S5YMSu-~-#`j%@u)0`EhM
zLHTN)U;38@^VYw1mG!S%W&MU#)?c>D`i;lA{)$!hzjBrJn?~0A`sl}f4atcZL&d#c
z7yEAr_60d2CwzN;mTWk8b>^!6`kdV({OJ1pQ=gN}fzLnst*zhIdY@a&`+TB5t@R77
z-`@J2t>4}HJ+0r{`mumIK603Q*
zFzaeu58#1@0(dkb3)%>hvFJso&9bA7-w3Kn_AL@K({|T-4XD9Sr-TG@%Xn_Z)*LUTmPM{e{1W%yY+8x{r9x~`&$3~t^a}6zq9o})cPN3{g1W&
z$6Nmst^di^|HszTI
z-}?XE`VX}J_gnuvt^d8&f4KD@Y5hlA|0k{gca%YU{VQep~DB*ZTXn{aftDY$2Fap2x`AGjNrgD(!;%cr#QmFf2dcMo12X!hPM
zu!kR8y51Zct!sM%>)I_xyXihQ&|M&h&g#$0ct>!*U}u1zUOk?QnZ9^SmVUVJaORE#
zWPtI|&V=x`KX*&$r|)-Sx6sDob&o*2$XE{Os(A5zEM9CTdrzPyw2Fl_x}Flq7g`SZ
zv^x+x?`0i8e6T4rI_|M(`Q{Atb1Ntzjr`Czr^MA0FOEKX?ec@
zM#@L^Q*o)eidP>CbL=kO;r-z3j@ih!ij6;$S}itWAkLMK9T`^*vK7tFT0bLWcG062
zHwMGnQ!C;jmlp)5gz5h2zakj^ojT`bxSu`v$=Mgs@sa%5DS2v8{nQ?7e6+`U@%udy
z>^9GadxVh>LmS9atG&FCQ(24Y$spI5-!}#H@z3`H&e=*J9>&jT<9W3pz9qBlCjXTI
z8TSd?Cv=F9UOfzZc8k$Mz>mtC-u%us&j)cL`<#HSWPzBlRj$=7J#;R&F&#^RzPHKq
z9`CT9WmE0v@5ya1JIUz#-k;tFF`l%lS!am5y(yDh_1@fbs4)i#o)PZ
z%&&R=v#avdk1J1Gv);$Dd=ytPMDx!bFzjdf+2@L%B}b0P;BV!LfATcX2Yc8tmcz1d
ztncmPJK$3TeGbKdj=t~r8dn_-b9k>AIg}?cEA%q>e`c^Z$o6Tg91YK^JXEgKTwfdB
zanzDl^&*ZvhIcL*ni{Hir@H^ywI@&yD{V}lvAFFEG{55!FWS1_4}xZ^Ir~45KNB{0
zR)7c2$_Xy-czOb9CI95GeU_CO`
z&)B_>Uz|K^t_;o#K~KN`OXlq7!%D}0BxAA`19I3(_r4%vrvDBcJ02NW+a0LEs%N%9
z`Ms2J`K#~e#k1CpCxKRaCsXP(@7ik9T~fNl48##8fi{``_cPD-@{h0l(CXg}`cRBz
z*N#9ed!BcvuFKc6vsS)lIQ@GFC*~)Cwq-0{*3Jzc7Vz=$!PA511uqO<7Tglt8oV|5
z{@}-hcLnbW-XDB8`19b?fzRYVXS+Y|z453o;;M-mTh+#wW{r*YchGtpd%jcG$akML
z@@-us-L
zb@K0AC;zT>^6y?J{~7D#-!q5bJ>o80YJJtUIcNXO!Cs$hP7buE1sn3elhV60-H%%X
z_sQPubCf??>B%%LC6#_VJ1R{PTUv
zp}@YCfV~?6%^gan_~`NRQCkYkU4%%pua^-sZ}R+NAI
zndhHp{Fs02mV>inn02;K0_}>U-R=DC>w(|(`Iz65nPFG?y;@$$AM;zh$Uiso<)4k3+*=jd!Qbw
z*2S)3ao&tr(ACGFm&rylEB4~D6zE?aXk)t0pP>u?y@IOEv3RT9-iE40e)P7=U7siM
z>i4lr4fEkXLESlGUHLkk@w0-$GrowsQKS&pRsy*zmz$AWiOd;
z%UsbRPx!jFuXJ9P&r|z~n$;ud_jyrrwO@0|R!AP?U6osIGnPyhE}YL6JO@uAUcuHMlXG8T`r
zg^kw)>`{Z(=;>|n=TX}-#|E-|{vw~PbUdu-cxJ}-v#;zZ+wna-d}TlS5p5s&=Y?Jh
z4h3XXtmVFs<0He%cR8nH=sQ{GXP&ISF64=9cB`>k@8ci`n)esE0J&lVzOsp2HnF4T
z@R@TCYmQEHbgF?1V;jHip9IbcLw;3$#xdmAfN2o5wLp_LapzNV6og9XznudZVGZd|L*$q
zWR1z;i?gr2FTAD4{O*80t+%(|^Q&!-8dO{Tp0a~qIX2V0iTi;Fy*54H{1V9zr5q&pLT0-X0SJ~rj=ZG&*F6E=-lu;_4nOU1kzRUdTPe(qNnZ)IcL{$
z^R?=DN9NS8XP}y`xbnMV`r3>&aaalZvvV-=$aM}Tf#&R#9I>%}arlNdl6N>DPu$3^
zb5EYQ$pgMu2O1mky06$Q&Zh_RxhW`r-IbLyzOdnv*kG=FU&xs3I=^(59(v0Mv8!0r
zx_z2_vLT|UIv(A0^fgv?)Vb@|D)wyGinnaObYSz2@bvcHJl%EF55uZK^;EJd_m4RS
zS=lm;cgZTd9y>#poQTaza3m1-%NlRhY=2iB%(^&xKI}-p6sX^e0_X3XKz`|UXFM)^
zWIjGU`33elBkF!3P$%-a9H={T_4ve}{5oGX-=8r$o)8`Qt6tPHnWqNoLyV2hsarZP
z57e_dB;$$A-Y2E6y&2xNSFGweV_*6Cm2KaXyM5}ubdq78Iq`XJV6N(Z=*v^G$QN;b
zaeBTNtv;3-{mAs21MBR6YWVrW_u}7{@htvB;m0?8=b)Eu_8ki3Nj{&}`1{(Z-^(DL
zc%B{}u}L?jpV9V^d4A@W0${kD=#%yIU?tR;PU9@
zW7Wk%#`M;?#B)V>#I^2Zdiay+X^!iCE9CUd(lPcdP^*s$^
z3pD?31bNN^o7Fyh-p#&mi2QEz;eQ;jXpjqJ*Y^P!y)
z(Bqz}`|Ww*!@rXLNcuwgJMSJRqtC^My4YEh3#!RddlvI&!ZYekvh>iST)ydi!y7ZLpnj^2~)MoL?;bTtxjIOFtzeit=
z%b(v2-PiE<4Au`1Xukui=RbWw*Pqpjr}MYD>54liY{?5Y|4R4!+V=wPcf4g6-b=IA
z>-pREJwf^LvC#NSNA1_E0eoub#P0irp7)fj$q{?{y+ym1E)3YOq51UC;Q2Aoz4urK
zrY#5LEw$cQJzO0=xlzyg|FoXf!`7hpt^cq3#jL8@=sj_r5gNs)qxC
z8sq2Vf+q!H>V3l<^xWX8;F{nC!B+)e6WkEID)5Z?#^9TRw*)^C{7K;FydM%=61+Be
zYw*tCCxUkc|26p57zDqb@kfKd4epWT-aj}i@cVo(3vLPiOR$(Y-4OiK;5&lv4SqEE
znc!D~j|L}4-j@as2+jx|7`!-mS@62x!LjWH;j6r%UpSy&G@xHRpucKB|C0gz)dTt^
z1Nv(Q^h*cy*AD2f8_;6V+yAlwedBd9uA1
zoR@wvP}8q!a`$Ik&(ef{+LrQPJYOFk=da#VpPI2dhh6_)(-pB(`sT(3z+JUiK%<)7X&p+VJpkY`;40
z=h^M~!k*V<&3<-H0?i$yEd^zN?-M=N^oIhzY30{9M&@KXbCjpX^t`@XL%$(3+bRZZ
z+Z3?vjai%J(>Jw!m80ILZ_e60pR9dLlRZ`ww`NVtdBSQdVBl$zd5}2{EN1y
zVr|c?ynN??x6jL4n!H)HM%P=zL$>kTnyjjgp{;0q-!-Chn49lza(iEE|G!+r{^s(X58=G-Uj
z(#Ro?9P-GqR&vPrz7ZK>u{qG}!T0}%Z&s~*f0MC4e6#NEe?4da53FJT56;>D&Nb}+
zH*@y?&>Hst@SOcWGH1Woi`!D`Z%(iI45W#zcamAL{jm|*Cuh%wKz`-3m+4tT=D(dI
z^T$VI)?NMYvZhx08m-#>iIIJ5(dN}I-wp+8)AQipM~-**bW{2#Gr+^{|1i)&_gHMa
z3yYz(n*+`JGWq{8GSqnQ!|u>{wITn1n!_*7?E0zj%#t_EF<;LN}Tasoa*z8IBjiwOX=D2)7ey?o9fI}j(%of=UDv2!ujUgu!g*kRSo@Y(?jRGn%vdy
z@c+C9{blRV4S3mAb@*ShMz7dS0&VPl=7C3-=Ek}1=%KH}IG+|-QG2_4mkmFkNoT_N
zzc!m!i^DH8zCJ(0I<7p3H{0sY?`zsSnVSB^$TQD|Us|ILzdW#kzLNv;-kr61@wMhN
z($MD0-Frr4dv0h;f&Kq&&i-GWvwwJ=%J28KJ@vdhBRcq_&D!(6W7zZGk73XMn6qao
z_Nikr`Jauiub+ys&)1qW`07Ais8RX)we0Kf%wG>p-fuK{eN61phA}ymIrpO0zYkPx
z|K^CSdJmxM{cXK!T0NDnrHuP~j?Moo{B`!w|GT3@PV1!N@>@-I`9bzcn9@o%8$Pf`
zz7MW}&wVZr3xTotpB2q!hJana-SqW&HUFVDUoj(39{afd&InI`|Kkc~^F+??kMQ*|$MfOvRDJe7So?#vzvjnsR%iDk16|JU
zm`#5;N8cZf=p)0kc5mRk+$UHH|&?V&(C=#VqH
zMtjHgJ*Llb3xPSh`8o--{`)@bLmPcp_QAl}du2cuJ2i6?gS0w7_86py^s{Yy7S=e9w%x2lk1Pp8dN5
zG0@0&b{-Rq$tUYz(Cg^O;;3#FQ$cBn5nd;zi!BFO~298z7
z*f|~Mz#S@oVl4lB5tD;~oGu4^TWYj3>x{Fp_HNHue(=2_cxvDt^GrH1@aJCE$wnJj
zjhvb>|INQFu-Bh&%bi-Wrd9mx9p<%SdL(Od!yZ1coeykhch!kG`pK48^|Ck6`a9{>
zp`D!_7ShV*F&=YT$(?75_=#2NW$KUC)G`-jP4BG>-kkkEvb7;RBdw6hRa3FAB@ab{E6N4uQ
zo)4D?V(`4+s^FU71%YS$OMc7NtN3B43t5UGSpdtAno%ZVc4v&B1Ge*9C73ZVkRI
zcysX9;9myc8+?E8&frIa9}j*q_^IGs!OsW36uc*RU+`v?wbg&_X<#&hqyUF(o{9Z7BN7?WH@;kq_2fG8muj_F5>-?zI8uRaN1N!a*TD|uC
z{oP>yy$0)^k3GNVU{Bv?Kzq;W*EbJn&%J*A0R#Gs0e${}e$aq+zI%DjdeP7C#(Z-|
zYYlz!fZjBqHxKA71KPdY%X5$Sv^%}0?>(TubU<$%(Ax&|{RZ@x59red^yve7VL&eq
z=pgw;fIeqHpF5yE6Z-w<4QTgH
zzkb1he#n6K*{tV(*nob-fPQ30^HuwmJj<_7Z_QaXpCf+4!!my)z4PgQGIwS0p90S&
zwKtrfWKO&2Xm>k#UlMuFe#ze)nr!FW+=k#&`57~E)osoFQRdWjKlh{EvPNAi1w
z#p`c39(`W_-}I-1=7T#$ZK2st9@=@bUpqVhFgo7ecJ?_l_Ui$^bNs1K9OZvj#-87F
ze>yrR=|36Ri&xw}5?;E=F~`^UX3n0!%N}tj+j*?@E3(eM&4Cz|{)$=6;ju=(UYtsn
z-hHU|PE+)S8Iz;YxiwHr9D7Q-FNx85x_vg$oPBrQhq6Ye_-Xw-e)CTa>a)q7jK$#0
zz{|?;9vlknWyey$mr0O6bZLf9z8~6~o`lJ5t$ft!$>F_}KGb
z8lN*@-aXbVtZ8H7u(Y+hn_}28j&8GP;hYM}YNB7Y7fb5bhX7v1A7Ynv~9%Ps|qs@}1e@FMaH%lPzM8X0zU1^*4bST4%F0
zSYE_rL!dqsbEvpLZCcXfbA
z{S;q@xBbliK15osvD?m|9N_Qo%o8JglDSWgtZnGlnm%3}sRqg1l>ucRuJ*huUEg8F8H^vut>OB-!n%Yy_
z)(-~!xj2{v+Ma-4n%YM5U8}vlzZK^fXPwQvgQjZAzZ}|`pr>S2jgkw_%7He<&p*2D
zv36>}ChyQ>ReabZ4`kGx>z=9SY~6*E%xUx|9G@kN9_OiKldrbOdO)x}V28Y~1lH;9
zeVc^VN@qRC*f!+FV}257WtaD`lVYHAFF%t&tMkpq#lRZf?5;S`VLY~upUvt8#B5{m
zw$vg&8I(#R%l3q^e(deoi@tIC~#Cv1#
zrtD#N#ezJ37BBuupiQR#JsNwlR(Hb~ySMCrdZ4z%TPxqxR^?o-s@D8WcVBBe+nStL
zuKU_&C*5kR_s73IU%IM(#CmrS71LHWi@}EAqurjWA^zJVMjBo^{T?~{i+)aMyk!G<
zf1Brqx#D?KdyZskn)iBsTo}4+;-gp$eI&Q;K6)pC#wTmf4&;w*b@wd#l7ibI_zcem%_83CD^y^Dc;%K`h+e#L>7KPFUSc_>M+}^$;;%cQKO?%8^`{5Ulyi4DD4A6Q+cGB>=HnE;;-&+3NoC2-rkZi`8Njc
zwVi>x(;jtWy?i0t9aD70NDSm2Kb~4=!(u@9s{%6Xel#Y#Y#F;_KM)&N+8*-l5%XaU
zY|flEmOuIq2gCf~@6XUMPijY#+g$f$>-l{8<>;;>ZsA_~zX4
zmrr6)b$w>Wdjs;I*2@p_hUY^+-2c>d*1Ws5w6)
zz@FiqL@vAVY4(a~(XR{L%lV?vbg>l=o8CWoHhp*ZY^pqqt25c#c~Qql7Tf=O{@!N4
zhkT!FHpNKqiH9(yJuCQzfc>WWxT4vt2A%hc-7KCrtbym%Yv6g+8hCDA1JBFX!1GVn
z!1K*(;CbB|c)oEBJg@I~GMwh;HEph?Y&!Q%BXhTm%)N1B?zJOx|Dv0lmEUh^JZfnc
z&-bi>=gn*2`L;Fie8(DiZe0VJ``*Tv4yq?qI$2gI{t=A7VFAA0Nhih1#wgNjwfqgwf>QVaKJ9IHU;GD4>km2w&6<{r;TkZfjRQz&R(^{
z_pgl6&c>wyd17>4pjOzdi6MS{`NuBJT=^l#&IuXx>&+SK*{T;?HMB>wA8L*r?4;j)hn@u5c|qlcZR(Nip`42|XCHZFEC>7`SDoA|j-b_1
z{mx7=Q*U3CHM;Ra)tWky^RoiBYVXZEv=|%-=yQg}93OdTwI)|;P`?sXUc@@;rgsg$
z{BEj;rI$~6k{@@vSkWO5WUB#wd~r5cj%xq2Grtgs%f>*=@P0|-rL*VV(P*_UR;9aQ
z%4X-0FMQ?KVo*Lf%bHk~&0;}!*?I4#oBUq)LTLWid8~8F_FKF8%QM~+kSRB>4K(^R
za^a>RDVhHLgQ|^8O=WFMFMe!e*M$My8lNTxX;%cj@8;xQ+%$gjy|-D6#DVPMH8+cQ
zC2Q)hc-b+=yD{@>((mJdyK1ZW8H4pnps6SJh*!y@k4BKK~a>q{l%xP?8!}frl+9&Sve?jo&k)zhizh`H>Gr%Ked>h7z
zF1D5~_LC>35qF!t>;vm~*}=y0cZ^>>-#|kKua!|VT&LG~412tvc_(j1BgDt`70XxJ9J1z5Kz&<{+>5j;!SZ!~<_C7u!^D9CBZlX4-jt^zb
z9z2zklQUips&?3DOvjEe*K=#=GdXHeUC}27{1pc}{?`pEuW^d<0Xgq3TcX-&g$r&4-$pe|w#8}=}0y(%esJXt5@zh!1kKZvoJO^iFp8xJ}HXdqpx@oL?`$~s3
zz6}2jhnk~fG0^kj%AoEnK5JwpG}9Q7qv7v)*`=Kqu)|(4#m~1PznE+I>F@2S{r0hG
z$io(SE1k8MPO`+sKJ7^0{o+7`6`%dvgL*D!IIV%R($lH^NS?)|zwD`e34t}ae?j10
zrsoww<)pr&!h1!asm+6ddbufxirf8NKQb-~G-LeYBz9y!H8>}DX25szFAVBDEN3hy
zi^25)yXteMcS|%b=hri=`hFcvd>xAbJ9^>^K$6D@Y(4Xf-FtX_L&)Yrq%kxGTt80*~hdW;~&QN
z^vD)p_fa2Ty4hIqMc*9g`KY1g?5l&513u89uRPQ}IkrZYRxv1FF3cQX)ayrsS+YG>
zHV0~-d^uy!jX|A>t1~`3n5W}?S=Z+A{9@MC;Fur19bz`LV=aFEaQ3am)^~(&7>}xH
z^Ftde7T=LIZJv+cob{DJ+}{uk^;AyB^wipuvd^<;Z|ZZXOAX8G#y}jct2yI~gPQ_(
z#IQ!4FEuJY3qkE0)=Nrx)pPl=!MPmPPsy%4uEi#2r1sqrHVxzc%E(vGV{w0ZTf1+1
zao;y5?&WLw)}IwIxBsk>{dKow>4aAW;_OZn8)NS`mj?CuZ!LNF-TWMYTH6!Uv#ad7
zU*^=4HL|p-k>T2zS=$?I49Fv^azLJXW2^dlLEtPN3F^!^FT-coeKJSiMS(`9d+lH_
zs~*H(jk4FBM|a(w!)Mb;S!2_y0{m-<*B=h*mcMLC7^gpv%-*V#F`vpu@e`l@!Fj=A
zpxOVd;E6G2C4Kqsd9*(U*PaK2wg->;;j6g3D3}$S%d#dme5OY&%Y%A5dyZ^1rDnlB
zu`dv-m&a%JJTl;q9Fr-ohXZ~*IgDd_pFd|WpK32zbk2I;V1LEr{uzsj*5~?I&c%-p
z^4!~0b;-sj#lKlO-IaB|*Vzy=??XPH@JBt@ea%nndjk2<#8mD2{d2EQ&sV@F$9ghq
ztd4dEC2Q7N*+UPAFPs&SxiRo>Jo8y?S(97#ECp;gRu_2j0KcrC5o`*2J!G**uDnNG
zk)BNckhL#h%lo4jpLutMvASl%av+x%27J`&uA{$XU!F19c+9&q&}``W$TQF9e%^j@
z!CdiKy~?&QGSfk2Z(G7kqwg5q-@;OpnuIJTGGo^L&SEADJ4IoD)7jGfp%
zF3_`C{L9}<+B`pv<>Nr0;U)X(AnBTZmLOjY``nl#n~Z*M>8ZPIOV;-Vn!lgut~)1z
zv3D`(*MB4HJ^k|o+UKW!{cQvK^`Xf>H}XrrIIlM5KO6b|*vMd8(T^JZEZw)}=biBL
z+vk4oB%6b?0{i9s+w=QY?AKn<`0=^N&5O~_HeY(aG<2<#vn4cN{F^}f^ICs?>mStm
z2d9_&A^JG|VSay1PrpAj`|as{=xJw<&F(Zd^6}Z($Hr3v^jllW
zhor~rjN;+<*6@_hp^lAN|JlDj8vlOJ4`oiw={vpkXQU_7p0{M3?QFwS`Ly;mZEw{;
z$vG`+Wz%!QQ}>HJ_PpX$e3ylfe06J1o*t38KDOsJefah_zG=P(e1HC_qq5jtvVJvl
zRa^Eyu&wdqO^yHDj{l0x_4QqTv+FTgJEh}&MB7g;Y;FCS>8p0>`KPJfbhnGa(3dTd
z)z|7@eeyH;IX`>xKRn?|Fu<-kpvI{G7&N~nKp{<{^
zeyR1(Xuan=K5^GSyYy#v8FZ2{2{dsc$2$!Fn5Wj+&G#FELjl<yd%I?)XiCoIE@^DSaVtR|}g%^HrmR{+^fqevZ6HjO186wIcyv)WpW1?w$-!cxG(W
zvsn!M+rqsMzuD-1kKf05O_v5+19AFL
z3}EwO;4BR1wvEi)H*@3`Ma7v
z`NbnIZ1#7d)z~M3z81=kF*}EPdb`W6wdfh!H_QI9c=r3p;&oGwG`
z*UO*fFB{!CrKiumwMn2=ovhWjK1LNkcSq@|xXtp%eb@Ul%t`I9IQOzk->kSlBX+n~
z@Y&C%4<$fkZV#%C`9FNFgl+V>LKdGZP8p6qBiQ+};83t7AW!_+T6U0iM!=qu_XV3j
z^Bvor9cS+%^J?Rotjm{LIo|sCT;`Q7_VUfWRQ1-^eVwN)-}bD(Bm5lRMgI`a!RJG~
zLkUB*LQTQavV(Eg~)^i)>+^CN@R81JLZ71e!cv8Wc}ogM29;)ROOc_^6f78;_E=-Ic!AF$ZGntoe-o
zsBAGc^#+aC0?KbF5UuSUgNp2SSde0BVJf{XF^T)e2
zbIRxY+FZrN+`s7L7vCF4_TD(M_u4jBev@~ZH|Aiwe{{|
z^g`>sFQFeE@Wb=@&)T0o(MPv9RXw|J@SoE9%1g!a>^6UH>(6h!d(uAlq2Bk8`iHij
zezZGM@0~<{TI&~D?;M-o*?M;+`e5rXY5ikbe^%?uo(DDhVXb$s+W(~1Ke_c!ZM|oW
zb)S1muV<9FX=-kIzomb4?ltd3e;Aw@>a#A_0WuN)X_R~+qbd%xHd+L;^fw`VaR
zr|wg}L)1>&QvQn%&kccRko$-J{TJexqI$6%|ELmz+KD4sqiQV2~wSx^$>f{_xOuurSa#o`IS%LG-
zjwfgTB>g7?wbidZrCSq+eSvmCdl%xrIp_AY%vD{vBkIgrcMeaRo-hf7Ghx{_z>#J^IwxIsHtQB0n?q*!`2~+s^rVcuL=)?62BZ3+!P7
z-{{^L)H|;_D}J#V<2NrC{4CzMG0JQHA%T1Ll=RMW?NOs+^7}ofhKEh|$`LtR({B&V
z*PMKstJvdrHuzX~PX9S&Pv*s;;>i}RY%?CSZDZ!|%CX|BT=PTC8pAAK9-Os9iK+PY
z@vIn|AI7-e8}M771RCAqKa4ZJit|7Anp{gQt~Ew=4#l_X*4$XG`!nTitmW*M{I#4}
zyoUqzFjg~kmhW{&+1=lZ!!xtXB<>Ib(Pp|hZibbJfQgL!tYOdlWM*Z_l
zY;wI#o7nX4mF^$yu2iRNhw`g@)$`4nI}m96an>r=<>y_=pS9k*&d~4~RKBZcYn9t!
zPThkQgD=$k?0Wyl7#rtZ-Kd{o-Sl_CKgQUs^`88Ek4@D__3EU29zHXCXQ3Sl+)tB0
zQ(p%I_xAo^Ti{(vjF$uJ-qHHI+w-UHEph?>q>bs`5NP#XqPeo6o)PsObpPC7|6;e#
z_t?7wI=%BhJr9eX-?Ib%m4Tn>==Hc?_XXOYweRD6hmD_)&Jp=|vh@T%gUvQP-c#r$
zf9NZp*eRAEp5*Kd@O!7JJ>mfNm@od}p8k2*?;&q3d&CF&+|p@o*8a^|D?8}{&n!3)
zXk@TwmJBgoiwyBS9vN%d%UA8L^d6yB`+Ak1?SbC8m4k})o{alC5HqcOpG>J^KeM(U
z&)IuM3Z(Z%y(|Ww>$69%m{eTWa`x)HiaYds`j{W@Iid&LABFz;z1n#iKHFE5HSb*Y
zvidtErrj31)nbA7^W{ACF_34^Hc$&^1pU3O#-P6s?H}&hoVmLHdinA)F&q
zuY(P<&godqYzhCE?_a2yqkjfCuVxau<9dc&p5)&Zo?-4?cDQ?X2Wqmf3AIr7uJKYJ
zF8!aes;!ka@1B|jdbM40`?Et1IA?ff>F@dQtc8zlYvEJ-YvFSq*TUx0~?vI|Aj>>f(YkPXWVNLWh?dy4anfR<9OZ{Zq-1@Oza*fC8lE3xm
z+3G^APXf)|Z(Tc{chM{EBIj5R`aBGCcC2~mpHJ?GS?Bl*=WhHg4bNPkmpkLk^)l7=
zteU{5-4SP~?hxl4*7E+;^SU$oIy)nDUuR+nb$-Qg$lt#Q4f)aY_{oDi>m9rIHEKS~
zmfqLO%aQPvzqRLJ2JWi;!M0#~Aiv82|CWLSfmZihpBwY*$v2tB&j<47J^S&m_5FIa
zocA#s%Xc5MyK=tSIjp_j_TJC1&gK2bP#YDid3C(9N}T$bZeN9W?CdX&?C~DhpCvln
za|=P)Jofp0SevJh@b`CDZ~JK@ynXEqWj|nqf0k^2-aF6k-VWc7&*L51Ar3?S-j1=D
z-*;rsteCs|hVtjd#n1K+`FneMU$>6%&Xeu^a-QrlU+d>S?W>yUeI3TrXRUcU*az<3
z9=`8$&(@#I^!nW6RnJ3xeqLpsz9B!I^Z3VN;5*6To<0VBPU^E{Z-1YYG5MaI^W+bG
zDBfO2Un4_)&)wQnIh@BY-s|DtvI>76A8{MX?&CAGot;DedA5_a9{#asdoRDYooz$e
zz3pT{eTS{D@3G~5xL4e&uE*+v?%|$Ub?13IdO
z^{{SNyJz}*jGg~kc2th_b(UxGj-C6ScWCn$&i!Z3W1pX~vpX-2WB0_YJ7w&Q&yziN
z&S%MXhO1s?)ym2$JfDwufw(LO&c{;g#b>dNC+W34fm~|%yocK79kb%8HnfAm@bhh*
zQF1E}2Qa6RU3gPnZXUqom
z-`nutLTk0Jda;oW@^?4b%RjO6+26CbmnBc^BBNp;M`ef4AndT$nbRsRd?aqaCon#bAarOwIu*;jdT7WjD}s2qr+*vqZf+o&Gc
z*xM(5_T00JpPZ1(ZgF9A#lm}5Z@2d}jXv^wedRM9WPK!m4{>OF$<6Y##=QHHUw-%;
zqs@{(+|P!7KfP!@UhDmx#Mc9X*57MK^RZ!Chue-WuljeA9~i!&f8-Y~%=n}xi!ODg
zm2dVh2F@CL@oWe*JZSUvZd_~Rm)`#D@)wWVnFMs>^LIM6$@ITR|Gs$nUb5-g*Vg^J
zrDVxX&Hb;gUaAhomaek`df|=9`45Jduhw=2YE>)0>wYI^HIPv}eTq(&5Cnomv`}+5e;l9nQ@Us#400#o{hC0Y8KZZKk
zJ>;KfQ{`r@KCo{+^4T|!zt4m5khjmnSbXGuxTlX#FF&lG#oNoryRr%oeVTgf>wygi
z17~c1ur1ggI6KRM^`$^gwLO8@R37Qp>ic?Q{B@_%>u$HF{!En2;pML+u2YX#S6!Xj+2^j}zjHB+GoL1bHkOO3A#o+=(!lQ|QPV4d
zXRkQ8Z)-in+n%SFXIwSh%fNGM@Q|Q>|5N2lZ1)BH`9PivTN<72g!hK-*MBxNxyAqX
z(0nTT8$z?S=&M8b@-83HPaM$8jgE+E{@u6E#=V2ht!EFKUOgVqaqF6Q3*+7{?^3-T
ze*Z%6$A?4r{J$Q$_v7b7(^G!^yU=n_^gBYcv*>RREmuXqCUp5wb1!XkWtaFLZgYLi
zpWNn7>Eun?TyOKand|9$gf7|Hdcw!^yQ9z=zO}}d-IW7lQ1AM!t#_}Y)ui5gw%&WK
z+}N+ljd35_GxGbLdOPnKy7%>j(7j)Omfv~Q@BdKfJ~!_R-RI_Aq5ItYXy`sSZx78@
zHB-5{wat}Xa`W|VuFuU^wYlEj=d`)r<|nkd-tLRqTyOh1ZLYV!e#cYq!@U|`@5iU}
z`<(az<;Ta`?|918=QQVRSP1mnTfejQ?nX7ChBP%{+{fW<&2D~Z-w?Ww@k>MZ@x3~9
zAKOErdwENt`As)eNFsD`}b4&n)sbI*W3HvHrLzyGi|Q7
z``@&=-uAb&x!(Raw7K4g8{1s($F*&)uZd^0IdQK#S#ERkP;=+EInSh;TWoXAea(Gw
zoBOhE?u0hyUMRkgw|`^BpGnr-2iu%`qvn34&G}BG=Kf=wbFb9g541U-uWIf)+njr+
z=DxAbo!-se*ya|xxog|pVmEhrn^VIj@6l~;M>qEsZBC6B-`>nstz`Oy`#0KH9mui#
zRh{X_o^9rf&luKo|KeY0`^L_q^*wEUZ|l!${n@QQxAo_>{z0w3p!ME^$az@nAJKZ}
z-29~Vk7~VlZ}S(o{?V;}OzSU8Z|@m_rdEynGw_b~@9&7W_J+`>q_6nDGIW35UKF}N
zYtISYpR*@~?&V(;x<6m%hVIYSVrco*jwPS`tNr{l?)81-6SuFQ_k`~K`{~fVe?Jtu
z_wQ|?d;h*Ebno9yp?iHV4&D3r+|Xs;9pzsy|3Q)8-$kPJ-rgJATyOLBnd|pGCG_#c
zl)Z(u+yQD#Of)rSJoNd*fsKEVf4rvm>o-F8KK)YYJ`evPbYEvb7`o5H+d}tw_?FOp
z9&QdjwCN>nuFu0&ZLW{!p*Gjsdr6z?ZT^Zj*W3MoHrLyJugvxGKaqbh=5v`ZaX78z
zXd%7)iIpaQ#(4U;{Ih1Gdev?S-N)ma(0wc}58cP%lF)q&9um6G-|ogqdLmR9}V66`1a7fkN-S$@8iv(dmmpCdM!4y?PNhs6Mtj2^}6>*
zR&VS5L-*@<3*FoHvHWG_-nRFL?rr&evJ-%7-?`>Wf*l^F#y^o*#)7$&_yPoa7WWK%qXOMe_mrea=ke|yx
z&S9?q4D#~KRSe`w{T&E2cKS}Uuc@;~Wc+siaawZw&oN)$=K9Yu56s+9SDh{218Q^{
z_d4&_?HlH)=i9UjANhQwlfCNZlE4{4n@5w0mVb2J59ZLD0%NwK>%NmKwC{AS%Lkf2
zXt}6&c{%W%yLoY|cYX1)=aj&j&wNWkf2PdStq1&@+W5}2sp8PvRQY5_-2rvp`}?zO
z?fJw5?X#)gXHUJ)mU^EZ_2sL0qEBo6p7ea*-RLtLy{plC8@;p9&Jq5Sdsd_C^WOeO
zm;SRGy^x;Xa~fTCp4;fM=Yfqbf6i-keb0A(qkU#4??H_gPxONutp?COH?miKpnWfm
zRy$~)C(#v`hc>$6>T{;`%FDwWUGen!(>hu3$VRJsw3@SC=f&AWJ2%!R0lM<+-axzO
zt@|8{u6j_%=&EfskFN9QJfQ3RIVw?I)9JPxX#-d8EbT@CB2%_S8bH8s*Td6HcFSeC|&1eT)NZ)UF20Qly6lFe3J(;
z(D0J2C(D}p(d5-w9XvCJJSF`b5+vt>{U4YME%L(-d67GEor!A#b9lg-9{l3rsQ
zy^~-|fab$2Tj`XeGlRdcn8y5>F}3#h5z{MY#8i%F#k6dl6;pY+J`ivDRyS`B)Wpuf
ze&=JDi`r-HSoX2`SoX1Jz5A{^hCSCF!ye~jo^9@%XU73C-XAz)yMhhD;Xq6){?5nt
zzf2{itCelG?Ut8E$c
zU)`((vtm`Y;V~BD_1Y%pY@P&K#s66BslAoEwb*`DbdLE))~r~H<1ohj5NB)NCx&sZ
zoKLc*&5OHpK8z`ORlj$X&DTYyv&R>|FW<9BZD{N9g^aNpB5O52kELG9wn^k`!`QM%
zyoNPY_KdAny|34vc`@wk`g3X1-Q)XeF{-mNjM1^ifjk(ir9KYFs+UiDf(^l}9Icnf
z8Iu?9P|r#I56>)p?zHCz>$xM?Q8h{a*u6{k#$YXXl)L}Av9Iiz<^PfJjon#nhe@EV
zrkk80zqrq`RZj7{1Dvt)og6V$Q!#(~Z-wF;-ktW3*)5LO1-)GPz*{;>zGu~X@5Sr0
zhh6gjybRc3ypl1wI|J)u@5jrTXU9_Ojp0BbR=w{hhn`hK>chTaOza^dL)OL2+H>_X!
z#?A^~>DUtZ&T28Je0bNXcb2k=jG;~ZWRrd@o|Tg^yVyHs7khojH1uPZy+a?$Ml#$t
zz7HGvVy*b0SZu{zPMn2nx;njfP^Wx89@*D*vacVJ
zz1}lW^}_BKbh2M~2gt7259>+{)tvd^d%oDJ6*c0Xo&*~Hsww;S2it<(fw<4RKlfza
zosGxXGin|`UGzJjLtP2WG2i`@?A7MUcNfjGja|EfjjQl2XWjj<)Ous*PaNv}troXC
zLdLLNai?ZWbW!QH-GKMjd
zLoqoXnPiCh@ygh8oHE9Ilhfm|YfPrvIUbqfr8avRheMCm
zbH~;Ff-b%~19b;F>uPz{8R%tt*CtbAGns6z`{JsM$82^V)p_h~CYy|*FL;;Rn)A#z
zwQzc{5U9`IuJV;l8ap?4J^A~CZGl)7U&-)yMZ|z_wPug^Xn&T*hJ^snB+&K*tDRXq
z8-iJJp?@qcVhEFfPJC4xcgy&2Fc#-o^2Bc#(*v1f+ferNXUM*`$r$EJZpU&+uDlHS
z@h-QuVQzP4UT&`oI=)yP5$LAuiXGE{KT_3Qca&%YB?VVl!
za&TQx_wV+M`?~hC2mL+NuMO`xv{-Hq?udHd89C~mjVrAm){FCQ-Mcc|>-@2^?kG8)
zb?41`7C7tT(#t(Dv^p;xC0|XiSANx=&mk|0f$T7TamM8Go!#p6%wTUoKP(4z-t>h7
z8E*)B-^FjeHDv$T9V*VizI_2(*81JotoYEy{$XCl-+aYdY`!W1!RPsSpY)5tn9uX_
zF;5@av)<49n38`u5R0MR^W^g-rr*x5zJ_MW6pKB9+|J^;E^A`+Pokh|>8msDYe_B4
zI!AP{k8i!N5iwKeJYOrP-dVOp#&WPbAfFBVQ9twS;RpNWS)A+nNzU=uHOYQ$p8T?N
zEXQKSA8SjkH?CT(oURt{J3_|6rk^Y^XOF((KUUA;UN*X4=H+0PjcT!E9IKxj?*JJm
z-34R}?~OV~#~UAUJzg2|d%Q9>AE%75__z~}$F4D%&Sfw2aOkn~JMZ4IMt1*BU$keU
zcMNB1(t7%K1?q6tIqGG4KXRXG>V$nI!+Cgqo1^p1LFv3U<2uv*ygO{{Sxu++v7sC?
zoN0TO0x^?|(}OdEs{_8&dmP*NT<^$r$Mrr9-vjZISv?!}2ipR&hBD@T-u1Jh>|6-k
z$&*0a6R7R0g0UQn%UHbFJr=KdaaqV7x>oafb9gFl$K&%I@fpAJI2M~(wKOX>YD9c0
zZ}$64TJOdOGTso_uU>Wst34C&%8_@Lm!#n4$x@GZ_PJ0K&V^bYo(ulS|8+r~gE|-d
z0Qv6kjEYt9SARTpQD=4`y2N)9XnO+o&C5C4$IgQsjGYHQjolyf;^gOq+2EYkIq2hb
zeOnU)XPyu4!itsodSARa;~l|WJ?1O1aqNsaGwR8jdeV!j983ajGX3w-{HgK7!I-St
zCq8cu>4>EIyMDrfzNd=`a0n+U;i36<^WJ61c1{-pah(JjJDmwJ9*fmK#Ji-<
z_gIdvi=S$2SU+k)jE3``QQkL(^J4D(a5#_Gy;$##;wSf~2j>KJ|I~BJdS4fEPYX0-qVM7Fbe$Bix!1WlG(YzQ?)6#voeyWMzDwGb@y6g-{6AiMXW7WFSusCeoolIu
zW3fxFk0<}bym)Sj!6cBMKG$~(z21D0Pu}s`Sb6bo?|b{@plW_zY~2r@lf54iv2H)=
zOjZ4g)Aa#a>bn0dQns4gnlxwpp^Ph9=<^v)+I7dgZaz
zKK6ZWXY1FE*m^iTW45wsPvAbB#dBTO=(wTN@v?yqwK;1)KjmjEfBjvm7OxG&S*_I`
zXT{&!UJ7;xe4eF?Klbkmocs00w9ip5D<({9ykv`)nio6uH_M(`zRN}V%5T0-0!>Wz
z2it=3*ZU0{#&Re>6|24u$ybxZxU0{xcT2W<-VgcdB*#0(fk4BHZ|uE~E%h#1e#mEk
zKFOqd`4wz>Xf6M22Hf;{y9c7amxua~lDze6MKkKfccP#g0h?lc5
z&o=R`T9_9v_uw6En>xRvY&(`*ijVtjH5-QYY>zu(EKj{G@9ECGMuz*$I=Ek)4Rf<(
zIoEXH?a$So&}z;;WA~DKgI!}bU7vY+R*GC(xwFR3tu^txBhD@v
z^w)FPcoOt+aaPSa!_Ic;AI7EbhSi=q;^A!HJ(v|2@3m|h)(740hFNhTdn_(x^Vq$n
zw#xSYUUSa*KD2?|Y@^4Ww<9pO9Pno;sJjo}yx8KiXA+1nn(t-rFviyDs`;%MZx0Rx
z+GP6QqtAA7y+4e_n2bHahCnW6oyTjl#)n}H#AYl9%_p|eV~?}8J5cw}55{b}
zGj-mXzQ&!IzFsxMS1}ojZ^hC2Sp3`#>y=rt{=)ZG<1w!@=X;tPb09ohj9;Fyy4@K#
zC+?WTLB(@;XUxl|bL6`ie_weya2Dip-Z^!SHU|CqVaKu9K!2ZqXN_;}kg}V7+d{j?
z%D!2;)ajnU`Q`&zyE@vMJ7Cs+K9$}+j$&K3EjFG>dW{eJ12&d@v(ADXj>)HY?Ea#+
z?rS`B&H8?(o+V|A7}j2KI3rLiceHKdc}LmiK2(2WwS0Z%QwpQ;yDsx%@e}W{=P!FJ
zUVWa)SZ;gN8(O}g^w+brK3~+IKZRu)?|Qb($`yO+x!TvxSiZ#Jj?Pz|-C6eWwPLec
zEgj1_Qj>DLTFne=_vGwxrpIcdmnF8&s78jGu?}?(=zo4NCd)Y&1M%r=!~U@vbLUu-
zS9K_M^vGvl8+$^t<&M^~xt#jJ=^pAH0?
zm>r93w)1HcXeDP>{or2?=wE6*`+6CZ&>C6nJsjX4tCO*K;-$k{=`g2mCV@7Y{`aU3
zHR?W8_hWjl&pe(nUDnt*RtQSyMLF=Y%>J
zXg<{$N3*qPu?Mz{J@4@IyLx>4gKdFx*UPci*I2EY_inM4pF_E;=0FT9#&TNmm7DVO
zAM($ls4qU&dHKSbJX+u4a6D&HJv%$jY}E|<3up4P@ALKEi=Xdja!=}HLvXm&i+l9V
zf&1ItTQ#*S#=;!Qa5$qvCExD?uo(heP|_f_=mo-i;S{=mW&PI@opieV{)#|
z{8%i-cr2D=fS8QgOwZxQGqkyE9nSN`8hv9j)z&PTv*M5~w~M7XtT&cpGG^JaR^Ns)
z`8Llka-pw_dA`V-{8T-Qr&je^`id@Dd%~ms=GjuR@YcSunv#>^S?`@d-g2NOms)Q;
z3CLylVt{WFXms5zm}UFCn2gD~vwUO!(3iUJX4&4y@>pumS?j-dEB)eCHE>eK>&;X7
zLdNd@$KH9s*;Q5hKgk4=2oDi31O#&@GwFmXpfqooNdnTO1r>-T34|o}0@heiR8W*+
z;bG^AVgV6BQIsMUL`9xr0~JMV*ib2ou%^m(
zl~35N@(EenZt9-c9Y60`|BU$U1F@6y_*sBF5I;Q~Lax?#4`73y!yo5+q&{UhsPQb%{{b6XcwJ%jX4Wo}Yovji0kk
z&CzStkALf;ANx%Kn^9-GUS26#>{j_c(sS1F(wpo#&KIuuG)1Utq_mgW^pW>lN!!*Q)iX>y_(K*Q?f}u2-)|U9VY>x=vn?x?Z~;b-ivq>N;gT>U#Zp)b)n-
zsOydEQP-&zx|ZmysCve=J100B{oLL__v=H)@zNvrDt+NOUH81Ld%msE8s_{C>~}Vw
zlT$T^@7U$MtjYm8y0J^n(8IMUFq*CZAJS9B$Db-b=lW?%2-i31%75Eoir{x%;^KX!
zDG&$s_;-lu%_XMOAHtZregC08RegXS-o0XM+=?E6O;3Adrk2sbg>>^S%d9p
zvo4RF%B_$-YIJ7F9rtJH9vl6FZd+&RNc##s{tV_?EfKG(_V`S$fIq`wpY`~4wg~el
zistNW3eF??k?+>m*tc(!0&0c5x9dLUVI-fYh>5;MkK?cNudes05&3fOpsy)dFa1i~
z?Vh*pzkDv>A9L}%gPtppcl@^g<8)tDH}^L=dxspcpH0yd1owb_@O+gW_T5P0poSX=
z`0!5oK+d>7r=o@<(NB!T&b28pnyvq@e-FU^f6G4Cb9L?Xc`wm*&cVB+#5s7k?sFgi
zGjs4B*(V3@)%Bm5gZG6Tynj9AplUylB$u&YKM?#pufoqI%3amI!9D8-5X
zr9xG%eRk#Z)3Whrp1d3QdpMt+-Ri|>x!0=4hjruHTu|XN?>-+XeC&-8$kPUb{X0kZ
zobgkH<-*27js+XYWWIIO#YhcVOU&)+hd*`C5c=+;B?jxm$9DSstXN-hl5=_;Up^*Z
zR+RgXr<{)$f2rWS#N2k%C$2I1=KF4J6T4&f{?%01_N<#&E|dcI&qXN~@2T~bL+2#+
ziu0P|%N`ebveNoK;Jb4
ze086;>yZ_btI9EUs{BRPb|&baJW+3CqiuLifq#R^`HC+a3U&Qc_g=8FtfSVSRpRlB
z`_JhQ)siIjD*iTht}%$~o|}Bq&;939E|FO*RN3^|K@8px?BhCl`W`(^fiXiEBPsG+us6pFRlUDl{Hpy-ZmP~F_oL_H`*2fh#tS~1@HzfYDf6uNxem=B*PLDL
z&Z7q_27K)k@GJJa<0JNszT^z(;_xvWORW-1!rsf&sgFYc2)UB$f%f+wKg^j9u
z+6HxN3ees&&<0)E-IIl7-DAjdqq@r_>K*@+x|I$gl`x|*`iI-_lTs;h(f(Fb&}1|P6FPUxf#
zb$->=fw}_hxDK7z>9*e3m?sbyH6Uhcz%^nY(PInnX{tc%-NsebUv+Vj8~keuj2Qww
z-K|aMvZ=KU^z;bb>cMw>A}{o|e-5}n_tc1f*iblLAXnJUdtkYE-S#2!etvrYRM{S`
z9{9eZ_!PhIvF;obHSQBwXP>L=ZlL+P8j>^ey{>iR-PwIdZkGsE`HjAwBN=MN*@5gl
z;i2sFZuhgjeh%~QgwALSpQ>yPmlK}@
zF&1Kk-xL`5jGpyXqmk%w>~%5L^&9J`i~Bm}j2Nr*jS;_2AGxXOqi$nDN7h4*hqLQA
znv!Ku8~p9oKK*1}m%2`sXTVm!(Xhhy+k^wX{SAG+w0PIo%H5N{PMHI&uI54d18;n
zy}mB`eSUC$MV-fquF56;JQQbXxBje@pW_A2yKB`e(7LqfFX@I@`wNfHgiC~~ctS*g`}4~Z
zuF4tj7gafpc8IZ4J6~BxJMF&1v7h-YCeNMZY9zYJA^pXk|EgkJQSPtPJw4Db=(hEp
zTwRV>`!xx<9;};I)-BPMeyWNo_E?>q{kdNH$pN;$uKVcQhT_%v)-I=O!22OI;aCa|F8Tc_uPM5_pI#~blb|+NcseS
z<7Y(I3V!@9*LAbM*zDGxb>shcq`7BR+ozGe!4JfkABa
zdb?a#*(Ek~lCN&R7q9CHbaI9<@N0~KEcc^@_4#ZhZ{#EAjd%vj+<>n5G(ngwa4v9G
zuMqeh3FbI2$S3*$`s)53G4fuA+#F$&zngC_EU{z9
zdgthVlED77AJ)`=wsXq*u)+nf8;p&OFc%Slm5>8(Ka--#%5j5
zM;{bkZExke6K7mY-P@fXD~d1KSM+omLsj1JIrec~?~(t!2k?1G;b*^yH|A`rXlhg^
z@A_sv*vxj()2*NDbI;>X_A}O(XQ1Q7Pt)GpGsL5RyN#hPcMo>1$zAl>_xR)cx>(xf
zr7Dlhq%+r>ygk_UtFv1dSDk!ajga?w8P7Fh&GGiMiMQSPSalAdd$8CZ(3SPPJJ6F;
zgm|WkT#8y>Xa#r?GJf-oN0xM^@Cfx13e`<$L1Zl9AI@;s7w`n8UD$RF>lKT-n`(@37zbveMls@@}S_L=#nz`%Zw
zuvl>2V$a5PeAoYD`P|f%!P+rGyS3E1>hpltF425DyX3~Qb#|5&9Zg*sBbBf71^sn7
zt;*#{&IWpqzQ|_@wyVxza>jYWocA=n>l(ApdpJL9S(D}3?MHf+{n#&X7Gj$ieV=_^
zskse=s+_G5zba10l64V>&zablw&55jNv>C*Ul$5$)7Cgb|Bs*aj%A$>{yhi%g+JKm
z9Ca?^9%tV9!WZVyHAlei6v6Y(dpG$+KlvojReOP0iJ>Z=&I3B|Dd&hhRP_(>R^^pG
ztoojZxEy!1k)J)tpyMS1b--`Vx}V4qYVV(^=yuKf!ED_VJO0PB!m;_8;@Ut{XXhL`
z*2p!edw!8)>#VCIe12XqUe^JkArMPbV9XHk;s1KwZv8)6w+H)K@?h&rk9jExJ`n}t_t&kq-;#gQ8-=UoQx;l0H?nIsD
z3;hDm51tw8E0&egrFL2?9%}W^j;GtbU)QJPp4zZa&JpNo-mR!RXbOxO0%sS`UgEFn
z3)ea8B0p98*?o}Z@u})PX@dBZh1ml2^t;jCa)@_I-bLMGtoL5e`+Uth$gOfI2ehYxB_U
z?`r&g4)q-Zm
zmUsSR-HDTZ$QtD1cN(TAia$l*dwlyEiYr}uc~drx*^msql0YJlAt
z0(m6Y@xIO<_)UR<{6C{7h_T9Uw|PTH*3)S(*6n3{tEy4e8G>9>V9>wh&U;bEUG1K&
zi@#f+x{d$Aw%cv}$myU!90TRbJ@2zkfzfRJ{{wrAzD6eRWny#fn!0B+TmSz+U$4tr
zo`XMEQD^AN{u;?M-p`r1_gzDL_xa-Qx=s7M;f#pi3-La{z$f~RGn4bDDnBd4uj*^g
z(kj33r|QgHDL%IB+a%rh3e=L%BFr)TnS-2L)^YiBiO*WwnIl>BO%d!X=WmRk@BY|h
z$i(YvSMHkv!#QqeBR|91$=2Dz$4+e3t?%h@{Ydk%oAlqV
znov{fML$xDrob4f@96zSjowaUs>{i`_|??nPVIM+({5yz$ad9Uj{RIG!+s~Hzf?{+
zH@N?m?%6y2f^J*iO>wUMS_J0+bG)AtFZ|z#kDkb1EP6Pf{;$fAlRK0XYREGH`nQSx
zU7~-V=szU-kBPoB(SJ(xpA-F;MBkO@yAyp+qVG-gUlaYeKzCACa&li-1O4|z-=FB!
ziRK~Z9JjN{dCTyg>h}GKedKpI>WQ8np`A_JBCgTFPv|j;?n(66K)18;P{j2gn`{64
zbeZbucaU>*&$|lGxw@X|_I=QLe734J+V
"
+      );
+      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
+      bs b "\n
" ;
+      bp b "" (Naming.attribute_target a);
+      bs b (self#keyword "val");
+      bs b " ";
+      (
+       if a.att_virtual then
+         bs b ((self#keyword "virtual")^ " ")
+       else
+         ()
+      );
+      (
+       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 !Global.target_dir file) c;
+           bp b "%s" file (Name.simple a.att_value.val_name);
+      );
+      bs b "";
+      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
+      bs b "\n
";
+      (* html mark *)
+      bp b "" (Naming.method_target m);
+     bs b ((self#keyword "method")^" ");
+       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 !Global.target_dir file) c;
+           bp b "%s" file (Name.simple m.met_value.val_name);
+      );
+      bs b "";
+      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 !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
+      )
+
+    (** 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 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
+          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
+        [] -> ()
+      | _ ->
+          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 ->
+            List.exists
+              (fun n -> (Parameter.desc_by_name p n) <> None)
+              (Parameter.names p))
+          l
+      in
+      let f p =
+        bs b "
";
+        bs b (Parameter.complete_name p);
+        bs b " : " ;
+        self#html_of_parameter_description b p;
+        bs b "
\n"
+      in
+      List.iter f l2
+
+    (** Print html code for a list of module parameters. *)
+    method html_of_module_parameter_list b m_name l =
+      match l with
+        [] ->
+          ()
+      | _ ->
+          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"
+
+    (** 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
+      bs b "\n
";
+      bs b ((self#keyword "module")^" ");
+      (
+       if with_link then
+         bp b "%s" html_file (Name.simple m.m_name)
+       else
+         bs b (Name.simple m.m_name)
+      );
+      (
+       match m.m_kind with
+         Module_functor _ when !html_short_functors  ->
+           ()
+       | _ -> bs b ": "
+      );
+      self#html_of_module_kind b father ~modu: m m.m_kind;
+      bs b "
";
+      if info then
+        (
+         if complete then
+           self#html_of_info ~cls: "module top" ~indent: true
+         else
+           self#html_of_info_first_sentence
+        ) b m.m_info
+      else
+        ()
+
+    (** 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
+      bs b "\n
";
+      bs b ((self#keyword "module type")^" ");
+      (
+       if with_link then
+         bp b "%s" html_file (Name.simple mt.mt_name)
+         else
+         bs b (Name.simple mt.mt_name)
+      );
+      (match mt.mt_kind with
+        None -> ()
+      | Some k ->
+          bs b " = ";
+          self#html_of_module_type_kind b father ~mt k
+      );
+      bs b "
";
+      if info then
+        (
+         if complete then
+           self#html_of_info ~cls: "modtype top" ~indent: true
+         else
+           self#html_of_info_first_sentence
+        ) b mt.mt_info
+      else
+        ()
+
+    (** Print html code for an included module. *)
+    method html_of_included_module b im =
+      bs b "\n
";
+      bs b ((self#keyword "include")^" ");
+      (
+       match im.im_module with
+         None ->
+           bs b im.im_name
+       | Some mmt ->
+           let (file, name) =
+             match mmt with
+               Mod m ->
+                 let (html_file, _) = Naming.html_files m.m_name in
+                 (html_file, m.m_name)
+             | Modtype mt ->
+                 let (html_file, _) = Naming.html_files mt.mt_name in
+                 (html_file, mt.mt_name)
+           in
+           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 _ ->
+          (* TODO: display final type from 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 " "
+          );
+          bs b "";
+          bs b (self#create_fully_qualified_idents_links father cco.cco_name);
+          bs b ""
+
+      | 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 " "
+          );
+          bs b "";
+          bs b (self#create_fully_qualified_idents_links father cta.cta_name);
+          bs b ""
+
+      | 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"]
+
+    (** 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 (html_file, _) = Naming.html_files c.cl_name in
+      bs b "\n
";
+      (* we add a html id, the same as for a type so we can
+         go directly here when the class name is used as a type name *)
+      bp b ""
+        (Naming.type_target
+           { ty_name = c.cl_name ;
+             ty_info = None ; ty_parameters = [] ;
+             ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
+             ty_loc = Odoc_info.dummy_loc ;
+             ty_code = None ;
+           }
+        );
+      bs b ((self#keyword "class")^" ");
+      print_DEBUG "html#html_of_class : virtual or not" ;
+      if c.cl_virtual then bs b ((self#keyword "virtual")^" ");
+      (
+       match c.cl_type_parameters with
+         [] -> ()
+       | 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
+         bp b "%s" html_file (Name.simple c.cl_name)
+       else
+         bs b (Name.simple c.cl_name)
+      );
+      bs b "";
+      bs b " : " ;
+      self#html_of_class_parameter_list b father c ;
+      self#html_of_class_kind b father ~cl: c c.cl_kind;
+      bs b "
" ;
+      print_DEBUG "html#html_of_class : info" ;
+      (
+       if complete then
+         self#html_of_info ~cls: "class top" ~indent: true
+       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 (html_file, _) = Naming.html_files ct.clt_name in
+      bs b "\n
";
+      (* we add a html id, the same as for a type so we can
+         go directly here when the class type name is used as a type name *)
+      bp b ""
+        (Naming.type_target
+           { ty_name = ct.clt_name ;
+             ty_info = None ; ty_parameters = [] ;
+             ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
+             ty_loc = Odoc_info.dummy_loc ;
+             ty_code = None ;
+           }
+        );
+      bs b ((self#keyword "class type")^" ");
+      if ct.clt_virtual then bs b ((self#keyword "virtual")^" ");
+      (
+       match ct.clt_type_parameters with
+        [] -> ()
+      | l ->
+          self#html_of_class_type_param_expr_list b father l;
+          bs b " "
+      );
+
+      if with_link then
+        bp b "%s" html_file (Name.simple ct.clt_name)
+      else
+        bs b (Name.simple ct.clt_name);
+
+      bs b "";
+      bs b " = ";
+      self#html_of_class_type_kind b father ~ct ct.clt_kind;
+      bs b "
";
+      (
+       if complete then
+         self#html_of_info ~cls: "classtype top" ~indent: true
+       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 =
+      let f n =
+        let (name, cct_opt) = n.Odoc_dag2html.valu in
+        (* if we have a c_opt = Some class then we take its information
+           because we are sure the name is complete. *)
+        let (name2, html_file) =
+          match cct_opt with
+            None -> (name, fst (Naming.html_files name))
+          | Some (Cl c) -> (c.cl_name, fst (Naming.html_files c.cl_name))
+          | Some (Cltype (ct, _)) -> (ct.clt_name, fst (Naming.html_files ct.clt_name))
+        in
+        let new_v =
+          "\n\n
"^
+          ""^name2^""^
+          "
\n"
+        in
+        { n with Odoc_dag2html.valu = new_v }
+      in
+      let a = Array.map f dag.Odoc_dag2html.dag in
+      Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a }
+
+    (** 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"
+
+    (** 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
+        | (Odoc_info.Raw s) :: q ->
+            (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q
+        | _ -> text
+      in
+      self#html_of_text b text2
+
+    (** Generate html code for the given list of inherited classes.*)
+    method generate_inheritance_info b inher_l =
+      let f inh =
+        match inh.ic_class with
+          None -> (* we can't make the link. *)
+            (Odoc_info.Code inh.ic_name) ::
+            (match inh.ic_text with
+              None -> []
+            | Some t -> (Odoc_info.Raw "    ") :: t)
+        | Some cct ->
+            (* we can create the link. *)
+            let real_name = (* even if it should be the same *)
+              match cct with
+                Cl c -> c.cl_name
+              | Cltype (ct, _) -> ct.clt_name
+            in
+            let (class_file, _) = Naming.html_files real_name in
+            (Odoc_info.Link (class_file, [Odoc_info.Code real_name])) ::
+            (match inh.ic_text with
+              None -> []
+            | Some t -> (Odoc_info.Raw "    ") :: t)
+      in
+      let text = [
+        Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits] ;
+        Odoc_info.List (List.map f inher_l)
+      ]
+      in
+      self#html_of_text b text
+
+    (** Generate html code for the inherited classes of the given class. *)
+    method generate_class_inheritance_info b cl =
+      let rec iter_kind k =
+        match k with
+          Class_structure ([], _) ->
+            ()
+        | Class_structure (l, _) ->
+            self#generate_inheritance_info b l
+        | Class_constraint (k, _) ->
+            iter_kind k
+        | Class_apply _
+        | Class_constr _ ->
+            ()
+      in
+      iter_kind cl.cl_kind
+
+    (** Generate html code for the inherited classes of the given class type. *)
+    method generate_class_type_inheritance_info b clt =
+      match clt.clt_kind with
+        Class_signature ([], _) ->
+          ()
+      | Class_signature (l, _) ->
+          self#generate_inheritance_info b l
+      | Class_type _ ->
+          ()
+
+    (** A method to create index files. *)
+    method generate_elements_index :
+        'a.
+        'a list ->
+          ('a -> Odoc_info.Name.t) ->
+            ('a -> Odoc_info.info option) ->
+              ('a -> string) -> string -> string -> unit =
+    fun elements name info target title simple_file ->
+      try
+        let chanout = open_out (Filename.concat !Global.target_dir simple_file) in
+        let b = new_buf () in
+        bs b "\n";
+        self#print_header b (self#inner_title title);
+        bs b "\n";
+        self#print_navbar b None None "";
+        bs b "
";
+        bs b title;
+        bs b "
\n" ;
+
+        let sorted_elements = List.sort
+            (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
+          bp b "%s " (target e) (self#escape 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
+            [] -> ()
+          | e :: _ ->
+              let s =
+                match (Char.uppercase_ascii (Name.simple (name e)).[0]) with
+                  'A'..'Z' as c -> String.make 1 c
+                | _ -> ""
+              in
+              bs b "
";
+              bs b s ;
+              bs b "\n" ;
+              List.iter f_ele l
+        in
+        bs b "\n";
+        List.iter f_group groups ;
+        bs b "
\n" ;
+        bs b "\n";
+        Buffer.output_buffer chanout b;
+        close_out chanout
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** A method to generate a list of module/class files. *)
+    method generate_elements :
+        'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit =
+      fun f_generate l ->
+        let rec iter pre_opt = function
+            [] -> ()
+          | ele :: [] -> f_generate pre_opt None ele
+          | ele1 :: ele2 :: q ->
+              f_generate pre_opt (Some ele2) ele1 ;
+              iter (Some ele1) (ele2 :: q)
+        in
+        iter None l
+
+    (** Generate the code of the html page for the given class.*)
+    method generate_for_class pre post cl =
+      Odoc_info.reset_type_names ();
+      let (html_file, _) = Naming.html_files cl.cl_name in
+      let type_file = Naming.file_type_class_complete_target cl.cl_name in
+      try
+        let chanout = open_out (Filename.concat !Global.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
+        bs b doctype ;
+        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";
+        self#html_of_class b ~with_link: false cl;
+        (* parameters *)
+        self#html_of_described_parameter_list b
+          (Name.father cl.cl_name) cl.cl_parameters;
+        (* class inheritance *)
+        self#generate_class_inheritance_info b cl;
+        (* a horizontal line *)
+        bs b "
\n";
+        (* the various elements *)
+        List.iter (self#html_of_class_element b)
+          (Class.class_elements ~trans:false cl);
+        bs b "";
+        Buffer.output_buffer chanout b;
+        close_out chanout;
+
+        (* generate the file with the complete class type *)
+        self#output_class_type
+          cl.cl_name
+          (Filename.concat !Global.target_dir type_file)
+          cl.cl_type
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Generate the code of the html page for the given class type.*)
+    method generate_for_class_type pre post clt =
+      Odoc_info.reset_type_names ();
+      let (html_file, _) = Naming.html_files clt.clt_name in
+      let type_file = Naming.file_type_class_complete_target clt.clt_name in
+      try
+        let chanout = open_out (Filename.concat !Global.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
+        bs b doctype ;
+        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";
+        self#html_of_class_type b ~with_link: false clt;
+
+        (* class inheritance *)
+        self#generate_class_type_inheritance_info b clt;
+        (* a horizontal line *)
+        bs b "
\n";
+        (* the various elements *)
+        List.iter (self#html_of_class_element b)
+          (Class.class_type_elements ~trans: false clt);
+        bs b "";
+        Buffer.output_buffer chanout b;
+        close_out chanout;
+
+        (* generate the file with the complete class type *)
+        self#output_class_type
+          clt.clt_name
+          (Filename.concat !Global.target_dir type_file)
+          clt.clt_type
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Generate the html file for the given module type.
+       @raise Failure if an error occurs.*)
+    method generate_for_module_type pre post mt =
+      try
+        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 !Global.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
+        bs b doctype ;
+        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" ;
+        self#html_of_modtype b ~with_link: false mt;
+
+        (* parameters for functors *)
+        self#html_of_module_parameter_list b
+          (Name.father mt.mt_name)
+          (Module.module_type_parameters mt);
+        (* a horizontal line *)
+        bs b "
\n";
+        (* module elements *)
+        List.iter
+          (self#html_of_module_element b mt.mt_name)
+          (Module.module_type_elements mt);
+
+        bs b "";
+        Buffer.output_buffer chanout b;
+        close_out chanout;
+
+        (* generate html files for submodules *)
+        self#generate_elements self#generate_for_module (Module.module_type_modules mt);
+        (* generate html files for module types *)
+        self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt);
+        (* generate html files for classes *)
+        self#generate_elements self#generate_for_class (Module.module_type_classes mt);
+        (* generate html files for class types *)
+        self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt);
+
+        (* generate the file with the complete module type *)
+        (
+         match mt.mt_type with
+           None -> ()
+         | Some mty ->
+             self#output_module_type
+               mt.mt_name
+               (Filename.concat !Global.target_dir type_file)
+               mty
+        )
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Generate the html file for the given module.
+       @raise Failure if an error occurs.*)
+    method generate_for_module pre post modu =
+      try
+        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 !Global.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
+        bs b doctype ;
+        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 "
";
+        if modu.m_text_only then
+          bs b modu.m_name
+        else
+          (
+           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";
+
+        if not modu.m_text_only then
+          self#html_of_module b ~with_link: false modu
+        else
+          self#html_of_info ~indent:false b modu.m_info;
+
+        (* parameters for functors *)
+        self#html_of_module_parameter_list b
+          (Name.father modu.m_name)
+          (Module.module_parameters modu);
+
+        (* a horizontal line *)
+        if not modu.m_text_only then bs b "
\n";
+
+        (* module elements *)
+        List.iter
+          (self#html_of_module_element b modu.m_name)
+          (Module.module_elements modu);
+
+        bs b "";
+        Buffer.output_buffer chanout b;
+        close_out chanout;
+
+        (* generate html files for submodules *)
+        self#generate_elements  self#generate_for_module (Module.module_modules modu);
+        (* generate html files for module types *)
+        self#generate_elements  self#generate_for_module_type (Module.module_module_types modu);
+        (* generate html files for classes *)
+        self#generate_elements  self#generate_for_class (Module.module_classes modu);
+        (* generate html files for class types *)
+        self#generate_elements  self#generate_for_class_type (Module.module_class_types modu);
+
+        (* generate the file with the complete module type *)
+        self#output_module_type
+          modu.m_name
+          (Filename.concat !Global.target_dir type_file)
+          modu.m_type;
+
+        match modu.m_code with
+          None -> ()
+        | Some code ->
+            self#output_code ~with_pre:false
+              modu.m_name
+              (Filename.concat !Global.target_dir code_file)
+              code
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Generate the [.html] file corresponding to the given module list.
+       @raise Failure if an error occurs.*)
+    method generate_index module_list =
+      try
+        let chanout = open_out (Filename.concat !Global.target_dir self#index) in
+        let b = new_buf () in
+        let title = match !Global.title with None -> "" | Some t -> self#escape t in
+        bs b doctype ;
+        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 module_list)
+            !Odoc_info.Global.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 _ -> self#html_of_info ~indent: false b info
+        );
+        bs b "\n";
+        Buffer.output_buffer chanout b;
+        close_out chanout
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Generate the values index in the file [index_values.html]. *)
+    method generate_values_index _module_list =
+      self#generate_elements_index
+        self#list_values
+        (fun v -> v.val_name)
+        (fun v -> v.val_info)
+        Naming.complete_value_target
+        Odoc_messages.index_of_values
+        self#index_values
+
+    (** Generate the extensions index in the file [index_extensions.html]. *)
+    method generate_extensions_index _module_list =
+      self#generate_elements_index
+        self#list_extensions
+        (fun x -> x.xt_name)
+        (fun x -> x.xt_type_extension.te_info)
+        (fun x -> Naming.complete_extension_target x)
+        Odoc_messages.index_of_extensions
+        self#index_extensions
+
+    (** Generate the exceptions index in the file [index_exceptions.html]. *)
+    method generate_exceptions_index _module_list =
+      self#generate_elements_index
+        self#list_exceptions
+        (fun e -> e.ex_name)
+        (fun e -> e.ex_info)
+        Naming.complete_exception_target
+        Odoc_messages.index_of_exceptions
+        self#index_exceptions
+
+    (** Generate the types index in the file [index_types.html]. *)
+    method generate_types_index _module_list =
+      self#generate_elements_index
+        self#list_types
+        (fun t -> t.ty_name)
+        (fun t -> t.ty_info)
+        Naming.complete_type_target
+        Odoc_messages.index_of_types
+        self#index_types
+
+    (** Generate the attributes index in the file [index_attributes.html]. *)
+    method generate_attributes_index _module_list =
+      self#generate_elements_index
+        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
+        self#index_attributes
+
+    (** Generate the methods index in the file [index_methods.html]. *)
+    method generate_methods_index _module_list =
+      self#generate_elements_index
+        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
+        self#index_methods
+
+    (** Generate the classes index in the file [index_classes.html]. *)
+    method generate_classes_index _module_list =
+      self#generate_elements_index
+        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
+        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
+        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
+        self#index_class_types
+
+    (** Generate the modules index in the file [index_modules.html]. *)
+    method generate_modules_index _module_list =
+      self#generate_elements_index
+        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
+        self#index_modules
+
+    (** Generate the module types index in the file [index_module_types.html]. *)
+    method generate_module_types_index _module_list =
+      self#generate_elements_index
+        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
+        self#index_module_types
+
+    (** Generate all the html files from a module list. The main
+       file is [.html]. *)
+    method generate module_list =
+      (* init the style *)
+      self#init_style ;
+      (* init the lists of elements *)
+      list_values <- Odoc_info.Search.values module_list ;
+      list_extensions <- Odoc_info.Search.extensions module_list ;
+      list_exceptions <- Odoc_info.Search.exceptions module_list ;
+      list_types <- Odoc_info.Search.types module_list ;
+      list_attributes <- Odoc_info.Search.attributes module_list ;
+      list_methods <- Odoc_info.Search.methods module_list ;
+      list_classes <- Odoc_info.Search.classes module_list ;
+      list_class_types <- Odoc_info.Search.class_types module_list ;
+      list_modules <- Odoc_info.Search.modules module_list ;
+      list_module_types <- Odoc_info.Search.module_types module_list ;
+
+      (* prepare the page header *)
+      self#prepare_header module_list ;
+      (* Get the names of all known types. *)
+      let types = Odoc_info.Search.types module_list in
+      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
+      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
+      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 !index_only then
+        self#generate_elements self#generate_for_module module_list ;
+
+      try
+        self#generate_index module_list;
+        self#generate_values_index module_list ;
+        self#generate_extensions_index module_list ;
+        self#generate_exceptions_index module_list ;
+        self#generate_types_index module_list ;
+        self#generate_attributes_index module_list ;
+        self#generate_methods_index module_list ;
+        self#generate_classes_index module_list ;
+        self#generate_class_types_index module_list ;
+        self#generate_modules_index module_list ;
+        self#generate_module_types_index module_list ;
+      with
+        Failure s ->
+          prerr_endline s ;
+          incr Odoc_info.errors
+
+    initializer
+      Odoc_ocamlhtml.html_of_comment :=
+        (fun s ->
+          let b = new_buf () in
+          self#html_of_text b (Odoc_text.Texter.text_of_string s);
+          Buffer.contents b
+        )
+  end
+end
+
+module type Html_generator = module type of Generator
diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml
new file mode 100644
index 00000000..19d04314
--- /dev/null
+++ b/ocamldoc/odoc_info.ml
@@ -0,0 +1,338 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Interface for analysing documented OCaml source files and to the collected information. *)
+
+type ref_kind = Odoc_types.ref_kind =
+    RK_module
+  | RK_module_type
+  | RK_class
+  | RK_class_type
+  | RK_value
+  | RK_type
+  | RK_extension
+  | RK_exception
+  | RK_attribute
+  | RK_method
+  | RK_section of text
+  | RK_recfield
+  | RK_const
+
+and text_element = Odoc_types.text_element =
+  | Raw of string
+  | Code of string
+  | CodePre of string
+  | Verbatim of string
+  | Bold of text
+  | Italic of text
+  | Emphasize of text
+  | Center of text
+  | Left of text
+  | Right of text
+  | List of text list
+  | Enum of text list
+  | Newline
+  | Block of text
+  | Title of int * string option * text
+  | Latex of string
+  | Link of string * text
+  | Ref of string * ref_kind option * text option
+  | Superscript of text
+  | Subscript of text
+  | Module_list of string list
+  | Index_list
+  | Custom of string * text
+  | Target of string * string
+
+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
+  | See_doc of string
+
+type see = see_ref * text
+
+type param = (string * text)
+
+type raised_exception = (string * text)
+
+type info = Odoc_types.info = {
+    i_desc : text option;
+    i_authors : string list;
+    i_version : string option;
+    i_sees : see list;
+    i_since : string option;
+    i_before : (string * text) list ;
+    i_deprecated : text option;
+    i_params : param list;
+    i_raised_exceptions : raised_exception list;
+    i_return_value : text option ;
+    i_custom : (string * text) list ;
+  }
+
+type location = Odoc_types.location = {
+    loc_impl : Location.t option ;
+    loc_inter : Location.t option ;
+  }
+
+let dummy_loc = { loc_impl = None ; loc_inter = None }
+
+module Name = Odoc_name
+module Parameter = Odoc_parameter
+module Extension = Odoc_extension
+module Exception = Odoc_exception
+module Type = Odoc_type
+module Value = Odoc_value
+module Class = Odoc_class
+module Module = Odoc_module
+
+
+let analyse_files
+    ?(merge_options=([] : Odoc_types.merge_option list))
+    ?(include_dirs=([] : string list))
+    ?(labels=false)
+    ?(sort_modules=false)
+    ?(no_stop=false)
+    ?(init=[])
+    files =
+  Odoc_global.merge_options := merge_options;
+  Odoc_global.include_dirs := include_dirs;
+  Odoc_global.classic := not labels;
+  Odoc_global.sort_modules := sort_modules;
+  Odoc_global.no_stop := no_stop;
+  Odoc_analyse.analyse_files ~init: init files
+
+let dump_modules = Odoc_analyse.dump_modules
+
+let load_modules = Odoc_analyse.load_modules
+
+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_print.string_of_type_expr t
+
+let string_of_class_params = Odoc_str.string_of_class_params
+
+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_type_extension_param_list te = Odoc_str.string_of_type_extension_param_list te
+
+let string_of_class_type_param_list l = Odoc_str.string_of_class_type_param_list l
+
+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
+
+let string_of_info i = Odoc_misc.string_of_info i
+
+let string_of_type t = Odoc_str.string_of_type t
+let string_of_record t = Odoc_str.string_of_record t
+
+let string_of_type_extension te = Odoc_str.string_of_type_extension te
+
+let string_of_exception e = Odoc_str.string_of_exception e
+
+let string_of_value v = Odoc_str.string_of_value v
+
+let string_of_attribute att = Odoc_str.string_of_attribute att
+
+let string_of_method m = Odoc_str.string_of_method m
+
+let first_sentence_of_text = Odoc_misc.first_sentence_of_text
+
+let first_sentence_and_rest_of_text = Odoc_misc.first_sentence_and_rest_of_text
+
+let text_no_title_no_list = Odoc_misc.text_no_title_no_list
+
+let text_concat = Odoc_misc.text_concat
+
+let get_titles_in_text = Odoc_misc.get_titles_in_text
+
+let create_index_lists = Odoc_misc.create_index_lists
+
+let remove_ending_newline = Odoc_misc.remove_ending_newline
+
+let remove_option = Odoc_misc.remove_option
+
+let is_optional = Odoc_misc.is_optional
+
+let label_name = Odoc_misc.label_name
+
+let use_hidden_modules n =
+  Odoc_name.hide_given_modules !Odoc_global.hidden_modules n
+
+let verbose s =
+  if !Odoc_global.verbose then
+    (print_string s ; print_newline ())
+  else
+    ()
+
+let warning s = Odoc_global.pwarning s
+let print_warnings = Odoc_config.print_warnings
+
+let errors = Odoc_global.errors
+
+let apply_opt = Odoc_misc.apply_opt
+
+let apply_if_equal f v1 v2 =
+  if v1 = v2 then
+    f v1
+  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_custom;
+
+  Buffer.contents b
+
+let info_of_string = Odoc_comments.info_of_string
+let info_of_comment_file = Odoc_comments.info_of_comment_file
+
+module Search =
+  struct
+    type result_element = Odoc_search.result_element =
+          Res_module of Module.t_module
+        | Res_module_type of Module.t_module_type
+        | Res_class of Class.t_class
+        | Res_class_type of Class.t_class_type
+        | Res_value of Value.t_value
+        | Res_type of Type.t_type
+        | Res_extension of Extension.t_extension_constructor
+        | Res_exception of Exception.t_exception
+        | Res_attribute of Value.t_attribute
+        | Res_method of Value.t_method
+        | Res_section of string * text
+        | Res_recfield of Type.t_type * Type.record_field
+        | Res_const of Type.t_type * Type.variant_constructor
+
+    type search_result = result_element list
+
+    let search_by_name = Odoc_search.Search_by_name.search
+
+    let values = Odoc_search.values
+    let extensions = Odoc_search.extensions
+    let exceptions = Odoc_search.exceptions
+    let types = Odoc_search.types
+    let attributes = Odoc_search.attributes
+    let methods = Odoc_search.methods
+    let classes = Odoc_search.classes
+    let class_types = Odoc_search.class_types
+    let modules = Odoc_search.modules
+    let module_types = Odoc_search.module_types
+  end
+
+module Scan =
+  struct
+    class scanner = Odoc_scan.scanner
+  end
+
+module Dep =
+  struct
+    let kernel_deps_of_modules = Odoc_dep.kernel_deps_of_modules
+    let deps_of_types = Odoc_dep.deps_of_types
+  end
+
+module Global = Odoc_global
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
new file mode 100644
index 00000000..d7c36777
--- /dev/null
+++ b/ocamldoc/odoc_info.mli
@@ -0,0 +1,1093 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Interface to the information collected in source files. *)
+
+(** The differents kinds of element references. *)
+type ref_kind = Odoc_types.ref_kind =
+    RK_module
+  | RK_module_type
+  | RK_class
+  | RK_class_type
+  | RK_value
+  | RK_type
+  | RK_extension
+  | RK_exception
+  | RK_attribute
+  | RK_method
+  | RK_section of text
+  | RK_recfield
+  | RK_const
+
+and text_element = Odoc_types.text_element =
+  | Raw of string (** Raw text. *)
+  | Code of string (** The string is source code. *)
+  | CodePre of string (** The string is pre-formatted source code. *)
+  | Verbatim of string (** String 'as is'. *)
+  | Bold of text (** Text in bold style. *)
+  | Italic of text (** Text in italic. *)
+  | Emphasize of text (** Emphasized text. *)
+  | Center of text (** Centered text. *)
+  | Left of text (** Left alignment. *)
+  | Right of text (** Right alignment. *)
+  | List of text list (** A list. *)
+  | Enum of text list (** An enumerated list. *)
+  | Newline   (** To force a line break. *)
+  | Block of text (** Like html's block quote. *)
+  | Title of int * string option * text
+             (** Style number, optional label, and text. *)
+  | Latex of string (** A string for latex. *)
+  | Link of string * text (** A reference string and the link text. *)
+  | Ref of string * ref_kind option * text option
+       (** A reference to an element. Complete name and kind.
+        An optional text can be given to display this text instead
+        of the element name.*)
+  | 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, ...) *)
+  | Custom of string * text (** to extend \{foo syntax *)
+  | Target of string * string (** (target, code) : to specify code specific to a target format *)
+
+(** A text is a list of [text_element]. The order matters. *)
+and text = text_element list
+
+(** The different forms of references in \@see tags. *)
+type see_ref = Odoc_types.see_ref =
+    See_url of string
+  | 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
+
+(** Parameter name and description. *)
+type param = (string * text)
+
+(** Raised exception name and description. *)
+type raised_exception = (string * text)
+
+(** Information in a special comment
+@before 3.12.0 \@before information was not present.
+*)
+type info = Odoc_types.info = {
+    i_desc : text option; (** The description text. *)
+    i_authors : string list; (** The list of authors in \@author tags. *)
+    i_version : string option; (** The string in the \@version tag. *)
+    i_sees : see list; (** The list of \@see tags. *)
+    i_since : string option; (** The string in the \@since tag. *)
+    i_before : (string * text) list ; (** the version number and text in \@before tag *)
+    i_deprecated : text option; (** The of the \@deprecated tag. *)
+    i_params : param list; (** The list of parameter descriptions. *)
+    i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *)
+    i_return_value : text option; (** The description text of the return value. *)
+    i_custom : (string * text) list ; (** A text associated to a custom @-tag. *)
+  }
+
+(** Location of elements in implementation and interface files. *)
+type location = Odoc_types.location = {
+    loc_impl : Location.t option ; (** implementation location *)
+    loc_inter : Location.t option ; (** interface location *)
+  }
+
+(** A dummy location. *)
+val dummy_loc : location
+
+(** Representation of element names. *)
+module Name :
+    sig
+      type t = string
+
+      (** Access to the simple name. *)
+      val simple : t -> t
+
+      (** [concat t1 t2] returns the concatenation of [t1] and [t2].*)
+      val concat : t -> t -> t
+
+      (** Return the depth of the name, i.e. the numer of levels to the root.
+         Example : [depth "Toto.Tutu.name"] = [3]. *)
+      val depth : t -> int
+
+      (** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *)
+      val get_relative : t -> t -> t
+
+      (** Return the name of the 'father' (like [dirname] for a file name).*)
+      val father : t -> t
+    end
+
+(** Representation and manipulation of method / function / class / module parameters.*)
+module Parameter :
+  sig
+    (** {3 Types} *)
+
+    (** Representation of a simple parameter name *)
+    type simple_name = Odoc_parameter.simple_name =
+        {
+          sn_name : string ;
+          sn_type : Types.type_expr ;
+          mutable sn_text : text option ;
+        }
+
+    (** Representation of parameter names. We need it to represent parameter names in tuples.
+       The value [Tuple ([], t)] stands for an anonymous parameter.*)
+    type param_info = Odoc_parameter.param_info =
+        Simple_name of simple_name
+      | Tuple of param_info list * Types.type_expr
+
+    (** A parameter is just a param_info.*)
+    type parameter = param_info
+
+    (** {3 Functions} *)
+
+    (** Acces to the name as a string. For tuples, parenthesis and commas are added. *)
+    val complete_name : parameter -> string
+
+    (** Access to the complete type. *)
+    val typ : parameter -> Types.type_expr
+
+    (** Access to the list of names ; only one for a simple parameter, or
+       a list for a tuple. *)
+    val names : parameter -> string list
+
+    (** Access to the description of a specific name.
+       @raise Not_found if no description is associated to the given name. *)
+    val desc_by_name : parameter -> string -> text option
+
+    (** Access to the type of a specific name.
+       @raise Not_found if no type is associated to the given name. *)
+    val type_by_name : parameter -> string -> Types.type_expr
+  end
+
+(** Representation and manipulation of extensions. *)
+module Extension :
+  sig
+    type private_flag = Odoc_extension.private_flag =
+      Private | Public
+
+    (** Used when the extension is a rebind of another extension,
+       when we have [extension Xt = Target_xt].*)
+    type extension_alias = Odoc_extension.extension_alias =
+        {
+          xa_name : Name.t ; (** The complete name of the target extension. *)
+          mutable xa_xt : t_extension_constructor option ; (** The target extension, if we found it.*)
+        }
+
+    and t_extension_constructor = Odoc_extension.t_extension_constructor =
+        {
+          xt_name : Name.t ;
+          xt_args: Odoc_type.constructor_args;
+          xt_ret: Types.type_expr option ; (** the optional return type of the extension *)
+          xt_type_extension: t_type_extension ; (** the type extension containing this constructor *)
+          xt_alias: extension_alias option ; (** [None] when the extension is not a rebind. *)
+          mutable xt_loc: Odoc_types.location ;
+          mutable xt_text: Odoc_types.info option ; (** optional user description *)
+        }
+
+    and t_type_extension = Odoc_extension.t_type_extension =
+        {
+          mutable te_info : info option ; (** Information found in the optional associated comment. *)
+          te_type_name : Name.t ; (** The type of the extension *)
+          te_type_parameters : Types.type_expr list;
+          te_private : private_flag ;
+          mutable te_constructors: t_extension_constructor list;
+          mutable te_loc : location ;
+          mutable te_code : string option ;
+        }
+
+    (** Access to the extensions in a group. *)
+    val extension_constructors : t_type_extension -> t_extension_constructor list
+
+  end
+
+(** Representation and manipulation of exceptions. *)
+module Exception :
+  sig
+    (** Used when the exception is a rebind of another exception,
+       when we have [exception Ex = Target_ex].*)
+    type exception_alias = Odoc_exception.exception_alias =
+        {
+          ea_name : Name.t ; (** The complete name of the target exception. *)
+          mutable ea_ex : t_exception option ; (** The target exception, if we found it.*)
+        }
+
+    and t_exception = Odoc_exception.t_exception =
+        {
+          ex_name : Name.t ;
+          mutable ex_info : info option ; (** Information found in the optional associated comment. *)
+          ex_args : Odoc_type.constructor_args;
+          ex_ret : Types.type_expr option ; (** The the optional return type of the exception. *)
+          ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *)
+          mutable ex_loc : location ;
+          mutable ex_code : string option ;
+        }
+  end
+
+(** Representation and manipulation of types.*)
+module Type :
+  sig
+    type private_flag = Odoc_type.private_flag =
+      Private | Public
+
+    (** Description of a record type field. *)
+    type record_field = Odoc_type.record_field =
+        {
+          rf_name : string ; (** Name of the field. *)
+          rf_mutable : bool ; (** [true] if mutable. *)
+          rf_type : Types.type_expr ; (** Type of the field. *)
+          mutable rf_text : info option ; (** Optional description in the associated comment.*)
+        }
+
+    (** Description of a variant type constructor. *)
+    type constructor_args = Odoc_type.constructor_args =
+      | Cstr_record of record_field list
+      | Cstr_tuple of Types.type_expr list
+
+    type variant_constructor = Odoc_type.variant_constructor =
+        {
+          vc_name : string ; (** Name of the constructor. *)
+          vc_args : constructor_args;
+          vc_ret : Types.type_expr option ;
+          mutable vc_text : info option ; (** Optional description in the associated comment. *)
+        }
+
+    (** The various kinds of a type. *)
+    type type_kind = Odoc_type.type_kind =
+        Type_abstract (** Type is abstract, for example [type t]. *)
+      | Type_variant of variant_constructor list
+                   (** constructors *)
+      | Type_record of record_field list
+                   (** fields *)
+      | Type_open (** Type is open *)
+
+    type object_field = Odoc_type.object_field = {
+      of_name : string ;
+      of_type : Types.type_expr ;
+      mutable of_text : Odoc_types.info option ; (** optional user description *)
+    }
+
+    type type_manifest = Odoc_type.type_manifest =
+      | Other of Types.type_expr (** Type manifest directly taken from Typedtre. *)
+      | Object_type of object_field list
+
+    (** Representation of a type. *)
+    type t_type = Odoc_type.t_type =
+        {
+          ty_name : Name.t ; (** Complete name of the type. *)
+          mutable ty_info : info option ; (** Information found in the optional associated comment. *)
+          ty_parameters : (Types.type_expr * bool * bool) list ;
+                    (** type parameters: (type, covariant, contravariant) *)
+          ty_kind : type_kind; (** Type kind. *)
+          ty_private : private_flag; (** Private or public type. *)
+          ty_manifest : type_manifest option ;
+          mutable ty_loc : location ;
+          mutable ty_code : string option;
+        }
+
+  end
+
+(** Representation and manipulation of values, class attributes and class methods. *)
+module Value :
+  sig
+    (** Representation of a value. *)
+    type t_value = Odoc_value.t_value =
+        {
+          val_name : Name.t ; (** Complete name of the value. *)
+          mutable val_info : info option ; (** Information found in the optional associated comment. *)
+          val_type : Types.type_expr ; (** Type of the value. *)
+          val_recursive : bool ; (** [true] if the value is recursive. *)
+          mutable val_parameters : Odoc_parameter.parameter list ; (** The parameters, if any. *)
+          mutable val_code : string option ; (** The code of the value, if we had the only the implementation file. *)
+          mutable val_loc : location ;
+        }
+
+    (** Representation of a class attribute. *)
+    type t_attribute = Odoc_value.t_attribute =
+        {
+          att_value : t_value ; (** an attribute has almost all the same information as a value *)
+          att_mutable : bool ;  (** [true] if the attribute is mutable. *)
+          att_virtual : bool ;  (** [true] if the attribute is virtual. *)
+        }
+
+    (** Representation of a class method. *)
+    type t_method = Odoc_value.t_method =
+        {
+          met_value : t_value ; (** a method has almost all the same information as a value *)
+          met_private : bool ;  (** [true] if the method is private.*)
+          met_virtual : bool ;  (** [true] if the method is virtual. *)
+        }
+
+    (** Return [true] if the value is a function, i.e. it has a functional type. *)
+    val is_function : t_value -> bool
+
+    (** Access to the description associated to the given parameter name.*)
+    val value_parameter_text_by_name : t_value -> string -> text option
+  end
+
+(** Representation and manipulation of classes and class types.*)
+module Class :
+  sig
+    (** {3 Types} *)
+
+    (** To keep the order of elements in a class. *)
+    type class_element = Odoc_class.class_element =
+        Class_attribute of Value.t_attribute
+      | Class_method of Value.t_method
+      | Class_comment of text
+
+    (** Used when we can reference a t_class or a t_class_type. *)
+    type cct = Odoc_class.cct =
+        Cl of t_class
+      | Cltype of t_class_type * Types.type_expr list (** Class type and type parameters. *)
+
+    and inherited_class = Odoc_class.inherited_class =
+        {
+          ic_name : Name.t ; (** Complete name of the inherited class. *)
+          mutable ic_class : cct option ; (** The associated t_class or t_class_type. *)
+          ic_text : text option ; (** The inheritance description, if any. *)
+        }
+
+    and class_apply = Odoc_class.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. *)
+        }
+
+    and class_constr = Odoc_class.class_constr =
+        {
+          cco_name : Name.t ; (** The complete name of the applied class. *)
+          mutable cco_class : cct option;
+              (** The associated class or class type if we found it. *)
+          cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed. *)
+        }
+
+    and class_kind = Odoc_class.class_kind =
+        Class_structure of inherited_class list * class_element list
+        (** An explicit class structure, used in implementation and interface. *)
+      | Class_apply of class_apply
+        (** Application/alias of a class, used in implementation only. *)
+      | Class_constr of class_constr
+        (** A class used to give the type of the defined class,
+           instead of a structure, used in interface only.
+           For example, it will be used with the name [M1.M2....bar]
+           when the class foo is defined like this :
+           [class foo : int -> bar] *)
+      | Class_constraint of class_kind * class_type_kind
+        (** A class definition with a constraint. *)
+
+    (** Representation of a class. *)
+    and t_class = Odoc_class.t_class =
+        {
+          cl_name : Name.t ; (** Complete name of the class. *)
+          mutable cl_info : info option ; (** Information found in the optional associated comment. *)
+          cl_type : Types.class_type ; (** Type of the class. *)
+          cl_type_parameters : Types.type_expr list ; (** Type parameters. *)
+          cl_virtual : bool ; (** [true] when the class is virtual. *)
+          mutable cl_kind : class_kind ; (** The way the class is defined. *)
+          mutable cl_parameters : Parameter.parameter list ; (** The parameters of the class. *)
+          mutable cl_loc : location ;
+        }
+
+    and class_type_alias = Odoc_class.class_type_alias =
+        {
+          cta_name : Name.t ; (** Complete name of the target class type. *)
+          mutable cta_class : cct option ;  (** The target t_class or t_class_type, if we found it.*)
+          cta_type_parameters : Types.type_expr list ; (** The type parameters. FIXME : use strings? *)
+        }
+
+    and class_type_kind = Odoc_class.class_type_kind =
+        Class_signature of inherited_class list * class_element list
+      | Class_type of class_type_alias (** A class type eventually applied to type args. *)
+
+    (** Representation of a class type. *)
+    and t_class_type = Odoc_class.t_class_type =
+        {
+          clt_name : Name.t ; (** Complete name of the type. *)
+          mutable clt_info : info option ; (** Information found in the optional associated comment. *)
+          clt_type : Types.class_type ;
+          clt_type_parameters : Types.type_expr list ; (** Type parameters. *)
+          clt_virtual : bool ; (** [true] if the class type is virtual *)
+          mutable clt_kind : class_type_kind ; (** The way the class type is defined. *)
+          mutable clt_loc : location ;
+        }
+
+    (** {3 Functions} *)
+
+    (** Access to the elements of a class. *)
+    val class_elements : ?trans:bool -> t_class -> class_element list
+
+    (** Access to the list of class attributes. *)
+    val class_attributes : ?trans:bool -> t_class -> Value.t_attribute list
+
+    (** Access to the description associated to the given class parameter name. *)
+    val class_parameter_text_by_name : t_class -> string -> text option
+
+    (** Access to the methods of a class. *)
+    val class_methods : ?trans:bool -> t_class -> Value.t_method list
+
+    (** Access to the comments of a class. *)
+    val class_comments : ?trans:bool -> t_class -> text list
+
+    (** Access to the elements of a class type. *)
+    val class_type_elements : ?trans:bool -> t_class_type -> class_element list
+
+    (** Access to the list of class type attributes. *)
+    val class_type_attributes : ?trans:bool -> t_class_type -> Value.t_attribute list
+
+    (** Access to the description associated to the given class type parameter name. *)
+    val class_type_parameter_text_by_name : t_class_type -> string -> text option
+
+    (** Access to the methods of a class type. *)
+    val class_type_methods : ?trans:bool -> t_class_type -> Value.t_method list
+
+    (** Access to the comments of a class type. *)
+    val class_type_comments : ?trans:bool -> t_class_type -> text list
+  end
+
+(** Representation and manipulation of modules and module types. *)
+module Module :
+  sig
+    (** {3 Types} *)
+
+    (** To keep the order of elements in a module. *)
+    type module_element = Odoc_module.module_element =
+        Element_module of t_module
+      | Element_module_type of t_module_type
+      | Element_included_module of included_module
+      | Element_class of Class.t_class
+      | Element_class_type of Class.t_class_type
+      | Element_value of Value.t_value
+      | Element_type_extension of Extension.t_type_extension
+      | Element_exception of Exception.t_exception
+      | Element_type of Type.t_type
+      | Element_module_comment of text
+
+    (** Used where we can reference t_module or t_module_type. *)
+    and mmt = Odoc_module.mmt =
+      | Mod of t_module
+      | Modtype of t_module_type
+
+    and included_module = Odoc_module.included_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 =
+        {
+          ma_name : Name.t ; (** Complete name of the target 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 option ; (** 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 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
+                     (** A module whose type is a with ... constraint.
+                        Should appear in interface files only. *)
+      | Module_constraint of module_kind * module_type_kind
+                     (** A module constraint by a module type. *)
+      | Module_typeof of string (** by now only the code of the module expression *)
+      | Module_unpack of string * module_type_alias (** code of the expression and module type alias *)
+
+    (** Representation of a module. *)
+    and t_module = Odoc_module.t_module =
+        {
+          m_name : Name.t ; (** Complete name of the module. *)
+          mutable m_type : Types.module_type ; (** The type of the module. *)
+          mutable m_info : info option ; (** Information found in the optional associated comment. *)
+          m_is_interface : bool ; (** [true] for modules read from interface files *)
+          m_file : string ; (** The file the module is defined in. *)
+          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 *)
+          m_text_only : bool ; (** [true] if the module comes from a text file *)
+        }
+
+    and module_type_alias = Odoc_module.module_type_alias =
+        {
+          mta_name : Name.t ; (** Complete name of the target module type. *)
+          mutable mta_module : t_module_type option ; (** The real module type if we could associate it. *)
+        }
+
+    (** 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 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
+            (** The module type kind and the code of the with constraint. *)
+      | Module_type_typeof of string
+            (** by now only the code of the module expression *)
+
+    (** Representation of a module type. *)
+    and t_module_type = Odoc_module.t_module_type =
+        {
+          mt_name : Name.t ; (** Complete name of the module type. *)
+          mutable mt_info : info option ; (** Information found in the optional associated comment. *)
+          mutable mt_type : Types.module_type option ; (** [None] means that the module type is abstract. *)
+          mt_is_interface : bool ; (** [true] for modules read from interface files. *)
+          mt_file : string ; (** The file the module type is defined in. *)
+          mutable mt_kind : module_type_kind option ;
+              (** The way the module is defined. [None] means that module type is abstract.
+                 It is always [None] when the module type was extracted from the implementation file.
+                 That means module types are only analysed in interface files. *)
+          mutable mt_loc : location ;
+        }
+
+    (** {3 Functions for modules} *)
+
+    (** Access to the elements of a module. *)
+    val module_elements : ?trans:bool -> t_module -> module_element list
+
+    (** Access to the submodules of a module. *)
+    val module_modules : ?trans:bool -> t_module -> t_module list
+
+    (** Access to the module types of a module. *)
+    val module_module_types : ?trans:bool -> t_module -> t_module_type list
+
+    (** Access to the included modules of a module. *)
+    val module_included_modules : ?trans:bool-> t_module -> included_module list
+
+    (** Access to the type extensions of a module. *)
+    val module_type_extensions : ?trans:bool-> t_module -> Extension.t_type_extension list
+
+    (** Access to the exceptions of a module. *)
+    val module_exceptions : ?trans:bool-> t_module -> Exception.t_exception list
+
+    (** Access to the types of a module. *)
+    val module_types : ?trans:bool-> t_module -> Type.t_type list
+
+    (** Access to the values of a module. *)
+    val module_values : ?trans:bool -> t_module -> Value.t_value list
+
+    (** Access to functional values of a module. *)
+    val module_functions : ?trans:bool-> t_module -> Value.t_value list
+
+    (** Access to non-functional values of a module. *)
+    val module_simple_values : ?trans:bool-> t_module -> Value.t_value list
+
+    (** Access to the classes of a module. *)
+    val module_classes : ?trans:bool-> t_module -> Class.t_class list
+
+    (** Access to the class types of a module. *)
+    val module_class_types : ?trans:bool-> t_module -> Class.t_class_type list
+
+    (** The list of classes defined in this module and all its submodules and functors. *)
+    val module_all_classes : ?trans:bool-> t_module -> Class.t_class list
+
+    (** [true] if the module is functor. *)
+    val module_is_functor : t_module -> bool
+
+    (** The list of couples (module parameter, optional description). *)
+    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
+
+    (** {3 Functions for module types} *)
+
+    (** Access to the elements of a module type. *)
+    val module_type_elements : ?trans:bool-> t_module_type -> module_element list
+
+    (** Access to the submodules of a module type. *)
+    val module_type_modules : ?trans:bool-> t_module_type -> t_module list
+
+    (** Access to the module types of a module type. *)
+    val module_type_module_types : ?trans:bool-> t_module_type -> t_module_type list
+
+    (** Access to the included modules of a module type. *)
+    val module_type_included_modules : ?trans:bool-> t_module_type -> included_module list
+
+    (** Access to the exceptions of a module type. *)
+    val module_type_exceptions : ?trans:bool-> t_module_type -> Exception.t_exception list
+
+    (** Access to the types of a module type. *)
+    val module_type_types : ?trans:bool-> t_module_type -> Type.t_type list
+
+    (** Access to the values of a module type. *)
+    val module_type_values : ?trans:bool-> t_module_type -> Value.t_value list
+
+    (** Access to functional values of a module type. *)
+    val module_type_functions : ?trans:bool-> t_module_type -> Value.t_value list
+
+    (** Access to non-functional values of a module type. *)
+    val module_type_simple_values : ?trans:bool-> t_module_type -> Value.t_value list
+
+    (** Access to the classes of a module type. *)
+    val module_type_classes : ?trans:bool-> t_module_type -> Class.t_class list
+
+    (** Access to the class types of a module type. *)
+    val module_type_class_types : ?trans:bool-> t_module_type -> Class.t_class_type list
+
+    (** The list of classes defined in this module type and all its submodules and functors. *)
+    val module_type_all_classes : ?trans:bool-> t_module_type -> Class.t_class list
+
+    (** [true] if the module type is functor. *)
+    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 -> (module_parameter * text option) list
+
+    (** The list of module comments. *)
+    val module_type_comments : ?trans:bool-> t_module_type -> text list
+  end
+
+
+(** {3 Getting strings from values} *)
+
+(** This function is used to reset the names of type variables.
+   It must be called when printing the whole type of a function,
+   but not when printing the type of its parameters. Same for
+   classes (call it) and methods and attributes (don't call it).*)
+val reset_type_names : unit -> unit
+
+(** [string_of_variance t (covariant, invariant)] returns ["+"] if
+   the given information means "covariant", ["-"] if the it means
+   "contravariant", orelse [""], and always [""] if the given
+   type is not an abstract type with no manifest (i.e. no need
+   for the variance to be printed.*)
+val string_of_variance : Type.t_type -> (bool * bool) -> string
+
+(** This function returns a string representing a Types.type_expr. *)
+val string_of_type_expr : Types.type_expr -> string
+
+(** @return a string to display the parameters of the given class,
+   in the same form as the compiler. *)
+val string_of_class_params : Class.t_class -> string
+
+(** This function returns a string to represent the given list of types,
+   with a given separator. *)
+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 list of type parameters
+   for the given type extension. *)
+val string_of_type_extension_param_list : Extension.t_type_extension -> 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 : ?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
+
+
+(** Get a string from a text. *)
+val string_of_text : text -> string
+
+(** Get a string from an info structure. *)
+val string_of_info : info -> string
+
+(** @return a string to describe the given type. *)
+val string_of_type : Type.t_type -> string
+
+val string_of_record : Type.record_field list -> string
+
+(** @return a string to describe the given type extension. *)
+val string_of_type_extension : Extension.t_type_extension -> string
+
+(** @return a string to describe the given exception. *)
+val string_of_exception : Exception.t_exception -> string
+
+(** @return a string to describe the given value. *)
+val string_of_value : Value.t_value -> string
+
+(** @return a string to describe the given attribute. *)
+val string_of_attribute : Value.t_attribute -> string
+
+(** @return a string to describe the given method. *)
+val string_of_method : Value.t_method -> string
+
+(** {3 Miscelaneous functions} *)
+
+(** Return the first sentence (until the first dot followed by a blank
+   or the first blank line) of a text.
+   Don't stop in the middle of [Code], [CodePre], [Verbatim], [List], [Enum],
+   [Latex], [Link], [Ref], [Subscript] or [Superscript]. *)
+val first_sentence_of_text : text -> text
+
+(** Return the first sentence (until the first dot followed by a blank
+   or the first blank line) of a text, and the remaining text after.
+   Don't stop in the middle of [Code], [CodePre], [Verbatim], [List], [Enum],
+   [Latex], [Link], [Ref], [Subscript] or [Superscript].*)
+val first_sentence_and_rest_of_text : text -> text * text
+
+(** Return the given [text] without any title or list. *)
+val text_no_title_no_list : text -> text
+
+(** [concat sep l] concats the given list of text [l], each separated with
+   the text [sep]. *)
+val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text
+
+(** Return the list of titles in a [text].
+   A title is a title level, an optional label and a text.*)
+val get_titles_in_text : text -> (int * string option * text) list
+
+(** Take a sorted list of elements, a function to get the name
+   of an element and return the list of list of elements,
+   where each list group elements beginning by the same letter.
+   Since the original list is sorted, elements whose name does not
+   begin with a letter should be in the first returned list.*)
+val create_index_lists : 'a list -> ('a -> string) -> 'a list list
+
+(** Take a type and remove the option top constructor. This is
+   useful when printing labels, we we then remove the top option contructor
+   for optional labels.*)
+val remove_option : Types.type_expr -> Types.type_expr
+
+(** Return [true] if the given label is optional.*)
+val is_optional : Asttypes.arg_label -> bool
+
+(** Return the label name for the given label,
+   i.e. removes the beginning '?' if present.*)
+val label_name : Asttypes.arg_label -> string
+
+(** Return the given name where the module name or
+   part of it was removed, according to the list of modules
+   which must be hidden (cf {!Odoc_args.hidden_modules})*)
+val use_hidden_modules : Name.t -> Name.t
+
+(** Print the given string if the verbose mode is activated. *)
+val verbose : string -> unit
+
+(** Print a warning message to stderr.
+   If warnings must be treated as errors, then the
+   error counter is incremented. *)
+val warning : string -> unit
+
+(** A flag to indicate whether ocamldoc warnings must be printed or not. *)
+val print_warnings : bool ref
+
+(** Increment this counter when an error is encountered.
+   The ocamldoc tool will print the number of errors
+   encountered exit with code 1 if this number is greater
+   than 0. *)
+val errors : int ref
+
+(** Apply a function to an optional value. *)
+val apply_opt : ('a -> 'b) -> 'a option -> 'b option
+
+(** Apply a function to a first value if it is
+   not different from a second value. If the two values
+   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.
+   The given module list is used for cross reference.
+   @raise Failure is the file could not be opened or there is a
+   syntax error.
+*)
+val info_of_comment_file : Module.t_module list -> string -> info
+
+(** [remove_ending_newline s] returns [s] without the optional ending newline. *)
+val remove_ending_newline : string -> string
+
+(** Research in elements *)
+module Search :
+    sig
+      type result_element = Odoc_search.result_element =
+          Res_module of Module.t_module
+        | Res_module_type of Module.t_module_type
+        | Res_class of Class.t_class
+        | Res_class_type of Class.t_class_type
+        | Res_value of Value.t_value
+        | Res_type of Type.t_type
+        | Res_extension of Extension.t_extension_constructor
+        | Res_exception of Exception.t_exception
+        | Res_attribute of Value.t_attribute
+        | Res_method of Value.t_method
+        | Res_section of string  * text
+        | Res_recfield of Type.t_type * Type.record_field
+        | Res_const of Type.t_type * Type.variant_constructor
+
+      (** The type representing a research result.*)
+      type search_result = result_element list
+
+      (** Research of the elements whose name matches the given regular expression.*)
+      val search_by_name : Module.t_module list -> Str.regexp -> search_result
+
+      (** A function to search all the values in a list of modules. *)
+      val values : Module.t_module list -> Value.t_value list
+
+      (** A function to search all the extensions in a list of modules. *)
+      val extensions : Module.t_module list -> Extension.t_extension_constructor list
+
+      (** A function to search all the exceptions in a list of modules. *)
+      val exceptions : Module.t_module list -> Exception.t_exception list
+
+      (** A function to search all the types in a list of modules. *)
+      val types : Module.t_module list -> Type.t_type list
+
+      (** A function to search all the class attributes in a list of modules. *)
+      val attributes : Module.t_module list -> Value.t_attribute list
+
+      (** A function to search all the class methods in a list of modules. *)
+      val methods : Module.t_module list -> Value.t_method list
+
+      (** A function to search all the classes in a list of modules. *)
+      val classes : Module.t_module list -> Class.t_class list
+
+      (** A function to search all the class types in a list of modules. *)
+      val class_types : Module.t_module list -> Class.t_class_type list
+
+      (** A function to search all the modules in a list of modules. *)
+      val modules : Module.t_module list -> Module.t_module list
+
+      (** A function to search all the module types in a list of modules. *)
+      val module_types : Module.t_module list -> Module.t_module_type list
+
+    end
+
+(** Scanning of collected information *)
+module Scan :
+  sig
+    class scanner :
+      object
+
+        method scan_value : Value.t_value -> unit
+
+        method scan_type_pre : Type.t_type -> bool
+        method scan_type_const : Type.t_type -> Type.variant_constructor -> unit
+        method scan_type_recfield : Type.t_type -> Type.record_field -> unit
+        method scan_type : Type.t_type -> unit
+        method scan_extension_constructor : Extension.t_extension_constructor -> unit
+        method scan_exception : Exception.t_exception -> unit
+        method scan_attribute : Value.t_attribute -> unit
+        method scan_method : Value.t_method -> unit
+        method scan_included_module : Module.included_module -> unit
+
+      (** Scan of a type extension *)
+
+        (** Overide this method to perform controls on the extension's type,
+            private and info. This method is called before scanning the
+            extension's constructors.
+            @return true if the extension's constructors must be scanned.*)
+        method scan_type_extension_pre : Extension.t_type_extension -> bool
+
+       (** This method scans the constructors of the given type extension. *)
+        method scan_type_extension_constructors : Extension.t_type_extension -> unit
+
+        (** Scan of a type extension. Should not be overridden. It calls [scan_type_extension_pre]
+            and if [scan_type_extension_pre] returns [true], then it calls scan_type_extension_constructors.*)
+        method scan_type_extension : Extension.t_type_extension -> unit
+
+      (** Scan of a class. *)
+
+        (** Scan of a comment inside a class. *)
+        method scan_class_comment : text -> unit
+
+       (** Override this method to perform controls on the class comment
+          and params. This method is called before scanning the class elements.
+          @return true if the class elements must be scanned.*)
+        method scan_class_pre : Class.t_class -> bool
+
+       (** This method scan the elements of the given class. *)
+        method scan_class_elements : Class.t_class -> unit
+
+       (** Scan of a class. Should not be overridden. It calls [scan_class_pre]
+          and if [scan_class_pre] returns [true], then it calls scan_class_elements.*)
+        method scan_class : Class.t_class -> unit
+
+      (** Scan of a class type. *)
+
+        (** Scan of a comment inside a class type. *)
+        method scan_class_type_comment : text -> unit
+
+        (** Override this method to perform controls on the class type comment
+           and form. This method is called before scanning the class type elements.
+           @return true if the class type elements must be scanned.*)
+        method scan_class_type_pre : Class.t_class_type -> bool
+
+        (** This method scan the elements of the given class type. *)
+        method scan_class_type_elements : Class.t_class_type -> unit
+
+        (** Scan of a class type. Should not be overridden. It calls [scan_class_type_pre]
+           and if [scan_class_type_pre] returns [true], then it calls scan_class_type_elements.*)
+        method scan_class_type : Class.t_class_type -> unit
+
+      (** Scan of modules. *)
+
+        (** Scan of a comment inside a module. *)
+        method scan_module_comment : text -> unit
+
+        (** Override this method to perform controls on the module comment
+           and form. This method is called before scanning the module elements.
+           @return true if the module elements must be scanned.*)
+        method scan_module_pre : Module.t_module -> bool
+
+        (** This method scan the elements of the given module. *)
+        method scan_module_elements : Module.t_module -> unit
+
+       (** Scan of a module. Should not be overridden. It calls [scan_module_pre]
+          and if [scan_module_pre] returns [true], then it calls scan_module_elements.*)
+        method scan_module : Module.t_module -> unit
+
+      (** Scan of module types. *)
+
+        (** Scan of a comment inside a module type. *)
+        method scan_module_type_comment : text -> unit
+
+        (** Override this method to perform controls on the module type comment
+           and form. This method is called before scanning the module type elements.
+           @return true if the module type elements must be scanned. *)
+        method scan_module_type_pre : Module.t_module_type -> bool
+
+        (** This method scan the elements of the given module type. *)
+        method scan_module_type_elements : Module.t_module_type -> unit
+
+        (** Scan of a module type. Should not be overridden. It calls [scan_module_type_pre]
+           and if [scan_module_type_pre] returns [true], then it calls scan_module_type_elements.*)
+        method scan_module_type : Module.t_module_type -> unit
+
+      (** Main scanning method. *)
+
+        (** Scan a list of modules. *)
+        method scan_module_list : Module.t_module list -> unit
+      end
+  end
+
+(** Computation of dependencies. *)
+module Dep :
+  sig
+    (** Modify the modules depencies of the given list of modules,
+       to get the minimum transitivity kernel. *)
+    val kernel_deps_of_modules : Module.t_module list -> unit
+
+    (** Return the list of dependencies between the given types,
+       in the form of a list [(type name, names of types it depends on)].
+       @param kernel indicates if we must keep only the transitivity kernel
+       of the dependencies. Default is [false].
+    *)
+    val deps_of_types : ?kernel: bool -> Type.t_type list -> (Type.t_type * (Name.t list)) list
+  end
+
+(** {2 Some global variables} *)
+
+module Global :
+  sig
+    val errors : int ref
+    val warn_error : bool ref
+
+    (** The file used by the generators outputting only one file. *)
+    val out_file : string ref
+
+    (** Verbose mode or not. *)
+    val verbose : bool ref
+
+    (** The directory where files have to be generated. *)
+    val target_dir : string 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
+
+    (** The flag which indicates if we must generate a table of contents. *)
+    val with_toc : bool ref
+
+    (** The flag which indicates if we must generate an index. *)
+    val with_index : bool ref
+
+    (** The flag which indicates if we must generate a header.*)
+    val with_header : bool ref
+
+    (** The flag which indicates if we must generate a trailer.*)
+    val with_trailer : bool ref
+end
+
+(** Analysis of the given source files.
+   @param init is the list of modules already known from a previous analysis.
+   @return the list of analysed top modules. *)
+val analyse_files :
+    ?merge_options:Odoc_types.merge_option list ->
+      ?include_dirs:string list ->
+        ?labels:bool ->
+          ?sort_modules:bool ->
+            ?no_stop:bool ->
+              ?init: Odoc_module.t_module list ->
+                Odoc_global.source_file list ->
+                  Module.t_module list
+
+(** Dump of a list of modules into a file.
+   @raise Failure if an error occurs.*)
+val dump_modules : string -> Odoc_module.t_module list -> unit
+
+(** Load of a list of modules from a file.
+   @raise Failure if an error occurs.*)
+val load_modules : string -> Odoc_module.t_module list
diff --git a/ocamldoc/odoc_inherit.ml b/ocamldoc/odoc_inherit.ml
new file mode 100644
index 00000000..d47351e9
--- /dev/null
+++ b/ocamldoc/odoc_inherit.ml
@@ -0,0 +1,14 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
new file mode 100644
index 00000000..c9292b84
--- /dev/null
+++ b/ocamldoc/odoc_latex.ml
@@ -0,0 +1,1339 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Generation of LaTeX documentation. *)
+
+let print_DEBUG s = print_string s ; print_newline ()
+
+open Odoc_info
+open Value
+open Type
+open Extension
+open Exception
+open Class
+open Module
+
+
+
+let separate_files = ref false
+
+let latex_titles = ref [
+  1, "section" ;
+  2, "subsection" ;
+  3, "subsubsection" ;
+  4, "paragraph" ;
+  5, "subparagraph" ;
+]
+
+let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix
+let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix
+let latex_type_elt_prefix = ref Odoc_messages.default_latex_type_elt_prefix
+let latex_extension_prefix = ref Odoc_messages.default_latex_extension_prefix
+let latex_exception_prefix = ref Odoc_messages.default_latex_exception_prefix
+let latex_module_prefix = ref Odoc_messages.default_latex_module_prefix
+let latex_module_type_prefix = ref Odoc_messages.default_latex_module_type_prefix
+let latex_class_prefix = ref Odoc_messages.default_latex_class_prefix
+let latex_class_type_prefix = ref Odoc_messages.default_latex_class_type_prefix
+let latex_attribute_prefix = ref Odoc_messages.default_latex_attribute_prefix
+let latex_method_prefix = ref Odoc_messages.default_latex_method_prefix
+
+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 rec merge_codepre = function
+    [] -> []
+  | [e] -> [e]
+  | (CodePre s1) :: (CodePre s2) :: q ->
+      merge_codepre ((CodePre (s1^"\n"^s2)) :: q)
+  | e :: q ->
+      e :: (merge_codepre q)
+
+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 =
+  object (self)
+    (** Return latex code to make a sectionning according to the given level,
+       and with the given latex code. *)
+    method section_style level s =
+      try
+        let sec = List.assoc level !latex_titles in
+        "\\"^sec^"{"^s^"}\n"
+      with Not_found -> s
+
+    (** Associations of strings to substitute in latex code. *)
+    val subst_strings = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+
+        "{", "\\\\{";
+        "}", "\\\\}";
+        "\\$", "\\\\$";
+        "\\^", "{\\\\textasciicircum}";
+        "\xE0", "\\\\`a";
+        "\xE2", "\\\\^a";
+        "\xE9", "\\\\'e";
+        "\xE8", "\\\\`e";
+        "\xEA", "\\\\^e";
+        "\xEB", "\\\\\"e";
+        "\xE7", "\\\\c{c}";
+        "\xF4", "\\\\^o";
+        "\xF6", "\\\\\"o";
+        "\xEE", "\\\\^i";
+        "\xEF", "\\\\\"i";
+        "\xF9", "\\\\`u";
+        "\xFB", "\\\\^u";
+        "%", "\\\\%";
+        "_", "\\\\_";
+        "~", "\\\\~{}";
+        "#", "{\\char35}";
+        "->", "$\\\\rightarrow$";
+        "<-", "$\\\\leftarrow$";
+        ">=", "$\\\\geq$";
+        "<=", "$\\\\leq$";
+        ">", "$>$";
+        "<", "$<$";
+        "=", "$=$";
+        "|", "{\\\\textbar}";
+        "\\.\\.\\.", "$\\\\ldots$";
+        "&", "\\\\&";
+
+        "\001b", "{\\\\char92}";
+        "\001\002", "\001";
+      ]
+
+    val subst_strings_simple = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+        "{", "\001l";
+
+        "}", "{\\\\char125}";
+        "'", "{\\\\textquotesingle}";
+        "`", "{\\\\textasciigrave}";
+
+        "\001b", "{\\\\char92}";
+        "\001l", "{\\\\char123}";
+        "\001\002", "\001";
+      ]
+
+    val subst_strings_code = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+        "{", "\001l";
+
+        "}", "{\\\\char125}";
+        "'", "{\\\\textquotesingle}";
+        "`", "{\\\\textasciigrave}";
+        "%", "\\\\%";
+        "_", "\\\\_";
+        "~", "{\\\\char126}";
+        "#", "{\\\\char35}";
+        "&", "\\\\&";
+        "\\$", "\\\\$";
+        "\\^", "{\\\\char94}";
+
+        "\001b", "{\\\\char92}";
+        "\001l", "{\\\\char123}";
+        "\001\002", "\001";
+      ]
+
+    method subst l s =
+      List.fold_left (fun acc (re, st) -> Str.global_replace re st acc) s l
+
+    (** Escape the strings which would clash with LaTeX syntax. *)
+    method escape s = self#subst subst_strings s
+
+    (** Escape the ['\'], ['{'] and ['}'] characters. *)
+    method escape_simple s = self#subst subst_strings_simple s
+
+    (** Escape some characters for the code style. *)
+    method escape_code s = self#subst subst_strings_code s
+
+    (** Make a correct latex label from a name. *)
+    (* The following characters are forbidden in LaTeX \index:
+       \ { } $ & # ^ _ % ~ ! " @ | (" to close the double quote)
+       The following characters are forbidden in LaTeX \label:
+       \ { } $ & # ^ _ % ~
+       So we will use characters not forbidden in \index if no_ = true.
+    *)
+    method label ?(no_=true) name =
+      let len = String.length name in
+      let buf = Buffer.create len in
+      for i = 0 to len - 1 do
+        let (s_no_, s) =
+          match name.[i] with
+          '_' -> ("-underscore", "_")
+        | '~' -> ("-tilde", "~")
+        | '%' -> ("-percent", "%")
+        | '@' -> ("-at", "\"@")
+        | '!' -> ("-bang", "\"!")
+        | '|' -> ("-pipe", "\"|")
+        | '<' -> ("-lt", "<")
+        | '>' -> ("-gt", ">")
+        | '^' -> ("-exp", "^")
+        | '&' -> ("-ampersand", "&")
+        | '+' -> ("-plus", "+")
+        | '-' -> ("-minus", "-")
+        | '*' -> ("-star", "*")
+        | '/' -> ("-slash", "/")
+        | '$' -> ("-dollar", "$")
+        | '=' -> ("-equal", "=")
+        | ':' -> ("-colon", ":")
+        | c -> (String.make 1 c, String.make 1 c)
+        in
+        Buffer.add_string buf (if no_ then s_no_ else s)
+      done;
+      Buffer.contents buf
+
+    (** Make a correct label from a value name. *)
+    method value_label ?no_ name = !latex_value_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from an attribute name. *)
+    method attribute_label ?no_ name = !latex_attribute_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a method name. *)
+    method method_label ?no_ name = !latex_method_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a class name. *)
+    method class_label ?no_ name = !latex_class_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a class type name. *)
+    method class_type_label ?no_ name = !latex_class_type_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a module name. *)
+    method module_label ?no_ name = !latex_module_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a module type name. *)
+    method module_type_label ?no_ name = !latex_module_type_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from an extension name. *)
+    method extension_label ?no_ name = !latex_extension_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from an exception name. *)
+    method exception_label ?no_ name = !latex_exception_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a type name. *)
+    method type_label ?no_ name = !latex_type_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a record field. *)
+    method recfield_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a variant constructor. *)
+    method const_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name)
+
+    (** Return latex code for the label of a given label. *)
+    method make_label label = "\\label{"^label^"}"
+
+    (** Return latex code for the ref to a given label. *)
+    method make_ref label = "\\ref{"^label^"}"
+
+    (** Print the LaTeX code corresponding to the [text] parameter.*)
+    method latex_of_text fmt t =
+      List.iter (self#latex_of_text_element fmt) t
+
+    (** Print the LaTeX code for the [text_element] in parameter. *)
+    method latex_of_text_element fmt txt =
+      match txt with
+      | 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, text_opt) ->
+          self#latex_of_Ref fmt name ref_opt text_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 -> ()
+      | Odoc_info.Custom (s,t) -> self#latex_of_custom_text fmt s t
+      | Odoc_info.Target (target, code) -> self#latex_of_Target fmt ~target ~code
+
+    method latex_of_custom_text _ _ _ = ()
+
+    method latex_of_Target fmt ~target ~code =
+      if String.lowercase_ascii target = "latex" then
+        self#latex_of_Latex fmt code
+      else
+        ()
+
+    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
+      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 "\n\\begin{verbatim}\n";
+      ps fmt s;
+      ps fmt "\n\\end{verbatim}\n"
+
+    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 fmt s = ps fmt s
+
+    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 fmt name ref_opt text_opt =
+      match ref_opt with
+        None ->
+          self#latex_of_text fmt
+          (match text_opt with
+             None ->
+               [Odoc_info.Code (Odoc_info.use_hidden_modules name)]
+           | Some t -> t
+           )
+      | Some (RK_section _) ->
+          self#latex_of_text_element fmt
+            (Latex ("["^(self#make_ref (self#label ~no_:false (Name.simple name)))^"]"))
+      | Some kind ->
+          let f_label =
+            match kind with
+              Odoc_info.RK_module -> self#module_label
+            | Odoc_info.RK_module_type -> self#module_type_label
+            | Odoc_info.RK_class -> self#class_label
+            | Odoc_info.RK_class_type -> self#class_type_label
+            | Odoc_info.RK_value -> self#value_label
+            | Odoc_info.RK_type -> self#type_label
+            | Odoc_info.RK_extension -> self#extension_label
+            | Odoc_info.RK_exception -> self#exception_label
+            | Odoc_info.RK_attribute -> self#attribute_label
+            | Odoc_info.RK_method -> self#method_label
+            | Odoc_info.RK_section _ -> assert false
+            | Odoc_info.RK_recfield -> self#recfield_label
+            | Odoc_info.RK_const -> self#const_label
+          in
+          let text =
+            match text_opt with
+              None -> [Odoc_info.Code (Odoc_info.use_hidden_modules name)]
+            | Some t -> t
+          in
+          self#latex_of_text fmt
+             (text @ [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
+
+(** A class used to generate LaTeX code for info structures. *)
+class virtual info =
+  object (self)
+    (** The method used to get LaTeX code from a [text]. *)
+    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
+
+    (** 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
+
+module Generator =
+struct
+(** This class is used to create objects which can generate a simple LaTeX documentation. *)
+class latex =
+  object (self)
+    inherit text
+    inherit Odoc_to_text.to_text as to_text
+    inherit info
+
+    (** Get the first sentence and the rest of a description,
+       from an optional [info] structure. The first sentence
+       can be empty if it would not appear right in a title.
+       In the first sentence, the titles and lists has been removed,
+       since it is used in LaTeX titles and would make LaTeX complain
+       if we has two nested \section commands.
+    *)
+    method first_and_rest_of_info i_opt =
+      match i_opt with
+        None -> ([], [])
+      | Some i ->
+            match i.Odoc_info.i_desc with
+              None -> ([], self#text_of_info ~block: true i_opt)
+            | Some t ->
+                let (first,_) = Odoc_info.first_sentence_and_rest_of_text t in
+                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)
+
+    (** Print LaTeX code for a value. *)
+    method latex_of_value fmt v =
+      Odoc_info.reset_type_names () ;
+      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))
+
+    (** 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))
+
+    (** 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))
+
+    (** 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)] -> print_one (p, co, cn)
+      | _ ->
+          ps fmt "(";
+          print_concat fmt ", " print_one t.ty_parameters;
+          ps fmt ")"
+
+    method latex_of_class_parameter_list fmt father c =
+      self#latex_of_text fmt
+        (self#text_of_class_params father c)
+
+
+    method entry_comment (fmt,flush) = function
+      | None -> []
+      | Some t ->
+          let s =
+            ps fmt "\\begin{ocamldoccomment}\n";
+            self#latex_of_info fmt (Some t);
+            ps fmt "\n\\end{ocamldoccomment}\n";
+            flush ()
+          in
+          [ Latex s]
+
+    (** record printing method *)
+    method latex_of_record ( (fmt,flush) as f) mod_name l =
+      p fmt "{";
+      let fields =
+        List.map (fun r ->
+            let s_field =
+              p fmt
+                "@[  %s%s :@ %s ;"
+                (if r.rf_mutable then "mutable " else "")
+                r.rf_name
+                (self#normal_type mod_name r.rf_type);
+              flush ()
+            in
+            [ CodePre s_field ] @ (self#entry_comment f r.rf_text)
+          ) l in
+      List.flatten fields @ [ CodePre "}" ]
+
+    method latex_of_cstr_args ( (fmt,flush) as f) mod_name (args, ret) =
+      match args, ret with
+      | Cstr_tuple [], None -> [CodePre(flush())]
+      | Cstr_tuple _ as l, None ->
+          p fmt " of@ %s"
+            (self#normal_cstr_args ~par:false mod_name l);
+          [CodePre (flush())]
+      | Cstr_tuple t as l, Some r ->
+          let res = self#normal_type mod_name r in
+          if t = [] then
+            p fmt " :@ %s" res
+          else
+            p fmt " :@ %s -> %s" (self#normal_cstr_args ~par:false mod_name l) res
+          ;
+          [CodePre (flush())]
+      | Cstr_record l, None ->
+          p fmt " of@ ";
+          self#latex_of_record f mod_name l
+      | Cstr_record r, Some res ->
+          let l =
+            p fmt " :@ ";
+            self#latex_of_record f mod_name r in
+          let l2 =
+            p fmt "@ %s@ %s" "->"
+              (self#normal_type mod_name res);
+            [CodePre (flush())] in
+          l @ l2
+
+
+
+
+    (** 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) as f) = new_fmt () in
+        Odoc_info.reset_type_names () ;
+        let mod_name = Name.father t.ty_name 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;
+        let priv = t.ty_private = Asttypes.Private in
+        (
+         match t.ty_manifest with
+         | Some (Other typ) ->
+             p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ)
+         | _ -> ()
+        );
+        let s_type3 =
+          p fmt2
+            " %s"
+            (
+             match t.ty_kind with
+               Type_abstract ->
+                begin match t.ty_manifest with
+                | Some (Object_type _) ->
+                  "= " ^ (if priv then "private" else "") ^ " <"
+                | _ -> ""
+                end
+             | Type_variant _ -> "="^(if priv then " private" else "")
+             | Type_record _ -> "= "^(if priv then "private " else "")
+             | Type_open -> "= .."
+            ) ;
+          flush2 ()
+        in
+
+        let defs =
+          match t.ty_kind with
+          | Type_abstract ->
+             begin match t.ty_manifest with
+             | Some (Object_type l) ->
+               let fields =
+                 List.map (fun r ->
+                   let s_field =
+                     p fmt2
+                       "@[  %s :@ %s ;"
+                       r.of_name
+                       (self#normal_type mod_name r.of_type);
+                     flush2 ()
+                   in
+                   [ CodePre s_field ] @ (self#entry_comment f r.of_text)
+                 ) l
+               in
+               List.flatten fields @ [ CodePre ">" ]
+
+             | None | Some (Other _) -> []
+             end
+          | Type_variant l ->
+             let constructors =
+               List.map (fun {vc_name; vc_args; vc_ret; vc_text} ->
+                   p fmt2 "@[  | %s" vc_name ;
+                   let l = self#latex_of_cstr_args f mod_name (vc_args,vc_ret) in
+                   l @ (self#entry_comment f vc_text) ) l
+             in
+             List.flatten constructors
+          | Type_record l ->
+              self#latex_of_record f mod_name l
+          | Type_open ->
+             (* FIXME ? *)
+             []
+        in
+        let defs2 = (CodePre s_type3) :: defs in
+        (merge_codepre defs2) @
+        [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 fmt
+        ((Latex (self#make_label (self#type_label t.ty_name))) :: text)
+
+    (** Print LaTeX code for a type extension. *)
+    method latex_of_type_extension mod_name fmt te =
+      let text =
+        let (fmt2, flush2) as f = new_fmt () in
+        Odoc_info.reset_type_names () ;
+        Format.fprintf fmt2 "@[type ";
+        (
+          match te.te_type_parameters with
+              [] -> ()
+            | [p] ->
+                ps fmt2 (self#normal_type mod_name p);
+                ps fmt2 " "
+            | l ->
+                ps fmt2 "(";
+                print_concat fmt2 ", " (fun p -> ps fmt2 (self#normal_type mod_name p)) l;
+                ps fmt2 ") "
+        );
+        ps fmt2 (self#relative_idents mod_name te.te_type_name);
+        p fmt2 " +=%s" (if te.te_private = Asttypes.Private then " private" else "") ;
+        let s_type3 = flush2 () in
+        let defs =
+          (List.flatten
+             (List.map
+                (fun x ->
+                   let father = Name.father x.xt_name in
+                   p fmt2 "@[  | %s" (Name.simple x.xt_name);
+                   let l = self#latex_of_cstr_args f father (x.xt_args, x.xt_ret) in
+                   let c =
+                     match x.xt_alias with
+                     | None -> []
+                     | Some xa ->
+                         p fmt2 " = %s"
+                           (
+                             match xa.xa_xt with
+                             | None -> xa.xa_name
+                             | Some x -> x.xt_name
+                           );
+                         [CodePre (flush2 ())]
+                   in
+                    Latex (self#make_label (self#extension_label x.xt_name)) :: l @ c
+                    @ (match x.xt_text with
+                      None -> []
+                    | Some t ->
+                        let s =
+                          ps fmt2 "\\begin{ocamldoccomment}\n";
+                          self#latex_of_info fmt2 (Some t);
+                          ps fmt2 "\n\\end{ocamldoccomment}\n";
+                          flush2 ()
+                        in
+                        [ Latex s]
+                    )
+                  )
+                  te.te_constructors
+               )
+              )
+        in
+        let defs2 = (CodePre s_type3) :: defs in
+        (merge_codepre defs2) @
+        (self#text_of_info te.te_info)
+      in
+      self#latex_of_text fmt text
+
+    (** Print LaTeX code for an exception. *)
+    method latex_of_exception fmt e =
+      let text =
+        let (fmt2, flush2) as f = new_fmt() in
+        Odoc_info.reset_type_names () ;
+        let s_name = Name.simple e.ex_name in
+        let father = Name.father e.ex_name in
+        p fmt2 "@[exception %s" s_name;
+        let l = self#latex_of_cstr_args f father (e.ex_args, e.ex_ret) in
+        let s =
+          match e.ex_alias with
+            None -> []
+          | Some ea ->
+              Format.fprintf fmt " = %s"
+                (
+                  match ea.ea_ex with
+                    None -> ea.ea_name
+                  | Some e -> e.ex_name
+                );
+              [CodePre (flush2 ())]
+        in
+       merge_codepre (l @ s ) @
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]
+       @ (self#text_of_info e.ex_info) in
+      self#latex_of_text fmt text
+
+    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);
+            ]
+      | Module_type_typeof s ->
+          self#latex_of_text fmt
+            [ Code "module type of ";
+              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: application is not correct in a .mli.
+             Fix? -> print the typedtree module_type *)
+          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: modify when Module_with will be more detailled *)
+          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: what should we print? *)
+          self#latex_of_module_kind fmt father k
+      | Module_typeof s ->
+          self#latex_of_text fmt
+            [ Code "module type of ";
+              Code (self#relative_idents father s);
+            ]
+      | Module_unpack (s, _) ->
+          self#latex_of_text fmt
+            [
+              Code (self#relative_idents father s);
+            ]
+
+    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 _ ->
+          (* TODO: print final type from 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 "] "]
+                 )
+          );
+          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"
+               )
+        ]
+
+    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"
+               )
+        ]
+
+    method latex_for_module_label fmt m =
+      ps fmt (self#make_label (self#module_label m.m_name))
+
+    method latex_for_module_type_label fmt mt =
+      ps fmt (self#make_label (self#module_type_label mt.mt_name))
+
+
+    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 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 _, 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 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 =
+        [
+          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 fmt t;
+      self#latex_of_class_parameter_list fmt father c;
+      (* avoid a big gap if the kind is a consrt *)
+      (
+       match c.cl_kind with
+         Class.Class_constr _ ->
+           self#latex_of_class_kind fmt father c.cl_kind
+       | _ ->
+           ()
+      );
+      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 "@[";
+      (match c.cl_kind with
+        Class.Class_constr _ -> ()
+      |        _ -> 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 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 =
+        [
+          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 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_type_extension te -> self#latex_of_type_extension module_name fmt te
+      | 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 fmt inher_l =
+      let f inh =
+        match inh.ic_class with
+          None -> (* we can't make the reference *)
+            Newline ::
+            Code ("inherit "^inh.ic_name) ::
+            (match inh.ic_text with
+              None -> []
+            | Some t -> Newline :: t
+            )
+        | Some cct ->
+            let label =
+              match cct with
+                Cl _ -> self#class_label inh.ic_name
+              | Cltype _ -> self#class_type_label inh.ic_name
+            in
+            (* we can create the reference *)
+            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
+      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 fmt cl =
+      let rec iter_kind k =
+        match k with
+          Class_structure ([], _) ->
+            ()
+        | Class_structure (l, _) ->
+            self#generate_inheritance_info fmt l
+        | Class_constraint (k, _) ->
+            iter_kind k
+        | Class_apply _
+        | Class_constr _ ->
+            ()
+      in
+      iter_kind cl.cl_kind
+
+    (** Generate the LaTeX code for the inherited classes of the given class type. *)
+    method generate_class_type_inheritance_info fmt clt =
+      match clt.clt_kind with
+        Class_signature ([], _) ->
+          ()
+      | Class_signature (l, _) ->
+          self#generate_inheritance_info fmt l
+      | Class_type _ ->
+          ()
+
+    (** 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 =
+        let title =
+          if m.m_text_only then [Raw m.m_name]
+          else [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] in
+        let subtitle = match first_t with
+          | [] -> []
+          | t -> (Raw " : ") :: t in
+        [ Title (1, None, title @ subtitle ) ]
+      in
+      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 ] ;
+      if not m.m_text_only then ps fmt "\\ocamldocvspace{0.5cm}\n\n";
+      List.iter
+        (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 module_list =
+      ps fmt "\\documentclass[11pt]{article} \n";
+      ps fmt "\\usepackage[latin1]{inputenc} \n";
+      ps fmt "\\usepackage[T1]{fontenc} \n";
+      ps fmt "\\usepackage{textcomp}\n";
+      ps fmt "\\usepackage{fullpage} \n";
+      ps fmt "\\usepackage{url} \n";
+      ps fmt "\\usepackage{ocamldoc}\n";
+      (
+       match !Global.title with
+         None -> ()
+       | Some s ->
+           ps fmt "\\title{";
+           ps fmt (self#escape s);
+           ps fmt "}\n"
+      );
+      ps fmt "\\begin{document}\n";
+      (match !Global.title with
+        None -> () |
+        Some _ -> ps fmt "\\maketitle\n"
+      );
+      if !Global.with_toc then ps fmt "\\tableofcontents\n";
+      (
+       let info = Odoc_info.apply_opt
+           (Odoc_info.info_of_comment_file module_list)
+           !Odoc_info.Global.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 =
+      try
+        let dir = Filename.dirname !Global.out_file in
+        let file = Filename.concat dir "ocamldoc.sty" in
+        if Sys.file_exists file then
+          Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
+        else
+          (
+           let chanout = open_out file in
+           output_string chanout Odoc_latex_style.content ;
+           flush chanout ;
+           close_out chanout;
+           Odoc_info.verbose (Odoc_messages.file_generated file)
+          )
+      with
+        Sys_error s ->
+          prerr_endline s ;
+          incr Odoc_info.errors ;
+
+    (** Generate the LaTeX file from a module list, in the {!Odoc_info.Global.out_file} file. *)
+    method generate module_list =
+      self#generate_style_file ;
+      let main_file = !Global.out_file in
+      let dir = Filename.dirname main_file in
+      if !separate_files then
+        (
+         let f m =
+           try
+             let chanout =
+               open_out ((Filename.concat dir (Name.simple m.m_name))^".tex")
+             in
+             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
+           | Sys_error s ->
+               prerr_endline s ;
+               incr Odoc_info.errors
+         in
+         List.iter f module_list
+        );
+
+      try
+        let chanout = open_out main_file in
+        let fmt = Format.formatter_of_out_channel chanout in
+        if !Global.with_header then self#latex_header fmt module_list;
+        List.iter
+          (fun m ->
+            if !separate_files then
+              ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n")
+            else
+              self#generate_for_top_module fmt m
+          )
+          module_list ;
+        if !Global.with_trailer then ps fmt "\\end{document}";
+        Format.pp_print_flush fmt ();
+        close_out chanout
+      with
+        Failure s
+      | Sys_error s ->
+          prerr_endline s ;
+          incr Odoc_info.errors
+  end
+end
+
+module type Latex_generator = module type of Generator
diff --git a/ocamldoc/odoc_latex_style.ml b/ocamldoc/odoc_latex_style.ml
new file mode 100644
index 00000000..e3453e2e
--- /dev/null
+++ b/ocamldoc/odoc_latex_style.ml
@@ -0,0 +1,93 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The content of the LaTeX style to generate when generating LaTeX code. *)
+
+let content ="\
+\n%% Support macros for LaTeX documentation generated by ocamldoc.\
+\n%% This file is in the public domain; do what you want with it.\
+\n\
+\n\\NeedsTeXFormat{LaTeX2e}\
+\n\\ProvidesPackage{ocamldoc}\
+\n              [2001/12/04 v1.0 ocamldoc support]\
+\n\
+\n\\newenvironment{ocamldoccode}{%\
+\n  \\bgroup\
+\n  \\leftskip\\@totalleftmargin\
+\n  \\rightskip\\z@skip\
+\n  \\parindent\\z@\
+\n  \\parfillskip\\@flushglue\
+\n  \\parskip\\z@skip\
+\n  %\\noindent\
+\n  \\@@par\\smallskip\
+\n  \\@tempswafalse\
+\n  \\def\\par{%\
+\n    \\if@tempswa\
+\n      \\leavevmode\\null\\@@par\\penalty\\interlinepenalty\
+\n  \\else\
+\n    \\@tempswatrue\
+\n    \\ifhmode\\@@par\\penalty\\interlinepenalty\\fi\
+\n  \\fi}\
+\n  \\obeylines\
+\n  \\verbatim@font\
+\n  \\let\\org@prime~%\
+\n  \\@noligs\
+\n  \\let\\org@dospecials\\dospecials\
+\n  \\g@remfrom@specials{\\\\}\
+\n  \\g@remfrom@specials{\\{}\
+\n  \\g@remfrom@specials{\\}}\
+\n  \\let\\do\\@makeother\
+\n  \\dospecials\
+\n  \\let\\dospecials\\org@dospecials\
+\n  \\frenchspacing\\@vobeyspaces\
+\n  \\everypar \\expandafter{\\the\\everypar \\unpenalty}}\
+\n{\\egroup\\par}\
+\n\
+\n\\def\\g@remfrom@specials#1{%\
+\n  \\def\\@new@specials{}\
+\n  \\def\\@remove##1{%\
+\n    \\ifx##1#1\\else\
+\n    \\g@addto@macro\\@new@specials{\\do ##1}\\fi}\
+\n  \\let\\do\\@remove\\dospecials\
+\n  \\let\\dospecials\\@new@specials\
+\n  }\
+\n\
+\n\\newenvironment{ocamldocdescription}\
+\n{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax\\ignorespaces}\
+\n{\\endlist\\medskip}\
+\n\
+\n\\newenvironment{ocamldoccomment}\
+\n{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax}\
+\n{\\endlist}\
+\n\
+\n\\let \\ocamldocparagraph \\paragraph\
+\n\\def \\paragraph #1{\\ocamldocparagraph {#1}\\noindent}\
+\n\\let \\ocamldocsubparagraph \\subparagraph\
+\n\\def \\subparagraph #1{\\ocamldocsubparagraph {#1}\\noindent}\
+\n\
+\n\\let\\ocamldocvspace\\vspace\
+\n\
+\n\\newenvironment{ocamldocindent}{\\list{}{}\\item\\relax}{\\endlist}\
+\n\\newenvironment{ocamldocsigend}\
+\n     {\\noindent\\quad\\texttt{sig}\\ocamldocindent}\
+\n     {\\endocamldocindent\\vskip -\\lastskip\
+\n      \\noindent\\quad\\texttt{end}\\medskip}\
+\n\\newenvironment{ocamldocobjectend}\
+\n     {\\noindent\\quad\\texttt{object}\\ocamldocindent}\
+\n     {\\endocamldocindent\\vskip -\\lastskip\
+\n      \\noindent\\quad\\texttt{end}\\medskip}\
+\n\
+\n\\endinput\
+\n"
diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll
new file mode 100644
index 00000000..8749d123
--- /dev/null
+++ b/ocamldoc/odoc_lexer.mll
@@ -0,0 +1,422 @@
+{
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The lexer for special comments. *)
+
+open Lexing
+open Odoc_parser
+
+let line_number = ref 0
+
+
+let string_buffer = Buffer.create 32
+
+(** Reset the buffer *)
+let reset_string_buffer () = Buffer.reset string_buffer
+
+(** Add a character to the buffer *)
+let add_char_string = Buffer.add_char string_buffer
+
+(** Add a string to the buffer. *)
+let add_string = Buffer.add_string string_buffer
+
+let read_string () = Buffer.contents string_buffer
+
+(** The variable which will contain the description string.
+   Is initialized when we encounter the start of a special comment. *)
+let description = ref ""
+
+let blank = "[ \013\009\012]"
+
+(** The nested comments level. *)
+let comments_level = ref 0
+
+let print_DEBUG2 s = print_string s; print_newline ()
+
+(** This function returns the given string without the leading and trailing blanks.*)
+let remove_blanks s =
+  print_DEBUG2 ("remove_blanks "^s);
+  let l = Str.split_delim (Str.regexp "\n") s in
+  let l2 =
+    let rec iter liste =
+      match liste with
+        h :: q ->
+          let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in
+          if h2 = "" then
+            (
+             print_DEBUG2 (h^" n'a que des blancs");
+             (* we remove this line and must remove leading blanks of the next one *)
+             iter q
+            )
+          else
+            (* we don't remove leading blanks in the remaining lines *)
+            h2 :: q
+      | _ ->
+          []
+    in iter l
+  in
+  let l3 =
+    let rec iter liste =
+      match liste with
+        h :: q ->
+          let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in
+          if h2 = "" then
+            (
+             print_DEBUG2 (h^" n'a que des blancs");
+             (* we remove this line and must remove trailing blanks of the next one *)
+             iter q
+            )
+          else
+            (* we don't remove trailing blanks in the remaining lines *)
+            h2 :: q
+      | _ ->
+          []
+    in
+    List.rev (iter (List.rev l2))
+  in
+  String.concat "\n" l3
+
+(** Remove first blank characters of each line of a string, until the first '*' *)
+let remove_stars s =
+  Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s
+}
+
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+
+rule main = parse
+    [' ' '\013' '\009' '\012'] +
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        main lexbuf
+      }
+
+  | [ '\010' ]
+      {
+        incr line_number;
+        incr Odoc_comments_global.nb_chars;
+        main lexbuf
+      }
+  | "(**)"
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        Description ("", None)
+      }
+
+  | "(**"("*"+)")"
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        main lexbuf
+      }
+
+  | "(***"
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        incr comments_level;
+        main lexbuf
+      }
+
+  | "(**"
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        incr comments_level;
+        if !comments_level = 1 then
+          (
+           reset_string_buffer ();
+           description := "";
+           special_comment lexbuf
+          )
+        else
+          main lexbuf
+      }
+
+  | eof
+      { EOF }
+
+  |  "*)"
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        decr comments_level ;
+        main lexbuf
+      }
+
+  |  "(*"
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        incr comments_level ;
+        main lexbuf
+      }
+
+  | _
+      {
+        incr Odoc_comments_global.nb_chars;
+        main lexbuf
+      }
+
+and special_comment = parse
+  | "*)"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        if !comments_level = 1 then
+          (
+           (* there is just a description *)
+           let s2 = read_string () in
+           let s3 = remove_blanks s2 in
+           let s4 =
+             if !Odoc_global.remove_stars then
+               remove_stars s3
+             else
+               s3
+           in
+           Description (s4, None)
+          )
+        else
+          (
+           add_string s;
+           decr comments_level;
+           special_comment lexbuf
+          )
+      }
+
+  |  "(*"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        incr comments_level ;
+        add_string s;
+        special_comment lexbuf
+      }
+
+  | "\\@"
+      {
+        let s = Lexing.lexeme lexbuf in
+        let c = (Lexing.lexeme_char lexbuf 1) in
+        add_char_string c;
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        special_comment lexbuf
+      }
+
+  | "@"lowercase+
+      {
+        (* we keep the description before we go further *)
+        let s = read_string () in
+        description := remove_blanks s;
+        reset_string_buffer ();
+        let len = String.length (Lexing.lexeme lexbuf) in
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len;
+        lexbuf.Lexing.lex_curr_p <-
+          { lexbuf.Lexing.lex_curr_p with
+            pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len
+          } ;
+        (* we don't increment the Odoc_comments_global.nb_chars *)
+        special_comment_part2 lexbuf
+      }
+
+  | _
+      {
+        let c = (Lexing.lexeme_char lexbuf 0) in
+        add_char_string c;
+        if c = '\010' then incr line_number;
+        incr Odoc_comments_global.nb_chars;
+        special_comment lexbuf
+      }
+
+and special_comment_part2 = parse
+  | "*)"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        if !comments_level = 1 then
+          (* finally we return the description we kept *)
+          let desc =
+            if !Odoc_global.remove_stars then
+              remove_stars !description
+             else
+              !description
+          in
+          let remain = read_string () in
+          let remain2 =
+            if !Odoc_global.remove_stars then
+              remove_stars remain
+             else
+               remain
+          in
+          Description (desc, Some remain2)
+        else
+          (
+           add_string s ;
+           decr comments_level ;
+           special_comment_part2 lexbuf
+          )
+      }
+
+  |  "(*"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        add_string s;
+        incr comments_level ;
+        special_comment_part2 lexbuf
+      }
+
+  | _
+      {
+        let c = (Lexing.lexeme_char lexbuf 0) in
+        add_char_string c;
+        if c = '\010' then incr line_number;
+        incr Odoc_comments_global.nb_chars;
+        special_comment_part2 lexbuf
+      }
+
+and elements = parse
+  | [' ' '\013' '\009' '\012'] +
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        elements lexbuf
+      }
+
+  | [ '\010' ]
+      { incr line_number;
+        incr Odoc_comments_global.nb_chars;
+        print_DEBUG2 "newline";
+        elements lexbuf }
+  | "@"
+      {
+        raise (Failure (Odoc_messages.should_escape_at_sign))
+      }
+
+  | "@"lowercase+
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        let s2 = String.sub s 1 ((String.length s) - 1) in
+        print_DEBUG2 s2;
+        match s2 with
+          "param" ->
+            T_PARAM
+         | "author" ->
+            T_AUTHOR
+         | "version" ->
+             T_VERSION
+         | "see" ->
+             T_SEE
+         | "since" ->
+             T_SINCE
+         | "before" ->
+             T_BEFORE
+         | "deprecated" ->
+             T_DEPRECATED
+         | "raise" ->
+             T_RAISES
+         | "return" ->
+             T_RETURN
+         | s ->
+             if !Odoc_global.no_custom_tags then
+               raise (Failure (Odoc_messages.not_a_valid_tag s))
+             else
+               T_CUSTOM s
+      }
+
+  | ("\\@" | [^'@'])+
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        let s = Lexing.lexeme lexbuf in
+        let s = Str.global_replace (Str.regexp_string "\\@") "@" s in
+        let s = remove_blanks s in
+        print_DEBUG2 ("Desc "^s);
+        Desc s
+      }
+  | eof
+      {
+        EOF
+      }
+  | _ {
+        let s = Lexing.lexeme lexbuf in
+        failwith ("Unexpected character '"^s^"'")
+      }
+
+
+and simple = parse
+    [' ' '\013' '\009' '\012'] +
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        simple lexbuf
+      }
+
+  | [ '\010' ]
+      { incr line_number;
+        incr Odoc_comments_global.nb_chars;
+        simple lexbuf
+      }
+
+  | "(**"("*"+)
+      {
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf));
+        incr comments_level;
+        simple lexbuf
+      }
+
+  | "(*"("*"+)")"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        simple lexbuf
+      }
+  | "(**"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        incr comments_level;
+        simple lexbuf
+      }
+
+  | "(*"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        incr comments_level;
+        if !comments_level = 1 then
+          (
+           reset_string_buffer ();
+           description := "";
+           special_comment lexbuf
+          )
+        else
+          (
+           add_string s;
+           simple lexbuf
+          )
+      }
+
+  | eof
+      { EOF }
+
+  |  "*)"
+      {
+        let s = Lexing.lexeme lexbuf in
+        Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
+        decr comments_level ;
+        simple lexbuf
+      }
+
+  | _
+      {
+        incr Odoc_comments_global.nb_chars;
+        simple lexbuf
+      }
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
new file mode 100644
index 00000000..a640d767
--- /dev/null
+++ b/ocamldoc/odoc_man.ml
@@ -0,0 +1,1315 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The man pages generator. *)
+open Odoc_info
+open Value
+open Type
+open Extension
+open Exception
+open Class
+open Module
+open Search
+
+let man_suffix = ref Odoc_messages.default_man_suffix
+let man_section = ref Odoc_messages.default_man_section
+
+let man_mini = ref false
+
+let new_buf () = Buffer.create 1024
+let bp = Printf.bprintf
+let bs = Buffer.add_string
+
+let linebreak = "\n.sp\n";;
+
+(** A class used to get a [text] for info structures. *)
+class virtual info =
+  object (self)
+    (** The list of pairs [(tag, f)] where [f] is a function taking
+       the [text] associated to [tag] and returning man code.
+       Add a pair here to handle a tag.*)
+    val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list)
+
+    (** Return man code for a [text]. *)
+    method virtual man_of_text : Buffer.t -> Odoc_info.text -> unit
+
+    method str_man_of_text t =
+      let b = Buffer.create 256 in
+      self#man_of_text b t ;
+      Buffer.contents b
+
+    (** Print groff string for an author list. *)
+    method str_man_of_author_list l =
+      match l with
+        [] -> ""
+      | _ ->
+          let b = Buffer.create 256 in
+          bs b ".B \"";
+          bs b Odoc_messages.authors;
+          bs b "\"\n:\n";
+          bs b (String.concat ", " l);
+          bs b "\n";
+          (*bs b "\n.sp\n"*)
+          Buffer.contents b
+
+    (** Print groff string for the given optional version information.*)
+    method str_man_of_version_opt v_opt =
+      match v_opt with
+        None -> ""
+      | Some v ->
+          let b = Buffer.create 256 in
+          bs b ".B \"";
+          bs b Odoc_messages.version;
+          bs b "\"\n:\n";
+          bs b v;
+          bs b "\n";
+          (*".sp\n"*)
+          Buffer.contents b
+
+    (** Printf groff string for the \@before information. *)
+    method str_man_of_before = function
+      [] -> ""
+    | l ->
+        let b = Buffer.create 256 in
+        let rec iter = function
+          [] -> ()
+        | (v, text) :: q ->
+             bp b ".B \"%s" Odoc_messages.before;
+             bs b v;
+             bs b "\"\n";
+             self#man_of_text b text;
+             bs b "\n";
+             bs b "\n";
+             match q with
+               [] -> ()
+             | _ -> bs b linebreak ; iter q
+        in
+        iter l;
+        Buffer.contents b
+
+    (** Print groff string for the given optional since information.*)
+    method str_man_of_since_opt s_opt =
+      match s_opt with
+        None -> ""
+      | Some s ->
+          let b = Buffer.create 256 in
+          bs b ".B \"";
+          bs b Odoc_messages.since;
+          bs b "\"\n";
+          bs b s;
+          bs b "\n";(*".sp\n"*)
+          Buffer.contents b
+
+    (** Print groff string for the given list of raised exceptions.*)
+    method str_man_of_raised_exceptions l =
+      match l with
+        [] -> ""
+      | _ ->
+          let b = Buffer.create 256 in
+          let rec iter = function
+            [] -> ()
+          | (s, t) :: q ->
+              bs b ".B \"";
+              bs b Odoc_messages.raises;
+              bs b (" "^s^"\"\n");
+              self#man_of_text b t;
+              bs b "\n";
+              match q with
+                [] -> ()
+              | _ -> bs b linebreak; iter q
+          in
+          iter l;
+          Buffer.contents b
+
+    (** Print groff string for the given "see also" reference. *)
+    method str_man_of_see (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#str_man_of_text t_ref
+
+    (** Print groff string for the given list of "see also" references.*)
+    method str_man_of_sees l =
+      match l with
+        [] -> ""
+      | _ ->
+          let b = Buffer.create 256 in
+          let rec iter = function
+            [] -> ()
+          | see :: q ->
+              bs b ".B \"";
+              bs b Odoc_messages.see_also;
+              bs b "\"\n";
+              bs b (self#str_man_of_see see);
+              bs b "\n";
+              match q with
+                [] -> ()
+              | _ -> bs b linebreak; iter q
+          in
+          iter l;
+          Buffer.contents b
+
+    (** Print groff string for the given optional return information.*)
+    method str_man_of_return_opt return_opt =
+      match return_opt with
+        None -> ""
+      | Some s ->
+          let b = Buffer.create 256 in
+          bs b ".B ";
+          bs b Odoc_messages.returns;
+          bs b "\n";
+          self#man_of_text b s;
+          bs b "\n";
+          Buffer.contents b
+
+    (** Print man code for the given list of custom tagged texts. *)
+    method str_man_of_custom l =
+      List.fold_left
+        (fun acc (tag, text) ->
+           try
+             let f = List.assoc tag tag_functions in
+             let buf = Buffer.create 50 in
+             Buffer.add_string buf (f text);
+             (Buffer.contents buf) :: acc
+          with
+            Not_found ->
+              Odoc_info.warning (Odoc_messages.tag_not_handled tag);
+              acc
+        )
+        [] l
+
+    (** Print the groff string to display an optional info structure. *)
+    method man_of_info ?margin:(_ :int option) b info_opt =
+        match info_opt with
+        None -> ()
+      | Some info ->
+          let module M = Odoc_info in
+          let l =
+            (
+           match info.M.i_deprecated with
+             None -> []
+           | Some d ->
+               let b = Buffer.create 256 in
+               bs b ".B \"";
+               bs b Odoc_messages.deprecated;
+               bs b "\"\n";
+               self#man_of_text b d;
+               bs b "\n";
+               [ Buffer.contents b ]
+            ) @
+              (
+               match info.M.i_desc with
+                 None -> []
+               | Some d when d = [Odoc_info.Raw ""] -> []
+               | Some d ->
+                   [ (self#str_man_of_text d)^"\n" ]
+              ) @
+              [
+                self#str_man_of_author_list info.M.i_authors;
+                self#str_man_of_version_opt info.M.i_version;
+                self#str_man_of_before info.M.i_before;
+                self#str_man_of_since_opt info.M.i_since;
+                self#str_man_of_raised_exceptions info.M.i_raised_exceptions;
+                self#str_man_of_return_opt info.M.i_return_value;
+                self#str_man_of_sees info.M.i_sees;
+              ] @
+                (self#str_man_of_custom info.M.i_custom)
+          in
+          let l = List.filter ((<>) "") l in
+          Buffer.add_string b (String.concat "\n.sp\n" l)
+  end
+
+module Generator =
+struct
+
+(** This class is used to create objects which can generate a simple html documentation. *)
+class man =
+  let re_slash = Str.regexp_string "/" in
+  object (self)
+    inherit info
+
+    (** Get a file name from a complete name. *)
+    method file_name name =
+      let s = Printf.sprintf "%s.%s" name !man_suffix in
+      Str.global_replace re_slash "slash" s
+
+    (** Escape special sequences of characters in a string. *)
+    method escape (s : string) =
+      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 "\\(rs"
+        | '.' -> Buffer.add_string b "\\&."
+        | '\'' -> Buffer.add_string b "\\&'"
+        | '-' -> Buffer.add_string b "\\-"
+        | c -> Buffer.add_char b c
+      done;
+      Buffer.contents b
+
+    (** Open a file for output. Add the target directory.*)
+    method open_out file =
+      let f = Filename.concat !Global.target_dir file in
+      open_out f
+
+    (** 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
+      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
+
+    (** Print the groff string for a text element. *)
+    method man_of_text_element b txt =
+      match txt with
+      | Odoc_info.Raw s -> bs b (self#escape s)
+      | Odoc_info.Code s ->
+          bs b "\n.B ";
+          bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
+      | Odoc_info.CodePre 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 b t
+      | Odoc_info.List tl ->
+          List.iter
+            (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n")
+            tl;
+          bs b "\n"
+      | Odoc_info.Enum tl ->
+          List.iter
+            (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n")
+            tl;
+          bs b "\n"
+      | Odoc_info.Newline ->
+          bs b "\n.sp\n"
+      | Odoc_info.Block t ->
+          bs b "\n.sp\n";
+          self#man_of_text2 b t;
+          bs b "\n.sp\n"
+      | Odoc_info.Title (_, _, 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 (_, t) ->
+          self#man_of_text2 b t
+      | Odoc_info.Ref (name, _, _) ->
+          self#man_of_text_element b
+            (Odoc_info.Code (Odoc_info.use_hidden_modules name))
+      | Odoc_info.Superscript t ->
+          bs b "^{"; self#man_of_text2 b t
+      | Odoc_info.Subscript t ->
+          bs b "_{"; self#man_of_text2 b t
+      | Odoc_info.Module_list _ ->
+          ()
+      | Odoc_info.Index_list ->
+          ()
+      | Odoc_info.Custom (s,t) -> self#man_of_custom_text b s t
+      | Odoc_info.Target (target, code) -> self#man_of_Target b ~target ~code
+
+    method man_of_custom_text _ _ _ = ()
+
+    method man_of_Target b ~target ~code =
+      if String.lowercase_ascii target = "man" then bs b code else ()
+
+    (** 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.*)
+    method relative_idents m_name s =
+      let f str_t =
+        let match_s = Str.matched_string str_t in
+        Odoc_info.apply_if_equal
+          Odoc_info.use_hidden_modules
+          match_s
+          (Name.get_relative m_name match_s)
+      in
+      Str.global_substitute
+        (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)")
+        f
+        s
+
+    (** 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_print.string_of_type_expr t))
+      in
+      let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
+
+    (** 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_print.string_of_class_type t))
+      in
+      let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
+
+    (** Print groff string to display a [Types.type_expr list].*)
+    method man_of_cstr_args ?par b m_name sep l =
+        match l with
+        | Cstr_tuple 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
+            bs b "\n.B ";
+            bs b (self#relative_idents m_name s2);
+            bs b "\n"
+        | Cstr_record l ->
+            self#man_of_record m_name b l
+
+    (** 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
+        [] -> ()
+      | _ ->
+          let s = Odoc_str.string_of_type_param_list t in
+          let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+          bs b "\n.B ";
+          bs b (self#relative_idents m_name s2);
+          bs b "\n"
+
+    (** 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_print.string_of_module_type t))
+      in
+      let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
+
+    (** Print groff string code for a value. *)
+    method man_of_value b v =
+      Odoc_info.reset_type_names () ;
+      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 a type extension. *)
+    method man_of_type_extension b m_name te =
+      Odoc_info.reset_type_names () ;
+      bs b ".I type ";
+      (
+        match te.te_type_parameters with
+            [] -> ()
+          | _ ->
+              let s = Odoc_str.string_of_type_extension_param_list te in
+              let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+                bs b "\n.B ";
+                bs b (self#relative_idents m_name s2);
+                bs b "\n";
+                bs b ".I "
+      );
+      bs b (self#relative_idents m_name te.te_type_name);
+      bs b " \n";
+      bs b "+=";
+      if te.te_private = Asttypes.Private then bs b " private";
+      bs b "\n ";
+      List.iter
+        (fun x ->
+           let father = Name.father x.xt_name in
+           bs b ("| "^(Name.simple x.xt_name));
+           (
+             match x.xt_args, x.xt_ret with
+               | Cstr_tuple [], None -> bs b "\n"
+               | l, None ->
+                   bs b "\n.B of ";
+                   self#man_of_cstr_args ~par: false b father " * " l;
+               | Cstr_tuple [], Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr b father r;
+               | l, Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_cstr_args ~par: false b father " * " l;
+                   bs b ".B -> ";
+                   self#man_of_type_expr b father r;
+           );
+           (
+             match x.xt_alias with
+                 None -> ()
+               | Some xa ->
+                   bs b ".B = ";
+                   bs b
+                     (
+                       match xa.xa_xt with
+                           None -> xa.xa_name
+                         | Some x -> x.xt_name
+                     );
+                   bs b "\n"
+           );
+           (
+             match x.xt_text with
+                 None ->
+                   bs b " "
+               | Some t ->
+                   bs b ".I \"  \"\n";
+                   bs b "(* ";
+                   self#man_of_info b (Some t);
+                   bs b " *)\n "
+           )
+        )
+        te.te_constructors;
+      bs b "\n.sp\n";
+      self#man_of_info b te.te_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string code for an exception. *)
+    method man_of_exception b e =
+      Odoc_info.reset_type_names () ;
+      bs b "\n.I exception ";
+      bs b (Name.simple e.ex_name);
+      bs b " \n";
+      (
+        match e.ex_args, e.ex_ret with
+        | Cstr_tuple [], None -> ()
+        | _, None ->
+           bs b ".B of ";
+           self#man_of_cstr_args
+             ~par: false
+             b (Name.father e.ex_name) " * " e.ex_args
+        | Cstr_tuple [], Some r ->
+            bs b ".B : ";
+            self#man_of_type_expr b (Name.father e.ex_name) r
+        | l, Some r ->
+            bs b ".B : ";
+            self#man_of_cstr_args
+                   ~par: false
+                   b (Name.father e.ex_name) " * " l;
+            bs b ".B -> ";
+            self#man_of_type_expr b (Name.father e.ex_name) r
+      );
+      (
+       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"
+
+
+    method field_comment b = function
+      | None -> ()
+      | Some t ->
+          bs b "  (* ";
+          self#man_of_info b (Some t);
+          bs b " *) "
+
+    (** Print groff string for a record type *)
+    method man_of_record father b l =
+          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 ";";
+             self#field_comment b r.rf_text ;
+           ) l;
+          bs b "\n }\n"
+
+
+    (** 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
+      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";
+      let priv = t.ty_private = Asttypes.Private in
+      (
+       match t.ty_manifest with
+         None -> ()
+       | Some (Object_type l) ->
+          bs b "= ";
+          if priv then bs b "private ";
+          bs b "<";
+          List.iter (fun r ->
+            bs b (r.of_name^" : ");
+            self#man_of_type_expr b father r.of_type;
+            bs b ";";
+            self#field_comment b r.of_text ;
+          ) l;
+          bs b "\n >\n"
+       | Some (Other typ) ->
+           bs b "= ";
+           if priv then bs b "private ";
+           self#man_of_type_expr b father typ
+      );
+      (
+       match t.ty_kind with
+        Type_abstract -> ()
+      | Type_variant l ->
+         bs b "=";
+         if priv then bs b " private";
+         bs b "\n ";
+         List.iter (fun constr ->
+           bs b ("| "^constr.vc_name);
+           let print_text t =
+             bs b "  (* ";
+             self#man_of_info b (Some t);
+             bs b " *)\n "
+           in
+           match constr.vc_args, constr.vc_text,constr.vc_ret with
+           | Cstr_tuple [], None, None -> bs b "\n "
+           | Cstr_tuple [], (Some t), None ->
+             print_text t
+           | l, None, None ->
+             bs b "\n.B of ";
+             self#man_of_cstr_args ~par: false b father " * " l;
+             bs b " "
+           | l, (Some t), None ->
+             bs b "\n.B of ";
+             self#man_of_cstr_args ~par: false b father " * " l;
+             bs b ".I \"  \"\n";
+             print_text t
+           | Cstr_tuple [], None, Some r ->
+             bs b "\n.B : ";
+             self#man_of_type_expr b father r;
+             bs b " "
+           | Cstr_tuple [], (Some t), Some r ->
+             bs b "\n.B : ";
+             self#man_of_type_expr b father r;
+             bs b ".I \"  \"\n";
+             print_text t
+           | l, None, Some r ->
+             bs b "\n.B : ";
+             self#man_of_cstr_args ~par: false b father " * " l;
+             bs b ".B -> ";
+             self#man_of_type_expr b father r;
+             bs b " "
+           | l, (Some t), Some r ->
+             bs b "\n.B of ";
+             self#man_of_cstr_args ~par: false b father " * " l;
+             bs b ".B -> ";
+             self#man_of_type_expr b father r;
+             bs b ".I \"  \"\n";
+             print_text t
+         ) l
+
+      | Type_record l ->
+          bs b "= ";
+          if priv then bs b "private ";
+          self#man_of_record father b l
+      | Type_open ->
+          bs b "= ..";
+          bs b "\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_virtual then bs b ("virtual ");
+      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 b m_name l =
+      match l with
+        [] -> ()
+      | _ ->
+          bs b "\n.B ";
+          bs b Odoc_messages.parameters;
+          bs b ": \n";
+          List.iter
+            (fun p ->
+              bs b ".sp\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 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 -> bs b "\n "; self#man_of_text b t
+          )
+      | l ->
+          (*  A list of names, we display those with a description. *)
+          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
+
+    (** Print groff string for a list of module parameters. *)
+    method man_of_module_parameter_list b m_name l =
+      match l with
+        [] -> ()
+      | _ ->
+          bs b ".B \"";
+          bs b Odoc_messages.parameters;
+          bs b ":\"\n";
+          List.iter
+            (fun (p, desc_opt) ->
+              bs b ".sp\n";
+              bs b ("\""^p.mp_name^"\"\n");
+              Misc.may (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"
+
+    (** 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
+      bs b  ".I class ";
+      if c.cl_virtual then bs b "virtual ";
+      (
+       match c.cl_type_parameters with
+         [] -> ()
+       | l ->
+           bs b (Odoc_str.string_of_class_type_param_list l);
+           bs b " "
+      );
+      bs b (Name.simple c.cl_name);
+      bs b " : " ;
+      self#man_of_class_type_expr b father 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 () ;
+      bs b ".I class type ";
+      if ct.clt_virtual then bs b "virtual " ;
+      (
+       match ct.clt_type_parameters with
+        [] -> ()
+      | l ->
+          bs b (Odoc_str.string_of_class_type_param_list l);
+          bs b " "
+      );
+      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 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"
+
+    method man_of_recfield b modname f =
+      bs b ".I ";
+      if f.rf_mutable then bs b (Odoc_messages.mutab^" ");
+      bs b (f.rf_name^" : ");
+      self#man_of_type_expr b modname f.rf_type;
+      bs b "\n.sp\n";
+      self#man_of_info b f.rf_text;
+      bs b "\n.sp\n"
+
+    method man_of_const b modname c =
+      bs b ".I ";
+      bs b (c.vc_name^" ");
+      (match c.vc_args with
+       | Cstr_tuple [] -> ()
+       | Cstr_tuple (h::q) ->
+         bs b "of ";
+         self#man_of_type_expr b modname h;
+         List.iter
+           (fun ty ->
+              bs b " * ";
+              self#man_of_type_expr b modname ty)
+            q
+       | Cstr_record r -> self#man_of_record c.vc_name b r
+      );
+      bs b "\n.sp\n";
+      self#man_of_info b c.vc_text;
+      bs b "\n.sp\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 -> bs b im.im_name
+       | Some mmt ->
+           let name =
+             match mmt with
+               Mod m -> m.m_name
+             | Modtype mt -> mt.mt_name
+           in
+           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 =
+      Odoc_info.reset_type_names () ;
+      let file = self#file_name cl.cl_name in
+      try
+        let chanout = self#open_out file in
+        let b = new_buf () in
+        bs b (".TH \""^cl.cl_name^"\" ");
+        bs b !man_section ;
+        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
+
+        let abstract =
+          match cl.cl_info with
+            None | Some { i_desc = None } -> "no description"
+          | Some { i_desc = Some t } ->
+              let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+              self#remove_newlines s
+        in
+
+        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 *)
+        self#man_of_parameter_list b "" cl.cl_parameters;
+        (* a large blank *)
+        bs b  "\n.sp\n.sp\n";
+
+(*
+        (* class inheritance *)
+        self#generate_class_inheritance_info chanout cl;
+*)
+        (* the various elements *)
+        List.iter
+          (fun element ->
+            match element with
+              Class_attribute a ->
+                self#man_of_attribute b a
+            | Class_method m ->
+                self#man_of_method b m
+            | 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 ->
+          incr Odoc_info.errors ;
+          prerr_endline s
+
+    (** Generate the man page for the given class type.*)
+    method generate_for_class_type ct =
+      Odoc_info.reset_type_names () ;
+      let file = self#file_name ct.clt_name in
+      try
+        let chanout = self#open_out file in
+        let b = new_buf () in
+        bs b (".TH \""^ct.clt_name^"\" ");
+        bs b !man_section ;
+        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
+
+        let abstract =
+          match ct.clt_info with
+            None | Some { i_desc = None } -> "no description"
+          | Some { i_desc = Some t } ->
+              let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+              self#remove_newlines s
+        in
+
+        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 *)
+        bs b "\n.sp\n.sp\n";
+(*
+        (* class inheritance *)
+        self#generate_class_inheritance_info chanout cl;
+*)
+        (* the various elements *)
+        List.iter
+          (fun element ->
+            match element with
+              Class_attribute a ->
+                self#man_of_attribute b a
+            | Class_method m ->
+                self#man_of_method b m
+            | 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 ->
+          incr Odoc_info.errors ;
+          prerr_endline s
+
+    method man_of_module_type_body b mt =
+      self#man_of_info b mt.mt_info;
+      bs b "\n.sp\n";
+
+      (* parameters for functors *)
+      self#man_of_module_parameter_list b "" (Module.module_type_parameters mt);
+      (* a large blank *)
+      bs b "\n.sp\n.sp\n";
+
+      (* module elements *)
+      List.iter
+        (fun ele ->
+          match ele with
+            Element_module m ->
+              self#man_of_module b m
+          | Element_module_type mt ->
+              self#man_of_modtype b mt
+          | Element_included_module im ->
+              self#man_of_included_module b mt.mt_name im
+          | Element_class c ->
+              self#man_of_class b c
+          | Element_class_type ct ->
+              self#man_of_class_type b ct
+          | Element_value v ->
+              self#man_of_value b v
+          | Element_type_extension te ->
+              self#man_of_type_extension b mt.mt_name te
+          | Element_exception e ->
+              self#man_of_exception b e
+          | Element_type t ->
+              self#man_of_type b t
+          | Element_module_comment text ->
+              self#man_of_module_comment b text
+        )
+        (Module.module_type_elements mt);
+
+    (** Generate the man file for the given module type.
+       @raise Failure if an error occurs.*)
+    method generate_for_module_type mt =
+      let file = self#file_name mt.mt_name in
+      try
+        let chanout = self#open_out file in
+        let b = new_buf () in
+        bs b (".TH \""^mt.mt_name^"\" ");
+        bs b !man_section ;
+        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
+
+        let abstract =
+          match mt.mt_info with
+            None | Some { i_desc = None } -> "no description"
+          | Some { i_desc = Some t } ->
+              let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+              self#remove_newlines s
+        in
+        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_module_type_body b mt;
+
+        Buffer.output_buffer chanout b;
+        close_out chanout
+
+      with
+        Sys_error s ->
+          incr Odoc_info.errors ;
+          prerr_endline s
+
+    method man_of_module_body b m =
+      self#man_of_info b m.m_info;
+      bs b "\n.sp\n";
+
+      (* parameters for functors *)
+      self#man_of_module_parameter_list b "" (Module.module_parameters m);
+      (* a large blank *)
+      bs b "\n.sp\n.sp\n";
+
+      (* module elements *)
+      List.iter
+        (fun ele ->
+          match ele with
+            Element_module m ->
+              self#man_of_module b m
+          | Element_module_type mt ->
+              self#man_of_modtype b mt
+          | Element_included_module im ->
+              self#man_of_included_module b m.m_name im
+          | Element_class c ->
+              self#man_of_class b c
+          | Element_class_type ct ->
+              self#man_of_class_type b ct
+          | Element_value v ->
+              self#man_of_value b v
+          | Element_type_extension te ->
+              self#man_of_type_extension b m.m_name te
+          | Element_exception e ->
+              self#man_of_exception b e
+          | Element_type t ->
+              self#man_of_type b t
+          | Element_module_comment text ->
+              self#man_of_module_comment b text
+        )
+        (Module.module_elements m);
+
+    (** Generate the man file for the given module.
+       @raise Failure if an error occurs.*)
+    method generate_for_module m =
+      let file = self#file_name m.m_name in
+      try
+        let chanout = self#open_out file in
+        let b = new_buf () in
+        bs b (".TH \""^m.m_name^"\" ");
+        bs b !man_section ;
+        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
+
+        let abstract =
+          match m.m_info with
+            None | Some { i_desc = None } -> "no description"
+          | Some { i_desc = Some t } ->
+              let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
+              self#remove_newlines s
+        in
+
+        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_module_body b m;
+        Buffer.output_buffer chanout b;
+        close_out chanout
+
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Create the groups of elements to generate pages for. *)
+    method create_groups mini module_list =
+      let name res_ele =
+        match res_ele with
+          Res_module m -> m.m_name
+        | Res_module_type mt -> mt.mt_name
+        | Res_class c -> c.cl_name
+        | Res_class_type ct -> ct.clt_name
+        | Res_value v -> Name.simple v.val_name
+        | Res_type t -> Name.simple t.ty_name
+        | Res_extension x -> Name.simple x.xt_name
+        | Res_exception e -> Name.simple e.ex_name
+        | Res_attribute a -> Name.simple a.att_value.val_name
+        | Res_method m -> Name.simple m.met_value.val_name
+        | Res_section _ -> assert false
+        | Res_recfield (_,f) -> f.rf_name
+        | Res_const (_,f) -> f.vc_name
+      in
+      let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*")  in
+      let all_items = List.filter
+          (fun r ->
+             match r with
+               Res_section _ -> false
+             | Res_module _ | Res_module_type _
+             | Res_class _ | Res_class_type _ -> true
+             | _ -> not mini
+          )
+          all_items_pre
+      in
+      let sorted_items = List.sort (fun e1 -> fun e2 -> compare (name e1) (name e2)) all_items in
+      let rec f acc1 acc2 l =
+        match l with
+          [] -> acc2 :: acc1
+        | h :: q ->
+            match acc2 with
+              [] -> f acc1 [h] q
+            | h2 :: _ ->
+                if (name h) = (name h2) then
+                  if List.mem h acc2 then
+                    f acc1 acc2 q
+                  else
+                    f acc1 (acc2 @ [h]) q
+                else
+                  f (acc2 :: acc1) [h] q
+      in
+      f [] [] sorted_items
+
+    (** Generate a man page for a group of elements with the same name.
+       A group must not be empty.*)
+    method generate_for_group l =
+     let name =
+       Name.simple
+         (
+          match List.hd l with
+            Res_module m -> m.m_name
+          | Res_module_type mt -> mt.mt_name
+          | Res_class c -> c.cl_name
+          | Res_class_type ct -> ct.clt_name
+          | Res_value v -> v.val_name
+          | Res_type t -> t.ty_name
+          | Res_extension x -> x.xt_name
+          | Res_exception e -> e.ex_name
+          | Res_attribute a -> a.att_value.val_name
+          | Res_method m -> m.met_value.val_name
+          | Res_section (s,_) -> s
+          | Res_recfield (_,f) -> f.rf_name
+          | Res_const (_,f) -> f.vc_name
+         )
+     in
+      let file = self#file_name name in
+      try
+        let chanout = self#open_out file in
+        let b = new_buf () in
+        bs b (".TH \""^name^"\" ");
+        bs b !man_section ;
+        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Global.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 ->
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n");
+              self#man_of_value b v
+          | Res_type t ->
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n");
+              self#man_of_type b t
+          | Res_extension x ->
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father x.xt_name)^"\n");
+              self#man_of_type_extension b (Name.father x.xt_name) x.xt_type_extension
+          | Res_exception e ->
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n");
+              self#man_of_exception b e
+          | Res_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 ->
+              bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n");
+              self#man_of_method b m
+          | Res_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 ->
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n");
+              self#man_of_class_type b ct
+          | Res_recfield (ty,f) ->
+               bs b ("\n.SH Type "^(ty.ty_name)^"\n");
+              self#man_of_recfield b (Name.father ty.ty_name) f
+          | Res_const (ty,c) ->
+               bs b ("\n.SH Type "^(ty.ty_name)^"\n");
+              self#man_of_const b (Name.father ty.ty_name) c
+          | Res_module m ->
+              if Name.father m.m_name <> "" then
+                begin
+                  bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father m.m_name)^"\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;
+                end
+              else
+                begin
+                  bs b ("\n.SH "^Odoc_messages.modul^" "^m.m_name^"\n");
+                  bs b " : ";
+                  self#man_of_module_type b (Name.father m.m_name) m.m_type;
+                end;
+              bs b "\n.sp\n";
+              self#man_of_module_body b m
+
+          | Res_module_type mt ->
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father mt.mt_name)^"\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_module_type_body b mt
+
+          | Res_section _ ->
+              (* normaly, we cannot have modules here. *)
+              ()
+        in
+        List.iter f l;
+        Buffer.output_buffer chanout b;
+        close_out chanout
+      with
+        Sys_error s ->
+          incr Odoc_info.errors ;
+          prerr_endline s
+
+    (** Generate all the man pages from a module list. *)
+    method generate module_list =
+      let sorted_module_list = List.sort (fun m1 m2 -> compare m1.m_name m2.m_name) module_list in
+      let groups = self#create_groups !man_mini sorted_module_list in
+      let f group =
+        match group with
+          [] ->
+            ()
+        | [Res_module m] -> self#generate_for_module m
+        | [Res_module_type mt] -> self#generate_for_module_type mt
+        | [Res_class cl] -> self#generate_for_class cl
+        | [Res_class_type ct] -> self#generate_for_class_type ct
+        | l -> self#generate_for_group l
+      in
+      List.iter f groups
+  end
+end
+
+module type Man_generator = module type of Generator
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
new file mode 100644
index 00000000..4f1bbff7
--- /dev/null
+++ b/ocamldoc/odoc_merge.ml
@@ -0,0 +1,1086 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Merge of information from [.ml] and [.mli] for a module.*)
+
+open Odoc_types
+open Odoc_parameter
+open Odoc_value
+open Odoc_type
+open Odoc_extension
+open Odoc_exception
+open Odoc_class
+open Odoc_module
+
+let merge_before_tags l =
+  let rec iter acc = function
+    [] -> List.rev acc
+  | (v, text) :: q ->
+      let (l1, l2) = List.partition
+        (fun (v2,_) -> v = v2) q
+      in
+      let acc =
+        let text =
+          List.fold_left
+            (fun acc t -> acc @ [Raw " "] @ t)
+            text (List.map snd l1)
+        in
+        (v, text) :: acc
+      in
+      iter acc l2
+  in
+  iter [] l
+;;
+
+let version_separators = Str.regexp "[\\.\\+]";;
+
+(** Merge two Odoctypes.info struture, completing the information of
+   the first one with the information in the second one.
+   The merge treatment depends on a given merge_option list.
+   @return the new info structure.*)
+let merge_info merge_options (m1 : info) (m2 : info) =
+  let new_desc_opt =
+    match m1.i_desc, m2.i_desc with
+      None, None -> None
+    | None, Some d
+    | Some d, None -> Some d
+    | Some d1, Some d2 ->
+        if List.mem Merge_description merge_options then
+          Some (d1 @ (Newline :: d2))
+        else
+          Some d1
+  in
+  let new_authors =
+    match m1.i_authors, m2.i_authors with
+      [], [] -> []
+    | l, []
+    | [], l -> l
+    | l1, l2 ->
+        if List.mem Merge_author merge_options then
+          l1 @ l2
+        else
+          l1
+  in
+  let new_version =
+    match m1.i_version , m2.i_version with
+      None, None -> None
+    | Some v, None
+    | None, Some v -> Some v
+    | Some v1, Some v2 ->
+        if List.mem Merge_version merge_options then
+          Some (v1^" "^v2)
+        else
+          Some v1
+  in
+  let new_sees =
+    match m1.i_sees, m2.i_sees with
+      [], [] -> []
+    | l, []
+    | [], l -> l
+    | l1, l2 ->
+        if List.mem Merge_see merge_options then
+          l1 @ l2
+        else
+          l1
+  in
+  let new_since =
+    match m1.i_since, m2.i_since with
+      None, None -> None
+    | Some v, None
+    | None, Some v -> Some v
+    | Some v1, Some v2 ->
+        if List.mem Merge_since merge_options then
+          Some (v1^" "^v2)
+        else
+          Some v1
+  in
+  let new_before =
+    match m1.i_before, m2.i_before with
+      [], [] -> []
+    | l, []
+    | [], l -> l
+    | l1, _ ->
+        if List.mem Merge_before merge_options then
+          merge_before_tags (m1.i_before @ m2.i_before)
+        else
+          l1 in
+  let new_before = List.map (fun (v, t) -> (Str.split version_separators v, v, t)) new_before in
+  let new_before = List.sort Pervasives.compare new_before in
+  let new_before = List.map (fun (_, v, t) -> (v, t)) new_before in
+  let new_dep =
+    match m1.i_deprecated, m2.i_deprecated with
+      None, None -> None
+    | None, Some t
+    | Some t, None -> Some t
+    | Some t1, Some t2 ->
+        if List.mem Merge_deprecated merge_options then
+          Some (t1 @ (Newline :: t2))
+        else
+          Some t1
+  in
+  let new_params =
+    match m1.i_params, m2.i_params with
+      [], [] -> []
+    | l, []
+    | [], l -> l
+    | l1, l2 ->
+        if List.mem Merge_param merge_options then
+          (
+           let l_in_m1_and_m2, l_in_m2_only = List.partition
+               (fun (param2, _) -> List.mem_assoc param2 l1)
+               l2
+           in
+           let rec iter = function
+               [] -> []
+             | (param2, desc2) :: q ->
+                 let desc1 = List.assoc param2 l1 in
+                 (param2, desc1 @ (Newline :: desc2)) :: (iter q)
+           in
+           let l1_completed = iter l_in_m1_and_m2 in
+           l1_completed @ l_in_m2_only
+          )
+        else
+          l1
+  in
+  let new_raised_exceptions =
+    match m1.i_raised_exceptions, m2.i_raised_exceptions with
+      [], [] -> []
+    | l, []
+    | [], l -> l
+    | l1, l2 ->
+        if List.mem Merge_raised_exception merge_options then
+          (
+           let l_in_m1_and_m2, l_in_m2_only = List.partition
+               (fun (exc2, _) -> List.mem_assoc exc2 l1)
+               l2
+           in
+           let rec iter = function
+               [] -> []
+             | (exc2, desc2) :: q ->
+                 let desc1 = List.assoc exc2 l1 in
+                 (exc2, desc1 @ (Newline :: desc2)) :: (iter q)
+           in
+           let l1_completed = iter l_in_m1_and_m2 in
+           l1_completed @ l_in_m2_only
+          )
+        else
+          l1
+  in
+  let new_rv =
+    match m1.i_return_value, m2.i_return_value with
+      None, None -> None
+    | None, Some t
+    | Some t, None -> Some t
+    | Some t1, Some t2 ->
+        if List.mem Merge_return_value merge_options then
+          Some (t1 @ (Newline :: t2))
+        else
+          Some t1
+  in
+  let new_custom =
+    match m1.i_custom, m2.i_custom with
+      [], [] -> []
+    | [], l
+    | l, [] -> l
+    | l1, l2 ->
+        if List.mem Merge_custom merge_options then
+          l1 @ l2
+        else
+          l1
+  in
+  {
+    Odoc_types.i_desc = new_desc_opt ;
+    Odoc_types.i_authors = new_authors ;
+    Odoc_types.i_version = new_version ;
+    Odoc_types.i_sees = new_sees ;
+    Odoc_types.i_since = new_since ;
+    Odoc_types.i_before = new_before ;
+    Odoc_types.i_deprecated = new_dep ;
+    Odoc_types.i_params = new_params ;
+    Odoc_types.i_raised_exceptions = new_raised_exceptions ;
+    Odoc_types.i_return_value = new_rv ;
+    Odoc_types.i_custom = new_custom ;
+  }
+
+(** Merge of two optional info structures. *)
+let merge_info_opt merge_options mli_opt ml_opt =
+  match mli_opt, ml_opt with
+    None, Some i -> Some i
+  | Some i, None -> Some i
+  | None, None -> None
+  | Some i1, Some i2 -> Some (merge_info merge_options i1 i2)
+
+(** merge of two t_type, one for a .mli, another for the .ml.
+   The .mli type is completed with the information in the .ml type. *)
+let merge_types merge_options mli ml =
+  mli.ty_info <- merge_info_opt merge_options mli.ty_info ml.ty_info;
+  mli.ty_loc <- { mli.ty_loc with loc_impl = ml.ty_loc.loc_impl } ;
+  mli.ty_code <- (match mli.ty_code with None -> ml.ty_code | _ -> mli.ty_code) ;
+
+  match mli.ty_kind, ml.ty_kind with
+    Type_abstract, _ ->
+      ()
+
+  | Type_variant l1, Type_variant l2 ->
+      let f cons =
+        try
+          let cons2 = List.find
+              (fun c2 -> c2.vc_name = cons.vc_name)
+              l2
+          in
+          let new_desc =
+            match cons.vc_text, cons2.vc_text with
+              None, None -> None
+            | Some d, None
+            | None, Some d -> Some d
+            | Some d1, Some d2 ->
+                if List.mem Merge_description merge_options then
+                  Some (merge_info merge_options d1 d2)
+                else
+                  Some d1
+          in
+          cons.vc_text <- new_desc
+        with
+          Not_found ->
+            if !Odoc_global.inverse_merge_ml_mli then
+              ()
+            else
+              raise (Failure (Odoc_messages.different_types mli.ty_name))
+      in
+      List.iter f l1
+
+  | Type_record l1, Type_record l2 ->
+      let f record =
+        try
+          let record2= List.find
+              (fun r -> r.rf_name = record.rf_name)
+              l2
+          in
+          let new_desc =
+            match record.rf_text, record2.rf_text with
+              None, None -> None
+            | Some d, None
+            | None, Some d -> Some d
+            | Some d1, Some d2 ->
+                if List.mem Merge_description merge_options then
+                  Some (merge_info merge_options d1 d2)
+                else
+                  Some d1
+          in
+          record.rf_text <- new_desc
+        with
+          Not_found ->
+            if !Odoc_global.inverse_merge_ml_mli then
+              ()
+            else
+              raise (Failure (Odoc_messages.different_types mli.ty_name))
+      in
+      List.iter f l1
+
+  | Type_open, Type_open ->
+      ()
+
+  | _ ->
+      if !Odoc_global.inverse_merge_ml_mli then
+        ()
+      else
+        raise (Failure (Odoc_messages.different_types mli.ty_name))
+
+(** merge of two t_type_extension, one for a .mli, another for the .ml.
+   The .mli type is completed with the information in the .ml type.
+   Information for the extension constructors is merged separately
+   by [merge_extension_constructor]. *)
+let merge_type_extension merge_options mli ml =
+  mli.te_info <- merge_info_opt merge_options mli.te_info ml.te_info;
+  mli.te_loc <- { mli.te_loc with loc_impl = ml.te_loc.loc_impl } ;
+  mli.te_code <- (match mli.te_code with None -> ml.te_code | _ -> mli.te_code)
+
+(** merge of two t_extension_constructor, one for a .mli, another for the .ml.
+   The .mli type is completed with the information in the .ml type. *)
+let merge_extension_constructor merge_options mli ml =
+  let new_desc =
+    match mli.xt_text, ml.xt_text with
+      None, None -> None
+    | Some d, None
+    | None, Some d -> Some d
+    | Some d1, Some d2 ->
+      if List.mem Merge_description merge_options then
+        Some (merge_info merge_options d1 d2)
+      else
+        Some d1
+  in
+    mli.xt_text <- new_desc
+
+
+(** Merge of two param_info, one from a .mli, one from a .ml.
+   The text fields are not handled but will be recreated from the
+   i_params field of the info structure.
+   Here, if a parameter in the .mli has no name, we take the one
+   from the .ml. When two parameters have two different forms,
+   we take the one from the .mli. *)
+let rec merge_param_info pi_mli pi_ml =
+  match (pi_mli, pi_ml) with
+    (Simple_name sn_mli, Simple_name sn_ml) ->
+      if sn_mli.sn_name = "" then
+        Simple_name { sn_mli with sn_name = sn_ml.sn_name }
+      else
+        pi_mli
+  | (Simple_name _, Tuple _) ->
+      pi_mli
+  | (Tuple (_, t_mli), Simple_name sn_ml) ->
+      (* if we're here, then the tuple in the .mli has no parameter names ;
+         then we take the name of the parameter of the .ml and the type of the .mli. *)
+      Simple_name { sn_ml with sn_type = t_mli }
+
+  | (Tuple (l_mli, t_mli), Tuple (l_ml, _)) ->
+      (* if the two tuples have different lengths
+         (which should not occurs), we return the pi_mli,
+         without further investigation.*)
+      if (List.length l_mli) <> (List.length l_ml) then
+        pi_mli
+      else
+        let new_l = List.map2 merge_param_info l_mli l_ml in
+        Tuple (new_l, t_mli)
+
+(** Merge of the parameters of two functions/methods/classes, one for a .mli, another for a .ml.
+   The prameters in the .mli are completed by the name in the .ml.*)
+let rec merge_parameters param_mli param_ml =
+  match (param_mli, param_ml) with
+    ([], []) -> []
+  | (l, []) | ([], l) -> l
+  | ((pi_mli :: li), (pi_ml :: l)) ->
+      (merge_param_info pi_mli pi_ml) :: merge_parameters li l
+
+(** Merge of two t_class, one for a .mli, another for the .ml.
+   The .mli class is completed with the information in the .ml class. *)
+let merge_classes merge_options mli ml =
+  mli.cl_info <- merge_info_opt merge_options mli.cl_info ml.cl_info;
+  mli.cl_loc <- { mli.cl_loc with loc_impl = ml.cl_loc.loc_impl } ;
+  mli.cl_parameters <- merge_parameters mli.cl_parameters ml.cl_parameters;
+
+  (* we must reassociate comments in @param to the the corresponding
+     parameters because the associated comment of a parameter may have been changed y the merge.*)
+  Odoc_class.class_update_parameters_text mli;
+
+  (* merge values *)
+  List.iter
+    (fun a ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Class_attribute a2 ->
+                  if a2.att_value.val_name = a.att_value.val_name then
+                    (
+                     a.att_value.val_info <- merge_info_opt merge_options
+                         a.att_value.val_info a2.att_value.val_info;
+                     a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ;
+                     if !Odoc_global.keep_code then
+                       a.att_value.val_code <- a2.att_value.val_code;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last attribute with this name defined in the implementation *)
+            (List.rev (Odoc_class.class_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_class.class_attributes mli);
+  (* merge methods *)
+  List.iter
+    (fun m ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Class_method m2 ->
+                  if m2.met_value.val_name = m.met_value.val_name then
+                    (
+                     m.met_value.val_info <- merge_info_opt
+                         merge_options m.met_value.val_info m2.met_value.val_info;
+                     m.met_value.val_loc <- { m.met_value.val_loc with loc_impl = m2.met_value.val_loc.loc_impl } ;
+                     (* merge the parameter names *)
+                     m.met_value.val_parameters <- (merge_parameters
+                                                      m.met_value.val_parameters
+                                                      m2.met_value.val_parameters) ;
+                     (* we must reassociate comments in @param to the corresponding
+                        parameters because the associated comment of a parameter may have been changed by the merge.*)
+                     Odoc_value.update_value_parameters_text m.met_value;
+
+                     if !Odoc_global.keep_code then
+                       m.met_value.val_code <- m2.met_value.val_code;
+
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last method with this name defined in the implementation *)
+            (List.rev (Odoc_class.class_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_class.class_methods mli)
+
+(** merge of two t_class_type, one for a .mli, another for the .ml.
+   The .mli class is completed with the information in the .ml class. *)
+let merge_class_types merge_options mli ml =
+  mli.clt_info <- merge_info_opt merge_options  mli.clt_info ml.clt_info;
+  mli.clt_loc <- { mli.clt_loc with loc_impl = ml.clt_loc.loc_impl } ;
+  (* merge values *)
+  List.iter
+    (fun a ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Class_attribute a2 ->
+                  if a2.att_value.val_name = a.att_value.val_name then
+                    (
+                     a.att_value.val_info <- merge_info_opt merge_options
+                         a.att_value.val_info a2.att_value.val_info;
+                     a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ;
+                     if !Odoc_global.keep_code then
+                       a.att_value.val_code <- a2.att_value.val_code;
+
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last attribute with this name defined in the implementation *)
+            (List.rev (Odoc_class.class_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_class.class_type_attributes mli);
+  (* merge methods *)
+  List.iter
+    (fun m ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Class_method m2 ->
+                  if m2.met_value.val_name = m.met_value.val_name then
+                    (
+                     m.met_value.val_info <- merge_info_opt
+                         merge_options m.met_value.val_info m2.met_value.val_info;
+                     m.met_value.val_loc <- { m.met_value.val_loc with loc_impl = m2.met_value.val_loc.loc_impl } ;
+                     m.met_value.val_parameters <- (merge_parameters
+                                                      m.met_value.val_parameters
+                                                      m2.met_value.val_parameters) ;
+                     (* we must reassociate comments in @param to the the corresponding
+                        parameters because the associated comment of a parameter may have been changed y the merge.*)
+                     Odoc_value.update_value_parameters_text m.met_value;
+
+                     if !Odoc_global.keep_code then
+                       m.met_value.val_code <- m2.met_value.val_code;
+
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last method with this name defined in the implementation *)
+            (List.rev (Odoc_class.class_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_class.class_type_methods mli)
+
+
+(** merge of two t_module_type, one for a .mli, another for the .ml.
+   The .mli module is completed with the information in the .ml module. *)
+let rec merge_module_types merge_options mli ml =
+  mli.mt_info <- merge_info_opt merge_options mli.mt_info ml.mt_info;
+  mli.mt_loc <- { mli.mt_loc with loc_impl = ml.mt_loc.loc_impl } ;
+  (* merge type extensions *)
+  List.iter
+    (fun te ->
+       let rec f exts elems =
+         match exts, elems with
+             [], _
+           | _, [] -> ()
+           | _, (Element_type_extension te2 :: rest) ->
+               let merge_ext xt =
+                 try
+                   let xt2 =
+                     List.find (fun xt2 -> xt.xt_name = xt2.xt_name)
+                       te2.te_constructors
+                   in
+                     merge_extension_constructor merge_options xt xt2;
+                     true
+                 with Not_found -> false
+               in
+               let merged, unmerged = List.partition merge_ext exts in
+                 if merged <> [] then merge_type_extension merge_options te te2;
+                 f unmerged rest
+           | _, (_ :: rest) -> f exts rest
+       in
+         (* we look for the extensions in reverse order *)
+         f te.te_constructors (List.rev (Odoc_module.module_type_elements ml))
+    )
+    (Odoc_module.module_type_type_extensions mli);
+  (* merge exceptions *)
+  List.iter
+    (fun ex ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_exception ex2 ->
+                  if ex2.ex_name = ex.ex_name then
+                    (
+                     ex.ex_info <- merge_info_opt merge_options ex.ex_info ex2.ex_info;
+                     ex.ex_loc <- { ex.ex_loc with loc_impl = ex2.ex_loc.loc_impl } ;
+                     ex.ex_code <- (match ex.ex_code with None -> ex2.ex_code | _ -> ex.ex_code) ;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last exception with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_exceptions mli);
+  (* merge types *)
+  List.iter
+    (fun ty ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_type ty2 ->
+                  if ty2.ty_name = ty.ty_name then
+                    (
+                     merge_types merge_options ty ty2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last type with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_types mli);
+  (* merge submodules *)
+  List.iter
+    (fun m ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_module m2 ->
+                  if m2.m_name = m.m_name then
+                    (
+                     ignore (merge_modules merge_options m m2);
+(*
+                     m.m_info <- merge_info_opt merge_options m.m_info m2.m_info;
+                     m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ;
+*)
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last module with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_modules mli);
+
+  (* merge module types *)
+  List.iter
+    (fun m ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_module_type m2 ->
+                  if m2.mt_name = m.mt_name then
+                    (
+                     merge_module_types merge_options m m2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last module with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_module_types mli);
+
+  (* A VOIR : merge included modules ? *)
+
+  (* merge values *)
+  List.iter
+    (fun v ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_value v2 ->
+                  if v2.val_name = v.val_name then
+                    (
+                     v.val_info <- merge_info_opt merge_options v.val_info v2.val_info ;
+                     v.val_loc <- { v.val_loc with loc_impl = v2.val_loc.loc_impl } ;
+                     (* in the .mli we don't know any parameters so we add the ones in the .ml *)
+                     v.val_parameters <- (merge_parameters
+                                            v.val_parameters
+                                            v2.val_parameters) ;
+                     (* we must reassociate comments in @param to the the corresponding
+                        parameters because the associated comment of a parameter may have been changed y the merge.*)
+                     Odoc_value.update_value_parameters_text v;
+
+                     if !Odoc_global.keep_code then
+                       v.val_code <- v2.val_code;
+
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last value with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_values mli);
+
+  (* merge classes *)
+  List.iter
+    (fun c ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_class c2 ->
+                  if c2.cl_name = c.cl_name then
+                    (
+                     merge_classes merge_options c c2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last value with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_classes mli);
+
+  (* merge class types *)
+  List.iter
+    (fun c ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_class_type c2 ->
+                  if c2.clt_name = c.clt_name then
+                    (
+                     merge_class_types merge_options c c2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last value with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_type_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_type_class_types mli)
+
+(** merge of two t_module, one for a .mli, another for the .ml.
+   The .mli module is completed with the information in the .ml module. *)
+and merge_modules merge_options mli ml =
+  mli.m_info <- merge_info_opt merge_options mli.m_info ml.m_info;
+  mli.m_loc <- { mli.m_loc with loc_impl = ml.m_loc.loc_impl } ;
+  let rec remove_doubles acc = function
+      [] -> acc
+    | h :: q ->
+        if List.mem h acc then remove_doubles acc q
+        else remove_doubles (h :: acc) q
+  in
+  mli.m_top_deps <- remove_doubles mli.m_top_deps ml.m_top_deps ;
+
+  let code =
+    if !Odoc_global.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_global.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 type extensions *)
+  List.iter
+    (fun te ->
+       let rec f exts elems =
+         match exts, elems with
+             [], _
+           | _, [] -> ()
+           | _, (Element_type_extension te2 :: rest) ->
+               let merge_ext xt =
+                 try
+                   let xt2 =
+                     List.find (fun xt2 -> xt.xt_name = xt2.xt_name)
+                       te2.te_constructors
+                   in
+                     merge_extension_constructor merge_options xt xt2;
+                     true
+                 with Not_found -> false
+               in
+               let merged, unmerged = List.partition merge_ext exts in
+                 if merged <> [] then merge_type_extension merge_options te te2;
+                 f unmerged rest
+           | _, (_ :: rest) -> f exts rest
+       in
+         (* we look for the extensions in reverse order *)
+         f te.te_constructors (List.rev (Odoc_module.module_elements ml))
+    )
+    (Odoc_module.module_type_extensions mli);
+  (* merge exceptions *)
+  List.iter
+    (fun ex ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_exception ex2 ->
+                  if ex2.ex_name = ex.ex_name then
+                    (
+                     ex.ex_info <- merge_info_opt merge_options ex.ex_info ex2.ex_info;
+                     ex.ex_loc <- { ex.ex_loc with loc_impl = ex.ex_loc.loc_impl } ;
+                     ex.ex_code <- (match ex.ex_code with None -> ex2.ex_code | _ -> ex.ex_code) ;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last exception with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_exceptions mli);
+  (* merge types *)
+  List.iter
+    (fun ty ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_type ty2 ->
+                  if ty2.ty_name = ty.ty_name then
+                    (
+                     merge_types merge_options ty ty2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last type with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_types mli);
+  (* merge submodules *)
+  List.iter
+    (fun m ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_module m2 ->
+                  if m2.m_name = m.m_name then
+                    (
+                     ignore (merge_modules merge_options m m2);
+(*
+                     m.m_info <- merge_info_opt merge_options m.m_info m2.m_info;
+                     m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ;
+*)
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last module with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_modules mli);
+
+  (* merge module types *)
+  List.iter
+    (fun m ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_module_type m2 ->
+                  if m2.mt_name = m.mt_name then
+                    (
+                     merge_module_types merge_options m m2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last module with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_module_types mli);
+
+  (* A VOIR : merge included modules ? *)
+
+  (* merge values *)
+  List.iter
+    (fun v ->
+      try
+        let _ = List.find
+            (fun v2 ->
+              if v2.val_name = v.val_name then
+                (
+                 v.val_info <- merge_info_opt merge_options v.val_info v2.val_info ;
+                 v.val_loc <- { v.val_loc with loc_impl = v2.val_loc.loc_impl } ;
+                 (* in the .mli we don't know any parameters so we add the ones in the .ml *)
+                 v.val_parameters <- (merge_parameters
+                                        v.val_parameters
+                                        v2.val_parameters) ;
+                 (* we must reassociate comments in @param to the the corresponding
+                    parameters because the associated comment of a parameter may have been changed y the merge.*)
+                 Odoc_value.update_value_parameters_text v;
+
+                 if !Odoc_global.keep_code then
+                   v.val_code <- v2.val_code;
+                 true
+                )
+              else
+                false
+            )
+            (* we look for the last value with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_values ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_values mli);
+
+  (* merge classes *)
+  List.iter
+    (fun c ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_class c2 ->
+                  if c2.cl_name = c.cl_name then
+                    (
+                     merge_classes merge_options c c2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last value with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_classes mli);
+
+  (* merge class types *)
+  List.iter
+    (fun c ->
+      try
+        let _ = List.find
+            (fun ele ->
+              match ele with
+                Element_class_type c2 ->
+                  if c2.clt_name = c.clt_name then
+                    (
+                     merge_class_types merge_options c c2;
+                     true
+                    )
+                  else
+                    false
+              | _ ->
+                  false
+            )
+            (* we look for the last value with this name defined in the implementation *)
+            (List.rev (Odoc_module.module_elements ml))
+        in
+        ()
+      with
+        Not_found ->
+          ()
+    )
+    (Odoc_module.module_class_types mli);
+
+  mli
+
+let merge merge_options modules_list =
+  let rec iter = function
+      [] -> []
+    | m :: q ->
+        (* look for another module with the same name *)
+        let (l_same, l_others) = List.partition
+            (fun m2 -> m.m_name = m2.m_name)
+            q
+        in
+        match l_same with
+          [] ->
+            (* no other module to merge with *)
+            m :: (iter l_others)
+        | m2 :: [] ->
+            (
+             (* we can merge m with m2 if there is an implementation
+                and an interface.*)
+             let f b = if !Odoc_global.inverse_merge_ml_mli then not b else b in
+             match f m.m_is_interface, f m2.m_is_interface with
+               true, false -> (merge_modules merge_options m m2) :: (iter l_others)
+             | false, true -> (merge_modules merge_options m2 m) :: (iter l_others)
+             | false, false ->
+                 if !Odoc_global.inverse_merge_ml_mli then
+                   (* two Module.ts for the .mli ! *)
+                   raise (Failure (Odoc_messages.two_interfaces m.m_name))
+                 else
+                   (* two Module.t for the .ml ! *)
+                   raise (Failure (Odoc_messages.two_implementations m.m_name))
+             | true, true ->
+                 if !Odoc_global.inverse_merge_ml_mli then
+                   (* two Module.t for the .ml ! *)
+                   raise (Failure (Odoc_messages.two_implementations m.m_name))
+                 else
+                   (* two Module.ts for the .mli ! *)
+                   raise (Failure (Odoc_messages.two_interfaces m.m_name))
+            )
+        | _ ->
+            (* too many Module.t ! *)
+            raise (Failure (Odoc_messages.too_many_module_objects m.m_name))
+
+  in
+  iter modules_list
diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli
new file mode 100644
index 00000000..8614ecfc
--- /dev/null
+++ b/ocamldoc/odoc_merge.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Merge of information from [.ml] and [.mli] for a module.*)
+
+(** Merging \@before tags. *)
+val merge_before_tags :
+    (string * Odoc_types.text) list -> (string * Odoc_types.text) list
+
+(** Merge of two optional info structures.
+   Used to merge a comment before and a comment after
+   an element in [Odoc_sig.Analyser.analyse_signature_item_desc]. *)
+val merge_info_opt :
+    Odoc_types.merge_option list ->
+      Odoc_types.info option ->
+        Odoc_types.info option ->
+          Odoc_types.info option
+
+(** Merge of modules which represent the same OCaml module, in a list of t_module.
+   There must be at most two t_module for the same OCaml module, one for a .mli, another for the .ml.
+   The function returns the list of t_module where same modules have been merged, according
+   to the given merge_option list.*)
+val merge :
+  Odoc_types.merge_option list ->
+  Odoc_module.t_module list -> Odoc_module.t_module list
diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
new file mode 100644
index 00000000..c4619886
--- /dev/null
+++ b/ocamldoc/odoc_messages.ml
@@ -0,0 +1,405 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The messages of the application. *)
+
+let ok = "Ok"
+let software = "OCamldoc"
+let config_version = Config.version
+let magic = config_version^""
+
+(** Messages for command line *)
+
+let usage = "Usage: "^(Sys.argv.(0))^" [options] \n"
+let options_are = "Options are:"
+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 option_impl =" Consider  as a .ml file"
+let option_intf =" Consider  as a .mli file"
+let option_text =" Consider  as a .txt file"
+let display_custom_generators_dir = "Display custom generators standard directory and exit"
+let add_load_dir = " Add the given directory to the search path for custom\n"^
+  "\t\tgenerators"
+let load_file = " Load file defining a new documentation generator"
+let werr = " Treat ocamldoc warnings as errors"
+let show_missed_crossref = " Show missed cross-reference opportunities"
+let hide_warnings = " do not print ocamldoc warnings"
+let target_dir = " Generate files in directory , rather than in current\n"^
+  "\t\tdirectory (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 html_short_functors = " Use short form to display functor types "^html_only
+let charset c = Printf.sprintf
+  " Add information about character encoding being s\n\t\t(default is %s)"
+  c
+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 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 output file name, used by texi, latex and dot generators\n"^
+  "\t\t(default is "^default_out_file^")\n"^
+  "\t\tor the prefix of index files for the HTML generator\n"^
+  "\t\t(default is index)"
+
+let dot_include_all =
+  " Include all modules in the dot output, not only the\n"^
+  "\t\tmodules 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 =
+  " \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 =
+  " Perform a transitive reduction on the selected dependency graph\n"^
+  "\t\tbefore the dot output"
+
+let man_mini = " Generate man pages only for modules, module types, classes\n"^
+  "\t\tand class types "^man_only
+let default_man_section = "3"
+let man_section = "
 Use 
 in man page files "^
+  "(default is "^default_man_section^") "^man_only^"\n"
+
+let default_man_suffix = default_man_section^"o"
+let man_suffix = " Use  for man page files "^
+  "(default is "^default_man_suffix^") "^man_only^"\n"
+
+let option_title = " Use <title> as title for the generated documentation"
+let option_intro =
+  "<file> Use content of <file> as ocamldoc text to use as introduction\n"^
+  "\t\t"^(html_latex_texi_only)
+let with_parameter_list = " Display the complete list of parameters for functions and\n"^
+  "\t\tmethods "^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\n\t\t"^latex_texi_only
+let no_trailer = " Suppress trailer in generated documentation\n\t\t"^latex_texi_only
+let separate_files = " Generate one file per toplevel module "^latex_only
+let latex_title ref_titles =
+  "n,style Associate {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>\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>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of types.\n"^
+  "\t\t(default is \""^default_latex_type_prefix^"\")"
+
+let default_latex_type_elt_prefix = "typeelt:"
+let latex_type_elt_prefix =
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^
+  "\t\t(default is \""^default_latex_type_elt_prefix^"\")"
+
+let default_latex_extension_prefix = "extension:"
+let latex_extension_prefix =
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of extensions.\n"^
+  "\t\t(default is \""^default_latex_extension_prefix^"\")"
+
+let default_latex_exception_prefix = "exception:"
+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>\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>\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>\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>\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>\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>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^
+  "\t\t(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 no_filter_with_module_constraints = "Do not filter module elements using module type constraints"
+let merge_description = ('d', "merge description")
+let merge_author = ('a', "merge @author")
+let merge_version = ('v', "merge @version")
+let merge_see = ('l', "merge @see")
+let merge_since = ('s', "merge @since")
+let merge_before = ('b', "merge @before")
+let merge_deprecated = ('o', "merge @deprecated")
+let merge_param = ('p', "merge @param")
+let merge_raised_exception = ('e', "merge @raise")
+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 info_section = " Specify section of Info directory "^texi_only
+let info_entry = " Specify Info directory entry "^texi_only
+
+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\t\t"^(String.make 1 c)^"  "^m)
+    ""
+    l
+
+let merge_options =
+  "<options> specify merge options between .mli and .ml\n\t\t"^
+  options_can_be^
+  (string_of_options_list
+     [ merge_description ;
+       merge_author ;
+       merge_version ;
+       merge_see ;
+       merge_since ;
+       merge_before ;
+       merge_deprecated ;
+       merge_param ;
+       merge_raised_exception ;
+       merge_return_value ;
+       merge_custom ;
+       merge_all ]
+  )
+
+let help = " Display this list of options"
+
+
+(** Error and warning messages *)
+
+let warning = "Warning"
+
+let error_location file l c =
+  Printf.sprintf "File \"%s\", line %d, character %d:\n" file l c
+
+let bad_magic_number =
+  "Bad magic number for this ocamldoc dump!\n"^
+  "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
+let wrong_format s = "Wrong format for \""^s^"\""
+let errors_occured n = (string_of_int n)^" error(s) encountered"
+let parse_error = "Parse error"
+let text_parse_error l c s =
+  let lines = Str.split (Str.regexp_string "\n") s in
+  "Error parsing text:\n"
+  ^ (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 should_escape_at_sign = "The character @ has a special meaning in ocamldoc comments, for commands such as @raise or @since. \
+If you want to write a single @, you must escape it as \\@."
+let bad_tree = "Incorrect tree structure."
+let not_a_valid_tag s = s^" is not a valid tag."
+let fun_without_param f = "Function "^f^" has no parameter.";;
+let method_without_param f = "Method "^f^" has no parameter.";;
+let anonymous_parameters f = "Function "^f^" has anonymous parameters."
+let function_colon f = "Function "^f^": "
+let implicit_match_in_parameter = "Parameters contain implicit pattern matching."
+let unknown_extension f = "Unknown extension for file "^f^"."
+let two_implementations name = "There are two implementations of module "^name^"."
+let two_interfaces name = "There are two interfaces of module "^name^"."
+let too_many_module_objects name = "There are too many interfaces/implementation of module "^name^"."
+let extension_not_found_in_implementation ext m = "Extension "^ext^" was not found in implementation of module "^m^"."
+let exception_not_found_in_implementation exc m = "Exception "^exc^" was not found in implementation of module "^m^"."
+let type_not_found_in_implementation exc m = "Type "^exc^" was not found in implementation of module "^m^"."
+let module_not_found_in_implementation m m2 = "Module "^m^" was not found in implementation of module "^m2^"."
+let value_not_found_in_implementation v m = "Value "^v^" was not found in implementation of module "^m^"."
+let class_not_found_in_implementation c m = "Class "^c^" was not found in implementation of module "^m^"."
+let attribute_not_found_in_implementation a c = "Attribute "^a^" was not found in implementation of class "^c^"."
+let method_not_found_in_implementation m c = "Method "^m^" was not found in implementation of class "^c^"."
+let different_types t = "Definition of type "^t^" doesn't match from interface to implementation."
+let attribute_type_not_found cl att = "The type of the attribute "^att^" could not be found in the signature of class "^cl^"."
+let method_type_not_found cl met = "The type of the method "^met^" could not be found in the signature of class "^cl^"."
+let module_not_found m m2 = "The module "^m2^" could not be found in the signature of module "^m^"."
+let module_type_not_found m mt = "The module type "^mt^" could not be found in the signature of module "^m^"."
+let value_not_found m v = "The value "^v^" could not be found in the signature of module "^m^"."
+let extension_not_found m e = "The extension "^e^" could not be found in the signature of module "^m^"."
+let exception_not_found m e = "The exception "^e^" could not be found in the signature of module "^m^"."
+let type_not_found m t = "The type "^t^" could not be found in the signature of module "^m^"."
+let class_not_found m c = "The class "^c^" could not be found in the signature of module "^m^"."
+let class_type_not_found m c = "The class type "^c^" could not be found in the signature of module "^m^"."
+let type_not_found_in_typedtree t = "Type "^t^" was not found in typed tree."
+let extension_not_found_in_typedtree x = "Extension "^x^" was not found in typed tree."
+let exception_not_found_in_typedtree e = "Exception "^e^" was not found in typed tree."
+let module_type_not_found_in_typedtree mt = "Module type "^mt^" was not found in typed tree."
+let module_not_found_in_typedtree m = "Module "^m^" was not found in typed tree."
+let class_not_found_in_typedtree c = "Class "^c^" was not found in typed tree."
+let class_type_not_found_in_typedtree ct = "Class type "^ct^" was not found in typed tree."
+let inherit_classexp_not_found_in_typedtree n =
+  "Inheritance class expression number "^(string_of_int n)^" was not found in typed tree."
+let attribute_not_found_in_typedtree att = "Class attribute "^att^" was not found in typed tree."
+let method_not_found_in_typedtree met = "Class method "^met^" was not found in typed tree."
+let misplaced_comment file pos =
+  Printf.sprintf "Misplaced special comment in file %s, character %d." file pos
+
+let cross_module_not_found n = "Module "^n^" not found"
+let cross_module_type_not_found n = "Module type "^n^" not found"
+let cross_module_or_module_type_not_found n = "Module or module type "^n^" not found"
+let cross_class_not_found n = "Class "^n^" not found"
+let cross_class_type_not_found n = "class type "^n^" not found"
+let cross_class_or_class_type_not_found n = "Class or class type "^n^" not found"
+let cross_extension_not_found n = "Extension "^n^" not found"
+let cross_exception_not_found n = "Exception "^n^" not found"
+let cross_element_not_found n = "Element "^n^" not found"
+let cross_method_not_found n = "Method "^n^" not found"
+let cross_attribute_not_found n = "Attribute "^n^" not found"
+let cross_section_not_found n = "Section "^n^" not found"
+let cross_value_not_found n = "Value "^n^" not found"
+let cross_type_not_found n = "Type "^n^" not found"
+let cross_recfield_not_found n = Printf.sprintf "Record field %s not found" n
+let cross_const_not_found n = Printf.sprintf "Constructor %s not found" n
+
+let code_could_be_cross_reference n parent =
+  Printf.sprintf "Code element [%s] in %s corresponds to a known \
+                  cross-referenceable element, it might be worthwhile to replace it \
+                  with {!%s}" n parent n
+
+
+let object_end = "object ... end"
+let struct_end = "struct ... end"
+let sig_end = "sig ... end"
+
+let current_generator_is_not kind =
+  Printf.sprintf "Current generator is not a %s generator" kind
+;;
+
+(** Messages for verbose mode. *)
+
+let analysing f = "Analysing file "^f^"..."
+let merging = "Merging..."
+let cross_referencing = "Cross referencing..."
+let generating_doc = "Generating documentation..."
+let loading f = "Loading "^f^"..."
+let file_generated f = "File "^f^" generated."
+let file_exists_dont_generate f =
+  "File "^f^" exists, we don't generate it."
+
+(** Messages for documentation generation.*)
+
+let modul = "Module"
+let modules = "Modules"
+let functors = "Functors"
+let values = "Simple values"
+let types = "Types"
+let extensions = "Extensions"
+let exceptions = "Exceptions"
+let record = "Record"
+let variant = "Variant"
+let mutab = "mutable"
+let functions = "Functions"
+let parameters = "Parameters"
+let abstract = "Abstract"
+let functo = "Functor"
+let clas = "Class"
+let classes = "Classes"
+let attributes = "Attributes"
+let methods = "Methods"
+let authors = "Author(s)"
+let version = "Version"
+let since = "Since"
+let before = "Before"
+let deprecated = "Deprecated."
+let raises = "Raises"
+let returns = "Returns"
+let inherits = "Inherits"
+let inheritance = "Inheritance"
+let privat = "private"
+let module_type = "Module type"
+let class_type = "Class type"
+let description = "Description"
+let interface = "Interface"
+let type_parameters = "Type parameters"
+let class_types = "Class types"
+let module_types = "Module types"
+let see_also = "See also"
+let documentation = "Documentation"
+let index_of = "Index of"
+let top = "Top"
+let index_of_values = index_of^" values"
+let index_of_extensions = index_of^" extensions"
+let index_of_exceptions = index_of^" exceptions"
+let index_of_types = index_of^" types"
+let index_of_attributes = index_of^" class attributes"
+let index_of_methods = index_of^" class methods"
+let index_of_classes = index_of^" classes"
+let index_of_class_types = index_of^" class types"
+let index_of_modules = index_of^" modules"
+let index_of_module_types = index_of^" module types"
+let previous = "Previous"
+let next = "Next"
+let up = "Up"
diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
new file mode 100644
index 00000000..cffffffd
--- /dev/null
+++ b/ocamldoc/odoc_misc.ml
@@ -0,0 +1,504 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let no_blanks s =
+  let len = String.length s in
+  let buf = Buffer.create len in
+  for i = 0 to len - 1 do
+    match s.[i] with
+      ' ' | '\n' | '\t' | '\r' -> ()
+    | c -> Buffer.add_char buf c
+  done;
+  Buffer.contents buf
+
+let input_file_as_string nom =
+  let chanin = open_in_bin nom in
+  let len = 1024 in
+  let s = Bytes.create len in
+  let buf = Buffer.create len in
+  let rec iter () =
+    try
+      let n = input chanin s 0 len in
+      if n = 0 then
+        ()
+      else
+        (
+         Buffer.add_subbytes buf s 0 n;
+         iter ()
+        )
+    with
+      End_of_file -> ()
+  in
+  iter ();
+  close_in chanin;
+  Buffer.contents buf
+
+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 "" 0
+
+let split_with_blanks s = split_string s [' ' ; '\n' ; '\r' ; '\t' ]
+
+let list_concat sep =
+  let rec iter = function
+      [] -> []
+    | [h] -> [h]
+    | h :: q -> h :: sep :: iter q
+  in
+  iter
+
+let rec string_of_longident li =
+  match li with
+  | Longident.Lident s -> s
+  | Longident.Ldot(li, s) -> string_of_longident li ^ "." ^ s
+  | Longident.Lapply(l1, l2) ->
+      string_of_longident l1 ^ "(" ^ string_of_longident l2 ^ ")"
+
+let get_fields type_expr =
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in
+  List.fold_left
+    (fun acc -> fun (label, field_kind, typ) ->
+      match field_kind with
+        Types.Fabsent ->
+          acc
+      | _ ->
+          if label = "*dummy method*" then
+            acc
+          else
+            acc @ [label, typ]
+    )
+    []
+    fields
+
+let rec string_of_text t =
+  let rec iter t_ele =
+    match t_ele with
+      | Odoc_types.Raw s
+      | Odoc_types.Code s
+      | Odoc_types.CodePre s
+      | Odoc_types.Verbatim s -> s
+      | Odoc_types.Bold t
+      | Odoc_types.Italic t
+      | Odoc_types.Center t
+      | Odoc_types.Left t
+      | Odoc_types.Right t
+      | Odoc_types.Emphasize t -> string_of_text t
+      | Odoc_types.List l ->
+          (String.concat ""
+             (List.map (fun t -> "\n- "^(string_of_text t)) l))^
+          "\n"
+      | Odoc_types.Enum l ->
+          let rec f n = function
+              [] -> "\n"
+            | t :: q ->
+                "\n"^(string_of_int n)^". "^(string_of_text t)^
+                (f (n + 1) q)
+          in
+          f 1 l
+      | Odoc_types.Newline -> "\n"
+      | Odoc_types.Block t -> "\t"^(string_of_text t)^"\n"
+      | Odoc_types.Title (_, _, t) -> "\n"^(string_of_text t)^"\n"
+      | Odoc_types.Latex s -> "{% "^s^" %}"
+      | Odoc_types.Link (s, t) ->
+          "["^s^"]"^(string_of_text t)
+      | Odoc_types.Ref (_name, _, Some text) ->
+          Printf.sprintf "[%s]" (string_of_text text)
+      | Odoc_types.Ref (name, _, None) ->
+          iter (Odoc_types.Code name)
+      | Odoc_types.Superscript 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 ->
+          ""
+      | Odoc_types.Custom (_, t) -> string_of_text t
+      | Odoc_types.Target _ -> ""
+  in
+  String.concat "" (List.map iter t)
+
+let string_of_author_list l =
+  match l with
+    [] ->
+      ""
+  | _ ->
+      "* "^Odoc_messages.authors^":\n"^
+      (String.concat ", " l)^
+      "\n"
+
+let string_of_version_opt v_opt =
+  match v_opt with
+    None -> ""
+  | Some v -> Odoc_messages.version^": "^v^"\n"
+
+let string_of_since_opt s_opt =
+  match s_opt with
+    None -> ""
+  | Some s -> Odoc_messages.since^" "^s^"\n"
+
+let string_of_raised_exceptions l =
+  match l with
+    [] -> ""
+  | (s, t) :: [] -> Odoc_messages.raises^" "^s^" "^(string_of_text t)^"\n"
+  | _ ->
+      Odoc_messages.raises^"\n"^
+      (String.concat ""
+         (List.map
+            (fun (ex, desc) -> "- "^ex^" "^(string_of_text desc)^"\n")
+            l
+         )
+      )^"\n"
+
+let string_of_see (see_ref, t) =
+  let t_ref =
+    match see_ref with
+      Odoc_types.See_url s -> [ Odoc_types.Link (s, t) ]
+    | Odoc_types.See_file s -> (Odoc_types.Code s) :: (Odoc_types.Raw " ") :: t
+    | Odoc_types.See_doc s -> (Odoc_types.Italic [Odoc_types.Raw s]) :: (Odoc_types.Raw " ") :: t
+  in
+  string_of_text t_ref
+
+let string_of_sees l =
+  match l with
+    [] -> ""
+  | see :: [] -> Odoc_messages.see_also^" "^(string_of_see see)^" \n"
+  | _ ->
+      Odoc_messages.see_also^"\n"^
+      (String.concat ""
+         (List.map
+            (fun see -> "- "^(string_of_see see)^"\n")
+            l
+         )
+      )^"\n"
+
+let string_of_return_opt return_opt =
+  match return_opt with
+    None -> ""
+  | Some s -> Odoc_messages.returns^" "^(string_of_text s)^"\n"
+
+let string_of_info i =
+  let module M = Odoc_types in
+  (match i.M.i_deprecated with
+    None -> ""
+  | Some d -> Odoc_messages.deprecated^"! "^(string_of_text d)^"\n")^
+  (match i.M.i_desc with
+    None -> ""
+  | Some d when d = [Odoc_types.Raw ""] -> ""
+  | Some d -> (string_of_text d)^"\n"
+  )^
+  (string_of_author_list i.M.i_authors)^
+  (string_of_version_opt i.M.i_version)^
+  (string_of_since_opt i.M.i_since)^
+  (string_of_raised_exceptions i.M.i_raised_exceptions)^
+  (string_of_return_opt i.M.i_return_value)
+
+let apply_opt f v_opt =
+  match v_opt with
+    None -> None
+  | Some v -> Some (f v)
+
+let string_of_date ?(absolute=false) ?(hour=true) d =
+  let add_0 s = if String.length s < 2 then "0"^s else s in
+  let t = (if absolute then Unix.gmtime else Unix.localtime) d in
+  (string_of_int (t.Unix.tm_year + 1900))^"-"^
+  (add_0 (string_of_int (t.Unix.tm_mon + 1)))^"-"^
+  (add_0 (string_of_int t.Unix.tm_mday))^
+  (
+   if hour then
+     " "^
+     (add_0 (string_of_int t.Unix.tm_hour))^":"^
+     (add_0 (string_of_int t.Unix.tm_min))
+   else
+     ""
+  )
+
+let current_date =
+  let time =
+    try
+      float_of_string (Sys.getenv "SOURCE_DATE_EPOCH")
+    with
+      Not_found -> Unix.time ()
+  in string_of_date ~absolute: true ~hour: false time
+
+
+let rec text_list_concat sep l =
+  match l with
+    [] -> []
+  | [t] -> t
+  | t :: q ->
+      t @ (sep :: (text_list_concat sep q))
+
+let rec text_no_title_no_list t =
+  let iter t_ele =
+    match t_ele with
+    | Odoc_types.Title (_,_,t) -> text_no_title_no_list t
+    | Odoc_types.List l
+    | Odoc_types.Enum l ->
+        (Odoc_types.Raw " ") ::
+        (text_list_concat
+           (Odoc_types.Raw ", ")
+           (List.map text_no_title_no_list l))
+    | Odoc_types.Raw _
+    | Odoc_types.Code _
+    | Odoc_types.CodePre _
+    | Odoc_types.Verbatim _
+    | Odoc_types.Ref _
+    | Odoc_types.Target _ -> [t_ele]
+    | Odoc_types.Newline ->  [Odoc_types.Newline]
+    | Odoc_types.Block t -> [Odoc_types.Block (text_no_title_no_list t)]
+    | Odoc_types.Bold t -> [Odoc_types.Bold (text_no_title_no_list t)]
+    | Odoc_types.Italic t -> [Odoc_types.Italic (text_no_title_no_list t)]
+    | Odoc_types.Center t -> [Odoc_types.Center (text_no_title_no_list t)]
+    | Odoc_types.Left t -> [Odoc_types.Left (text_no_title_no_list t)]
+    | Odoc_types.Right t -> [Odoc_types.Right (text_no_title_no_list t)]
+    | Odoc_types.Emphasize t -> [Odoc_types.Emphasize (text_no_title_no_list t)]
+    | Odoc_types.Latex s -> [Odoc_types.Latex s]
+    | 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, None))
+             l
+          )
+    | Odoc_types.Index_list -> []
+    | Odoc_types.Custom (s,t) -> [Odoc_types.Custom (s, text_no_title_no_list t)]
+  in
+  List.flatten (List.map iter t)
+
+let get_titles_in_text t =
+  let l = ref [] in
+  let rec iter_ele ele =
+    match ele with
+    | Odoc_types.Title (n,lopt,t) -> l := (n,lopt,t) :: !l
+    | Odoc_types.List l
+    | Odoc_types.Enum l -> List.iter iter_text l
+    | Odoc_types.Raw _
+    | Odoc_types.Code _
+    | Odoc_types.CodePre _
+    | Odoc_types.Verbatim _
+    | Odoc_types.Ref _ -> ()
+    | Odoc_types.Newline ->  ()
+    | Odoc_types.Block t
+    | Odoc_types.Bold t
+    | Odoc_types.Italic t
+    | Odoc_types.Center t
+    | Odoc_types.Left t
+    | Odoc_types.Right t
+    | Odoc_types.Emphasize t -> iter_text t
+    | Odoc_types.Latex _ -> ()
+    | Odoc_types.Link (_, t)
+    | Odoc_types.Superscript t
+    | Odoc_types.Subscript t  -> iter_text t
+    | Odoc_types.Module_list _ -> ()
+    | Odoc_types.Index_list -> ()
+    | Odoc_types.Custom (_, t) -> iter_text t
+    | Odoc_types.Target _ -> ()
+  and iter_text txt =
+    List.iter iter_ele txt
+  in
+  iter_text t;
+  List.rev !l
+
+let text_concat (sep : Odoc_types.text) l =
+  let rec iter = function
+      [] -> []
+    | [last] -> last
+    | h :: q -> h @ sep @ (iter q)
+  in
+  iter l
+
+(*********************************************************)
+let rec get_before_dot s =
+  try
+    let len = String.length s in
+    let n = String.index s '.' in
+    if n + 1 >= len then
+      (* The dot is the last character *)
+      (true, s, "")
+    else
+      match s.[n+1] with
+        ' ' | '\n' | '\r' | '\t' ->
+          (true, String.sub s 0 (n+1),
+           String.sub s (n+1) (len - n - 1))
+      | _ ->
+          let b, s2, s_after = get_before_dot (String.sub s (n + 1) (len - n - 1)) in
+          (b, (String.sub s 0 (n+1))^s2, s_after)
+  with
+    Not_found -> (false, s, "")
+
+let rec first_sentence_text t =
+  match t with
+    [] -> (false, [], [])
+  | ele :: q ->
+      let (stop, ele2, ele3_opt) = first_sentence_text_ele ele in
+      if stop then
+        (stop, [ele2],
+         match ele3_opt with None -> q | Some e -> e :: q)
+      else
+        let (stop2, q2, rest) = first_sentence_text q in
+        (stop2, ele2 :: q2, rest)
+
+
+and first_sentence_text_ele text_ele =
+  match text_ele with
+  | Odoc_types.Raw s ->
+      let b, s2, s_after = get_before_dot s in
+      (b, Odoc_types.Raw s2, Some (Odoc_types.Raw s_after))
+  | Odoc_types.Code _
+  | Odoc_types.CodePre _
+  | Odoc_types.Verbatim _ -> (false, text_ele, None)
+  | Odoc_types.Bold t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Bold t2, Some (Odoc_types.Bold t3))
+  | Odoc_types.Italic t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Italic t2, Some (Odoc_types.Italic t3))
+  | Odoc_types.Center t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Center t2, Some (Odoc_types.Center t3))
+  | Odoc_types.Left t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Left t2, Some (Odoc_types.Left t3))
+  | Odoc_types.Right t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Right t2, Some (Odoc_types.Right t3))
+  | Odoc_types.Emphasize t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Emphasize t2, Some (Odoc_types.Emphasize t3))
+  | Odoc_types.Block t ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b, Odoc_types.Block t2, Some (Odoc_types.Block t3))
+  | Odoc_types.Title (n, l_opt, t) ->
+      let (b, t2, t3) = first_sentence_text t in
+      (b,
+       Odoc_types.Title (n, l_opt, t2),
+       Some (Odoc_types.Title (n, l_opt, t3)))
+  | Odoc_types.Newline ->
+      (true, Odoc_types.Raw "", Some Odoc_types.Newline)
+  | Odoc_types.List _
+  | Odoc_types.Enum _
+  | Odoc_types.Latex _
+  | Odoc_types.Link _
+  | Odoc_types.Ref _
+  | Odoc_types.Superscript _
+  | Odoc_types.Subscript _
+  | Odoc_types.Module_list _
+  | Odoc_types.Index_list -> (false, text_ele, None)
+  | Odoc_types.Custom _
+  | Odoc_types.Target _ -> (false, text_ele, None)
+
+
+let first_sentence_of_text t =
+  let (_,t2,_) = first_sentence_text t in
+  t2
+
+let first_sentence_and_rest_of_text t =
+  let (_,t1, t2) = first_sentence_text t in
+  (t1, t2)
+
+let remove_ending_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
+
+let search_string_backward ~pat =
+  let lenp = String.length pat in
+  let rec iter s =
+    let len = String.length s in
+    match compare len lenp with
+      -1 -> raise Not_found
+    | 0 -> if pat = s then 0 else raise Not_found
+    | _ ->
+        let pos = len - lenp in
+        let s2 = String.sub s pos lenp in
+        if s2 = pat then
+          pos
+        else
+          iter (String.sub s 0 pos)
+  in
+  fun ~s -> iter s
+
+
+
+(*********************************************************)
+
+let create_index_lists elements string_of_ele =
+  let rec f current acc0 acc1 acc2 = function
+      [] -> (acc0 :: acc1) @ [acc2]
+    | ele :: q ->
+        let s = string_of_ele ele in
+        match s with
+          "" -> f current acc0 acc1 (acc2 @ [ele]) q
+        | _ ->
+            let first = Char.uppercase_ascii s.[0] in
+            match first with
+              'A' .. 'Z' ->
+                if current = first then
+                  f current acc0 acc1 (acc2 @ [ele]) q
+                else
+                  f first acc0 (acc1 @ [acc2]) [ele] q
+            | _ ->
+                f current (acc0 @ [ele]) acc1 acc2 q
+  in
+  f '_' [] [] [] elements
+
+
+(*** for labels *)
+
+let is_optional = Btype.is_optional
+let label_name = Btype.label_name
+
+let remove_option typ =
+  let rec iter t =
+    match t with
+    | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
+    | Types.Tconstr _
+    | Types.Tvar _
+    | Types.Tunivar _
+    | Types.Tpoly _
+    | Types.Tarrow _
+    | Types.Ttuple _
+    | Types.Tobject _
+    | Types.Tfield _
+    | Types.Tnil
+    | Types.Tvariant _
+    | Types.Tpackage _ -> t
+    | Types.Tlink t2
+    | Types.Tsubst t2 -> iter t2.Types.desc
+  in
+  { typ with Types.desc = iter typ.Types.desc }
diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
new file mode 100644
index 00000000..03918f8a
--- /dev/null
+++ b/ocamldoc/odoc_misc.mli
@@ -0,0 +1,122 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Miscellaneous functions *)
+
+(** [no_blanks s] returns the given string without any blank
+   characters, i.e. '\n' '\r' ' ' '\t'.
+*)
+val no_blanks : string -> string
+
+(** 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 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
+
+(** get a string from a text *)
+val string_of_text : Odoc_types.text -> string
+
+(** @return a string for an authors list. *)
+val string_of_author_list : string list -> string
+
+(** @return a string for the given optional version information.*)
+val string_of_version_opt : string option -> string
+
+(** @return a string for the given optional since information.*)
+val string_of_since_opt : string option -> string
+
+(** @return a string for the given list of raised exceptions.*)
+val string_of_raised_exceptions : (string * Odoc_types.text) list -> string
+
+(** @return a string for the given "see also" reference.*)
+val string_of_see : Odoc_types.see_ref * Odoc_types.text -> string
+
+(** @return a string for the given list of "see also" references.*)
+val string_of_sees : (Odoc_types.see_ref * Odoc_types.text) list -> string
+
+(** @return a string for the given optional return information.*)
+val string_of_return_opt : Odoc_types.text option -> string
+
+(** get a string from a Odoc_info.info structure *)
+val string_of_info : Odoc_types.info -> string
+
+(** Apply a function to an optional value. *)
+val apply_opt : ('a -> 'b) -> 'a option -> 'b option
+
+(** Return a string representing a date given as a number of seconds
+   since 1970. The hour is optionnaly displayed. *)
+val string_of_date : ?absolute:bool -> ?hour:bool -> float -> string
+
+(* Value returned by string_of_date for current time.
+ * Uses environment variable SOURCE_DATE_EPOCH if set; falls back to
+ * current timestamp otherwise. *)
+val current_date : string
+
+(** Return the first sentence (until the first dot) of a text.
+   Don't stop in the middle of [Code], [Verbatim], [List], [Lnum],
+   [Latex], [Link], or [Ref]. *)
+val first_sentence_of_text : Odoc_types.text -> Odoc_types.text
+
+(** Return the first sentence (until the first dot) of a text,
+   and the remaining text after.
+   Don't stop in the middle of [Code], [Verbatim], [List], [Lnum],
+   [Latex], [Link], or [Ref]. *)
+val first_sentence_and_rest_of_text :
+    Odoc_types.text -> Odoc_types.text * Odoc_types.text
+
+(** Return the given [text] without any title or list. *)
+val text_no_title_no_list : Odoc_types.text -> Odoc_types.text
+
+(** [concat sep l] concats the given list of text [l], each separated with
+   the text [sep]. *)
+val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text
+
+(** Return the list of titles in a [text].
+   A title is a title level, an optional label and a text.*)
+val get_titles_in_text : Odoc_types.text -> (int * string option * Odoc_types.text) list
+
+(** Take a sorted list of elements, a function to get the name
+   of an element and return the list of list of elements,
+   where each list group elements beginning by the same letter.
+   Since the original list is sorted, elements whose name does not
+   begin with a letter should be in the first returned list.*)
+val create_index_lists : 'a list -> ('a -> string) -> 'a list list
+
+(** [remove_ending_newline s] returns [s] without the optional ending newline. *)
+val remove_ending_newline : string -> string
+
+(** [search_string_backward pat s] searches backward string [pat] in string [s].
+   Return position in string [s] where [pat] appears, orelse raise [Not_found]. *)
+val search_string_backward : pat: string -> s: string -> int
+
+(** Take a type and remove the option top constructor. This is
+   useful when printing labels, we we then remove the top option contructor
+   for optional labels.*)
+val remove_option : Types.type_expr -> Types.type_expr
+
+(** Return [true] if the given label is optional.*)
+val is_optional : Asttypes.arg_label -> bool
+
+(** Return the label name for the given label,
+   i.e. removes the beginning '?' if present.*)
+val label_name : Asttypes.arg_label -> string
diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
new file mode 100644
index 00000000..afd31020
--- /dev/null
+++ b/ocamldoc/odoc_module.ml
@@ -0,0 +1,572 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Representation and manipulation of modules and module types. *)
+
+let print_DEBUG s = print_string s ; print_newline ()
+
+module Name = Odoc_name
+
+(** To keep the order of elements in a module. *)
+type module_element =
+    Element_module of t_module
+  | Element_module_type of t_module_type
+  | Element_included_module of included_module
+  | Element_class of Odoc_class.t_class
+  | Element_class_type of Odoc_class.t_class_type
+  | Element_value of Odoc_value.t_value
+  | Element_type_extension of Odoc_extension.t_type_extension
+  | Element_exception of Odoc_exception.t_exception
+  | Element_type of Odoc_type.t_type
+  | Element_module_comment of Odoc_types.text
+
+(** Used where we can reference t_module or t_module_type *)
+and mmt =
+  | Mod of t_module
+  | Modtype of t_module_type
+
+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 = {
+    ma_name : Name.t ;
+    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 option ; (** 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 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
+  | Module_typeof of string (** by now only the code of the module expression *)
+  | Module_unpack of string * module_type_alias (** code of the expression and module type alias *)
+
+(** Representation of a module. *)
+and t_module = {
+    m_name : Name.t ;
+    mutable m_type : Types.module_type ;
+    mutable m_info : Odoc_types.info option ;
+    m_is_interface : bool ; (** true for modules read from interface files *)
+    m_file : string ; (** the file the module is defined in. *)
+    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 *)
+    m_text_only : bool ; (** [true] if the module comes from a text file *)
+  }
+
+and module_type_alias = {
+    mta_name : Name.t ;
+    mutable mta_module : t_module_type option ; (** the real module type if we could associate it *)
+  }
+
+(** Different kinds of module type. *)
+and module_type_kind =
+  | Module_type_struct of module_element list
+  | 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 *)
+  | Module_type_typeof of string (** by now only the code of the module expression *)
+
+(** Representation of a module type. *)
+and t_module_type = {
+    mt_name : Name.t ;
+    mutable mt_info : Odoc_types.info option ;
+    mutable mt_type : Types.module_type option ; (** [None] = abstract module type *)
+    mt_is_interface : bool ; (** true for modules read from interface files *)
+    mt_file : string ; (** the file the module type is defined in. *)
+    mutable mt_kind : module_type_kind option ; (** [None] = abstract module type if mt_type = None ;
+                                           Always [None] when the module type was extracted from the implementation file. *)
+    mutable mt_loc : Odoc_types.location ;
+  }
+
+
+(** {2 Functions} *)
+
+(** Returns the list of values from a list of module_element. *)
+let values l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_value v -> acc @ [v]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of types from a list of module_element. *)
+let types l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_type t -> acc @ [t]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of type extensions from a list of module_element. *)
+let type_extensions l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_type_extension x -> acc @ [x]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of exceptions from a list of module_element. *)
+let exceptions l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_exception e -> acc @ [e]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of classes from a list of module_element. *)
+let classes l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_class c -> acc @ [c]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of class types from a list of module_element. *)
+let class_types l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_class_type ct -> acc @ [ct]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of modules from a list of module_element. *)
+let modules l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_module m -> acc @ [m]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of module types from a list of module_element. *)
+let mod_types l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_module_type mt -> acc @ [mt]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of module comment from a list of module_element. *)
+let comments l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_module_comment t -> acc @ [t]
+      | _ -> acc
+    )
+    []
+    l
+
+(** Returns the list of included modules from a list of module_element. *)
+let included_modules l =
+  List.fold_left
+    (fun acc -> fun ele ->
+      match ele with
+        Element_included_module m -> acc @ [m]
+      | _ -> acc
+    )
+    []
+    l
+
+module S = Misc.StringSet
+
+
+(** Returns the list of elements of a module type.
+   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let rec module_type_elements ?(trans=true) mt =
+  let rec iter_kind = function
+    | None -> []
+    | Some (Module_type_struct l) -> l
+    | Some (Module_type_functor (_, k)) -> iter_kind (Some k)
+    | Some (Module_type_with (k, _)) ->
+        if trans then
+          iter_kind (Some k)
+        else
+          []
+    | Some (Module_type_alias mta) ->
+        if trans then
+          match mta.mta_module with
+            None -> []
+          | Some mt -> module_type_elements mt
+        else
+          []
+  | Some (Module_type_typeof _) -> []
+  in
+  iter_kind mt.mt_kind
+
+(** Returns the list of elements of a module.
+   @param trans indicates if, for aliased modules, we must perform a transitive search.
+*)
+let module_elements ?(trans=true) m =
+(* visited is used to guard against aliases loop
+     (e.g [module rec M:sig end=M] induced loop.
+*)
+  let rec module_elements visited ?(trans=true) m =
+    let rec iter_kind = function
+        Module_struct l ->
+          print_DEBUG "Odoc_module.module_elements: Module_struct";
+          l
+      | Module_alias ma ->
+          print_DEBUG "Odoc_module.module_elements: Module_alias";
+          if trans then
+            match ma.ma_module with
+              None -> []
+            | Some (Mod m') ->
+                if S.mem m'.m_name visited then
+                  []
+                else
+                  module_elements (S.add m'.m_name visited) m'
+            | Some (Modtype mt) -> module_type_elements mt
+          else
+            []
+      | Module_functor (_, k)
+      | Module_apply (k, _) ->
+          print_DEBUG "Odoc_module.module_elements: Module_functor ou Module_apply";
+          iter_kind k
+      | Module_with (tk,_) ->
+          print_DEBUG "Odoc_module.module_elements: 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_elements: Module_constraint";
+          (* FIXME : use k or tk ? *)
+          module_elements visited ~trans: trans
+            { m_name = "" ;
+              m_info = None ;
+              m_type = Types.Mty_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 ;
+              m_text_only = false ;
+            }
+      | Module_typeof _ -> []
+      | Module_unpack _ -> []
+(*
+   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 in
+  module_elements S.empty ~trans m
+
+(** Returns the list of values of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_values ?(trans=true) m = values (module_elements ~trans m)
+
+(** Returns the list of functional values of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_functions ?(trans=true) m =
+  List.filter
+    (fun v -> Odoc_value.is_function v)
+    (values (module_elements ~trans m))
+
+(** Returns the list of non-functional values of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_simple_values ?(trans=true) m =
+    List.filter
+    (fun v -> not (Odoc_value.is_function v))
+    (values (module_elements ~trans m))
+
+(** Returns the list of types of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_types ?(trans=true) m = types (module_elements ~trans m)
+
+(** Returns the list of type extensions of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_extensions ?(trans=true) m = type_extensions (module_elements ~trans m)
+
+(** Returns the list of exceptions of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_exceptions ?(trans=true) m = exceptions (module_elements ~trans m)
+
+(** Returns the list of classes of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_classes ?(trans=true) m = classes (module_elements ~trans m)
+
+(** Returns the list of class types of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_class_types ?(trans=true) m = class_types (module_elements ~trans m)
+
+(** Returns the list of modules of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_modules ?(trans=true) m = modules (module_elements ~trans m)
+
+(** Returns the list of module types of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_module_types ?(trans=true) m = mod_types (module_elements ~trans m)
+
+(** Returns the list of included module of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_included_modules ?(trans=true) m = included_modules (module_elements ~trans m)
+
+(** Returns the list of comments of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_comments ?(trans=true) m = comments (module_elements ~trans m)
+
+(** Access to the parameters, for a functor type.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let rec module_type_parameters ?(trans=true) mt =
+  let rec iter k =
+    match k with
+      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
+            None -> []
+          | Some mt2 -> module_type_parameters ~trans mt2
+        else
+          []
+    | Some (Module_type_with (k, _)) ->
+        if trans then
+          iter (Some k)
+        else
+          []
+    | Some (Module_type_struct _) ->
+        []
+    | Some (Module_type_typeof _) -> []
+      | None ->
+        []
+  in
+  iter mt.mt_kind
+
+(** Access to the parameters, for a functor.
+   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+and module_parameters ?(trans=true) m =
+  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 ->
+                  (p, None)
+        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 _
+    | Module_typeof _
+    | Module_unpack _ -> []
+  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.*)
+let rec module_all_submodules ?(trans=true) m =
+  let l = module_modules ~trans m in
+  List.fold_left
+    (fun acc -> fun m -> acc @ (module_all_submodules ~trans m))
+    l
+    l
+
+(** The module type is a functor if is defined as a functor or if it is an alias for a functor. *)
+let rec module_type_is_functor mt =
+  let rec iter k =
+    match k with
+      Some (Module_type_functor _) -> true
+    | Some (Module_type_alias mta) ->
+        (
+         match mta.mta_module with
+           None -> false
+         | Some mtyp -> module_type_is_functor mtyp
+        )
+    | Some (Module_type_with (k, _)) ->
+        iter (Some k)
+    | Some (Module_type_struct _)
+    | Some (Module_type_typeof _)
+    | None -> false
+  in
+  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 module_is_functor m =
+  let rec iter visited = function
+      Module_functor _ -> true
+    | Module_alias ma ->
+        (
+          not (S.mem ma.ma_name visited)
+          &&
+          match ma.ma_module with
+            None -> false
+          | Some (Mod mo) -> iter (S.add ma.ma_name visited) mo.m_kind
+          | Some (Modtype mt) -> module_type_is_functor mt
+        )
+    | Module_constraint (k, _) ->
+        iter visited k
+    | _ -> false
+  in
+  iter S.empty 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.*)
+let module_type_values ?(trans=true) m = values (module_type_elements ~trans m)
+
+(** Returns the list of types of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_types ?(trans=true) m = types (module_type_elements ~trans m)
+
+(** Returns the list of type extensions of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_type_extensions ?(trans=true) m = type_extensions (module_type_elements ~trans m)
+
+(** Returns the list of exceptions of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_exceptions ?(trans=true) m = exceptions (module_type_elements ~trans m)
+
+(** Returns the list of classes of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_classes ?(trans=true) m = classes (module_type_elements ~trans m)
+
+(** Returns the list of class types of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_class_types ?(trans=true) m = class_types (module_type_elements ~trans m)
+
+(** Returns the list of modules of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_modules ?(trans=true)  m = modules (module_type_elements ~trans m)
+
+(** Returns the list of module types of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_module_types ?(trans=true) m = mod_types (module_type_elements ~trans m)
+
+(** Returns the list of included module of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_included_modules ?(trans=true) m = included_modules (module_type_elements ~trans m)
+
+(** Returns the list of comments of a module.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_comments ?(trans=true) m = comments (module_type_elements ~trans m)
+
+(** Returns the list of functional values of a module type.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_functions ?(trans=true) mt =
+  List.filter
+    (fun v -> Odoc_value.is_function v)
+    (values (module_type_elements ~trans mt))
+
+(** Returns the list of non-functional values of a module type.
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let module_type_simple_values ?(trans=true) mt =
+    List.filter
+    (fun v -> not (Odoc_value.is_function v))
+    (values (module_type_elements ~trans mt))
+
+(** {2 Functions for modules and module types} *)
+
+(** The list of classes defined in this module and all its modules, functors, ....
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+let rec module_all_classes ?(trans=true) m =
+  List.fold_left
+    (fun acc -> fun m -> acc @ (module_all_classes ~trans m))
+    (
+       List.fold_left
+       (fun acc -> fun mtyp -> acc @ (module_type_all_classes ~trans mtyp))
+       (module_classes ~trans m)
+       (module_module_types ~trans m)
+    )
+    (module_modules ~trans m)
+
+(** The list of classes defined in this module type and all its modules, functors, ....
+  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+and module_type_all_classes ?(trans=true) mt =
+  List.fold_left
+    (fun acc -> fun m -> acc @ (module_all_classes ~trans m))
+    (
+     List.fold_left
+       (fun acc -> fun mtyp -> acc @ (module_type_all_classes ~trans mtyp))
+       (module_type_classes ~trans mt)
+       (module_type_module_types ~trans mt)
+    )
+    (module_type_modules ~trans mt)
diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml
new file mode 100644
index 00000000..df8a7860
--- /dev/null
+++ b/ocamldoc/odoc_name.ml
@@ -0,0 +1,226 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Representation of element names. *)
+
+let infix_chars = [ '|' ;
+                    '<' ;
+                    '>' ;
+                    '@' ;
+                    '^' ;
+                    '&' ;
+                    '+' ;
+                    '-' ;
+                    '*' ;
+                    '/' ;
+                    '$' ;
+                    '%' ;
+                    '=' ;
+                    ':' ;
+                    '~' ;
+                    '!' ;
+                    '.' ;
+                    '#' ;
+                  ]
+
+type t = string
+
+let strip_string s =
+  let len = String.length s in
+  let rec iter_first n =
+    if n >= len then
+      None
+    else
+      match s.[n] with
+        ' ' | '\t' | '\n' | '\r' -> iter_first (n+1)
+      | _ -> Some n
+  in
+  match iter_first 0 with
+    None -> ""
+  | Some first ->
+      let rec iter_last n =
+        if n <= first then
+          None
+        else
+          match s.[n] with
+            ' ' | '\t' | '\n' | '\r' -> iter_last (n-1)
+          | _ -> Some n
+      in
+      match iter_last (len-1) with
+        None -> String.sub s first 1
+      | Some last -> String.sub s first ((last-first)+1)
+
+let parens_if_infix name =
+  match strip_string name with
+  | "" -> ""
+  | s when s.[0] = '*' || s.[String.length s - 1] = '*' -> "( " ^ s ^ " )"
+  | s when List.mem s.[0] infix_chars -> "(" ^ s ^ ")"
+  | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" ->
+     "(" ^ name ^ ")"
+  | name -> name
+;;
+
+let cut name =
+  match name with
+    "" -> ("", "")
+  | s ->
+      let len = String.length s in
+      match s.[len-1] with
+        ')' ->
+          (
+           let j = ref 0 in
+           let buf = [|Buffer.create len ; Buffer.create len |] in
+           for i = 0 to len - 1 do
+             match s.[i] with
+               '.' when !j = 0 ->
+                 if i < len - 1 then
+                   match s.[i+1] with
+                     '(' ->
+                       j := 1
+                   | _ ->
+                       Buffer.add_char buf.(!j) '.'
+                 else
+                   Buffer.add_char buf.(!j) s.[i]
+             | c ->
+                 Buffer.add_char buf.(!j) c
+           done;
+           (Buffer.contents buf.(0), Buffer.contents buf.(1))
+          )
+      | _ ->
+          match List.rev (Str.split (Str.regexp_string ".") s) with
+            [] -> ("", "")
+          | h :: q ->
+              (String.concat "." (List.rev q), h)
+
+let simple name = snd (cut name)
+let father name = fst (cut name)
+
+let concat n1 n2 = n1^"."^n2
+
+let normalize_name name =
+  let (p,s) = cut name in
+  let len = String.length s in
+  let s =
+    if len >= 2 &&
+      s.[0] = '(' && s.[len - 1] = ')'
+    then
+      parens_if_infix (strip_string (String.sub s 1 (len - 2)))
+    else
+      s
+  in
+  match p with
+    "" -> s
+  | p -> concat p s
+  ;;
+
+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 depth name =
+  try
+    List.length (Str.split (Str.regexp "\\.") name)
+  with
+    _ -> 1
+
+let prefix n1 n2 =
+  (n1 <> n2) &&
+  (try
+    let len1 = String.length n1 in
+    ((String.sub n2 0 len1) = n1) &&
+    (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 || s2 = "" then
+      s2
+    else
+      if f1 = s1 || 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
+    try
+      String.sub n2 (len1+1) ((String.length n2) - len1 - 1)
+    with
+      _ -> n2
+  else
+    n2
+
+let hide_given_modules l s =
+  let rec iter = function
+      [] -> s
+    | h :: q ->
+        let s2 = get_relative h s in
+        if s = s2 then
+          iter q
+        else
+          s2
+  in
+  iter l
+
+let qualified name = String.contains name '.'
+
+let from_ident ident = Ident.name ident
+
+
+let from_path path = Path.name path
+
+let to_path n =
+  match
+    List.fold_left
+      (fun acc_opt -> fun s ->
+        match acc_opt with
+          None -> Some (Path.Pident (Ident.create s))
+        | Some acc -> Some (Path.Pdot (acc, s, 0)))
+      None
+      (Str.split (Str.regexp "\\.") n)
+  with
+    None -> raise (Failure "to_path")
+  | Some p -> p
+
+let from_longident = Odoc_misc.string_of_longident
+
+module Set = Set.Make (struct
+  type z = t
+  type t = z
+  let compare = String.compare
+end)
diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli
new file mode 100644
index 00000000..2ca47a80
--- /dev/null
+++ b/ocamldoc/odoc_name.mli
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Representation of element names. *)
+
+type t = string
+
+(** Add parenthesis to the given simple name if needed. *)
+val parens_if_infix : t -> t
+
+(** Return a simple name from a name.*)
+val simple : t -> t
+
+(** Return the name of the 'father' (like dirname for a file name).*)
+val father : t -> t
+
+(** Concatenates two names. *)
+val concat : t -> t -> t
+
+(** Normalize the given name by removing the beginning and ending spaces
+     of the simple name and adding parenthesis if needed. *)
+val normalize_name : t -> t
+
+(** Returns the head of a name. *)
+val head : t -> t
+
+(** Returns the depth of the name, i.e. the numer of levels to the root.
+   Example : [Toto.Tutu.name] has depth 3. *)
+val depth : t -> int
+
+(** Returns true if the first name is a prefix of the second name.
+   If the two names are equals, then if is false (strict prefix).*)
+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 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. *)
+val qualified : t -> bool
+
+(** Get a name from an [Ident.t]. *)
+val from_ident : Ident.t -> t
+
+(** Get a name from a [Path.t]. *)
+val from_path : Path.t -> t
+
+(** Get a [Path.t] from a name.*)
+val to_path : t -> Path.t
+
+(** Get a name from a [Longident.t].*)
+val from_longident : Longident.t -> t
+
+(** Set of Name.t *)
+module Set : Set.S with type elt = t
diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll
new file mode 100644
index 00000000..76debf1e
--- /dev/null
+++ b/ocamldoc/odoc_ocamlhtml.mll
@@ -0,0 +1,552 @@
+{
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Generation of html code to display OCaml code. *)
+open Lexing
+
+exception Fatal_error
+
+let fatal_error msg =
+  prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error
+
+type error =
+  | Illegal_character of char
+  | Unterminated_comment
+  | Unterminated_string
+  | Unterminated_string_in_comment
+  | Keyword_as_label of string
+;;
+
+exception Error of error * int * int
+
+let base_escape_strings = [
+    ("&", "&") ;
+    ("<", "<") ;
+    (">", ">") ;
+]
+
+
+let prelike_escape_strings = [
+  (" ", " ") ;
+  ("\t", "        ") ;
+  ("\n", "<br>\n")
+]
+
+
+let pre = ref false
+let fmt = ref Format.str_formatter
+
+(** Escape the strings which would clash with html syntax,
+   and some other strings if we want to get a PRE style outside of
+   <pre> </pre>.*)
+let escape s =
+  let escape_strings =
+    if !pre then
+      base_escape_strings
+    else
+      base_escape_strings @ prelike_escape_strings in
+  List.fold_left
+    (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc)
+    s
+    escape_strings
+
+(** Escape the strings which would clash with html syntax. *)
+let escape_base s =
+  List.fold_left
+    (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc)
+    s
+    base_escape_strings
+
+(** The output functions *)
+
+let print ?(esc=true) s =
+  Format.pp_print_string !fmt (if esc then escape s else s)
+;;
+
+let print_class ?(esc=true) cl s =
+  print ~esc: false ("<span class=\""^cl^"\">"^
+                     (if esc then escape s else s)^
+                     "</span>")
+;;
+
+(** The table of keywords with colors *)
+let create_hashtable size init =
+  let tbl = Hashtbl.create size in
+  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
+  tbl
+
+(** The function used to return html code for the given comment body. *)
+let html_of_comment = ref
+    (fun (_ : string) -> "<b>Odoc_ocamlhtml.html_of_comment not initialized</b>")
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", "keyword" ;
+    "as", "keyword" ;
+    "assert", "keyword" ;
+    "begin", "keyword" ;
+    "class", "keyword" ;
+    "constraint", "keyword" ;
+    "do", "keyword" ;
+    "done", "keyword" ;
+    "downto", "keyword" ;
+    "else", "keyword" ;
+    "end", "keyword" ;
+    "exception", "keyword" ;
+    "external", "keyword" ;
+    "false", "keyword" ;
+    "for", "keyword" ;
+    "fun", "keyword" ;
+    "function", "keyword" ;
+    "functor", "keyword" ;
+    "if", "keyword" ;
+    "in", "keyword" ;
+    "include", "keyword" ;
+    "inherit", "keyword" ;
+    "initializer", "keyword" ;
+    "lazy", "keyword" ;
+    "let", "keyword" ;
+    "match", "keyword" ;
+    "method", "keyword" ;
+    "module", "keyword" ;
+    "mutable", "keyword" ;
+    "new", "keyword" ;
+    "object", "keyword" ;
+    "of", "keyword" ;
+    "open", "keyword" ;
+    "or", "keyword" ;
+    "parser", "keyword" ;
+    "private", "keyword" ;
+    "rec", "keyword" ;
+    "sig", "keyword" ;
+    "struct", "keyword" ;
+    "then", "keyword" ;
+    "to", "keyword" ;
+    "true", "keyword" ;
+    "try", "keyword" ;
+    "type", "keyword" ;
+    "val", "keyword" ;
+    "virtual", "keyword" ;
+    "when", "keyword" ;
+    "while", "keyword" ;
+    "with", "keyword" ;
+
+    "mod", "keyword" ;
+    "land", "keyword" ;
+    "lor", "keyword" ;
+    "lxor", "keyword" ;
+    "lsl", "keyword" ;
+    "lsr", "keyword" ;
+    "asr", "keyword" ;
+]
+
+let kwsign_class = "keywordsign"
+let constructor_class = "constructor"
+let comment_class = "comment"
+let string_class = "string"
+let code_class = "code"
+
+
+(** To buffer and print comments *)
+
+
+let margin = ref 0
+
+let comment_buffer = Buffer.create 32
+let reset_comment_buffer () = Buffer.reset comment_buffer
+let store_comment_char = Buffer.add_char comment_buffer
+let add_comment_string = Buffer.add_string comment_buffer
+
+let make_margin () =
+  let rec iter n =
+    if n <= 0 then ""
+    else " "^(iter (n-1))
+  in
+  iter !margin
+
+let print_comment () =
+  let s = Buffer.contents comment_buffer in
+  let len = String.length s in
+  let code =
+    if len < 1 then
+      "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>"
+    else
+      match s.[0] with
+        '*' ->
+          (
+           try
+             let html = !html_of_comment (String.sub s 1 (len-1)) in
+             "</code><table><tr><td>"^(make_margin ())^"</td><td>"^
+             "<span class=\""^comment_class^"\">"^
+             "(**"^html^"*)"^
+             "</span></td></tr></table><code class=\""^code_class^"\">"
+           with
+             e ->
+               prerr_endline (Printexc.to_string e);
+               "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>"
+          )
+      | _ ->
+          "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>"
+  in
+  print ~esc: false code
+
+(** To buffer string literals *)
+
+let string_buffer = Buffer.create 32
+let reset_string_buffer () = Buffer.reset string_buffer
+let store_string_char = Buffer.add_char string_buffer
+let get_stored_string () =
+  Buffer.contents string_buffer
+
+(** 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 =
+  let c = 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) in
+  Char.chr(c land 0xFF)
+
+let char_for_hexa_code lexbuf i =
+  let c = 16 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
+                (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) in
+  Char.chr(c land 0xFF)
+
+(** To store the position of the beginning of a string and comment *)
+let string_start_pos = ref 0;;
+let comment_start_pos = ref [];;
+let in_comment () = !comment_start_pos <> [];;
+
+(** Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Illegal_character c ->
+      fprintf ppf "Illegal character (%s)" (Char.escaped c)
+  | Unterminated_comment ->
+      fprintf ppf "Comment not terminated"
+  | Unterminated_string ->
+      fprintf ppf "String literal not terminated"
+  | Unterminated_string_in_comment ->
+      fprintf ppf "This comment contains an unterminated string literal"
+  | Keyword_as_label kwd ->
+      fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
+;;
+
+}
+
+let blank = [' ' '\010' '\013' '\009' '\012']
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let decimal_literal = ['0'-'9']+
+let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
+let oct_literal = '0' ['o' 'O'] ['0'-'7']+
+let bin_literal = '0' ['b' 'B'] ['0'-'1']+
+let float_literal =
+  ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+
+rule token = parse
+    blank
+      {
+        let s = Lexing.lexeme lexbuf in
+        (
+         match s with
+           " " -> incr margin
+         | "\t" -> margin := !margin + 8
+         | "\n" -> margin := 0
+         | _ -> ()
+        );
+        print s;
+        token lexbuf
+      }
+  | "_"
+      { print "_" ; token lexbuf }
+  | "~"  { print "~" ; token lexbuf }
+  | "~" lowercase identchar * ':'
+      { let s = Lexing.lexeme lexbuf in
+        let name = String.sub s 1 (String.length s - 2) in
+        if Hashtbl.mem keyword_table name then
+          raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
+                       Lexing.lexeme_end lexbuf));
+        print s ; token lexbuf }
+  | "?"  { print "?" ; token lexbuf }
+  | "?" lowercase identchar * ':'
+      { let s = Lexing.lexeme lexbuf in
+        let name = String.sub s 1 (String.length s - 2) in
+        if Hashtbl.mem keyword_table name then
+          raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
+                       Lexing.lexeme_end lexbuf));
+        print s ; token lexbuf }
+  | lowercase identchar *
+      { let s = Lexing.lexeme lexbuf in
+          try
+            let cl = Hashtbl.find keyword_table s in
+            (print_class cl s ; token lexbuf )
+          with Not_found ->
+            (print s ; token lexbuf )}
+  | uppercase identchar *
+      { print_class constructor_class (Lexing.lexeme lexbuf) ; token lexbuf }       (* No capitalized keywords *)
+  | decimal_literal | hex_literal | oct_literal | bin_literal
+      { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | float_literal
+      { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "\""
+      { reset_string_buffer();
+        let string_start = Lexing.lexeme_start lexbuf in
+        string_start_pos := string_start;
+        string lexbuf;
+        lexbuf.Lexing.lex_start_pos <-
+          string_start - lexbuf.Lexing.lex_abs_pos;
+        print_class string_class ("\""^(get_stored_string())^"\"") ;
+        token lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      { print_class string_class (Lexing.lexeme lexbuf) ;
+        token lexbuf }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { print_class string_class (Lexing.lexeme lexbuf ) ;
+        token lexbuf }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { print_class string_class (Lexing.lexeme lexbuf ) ;
+        token lexbuf }
+  | "(*"
+      {
+        reset_comment_buffer ();
+        comment_start_pos := [Lexing.lexeme_start lexbuf];
+        comment lexbuf ;
+        print_comment ();
+        token lexbuf }
+  | "(*)"
+      { reset_comment_buffer ();
+        comment_start_pos := [Lexing.lexeme_start lexbuf];
+        comment lexbuf ;
+        print_comment ();
+        token lexbuf
+      }
+  | "*)"
+      { 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
+          } ;
+        print (Lexing.lexeme lexbuf) ;
+        token lexbuf
+      }
+  | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
+      (* # linenum ...  *)
+      {
+        print (Lexing.lexeme lexbuf);
+        token lexbuf
+      }
+  | "#"  { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "&"  { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "&&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "`"  { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "'"  { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "("  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ")"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "*"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ","  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "??" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "->" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "."  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ".." { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ":"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "::" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ":=" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ":>" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ";"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ";;" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "<"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "<-" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "="  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "["  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "[|" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "[<" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "]"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "{"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "{<" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "|"  { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "||" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "|]" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ">"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ">]" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "}"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ">}" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+
+  | "!=" { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "+"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "-"  { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "-." { print (Lexing.lexeme lexbuf) ; token lexbuf }
+
+  | "!" symbolchar *
+            { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ['~' '?'] symbolchar +
+            { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar *
+            { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ['@' '^'] symbolchar *
+            { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ['+' '-'] symbolchar *
+            { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | "**" symbolchar *
+            { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | ['*' '/' '%'] symbolchar *
+            { print (Lexing.lexeme lexbuf) ; token lexbuf }
+  | eof { () }
+  | _
+      { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]),
+                     Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) }
+
+and comment = parse
+    "(*"
+      { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
+        store_comment_char '(';
+        store_comment_char '*';
+        comment lexbuf;
+      }
+  | "*)"
+      { match !comment_start_pos with
+        | [] -> assert false
+        | [_] -> comment_start_pos := []
+        | _ :: l ->
+            store_comment_char '*';
+            store_comment_char ')';
+            comment_start_pos := l;
+            comment lexbuf;
+       }
+(* These filters are useless
+  | "\""
+      { reset_string_buffer();
+        string_start_pos := Lexing.lexeme_start lexbuf;
+        store_comment_char '"';
+        begin
+          try string lexbuf; add_comment_string ((get_stored_string()^"\""))
+          with Error (Unterminated_string, _, _) ->
+          let st = List.hd !comment_start_pos in
+          raise (Error (Unterminated_string_in_comment, st, st + 2))
+        end;
+        comment lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      {
+        store_comment_char '\'';
+        store_comment_char (Lexing.lexeme_char lexbuf 1);
+        store_comment_char '\'';
+        comment lexbuf }
+  | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      {
+        store_comment_char '\'';
+        store_comment_char '\\';
+        store_comment_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)) ;
+        store_comment_char '\'';
+        comment lexbuf }
+  | "\\" ['0'-'9'] ['0'-'9'] ['0'-'9']
+      {
+        store_comment_char(char_for_decimal_code lexbuf 1);
+        comment lexbuf }
+  | "\\x" ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z']
+      {
+        store_comment_char(char_for_hexa_code lexbuf 2);
+        string lexbuf }
+  | "''"
+      {
+        store_comment_char '\'';
+        store_comment_char '\'';
+        comment lexbuf }
+*)
+  | eof
+      { let st = List.hd !comment_start_pos in
+        raise (Error (Unterminated_comment, st, st + 2));
+      }
+  | _
+      { store_comment_char(Lexing.lexeme_char lexbuf 0);
+        comment lexbuf }
+
+and string = parse
+    '"'
+      { () }
+  | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
+      { string lexbuf }
+  | '\\' ['\\' '"' 'n' 't' 'b' 'r' ]
+      { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ;
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      {
+        Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ;
+        string lexbuf
+      }
+  | '\\' 'x' ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z']
+      {  Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ;
+         string lexbuf }
+  | eof
+      { raise (Error (Unterminated_string,
+                      !string_start_pos, !string_start_pos+1)) }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        string lexbuf }
+{
+
+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
+  let old_string_buffer = Buffer.contents string_buffer in
+  let buf = Buffer.create 256 in
+  let old_fmt = !fmt in
+  fmt := Format.formatter_of_buffer buf ;
+  pre := with_pre;
+  margin := 0;
+
+  let start = "<code class=\""^code_class^"\">" in
+  let ending = "</code>" in
+  let html =
+    (
+     try
+       print ~esc: false start ;
+       let lexbuf = Lexing.from_string code in
+       token lexbuf;
+       print ~esc: false ending ;
+       Format.pp_print_flush !fmt () ;
+       Buffer.contents buf
+     with
+       _ ->
+         (* flush str_formatter because we already output
+            something in it *)
+         Format.pp_print_flush !fmt () ;
+         start^code^ending
+    )
+  in
+  pre := old_pre;
+  margin := old_margin ;
+  Buffer.reset comment_buffer;
+  Buffer.add_string comment_buffer old_comment_buffer ;
+  Buffer.reset string_buffer;
+  Buffer.add_string string_buffer old_string_buffer ;
+  fmt := old_fmt ;
+
+  Buffer.add_string b html
+
+}
diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml
new file mode 100644
index 00000000..6775b884
--- /dev/null
+++ b/ocamldoc/odoc_parameter.ml
@@ -0,0 +1,125 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Representation and manipulation of method / function / class parameters. *)
+
+let print_DEBUG s = print_string s ; print_newline ()
+
+(** Types *)
+
+(** Representation of a simple parameter name *)
+type simple_name = {
+    sn_name : string ;
+    sn_type : Types.type_expr ;
+    mutable sn_text : Odoc_types.text option ;
+  }
+
+(** Representation of parameter names. We need it to represent parameter names in tuples.
+   The value [Tuple ([], t)] stands for an anonymous parameter.*)
+type param_info =
+  | Simple_name of simple_name
+  | Tuple of param_info list * Types.type_expr
+
+(** A parameter is just a param_info.*)
+type parameter = param_info
+
+(** Functions *)
+
+(** acces to the name as a string. For tuples, parenthesis and commas are added. *)
+let complete_name p =
+  let rec iter pi =
+    match pi with
+      Simple_name sn ->
+        sn.sn_name
+    | Tuple ([], _) -> (* anonymous parameter *)
+        "??"
+    | Tuple (pi_list, _) ->
+        "("^(String.concat "," (List.map iter pi_list))^")"
+  in
+  iter p
+
+(** access to the complete type *)
+let typ pi =
+  match pi with
+    Simple_name sn -> sn.sn_type
+  | Tuple (_, typ) -> typ
+
+(** Update the text of a parameter using a function returning
+   the optional text associated to a parameter name.*)
+let update_parameter_text f p =
+  let rec iter pi =
+    match pi with
+      Simple_name sn ->
+        sn.sn_text <- f sn.sn_name
+    | Tuple (l, _) ->
+        List.iter iter l
+  in
+  iter p
+
+(** access to the description of a specific name.
+   @raise Not_found if no description is associated to the given name. *)
+let desc_by_name pi name =
+  let rec iter acc pi =
+    match pi with
+      Simple_name sn ->
+        (sn.sn_name, sn.sn_text) :: acc
+    | Tuple (pi_list, _) ->
+        List.fold_left iter acc pi_list
+      in
+  let l = iter [] pi in
+  List.assoc name l
+
+
+(** acces to the list of names ; only one for a simple parameter, or
+   a list for tuples. *)
+let names pi =
+  let rec iter acc pi =
+    match pi with
+      Simple_name sn ->
+        sn.sn_name :: acc
+    | Tuple (pi_list, _) ->
+            List.fold_left iter acc pi_list
+  in
+  iter [] pi
+
+(** access to the type of a specific name.
+   @raise Not_found if no type is associated to the given name. *)
+let type_by_name pi name =
+  let rec iter acc pi =
+    match pi with
+      Simple_name sn ->
+        (sn.sn_name, sn.sn_type) :: acc
+    | Tuple (pi_list, _) ->
+        List.fold_left iter acc pi_list
+      in
+  let l = iter [] pi in
+  List.assoc name l
+
+(** access to the optional description of a parameter name from an optional info structure.*)
+let desc_from_info_opt info_opt s =
+  print_DEBUG "desc_from_info_opt";
+  match info_opt with
+    None -> None
+  | Some i ->
+      match s with
+        "" -> None
+      | _ ->
+          try
+            Some (List.assoc s i.Odoc_types.i_params)
+          with
+            Not_found ->
+              print_DEBUG ("desc_from_info_opt "^s^" not found in\n");
+              List.iter (fun (s, _) -> print_DEBUG s) i.Odoc_types.i_params;
+              None
diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly
new file mode 100644
index 00000000..9c762b1d
--- /dev/null
+++ b/ocamldoc/odoc_parser.mly
@@ -0,0 +1,177 @@
+%{
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Odoc_comments_global
+
+let uppercase = "[A-Z\192-\214\216-\222]"
+let identchar =
+  "[A-Za-z_\192-\214\216-\246\248-\255'0-9]"
+let blank = "[ \010\013\009\012]"
+
+let print_DEBUG s = print_string s; print_newline ()
+%}
+
+%token <string * (string option)> Description
+
+%token <string> See_url
+%token <string> See_file
+%token <string> See_doc
+
+%token T_PARAM
+%token T_AUTHOR
+%token T_VERSION
+%token T_SEE
+%token T_SINCE
+%token T_BEFORE
+%token T_DEPRECATED
+%token T_RAISES
+%token T_RETURN
+%token <string> T_CUSTOM
+
+%token EOF
+
+%token <string> Desc
+
+/* Start Symbols */
+%start main info_part2 see_info
+%type <(string * (string option)) option> main
+%type <unit> info_part2
+%type <Odoc_types.see_ref * string> see_info
+
+
+%%
+see_info:
+  see_ref Desc { ($1, $2) }
+;
+
+see_ref:
+    See_url { Odoc_types.See_url $1 }
+| See_file { Odoc_types.See_file $1 }
+| See_doc { Odoc_types.See_doc $1 }
+;
+
+main:
+  Description { Some $1 }
+| EOF { None }
+;
+
+info_part2:
+  element_list EOF { () }
+;
+
+element_list:
+  element { () }
+| element element_list { () }
+;
+
+element:
+| param { () }
+| author { () }
+| version { () }
+| see { () }
+| since { () }
+| before { () }
+| deprecated { () }
+| raise_exc { () }
+| return { () }
+| custom { () }
+;
+
+param:
+    T_PARAM Desc
+    {
+      (* isolate the identificator *)
+      (* we only look for simple id, no pattern nor tuples *)
+      let s = $2 in
+      match Str.split (Str.regexp (blank^"+")) s with
+        []
+      | _ :: [] ->
+          raise (Failure "usage: @param id description")
+      | id :: _ ->
+          print_DEBUG ("Identificator "^id);
+          let reg = identchar^"+" in
+          print_DEBUG ("reg="^reg);
+          if Str.string_match (Str.regexp reg) id 0 then
+            let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in
+            print_DEBUG ("T_PARAM Desc remain="^remain);
+            let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in
+            params := !params @ [(id, remain2)]
+          else
+            raise (Failure (id^" is not a valid parameter identificator in \"@param "^s^"\""))
+    }
+;
+author:
+    T_AUTHOR Desc { authors := !authors @ [ $2 ] }
+;
+version:
+    T_VERSION Desc { version := Some $2 }
+;
+see:
+    T_SEE Desc { sees := !sees @ [$2] }
+;
+since:
+    T_SINCE Desc { since := Some $2 }
+;
+before:
+    T_BEFORE Desc
+    {
+      (* isolate the version name *)
+      let s = $2 in
+      match Str.split (Str.regexp (blank^"+")) s with
+        []
+      | _ :: [] ->
+          raise (Failure "usage: @before version description")
+      | id :: _ ->
+          print_DEBUG ("version "^id);
+            let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in
+            let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in
+            before := !before @ [(id, remain2)]
+    }
+;
+deprecated:
+    T_DEPRECATED Desc { deprecated := Some $2 }
+;
+raise_exc:
+    T_RAISES Desc
+    {
+      (* isolate the exception construtor name *)
+      let s = $2 in
+      match Str.split (Str.regexp (blank^"+")) s with
+        []
+      | _ :: [] ->
+          raise (Failure "usage: @raise Exception description")
+      | id :: _ ->
+          print_DEBUG ("exception "^id);
+          let reg = uppercase^identchar^"*"^"\\(\\."^uppercase^identchar^"*\\)*" in
+          print_DEBUG ("reg="^reg);
+          if Str.string_match (Str.regexp reg) id 0 then
+            let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in
+            let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in
+            raised_exceptions := !raised_exceptions @ [(id, remain2)]
+          else
+            raise (Failure (id^" is not a valid exception constructor in \"@raise "^s^"\""))
+    }
+;
+return:
+    T_RETURN Desc { return_value := Some $2 }
+;
+
+custom:
+    T_CUSTOM Desc { customs := !customs @ [($1, $2)] }
+;
+
+
+%%
diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
new file mode 100644
index 00000000..c07e7841
--- /dev/null
+++ b/ocamldoc/odoc_print.ml
@@ -0,0 +1,103 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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 outfuns = pp_get_formatter_out_functions type_fmt () in
+  pp_set_formatter_out_functions type_fmt
+    {outfuns with out_newline = fun () -> outfuns.out_string "\n  " 0 3}
+
+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.Mty_ident _
+    | Types.Mty_alias(_, _) -> t
+    | Types.Mty_signature _ ->
+        (
+         match code with
+           None -> Types.Mty_signature []
+         | Some s -> raise (Use_code s)
+        )
+    | Types.Mty_functor (id, mt1, mt2) ->
+        Types.Mty_functor (id, Misc.may_map 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.Cty_constr _ -> t
+    | Types.Cty_signature cs ->
+        (* we delete vals and methods in order to not print them when
+           displaying the type *)
+        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
+        Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with
+                                                  Types.desc = Types.Tobject (tnil, ref None) };
+                              csig_vars = Types.Vars.empty ;
+                              csig_concr = Types.Concr.empty ;
+                              csig_inher = []
+                             }
+    | Types.Cty_arrow (l, texp, ct) ->
+        let new_ct = iter ct in
+        Types.Cty_arrow (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
+  (* FIXME : my own Printtyp.class_type variant to avoid 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..f56d541e
--- /dev/null
+++ b/ocamldoc/odoc_print.mli
@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 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
new file mode 100644
index 00000000..7b5ba5dd
--- /dev/null
+++ b/ocamldoc/odoc_scan.ml
@@ -0,0 +1,190 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Scanning of modules and elements.
+
+   The class scanner defined in this module can be used to
+   develop generators which perform controls on the elements
+   and their comments.
+*)
+
+open Odoc_types
+
+(** Class which defines the scanning of a list of modules and their
+   elements. Inherit this class to develop your own scanner, by
+   overriding some methods.*)
+class scanner =
+  object (self)
+
+    method scan_value (_ : Odoc_value.t_value) = ()
+
+    method scan_type_pre (_ : Odoc_type.t_type) = true
+
+    method scan_type_recfield _t (_ : Odoc_type.record_field) = ()
+    method scan_type_const _t (_ : Odoc_type.variant_constructor) = ()
+    method scan_type (t : Odoc_type.t_type) =
+      if self#scan_type_pre t then
+        match t.Odoc_type.ty_kind with
+          Odoc_type.Type_abstract -> ()
+        | Odoc_type.Type_variant l -> List.iter (self#scan_type_const t) l
+        | Odoc_type.Type_record l -> List.iter (self#scan_type_recfield t) l
+        | Odoc_type.Type_open -> ()
+
+    method scan_extension_constructor (_ : Odoc_extension.t_extension_constructor) = ()
+    method scan_exception (_ : Odoc_exception.t_exception) = ()
+    method scan_attribute (_ : Odoc_value.t_attribute) = ()
+    method scan_method (_ : Odoc_value.t_method) = ()
+    method scan_included_module (_ : Odoc_module.included_module) = ()
+
+  (** Scan of a type extension *)
+
+    (** Overide this method to perform controls on the extension's type,
+        private and info. This method is called before scanning the
+        extensions's constructors.
+        @return true if the extension's constructors must be scanned.*)
+    method scan_type_extension_pre (_: Odoc_extension.t_type_extension) = true
+
+    (** This method scans the constructors of the given type extension. *)
+    method scan_type_extension_constructors (x: Odoc_extension.t_type_extension) =
+      List.iter self#scan_extension_constructor (Odoc_extension.extension_constructors x)
+
+    (** Scan of a type extension. Should not be overridden. It calls [scan_type_extension_pre]
+      and if [scan_type_extension_pre] returns [true], then it calls scan_type_extension_constructors.*)
+    method scan_type_extension (x: Odoc_extension.t_type_extension) =
+      if self#scan_type_extension_pre x then self#scan_type_extension_constructors x
+
+
+  (** Scan of a class. *)
+
+    (** Scan of a comment inside a class. *)
+    method scan_class_comment (_ : text) = ()
+
+    (** Override this method to perform controls on the class comment
+       and params. This method is called before scanning the class elements.
+       @return true if the class elements must be scanned.*)
+    method scan_class_pre (_ : Odoc_class.t_class) = true
+
+    (** This method scan the elements of the given class.
+       A VOIR : scan des classes heritees.*)
+    method scan_class_elements c =
+      List.iter
+        (fun ele ->
+          match ele with
+            Odoc_class.Class_attribute a -> self#scan_attribute a
+          | Odoc_class.Class_method m -> self#scan_method m
+          | Odoc_class.Class_comment t -> self#scan_class_comment t
+        )
+        (Odoc_class.class_elements c)
+
+    (** Scan of a class. Should not be overridden. It calls [scan_class_pre]
+      and if [scan_class_pre] returns [true], then it calls scan_class_elements.*)
+    method scan_class c = if self#scan_class_pre c then self#scan_class_elements c
+
+  (** Scan of a class type. *)
+
+    (** Scan of a comment inside a class type. *)
+    method scan_class_type_comment (_ : text) = ()
+
+    (** Override this method to perform controls on the class type comment
+       and form. This method is called before scanning the class type elements.
+       @return true if the class type elements must be scanned.*)
+    method scan_class_type_pre (_ : Odoc_class.t_class_type) = true
+
+    (** This method scan the elements of the given class type.
+       A VOIR : scan des classes heritees.*)
+    method scan_class_type_elements ct =
+      List.iter
+        (fun ele ->
+          match ele with
+            Odoc_class.Class_attribute a -> self#scan_attribute a
+          | Odoc_class.Class_method m -> self#scan_method m
+          | Odoc_class.Class_comment t -> self#scan_class_type_comment t
+        )
+        (Odoc_class.class_type_elements ct)
+
+    (** Scan of a class type. Should not be overridden. It calls [scan_class_type_pre]
+      and if [scan_class_type_pre] returns [true], then it calls scan_class_type_elements.*)
+    method scan_class_type ct = if self#scan_class_type_pre ct then self#scan_class_type_elements ct
+
+  (** Scan of modules. *)
+
+    (** Scan of a comment inside a module. *)
+    method scan_module_comment (_ : text) = ()
+
+    (** Override this method to perform controls on the module comment
+       and form. This method is called before scanning the module elements.
+       @return true if the module elements must be scanned.*)
+    method scan_module_pre (_ : Odoc_module.t_module) = true
+
+    (** This method scan the elements of the given module. *)
+    method scan_module_elements m =
+      List.iter
+        (fun ele ->
+          match ele with
+            Odoc_module.Element_module m -> self#scan_module m
+          | Odoc_module.Element_module_type mt -> self#scan_module_type mt
+          | Odoc_module.Element_included_module im -> self#scan_included_module im
+          | Odoc_module.Element_class c -> self#scan_class c
+          | Odoc_module.Element_class_type ct -> self#scan_class_type ct
+          | Odoc_module.Element_value v -> self#scan_value v
+          | Odoc_module.Element_type_extension x -> self#scan_type_extension x
+          | Odoc_module.Element_exception e -> self#scan_exception e
+          | Odoc_module.Element_type t -> self#scan_type t
+          | Odoc_module.Element_module_comment t -> self#scan_module_comment t
+        )
+        (Odoc_module.module_elements m)
+
+    (** Scan of a module. Should not be overridden. It calls [scan_module_pre]
+      and if [scan_module_pre] returns [true], then it calls scan_module_elements.*)
+    method scan_module m = if self#scan_module_pre m then self#scan_module_elements m
+
+  (** Scan of module types. *)
+
+    (** Scan of a comment inside a module type. *)
+    method scan_module_type_comment (_ : text) = ()
+
+    (** Override this method to perform controls on the module type comment
+       and form. This method is called before scanning the module type elements.
+       @return true if the module type elements must be scanned. *)
+    method scan_module_type_pre (_ : Odoc_module.t_module_type) = true
+
+    (** This method scan the elements of the given module type. *)
+    method scan_module_type_elements mt =
+      List.iter
+        (fun ele ->
+          match ele with
+            Odoc_module.Element_module m -> self#scan_module m
+          | Odoc_module.Element_module_type mt -> self#scan_module_type mt
+          | Odoc_module.Element_included_module im -> self#scan_included_module im
+          | Odoc_module.Element_class c -> self#scan_class c
+          | Odoc_module.Element_class_type ct -> self#scan_class_type ct
+          | Odoc_module.Element_value v -> self#scan_value v
+          | Odoc_module.Element_type_extension x -> self#scan_type_extension x
+          | Odoc_module.Element_exception e -> self#scan_exception e
+          | Odoc_module.Element_type t -> self#scan_type t
+          | Odoc_module.Element_module_comment t -> self#scan_module_comment t
+        )
+        (Odoc_module.module_type_elements mt)
+
+    (** Scan of a module type. Should not be overridden. It calls [scan_module_type_pre]
+      and if [scan_module_type_pre] returns [true], then it calls scan_module_type_elements.*)
+    method scan_module_type mt =
+      if self#scan_module_type_pre mt then self#scan_module_type_elements mt
+
+  (** Main scanning method. *)
+
+    (** Scan a list of modules. *)
+    method scan_module_list l = List.iter self#scan_module l
+  end
diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
new file mode 100644
index 00000000..530000bc
--- /dev/null
+++ b/ocamldoc/odoc_search.ml
@@ -0,0 +1,747 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Research of elements through modules. *)
+
+open Odoc_value
+open Odoc_type
+open Odoc_extension
+open Odoc_exception
+open Odoc_class
+open Odoc_module
+
+type result_element =
+    Res_module of t_module
+  | Res_module_type of t_module_type
+  | Res_class of t_class
+  | Res_class_type of t_class_type
+  | Res_value of t_value
+  | Res_type of t_type
+  | Res_extension of t_extension_constructor
+  | Res_exception of t_exception
+  | Res_attribute of t_attribute
+  | Res_method of t_method
+  | Res_section of string * Odoc_types.text
+  | Res_recfield of t_type * record_field
+  | Res_const of t_type * variant_constructor
+
+type result = result_element list
+
+module type Predicates =
+  sig
+    type t
+    val p_module : t_module -> t -> bool * bool
+    val p_module_type : t_module_type -> t -> bool * bool
+    val p_class : t_class -> t -> bool * bool
+    val p_class_type : t_class_type -> t -> bool * bool
+    val p_value : t_value -> t -> bool
+    val p_recfield : t_type -> record_field -> t -> bool
+    val p_const : t_type -> variant_constructor -> t -> bool
+    val p_type : t_type -> t -> (bool * bool)
+    val p_extension : t_extension_constructor -> t -> bool
+    val p_exception : t_exception -> t -> bool
+    val p_attribute : t_attribute -> t -> bool
+    val p_method : t_method -> t -> bool
+    val p_section : string -> t -> bool
+  end
+
+module Search =
+  functor (P : Predicates) ->
+  struct
+    let search_section t s v = if P.p_section s v then [Res_section (s,t)] else []
+
+    let rec search_text root t v =
+      List.flatten (List.map (fun e -> search_text_ele root e v) t)
+
+    and search_text_ele root e v =
+      let module T = Odoc_types in
+      match e with
+      | T.Raw _
+      | T.Code _
+      | T.CodePre _
+      | T.Latex _
+      | T.Verbatim _
+      | T.Ref (_, _, _) -> []
+      | T.Bold t
+      | T.Italic t
+      | T.Center t
+      | T.Left t
+      | T.Right t
+      | T.Emphasize t
+      | T.Block t
+      | T.Superscript t
+      | T.Subscript t
+      | T.Custom (_,t)
+      | 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.Module_list _
+      | T.Index_list -> []
+      | T.Target _ -> []
+      | T.Title (_, l_opt, t) ->
+          (match l_opt with
+            None -> []
+          | Some s -> search_section t (Name.concat root s) v) @
+          (search_text root t v)
+
+    let search_value va v = if P.p_value va v then [Res_value va] else []
+
+    let search_recfield t f v =
+      if P.p_recfield t f v then [Res_recfield (t,f)] else []
+
+    let search_const t f v =
+      if P.p_const t f v then [Res_const (t,f)] else []
+
+    let search_type t v =
+      let (go_deeper, ok) = P.p_type t v in
+      let l =
+        match go_deeper with
+          false -> []
+        | true ->
+            match t.ty_kind with
+              Type_abstract -> []
+            | Type_record l ->
+                List.flatten (List.map (fun rf -> search_recfield t rf v) l)
+            | Type_variant l ->
+                List.flatten (List.map (fun rf -> search_const t rf v) l)
+            | Type_open -> []
+      in
+      if ok then (Res_type t) :: l else l
+
+    let search_extension_constructor xt v =
+      if P.p_extension xt v then [Res_extension xt] else []
+
+    let search_type_extension te v =
+      List.fold_left
+        (fun acc -> fun xt -> acc @ (search_extension_constructor xt v))
+        []
+        (Odoc_extension.extension_constructors te)
+
+    let search_exception e v = if P.p_exception e v then [Res_exception e] else []
+
+    let search_attribute a v = if P.p_attribute a v then [Res_attribute a] else []
+
+    let search_method m v = if P.p_method m v then [Res_method m] else []
+
+    let search_class c v =
+      let (go_deeper, ok) = P.p_class c v in
+      let l =
+        if go_deeper then
+          let res_att =
+            List.fold_left
+              (fun acc -> fun att -> acc @ (search_attribute att v))
+              []
+              (Odoc_class.class_attributes c)
+          in
+          let res_met =
+            List.fold_left
+              (fun acc -> fun m -> acc @ (search_method m v))
+              []
+              (Odoc_class.class_methods c)
+          in
+          let res_sec =
+            List.fold_left
+              (fun acc -> fun t -> acc @ (search_text c.cl_name t v))
+              []
+              (Odoc_class.class_comments c)
+          in
+          res_att @ res_met @ res_sec
+        else
+          []
+      in
+      if ok then
+        (Res_class c) :: l
+      else
+        l
+
+    let search_class_type ct v =
+      let (go_deeper, ok) = P.p_class_type ct v in
+      let l =
+        if go_deeper then
+          let res_att =
+            List.fold_left
+              (fun acc -> fun att -> acc @ (search_attribute att v))
+              []
+              (Odoc_class.class_type_attributes ct)
+          in
+          let res_met =
+            List.fold_left
+              (fun acc -> fun m -> acc @ (search_method m v))
+              []
+              (Odoc_class.class_type_methods ct)
+          in
+          let res_sec =
+            List.fold_left
+              (fun acc -> fun t -> acc @ (search_text ct.clt_name t v))
+              []
+              (Odoc_class.class_type_comments ct)
+          in
+          res_att @ res_met @ res_sec
+        else
+          []
+      in
+      if ok then
+        (Res_class_type ct) :: l
+      else
+        l
+
+    let rec search_module_type mt v =
+      let (go_deeper, ok) =  P.p_module_type mt v in
+      let l =
+        if go_deeper then
+          let res_val =
+            List.fold_left
+              (fun acc -> fun va -> acc @ (search_value va v))
+              []
+              (Odoc_module.module_type_values mt)
+          in
+          let res_typ =
+            List.fold_left
+              (fun acc -> fun t -> acc @ (search_type t v))
+              []
+              (Odoc_module.module_type_types mt)
+          in
+          let res_ext =
+            List.fold_left
+              (fun acc -> fun te -> acc @ (search_type_extension te v))
+              []
+              (Odoc_module.module_type_type_extensions mt)
+          in
+          let res_exc =
+            List.fold_left
+              (fun acc -> fun e -> acc @ (search_exception e v))
+              []
+              (Odoc_module.module_type_exceptions mt)
+          in
+          let res_mod = search (Odoc_module.module_type_modules mt) v in
+          let res_modtyp =
+            List.fold_left
+              (fun acc -> fun mt -> acc @ (search_module_type mt v))
+              []
+              (Odoc_module.module_type_module_types mt)
+          in
+          let res_cl =
+            List.fold_left
+              (fun acc -> fun cl -> acc @ (search_class cl v))
+              []
+              (Odoc_module.module_type_classes mt)
+          in
+          let res_cltyp =
+            List.fold_left
+              (fun acc -> fun clt -> acc @ (search_class_type clt v))
+              []
+              (Odoc_module.module_type_class_types mt)
+          in
+          let res_sec =
+            List.fold_left
+              (fun acc -> fun t -> acc @ (search_text mt.mt_name t v))
+              []
+              (Odoc_module.module_type_comments mt)
+          in
+          res_val @ res_typ @ res_ext @ res_exc @ res_mod @
+            res_modtyp @ res_cl @ res_cltyp @ res_sec
+        else
+          []
+      in
+      if ok then
+        (Res_module_type mt) :: l
+      else
+        l
+
+    and search_module m v =
+      let (go_deeper, ok) =  P.p_module m v in
+      let l =
+        if go_deeper then
+          let res_val =
+            List.fold_left
+              (fun acc -> fun va -> acc @ (search_value va v))
+              []
+              (Odoc_module.module_values m)
+          in
+          let res_typ =
+            List.fold_left
+              (fun acc -> fun t -> acc @ (search_type t v))
+              []
+              (Odoc_module.module_types m)
+          in
+          let res_ext =
+            List.fold_left
+              (fun acc -> fun te -> acc @ (search_type_extension te v))
+              []
+              (Odoc_module.module_type_extensions m)
+          in
+          let res_exc =
+            List.fold_left
+              (fun acc -> fun e -> acc @ (search_exception e v))
+              []
+              (Odoc_module.module_exceptions m)
+          in
+          let res_mod = search (Odoc_module.module_modules m) v in
+          let res_modtyp =
+            List.fold_left
+              (fun acc -> fun mt -> acc @ (search_module_type mt v))
+              []
+              (Odoc_module.module_module_types m)
+          in
+          let res_cl =
+            List.fold_left
+              (fun acc -> fun cl -> acc @ (search_class cl v))
+              []
+              (Odoc_module.module_classes m)
+          in
+          let res_cltyp =
+            List.fold_left
+              (fun acc -> fun clt -> acc @ (search_class_type clt v))
+              []
+              (Odoc_module.module_class_types m)
+          in
+          let res_sec =
+            List.fold_left
+              (fun acc -> fun t -> acc @ (search_text m.m_name t v))
+              []
+              (Odoc_module.module_comments m)
+          in
+          res_val @ res_typ @ res_ext @ res_exc @ res_mod @
+            res_modtyp @ res_cl @ res_cltyp @ res_sec
+        else
+          []
+      in
+      if ok then
+        (Res_module m) :: l
+      else
+        l
+
+    and search module_list v =
+      List.fold_left
+        (fun acc -> fun m ->
+          List.fold_left
+            (fun acc2 -> fun ele ->
+              if List.mem ele acc2 then acc2 else acc2 @ [ele]
+            )
+            acc
+            (search_module m v)
+        )
+        []
+        module_list
+  end
+
+module P_name =
+  struct
+    type t = Str.regexp
+    let (=~) name regexp = Str.string_match regexp name 0
+    let p_module m r = (true, m.m_name =~ r)
+    let p_module_type mt r = (true, mt.mt_name =~ r)
+    let p_class c r = (true, c.cl_name =~ r)
+    let p_class_type ct r = (true, ct.clt_name =~ r)
+    let p_value v r = v.val_name =~ r
+    let p_recfield t f r =
+      let name = Printf.sprintf "%s.%s" t.ty_name f.rf_name in
+      name =~ r
+    let p_const t f r =
+      let name = Printf.sprintf "%s.%s" t.ty_name f.vc_name in
+      name =~ r
+    let p_type t r = (true, t.ty_name =~ r)
+    let p_extension x r = x.xt_name =~ r
+    let p_exception e r = e.ex_name =~ r
+    let p_attribute a r = a.att_value.val_name =~ r
+    let p_method m r = m.met_value.val_name =~ r
+    let p_section s r = s =~ r
+  end
+
+module Search_by_name = Search ( P_name )
+
+module P_values =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = true
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_values = Search ( P_values )
+let values l =
+  let l_ele = Search_values.search l () in
+  let p v1 v2 = v1.val_name = v2.val_name in
+  let rec iter acc = function
+      (Res_value v) :: q -> if List.exists (p v) acc then iter acc q else iter (v :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_extensions =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = true
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_extensions = Search ( P_extensions )
+let extensions l =
+  let l_ele = Search_extensions.search l () in
+  let p x1 x2 = x1.xt_name = x2.xt_name in
+  let rec iter acc = function
+      (Res_extension x) :: q -> if List.exists (p x) acc then iter acc q else iter (x :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_exceptions =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = true
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_exceptions = Search ( P_exceptions )
+let exceptions l =
+  let l_ele = Search_exceptions.search l () in
+  let p e1 e2 = e1.ex_name = e2.ex_name in
+  let rec iter acc = function
+      (Res_exception t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_types =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, true)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_types = Search ( P_types )
+let types l =
+  let l_ele = Search_types.search l () in
+  let p t1 t2 = t1.ty_name = t2.ty_name in
+  let rec iter acc = function
+      (Res_type t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_attributes =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (true, false)
+    let p_class_type _ _ = (true, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = true
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_attributes = Search ( P_attributes )
+let attributes l =
+  let l_ele = Search_attributes.search l () in
+  let p a1 a2 = a1.att_value.val_name = a2.att_value.val_name in
+  let rec iter acc = function
+      (Res_attribute t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_methods =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (true, false)
+    let p_class_type _ _ = (true, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = true
+    let p_section _ _ = true
+  end
+module Search_methods = Search ( P_methods )
+let methods l =
+  let l_ele = Search_methods.search l () in
+  let p m1 m2 = m1.met_value.val_name = m2.met_value.val_name in
+  let rec iter acc = function
+      (Res_method t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_classes =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, true)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_classes = Search ( P_classes )
+let classes l =
+  let l_ele = Search_classes.search l () in
+  let p c1 c2 = c1.cl_name = c2.cl_name in
+  let rec iter acc = function
+      (Res_class c) :: q -> if List.exists (p c) acc then iter acc q else iter (c :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_class_types =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, true)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_class_types = Search ( P_class_types )
+let class_types l =
+  let l_ele = Search_class_types.search l () in
+  let p c1 c2 = c1.clt_name = c2.clt_name in
+  let rec iter acc = function
+      (Res_class_type c) :: q -> if List.exists (p c) acc then iter acc q else iter (c :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_modules =
+  struct
+    type t = unit
+    let p_module _ _ = (true, true)
+    let p_module_type _ _ = (true, false)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_modules = Search ( P_modules )
+let modules l =
+  let l_ele = Search_modules.search l () in
+  let p m1 m2 = m1.m_name = m2.m_name in
+  let rec iter acc = function
+      (Res_module m) :: q -> if List.exists (p m) acc then iter acc q else iter (m :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+module P_module_types =
+  struct
+    type t = unit
+    let p_module _ _ = (true, false)
+    let p_module_type _ _ = (true, true)
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
+    let p_extension _ _ = false
+    let p_exception _ _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
+  end
+module Search_module_types = Search ( P_module_types )
+let module_types l =
+  let l_ele = Search_module_types.search l () in
+  let p m1 m2 = m1.mt_name = m2.mt_name in
+  let rec iter acc = function
+      (Res_module_type m) :: q -> if List.exists (p m) acc then iter acc q else iter (m :: acc) q
+    | _ :: q -> iter acc q
+    | [] -> acc
+  in
+  iter [] l_ele
+
+let type_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_type _ -> true
+      | _ -> false
+    )
+    l
+
+let value_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_value _ -> true
+      | _ -> false
+    )
+    l
+
+let class_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_class _ -> true
+      | _ -> false
+    )
+    l
+
+let class_type_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_class_type _ -> true
+      | _ -> false
+    )
+    l
+
+let module_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_module _ -> true
+      | _ -> false
+    )
+    l
+
+let module_type_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_module_type _ -> true
+      | _ -> false
+    )
+    l
+
+let extension_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_extension _ -> true
+      | _ -> false
+    )
+    l
+
+let exception_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_exception _ -> true
+      | _ -> false
+    )
+    l
+
+let attribute_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_attribute _ -> true
+      | _ -> false
+    )
+    l
+
+let method_exists mods regexp =
+  let l = Search_by_name.search mods regexp in
+  List.exists
+    (function
+        Res_method _ -> true
+      | _ -> false
+    )
+    l
+
+let find_section mods regexp =
+  let l = Search_by_name.search mods regexp in
+  match
+    List.find
+      (function
+          Res_section _ -> true
+        | _ -> false
+      )
+      l
+  with
+    Res_section (_,t) -> t
+  | _ -> assert false
diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli
new file mode 100644
index 00000000..a4681c60
--- /dev/null
+++ b/ocamldoc/odoc_search.mli
@@ -0,0 +1,242 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Research of elements through modules. *)
+
+(** The type for an element of the result of a research. *)
+type result_element =
+    Res_module of Odoc_module.t_module
+  | Res_module_type of Odoc_module.t_module_type
+  | Res_class of Odoc_class.t_class
+  | Res_class_type of Odoc_class.t_class_type
+  | Res_value of Odoc_value.t_value
+  | Res_type of Odoc_type.t_type
+  | Res_extension of Odoc_extension.t_extension_constructor
+  | Res_exception of Odoc_exception.t_exception
+  | Res_attribute of Odoc_value.t_attribute
+  | Res_method of Odoc_value.t_method
+  | Res_section of string * Odoc_types.text
+  | Res_recfield of  Odoc_type.t_type * Odoc_type.record_field
+  | Res_const of  Odoc_type.t_type * Odoc_type.variant_constructor
+
+(** The type representing a research result.*)
+type result = result_element list
+
+(** The type of modules which contain the predicates used during the research.
+   Some functions return a couple of booleans ; the first indicates if we
+   must go deeper in the analysed element, the second if the element satisfies
+   the predicate.
+*)
+module type Predicates =
+  sig
+    type t
+    val p_module : Odoc_module.t_module -> t -> bool * bool
+    val p_module_type : Odoc_module.t_module_type -> t -> bool * bool
+    val p_class : Odoc_class.t_class -> t -> bool * bool
+    val p_class_type : Odoc_class.t_class_type -> t -> bool * bool
+    val p_value : Odoc_value.t_value -> t -> bool
+    val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> t -> bool
+    val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> t -> bool
+    val p_type : Odoc_type.t_type -> t -> (bool * bool)
+    val p_extension :
+      Odoc_extension.t_extension_constructor -> t -> bool
+    val p_exception : Odoc_exception.t_exception -> t -> bool
+    val p_attribute : Odoc_value.t_attribute -> t -> bool
+    val p_method : Odoc_value.t_method -> t -> bool
+    val p_section : string -> t -> bool
+  end
+
+(** Search for elements verifying the predicates in the module in parameter.*)
+module Search :
+  functor (P : Predicates) ->
+    sig
+      (** search in a section title *)
+      val search_section : Odoc_types.text -> string -> P.t -> result_element list
+
+      (** search in a value *)
+      val search_value : Odoc_value.t_value -> P.t -> result_element list
+
+      (** search in a record field *)
+      val search_recfield :
+        Odoc_type.t_type -> Odoc_type.record_field -> P.t -> result_element list
+
+      (** search in a variant constructor *)
+      val search_const :
+        Odoc_type.t_type -> Odoc_type.variant_constructor -> P.t -> result_element list
+
+      (** search in a type *)
+      val search_type : Odoc_type.t_type -> P.t -> result_element list
+
+      (** search in an extension constructor *)
+      val search_extension_constructor :
+          Odoc_extension.t_extension_constructor -> P.t -> result_element list
+
+      (** search in a type extension *)
+      val search_type_extension :
+          Odoc_extension.t_type_extension -> P.t -> result_element list
+
+      (** search in an exception *)
+      val search_exception :
+          Odoc_exception.t_exception -> P.t -> result_element list
+
+      (** search in an attribute *)
+      val search_attribute :
+          Odoc_value.t_attribute -> P.t -> result_element list
+
+      (** search in a method *)
+      val search_method : Odoc_value.t_method -> P.t -> result_element list
+
+      (** search in a class *)
+      val search_class : Odoc_class.t_class -> P.t -> result_element list
+
+      (** search in a class type *)
+      val search_class_type :
+          Odoc_class.t_class_type -> P.t -> result_element list
+
+      (** search in a module type *)
+      val search_module_type :
+          Odoc_module.t_module_type -> P.t -> result_element list
+
+      (** search in a module *)
+      val search_module : Odoc_module.t_module -> P.t -> result_element list
+
+      (** search in a list of modules *)
+      val search : Odoc_module.t_module list -> P.t -> result_element list
+    end
+
+(** A module of predicates to search elements by name (and accepting regexps).*)
+module P_name :
+  sig
+    type t = Str.regexp
+    val ( =~ ) : string -> Str.regexp -> bool
+    val p_module : Odoc_module.t_module -> Str.regexp -> bool * bool
+    val p_module_type :
+      Odoc_module.t_module_type -> Str.regexp -> bool * bool
+    val p_class : Odoc_class.t_class -> Str.regexp -> bool * bool
+    val p_class_type : Odoc_class.t_class_type -> Str.regexp -> bool * bool
+    val p_value : Odoc_value.t_value -> Str.regexp -> bool
+    val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> Str.regexp -> bool
+    val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> Str.regexp -> bool
+    val p_type : Odoc_type.t_type -> Str.regexp -> (bool * bool)
+    val p_extension :
+      Odoc_extension.t_extension_constructor -> Str.regexp -> bool
+    val p_exception : Odoc_exception.t_exception -> Str.regexp -> bool
+    val p_attribute : Odoc_value.t_attribute -> Str.regexp -> bool
+    val p_method : Odoc_value.t_method -> Str.regexp -> bool
+  end
+
+(** A module to search elements by name. *)
+module Search_by_name :
+  sig
+    val search_section : Odoc_types.text -> string -> P_name.t -> result_element list
+    val search_value : Odoc_value.t_value -> P_name.t -> result_element list
+    val search_recfield : Odoc_type.t_type -> Odoc_type.record_field -> P_name.t -> result_element list
+    val search_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> P_name.t -> result_element list
+    val search_type : Odoc_type.t_type -> P_name.t -> result_element list
+    val search_extension_constructor :
+      Odoc_extension.t_extension_constructor -> P_name.t -> result_element list
+    val search_type_extension :
+      Odoc_extension.t_type_extension -> P_name.t -> result_element list
+    val search_exception :
+      Odoc_exception.t_exception -> P_name.t -> result_element list
+    val search_attribute :
+      Odoc_value.t_attribute -> P_name.t -> result_element list
+    val search_method :
+      Odoc_value.t_method -> P_name.t -> result_element list
+    val search_class : Odoc_class.t_class -> P_name.t -> result_element list
+    val search_class_type :
+      Odoc_class.t_class_type -> P_name.t -> result_element list
+    val search_module_type :
+      Odoc_module.t_module_type -> P_name.t -> result_element list
+    val search_module :
+      Odoc_module.t_module -> P_name.t -> result_element list
+    val search : Odoc_module.t_module list -> P_name.t -> result_element list
+  end
+
+(** A function to search all the values in a list of modules. *)
+val values : Odoc_module.t_module list -> Odoc_value.t_value list
+
+(** A function to search all the extension constructors in a list of modules. *)
+val extensions :
+  Odoc_module.t_module list -> Odoc_extension.t_extension_constructor list
+
+(** A function to search all the exceptions in a list of modules. *)
+val exceptions : Odoc_module.t_module list -> Odoc_exception.t_exception list
+
+(** A function to search all the types in a list of modules. *)
+val types : Odoc_module.t_module list -> Odoc_type.t_type list
+
+(** A function to search all the class attributes in a list of modules. *)
+val attributes : Odoc_module.t_module list -> Odoc_value.t_attribute list
+
+(** A function to search all the class methods in a list of modules. *)
+val methods : Odoc_module.t_module list -> Odoc_value.t_method list
+
+(** A function to search all the classes in a list of modules. *)
+val classes : Odoc_module.t_module list -> Odoc_class.t_class list
+
+(** A function to search all the class types in a list of modules. *)
+val class_types : Odoc_module.t_module list -> Odoc_class.t_class_type list
+
+(** A function to search all the modules in a list of modules. *)
+val modules : Odoc_module.t_module list -> Odoc_module.t_module list
+
+(** A function to search all the module types in a list of modules. *)
+val module_types : Odoc_module.t_module list -> Odoc_module.t_module_type list
+
+(** Return [true] if a type with the given complete name (regexp) exists
+   in the given module list.*)
+val type_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a value with the given complete name (regexp) exists
+   in the given module list.*)
+val value_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a module with the given complete name (regexp) exists
+   in the given module list.*)
+val module_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a module type with the given complete name (regexp) exists
+   in the given module list.*)
+val module_type_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a class with the given complete name (regexp) exists
+   in the given module list.*)
+val class_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a class type  with the given complete name (regexp) exists
+   in the given module list.*)
+val class_type_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if an extension with the given complete name (regexp) exists
+   in the given module list.*)
+val extension_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a exception with the given complete name (regexp) exists
+   in the given module list.*)
+val exception_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if an attribute with the given complete name (regexp) exists
+   in the given module list.*)
+val attribute_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return [true] if a method with the given complete name (regexp) exists
+   in the given module list.*)
+val method_exists : Odoc_module.t_module list -> Str.regexp -> bool
+
+(** Return the [text] of the section with the given complete name (regexp)
+   in the given module list.
+   @raise Not_found if the section was not found.*)
+val find_section : Odoc_module.t_module list -> Str.regexp -> Odoc_types.text
diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll
new file mode 100644
index 00000000..1962d50d
--- /dev/null
+++ b/ocamldoc/odoc_see_lexer.mll
@@ -0,0 +1,103 @@
+{
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let print_DEBUG2 s = print_string s ; print_newline ()
+
+(** the lexer for special comments. *)
+
+open Odoc_parser
+
+let buf = Buffer.create 32
+
+}
+
+rule main = parse
+  [' ' '\013' '\009' '\012'] +
+  {
+    print_DEBUG2 "[' ' '\013' '\009' '\012'] +";
+    main lexbuf
+  }
+
+  | [ '\010' ]
+      {
+        print_DEBUG2 " [ '\010' ] ";
+        main lexbuf
+      }
+
+  | "<"
+      {
+        print_DEBUG2 "call url lexbuf" ;
+        url lexbuf
+      }
+
+  | "\""
+      {
+        print_DEBUG2 "call doc lexbuf" ;
+        doc lexbuf
+      }
+
+
+  | '\''
+      {
+        print_DEBUG2 "call file lexbuf" ;
+        file lexbuf
+      }
+
+  | eof
+      {
+        print_DEBUG2 "EOF";
+        EOF
+      }
+
+  | _
+      {
+        Buffer.reset buf ;
+        Buffer.add_string buf (Lexing.lexeme lexbuf);
+        desc lexbuf
+      }
+
+and url = parse
+  | ([^'>'] | '\n')+">"
+      {
+        let s = Lexing.lexeme lexbuf in
+        print_DEBUG2 ("([^'>'] | '\n')+ \">\" with "^s) ;
+        See_url (String.sub s 0 ((String.length s) -1))
+      }
+
+
+and doc = parse
+  | ([^'"'] | '\n' | "\\'")* "\""
+      {
+        let s = Lexing.lexeme lexbuf in
+        See_doc (String.sub s 0 ((String.length s) -1))
+      }
+
+and file = parse
+  | ([^'\''] | '\n' | "\\\"")* "'"
+      {
+        let s = Lexing.lexeme lexbuf in
+        See_file (String.sub s 0 ((String.length s) -1))
+      }
+
+
+and desc = parse
+    eof
+      { Desc (Buffer.contents buf) }
+  | _
+      {
+        Buffer.add_string buf (Lexing.lexeme lexbuf);
+        desc lexbuf
+      }
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
new file mode 100644
index 00000000..5bc67b80
--- /dev/null
+++ b/ocamldoc/odoc_sig.ml
@@ -0,0 +1,1651 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Analysis of interface files. *)
+
+open Misc
+open Asttypes
+open Types
+
+let print_DEBUG s = print_string s ; print_newline ();;
+
+open Odoc_parameter
+open Odoc_value
+open Odoc_type
+open Odoc_extension
+open Odoc_exception
+open Odoc_class
+open Odoc_module
+open Odoc_types
+
+module Signature_search =
+  struct
+    type ele =
+      | M of string
+      | MT of string
+      | V of string
+      | T of string
+      | C of string
+      | CT of string
+      | X of string
+
+    type tab = (ele, Types.signature_item) Hashtbl.t
+
+    let add_to_hash table signat =
+      match signat with
+        Types.Sig_value (ident, _) ->
+          Hashtbl.add table (V (Name.from_ident ident)) signat
+      | Types.Sig_typext (ident, _, _) ->
+          Hashtbl.add table (X (Name.from_ident ident)) signat
+      | Types.Sig_type (ident, _, _) ->
+          Hashtbl.add table (T (Name.from_ident ident)) signat
+      | Types.Sig_class (ident, _, _) ->
+          Hashtbl.add table (C (Name.from_ident ident)) signat
+      | Types.Sig_class_type (ident, _, _) ->
+          Hashtbl.add table (CT (Name.from_ident ident)) signat
+      | Types.Sig_module (ident, _, _) ->
+          Hashtbl.add table (M (Name.from_ident ident)) signat
+      | Types.Sig_modtype (ident,_) ->
+          Hashtbl.add table (MT (Name.from_ident ident)) signat
+
+    let table signat =
+      let t = Hashtbl.create 13 in
+      List.iter (add_to_hash t) signat;
+      t
+
+    let search_value table name =
+      match Hashtbl.find table (V name) with
+      | (Types.Sig_value (_, val_desc)) ->  val_desc.Types.val_type
+      | _ -> assert false
+
+    let search_extension table name =
+      match Hashtbl.find table (X name) with
+      | (Types.Sig_typext (_, ext, _)) -> ext
+      | _ -> assert false
+
+    let search_type table name =
+      match Hashtbl.find table (T name) with
+      | (Types.Sig_type (_, type_decl, _)) -> type_decl
+      | _ -> assert false
+
+    let search_class table name =
+      match Hashtbl.find table (C name) with
+      | (Types.Sig_class (_, class_decl, _)) -> class_decl
+      | _ -> assert false
+
+    let search_class_type table name =
+      match Hashtbl.find table (CT name) with
+      | (Types.Sig_class_type (_, cltype_decl, _)) -> cltype_decl
+      | _ -> assert false
+
+    let search_module table name =
+      match Hashtbl.find table (M name) with
+      | (Types.Sig_module (_ident, md, _)) -> md.Types.md_type
+      | _ -> assert false
+
+    let search_module_type table name =
+      match Hashtbl.find table (MT name) with
+      | (Types.Sig_modtype (_, {Types.mtd_type = Some module_type})) ->
+          Some module_type
+      | (Types.Sig_modtype (_, {Types.mtd_type = None})) ->
+          None
+      | _ -> assert false
+
+    let search_attribute_type name class_sig =
+      let (_, _, type_expr) = Types.Vars.find name class_sig.Types.csig_vars in
+      type_expr
+
+    let search_method_type name class_sig =
+      let fields = Odoc_misc.get_fields class_sig.Types.csig_self in
+      List.assoc name fields
+  end
+
+module type Info_retriever =
+  sig
+    val all_special : string -> string -> int * (Odoc_types.info list)
+    val blank_line_outside_simple : string -> string -> bool
+    val just_after_special : string -> string -> (int * Odoc_types.info option)
+    val first_special : string -> string -> (int * Odoc_types.info option)
+    val get_comments :
+        (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list)
+  end
+
+module Analyser =
+  functor (My_ir : Info_retriever) ->
+  struct
+    (** This variable is used to load a file as a string and retrieve characters from it.*)
+    let file = ref ""
+
+    (** The name of the analysed file. *)
+    let file_name = ref ""
+
+    (** This function takes two indexes (start and end) and return the string
+       corresponding to the indexes in the file global variable. The function
+       prepare_file must have been called to fill the file global variable.*)
+    let get_string_of_file the_start the_end =
+      try
+        String.sub !file the_start (the_end-the_start)
+      with
+        Invalid_argument _ ->
+          ""
+
+    let just_after_special start stop =
+      let s = get_string_of_file start stop in
+      My_ir.just_after_special !file_name s
+
+    (** Helper functions for extracting location*)
+    module Loc = struct
+      let gen proj =
+        (fun ct -> (proj ct).Location.loc_start.Lexing.pos_cnum),
+        (fun ct -> (proj ct).Location.loc_end.Lexing.pos_cnum)
+    let ptyp' ct = ct.Parsetree.ptyp_loc
+    let pcd' pcd = pcd.Parsetree.pcd_loc
+    let loc' loc = loc
+    let psig' p = p.Parsetree.psig_loc
+
+    let start, end_ = gen loc'
+    let ptyp_start, ptyp_end = gen ptyp'
+    let pcd_start, pcd_end = gen pcd'
+    let psig_start, psig_end = gen psig'
+    end
+
+    (** This function loads the given file in the file global variable,
+       and sets file_name.*)
+    let prepare_file f input_f =
+      try
+        let s = Odoc_misc.input_file_as_string input_f in
+        file := s;
+        file_name := f
+      with
+        e ->
+          file := "";
+          raise e
+
+    (** The function used to get the comments in a class. *)
+    let get_comments_in_class pos_start pos_end =
+      My_ir.get_comments (fun t -> Class_comment t)
+        !file_name
+        (get_string_of_file pos_start pos_end)
+
+    (** The function used to get the comments in a module. *)
+    let get_comments_in_module pos_start pos_end =
+      My_ir.get_comments (fun t -> Element_module_comment t)
+        !file_name
+        (get_string_of_file pos_start pos_end)
+
+    let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options
+
+    (** Module for extracting documentation comments for record from different
+        tree types *)
+    module Record = struct
+
+      (** A structure to abstract over the tree type *)
+      type ('a,'b,'c) projector = {
+        name:'a -> string;
+        inline_record: 'b -> 'c option;
+        inline_end: 'b -> int;
+        start:'a -> int;
+        end_: 'a -> int }
+
+    (** A function to extract documentation from a list of label declarations *)
+    let doc p pos_end ld =
+      let rec f = function
+        | [] -> []
+        | ld :: [] ->
+            let name = p.name ld in
+            let pos = p.end_ ld in
+            let (_,comment_opt) =  just_after_special pos pos_end in
+            [name, comment_opt]
+        | ld  :: ele2 :: q ->
+            let pos = p.end_ ld in
+            let pos2 = p.start ele2 in
+            let name = p.name ld in
+            let (_,comment_opt) = just_after_special pos pos2 in
+            (name, comment_opt) :: (f (ele2 :: q))
+      in
+      f ld
+
+    let inline_doc p cstr =
+      match p.inline_record cstr with
+      | None -> []
+      | Some r ->
+          doc p (p.inline_end cstr) r
+
+    (** The three tree types used in the rest of the source: *)
+
+    let parsetree =
+      let open Parsetree in
+      { name = (fun ld -> ld.pld_name.txt );
+        start = (fun ld -> Loc.ptyp_start ld.pld_type);
+        end_ =  (fun ld -> Loc.ptyp_end ld.pld_type);
+        inline_record = begin
+          fun c -> match c.pcd_args with
+            | Pcstr_tuple _ -> None
+            | Pcstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.pcd_loc)
+      }
+
+    let types =
+      let open Types in
+      { name = (fun ld -> ld.ld_id.Ident.name );
+        start = (fun ld -> Loc.start ld.ld_loc);
+        end_ =  (fun ld -> Loc.start ld.ld_loc);
+        (* Beware, Loc.start is correct in the code above:
+           type_expr's do not hold location information, and ld.ld_loc
+           ends after the documentation comment, sow e use Loc.start as
+           the least problematic approximation for end_. *)
+        inline_record = begin
+          fun c -> match c.cd_args with
+            | Cstr_tuple _ -> None
+            | Cstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.cd_loc)
+      }
+
+    let typedtree =
+      let open Typedtree in
+      { name = (fun ld -> ld.ld_id.Ident.name );
+        start = (fun ld -> Loc.start ld.ld_type.ctyp_loc);
+        end_ =  (fun ld -> Loc.end_ ld.ld_type.ctyp_loc);
+        inline_record = begin
+          fun c -> match c.cd_args with
+            | Cstr_tuple _ -> None
+            | Cstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.cd_loc)
+      }
+
+
+    end
+
+    let name_comment_from_type_decl pos_end pos_limit ty_decl =
+      match ty_decl.Parsetree.ptype_kind with
+      | Parsetree.Ptype_abstract ->
+        let open Parsetree in
+        begin match ty_decl.ptype_manifest with
+        | None -> (0, [])
+        | Some core_ty ->
+          begin match core_ty.ptyp_desc with
+          | Ptyp_object (fields, _) ->
+            let rec f = function
+              | [] -> []
+              | ({txt=""},_,_) :: _ ->
+                (* Fields with no name have been eliminated previously. *)
+                assert false
+
+              | ({txt=name}, _atts, ct) :: [] ->
+                let pos = Loc.ptyp_end ct in
+                let (_,comment_opt) = just_after_special pos pos_end in
+                [name, comment_opt]
+              | ({txt=name}, _atts, ct) :: ((_name2, _atts2, ct2) as ele2) :: q ->
+                let pos = Loc.ptyp_end ct in
+                let pos2 = Loc.ptyp_start ct2 in
+                let (_,comment_opt) = just_after_special pos pos2 in
+                (name, comment_opt) :: (f (ele2 :: q))
+            in
+            let is_named_field field =
+              match field with
+              | ({txt=""},_,_) -> false
+              | _ -> true
+            in
+            (0, f @@ List.filter is_named_field fields)
+
+          | _ -> (0, [])
+          end
+        end
+
+      | Parsetree.Ptype_variant cons_core_type_list_list ->
+          let rec f acc cons_core_type_list_list =
+            let open Parsetree in
+            match cons_core_type_list_list with
+              [] ->
+                (0, acc)
+            | pcd :: [] ->
+                let acc = Record.(inline_doc parsetree) pcd @ acc in
+                let (len, comment_opt) =
+                  just_after_special (Loc.pcd_end pcd) pos_limit in
+                (len, List.rev @@ (pcd.pcd_name.txt, comment_opt):: acc )
+            | pcd :: (pcd2 :: _ as q) ->
+                let acc = Record.(inline_doc parsetree) pcd @ acc in
+                let pos_end_first = Loc.pcd_end pcd in
+                let pos_start_second = Loc.pcd_start pcd2 in
+                let (_,comment_opt) =
+                  just_after_special pos_end_first pos_start_second in
+                f ((pcd.pcd_name.txt, comment_opt)::acc) q
+          in
+          f [] cons_core_type_list_list
+
+      | Parsetree.Ptype_record label_declaration_list ->
+          (0, Record.(doc parsetree) pos_end label_declaration_list)
+      | Parsetree.Ptype_open ->
+          (0, [])
+
+
+    let manifest_structure env name_comment_list type_expr =
+      match type_expr.desc with
+      | Tobject (fields, _) ->
+        let f (field_name, _, type_expr) =
+          let comment_opt =
+            try List.assoc field_name name_comment_list
+            with Not_found -> None
+          in {
+            of_name = field_name ;
+            of_type = Odoc_env.subst_type env type_expr ;
+            of_text = comment_opt ;
+          }
+        in
+        Object_type (List.map f @@ fst @@ Ctype.flatten_fields fields)
+      | _ -> Other (Odoc_env.subst_type env type_expr)
+
+    let get_field env name_comment_list {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} =
+      let field_name = Ident.name field_name in
+      let comment_opt =
+        try List.assoc field_name name_comment_list
+        with Not_found -> None
+      in
+      {
+        rf_name = field_name ;
+        rf_mutable = mutable_flag = Mutable ;
+        rf_type = Odoc_env.subst_type env type_expr ;
+        rf_text = comment_opt
+      }
+
+    let get_type_kind env name_comment_list type_kind =
+      match type_kind with
+        Types.Type_abstract ->
+          Odoc_type.Type_abstract
+      | Types.Type_variant l ->
+          let f {Types.cd_id=constructor_name;cd_args;cd_res=ret_type} =
+            let constructor_name = Ident.name constructor_name in
+            let comment_opt =
+              try match List.assoc constructor_name name_comment_list with
+                | Some { i_desc = None | Some []; _ } -> None
+                | x -> x
+              with Not_found -> None
+            in
+            let vc_args =
+              match cd_args with
+              | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l)
+              | Cstr_record l ->
+                  Cstr_record (List.map (get_field env name_comment_list) l)
+            in
+            {
+              vc_name = constructor_name ;
+              vc_args;
+              vc_ret =  may_map (Odoc_env.subst_type env) ret_type;
+              vc_text = comment_opt
+            }
+          in
+          Odoc_type.Type_variant (List.map f l)
+
+      | Types.Type_record (l, _) ->
+          Odoc_type.Type_record (List.map (get_field env name_comment_list) l)
+
+      | Types.Type_open ->
+          Odoc_type.Type_open
+
+
+    let get_cstr_args env pos_end =
+      let tuple ct = Odoc_env.subst_type env ct.Typedtree.ctyp_type in
+      let record comments
+          { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
+        get_field env comments @@
+        {Types.ld_id; ld_mutable; ld_type=ld_type.Typedtree.ctyp_type;
+         ld_loc; ld_attributes } in
+      let open Typedtree in
+      function
+      | Cstr_tuple l ->
+          Odoc_type.Cstr_tuple (List.map tuple l)
+      | Cstr_record l ->
+          let comments = Record.(doc typedtree) pos_end l in
+          Odoc_type.Cstr_record (List.map (record comments) l)
+
+    let erased_names_of_constraints constraints acc =
+      List.fold_right (fun constraint_ acc ->
+        match constraint_ with
+        | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc
+        | Parsetree.Pwith_typesubst {Parsetree.ptype_name=s}
+        | Parsetree.Pwith_modsubst (s, _) ->
+          Name.Set.add s.txt acc)
+        constraints acc
+
+    let filter_out_erased_items_from_signature erased signature =
+      if Name.Set.is_empty erased then signature
+      else List.fold_right (fun sig_item acc ->
+        let take_item psig_desc = { sig_item with Parsetree.psig_desc } :: acc in
+        match sig_item.Parsetree.psig_desc with
+        | Parsetree.Psig_attribute _
+        | Parsetree.Psig_extension _
+        | Parsetree.Psig_value _
+        | Parsetree.Psig_typext _
+        | Parsetree.Psig_exception _
+        | Parsetree.Psig_open _
+        | Parsetree.Psig_include _
+        | Parsetree.Psig_class _
+        | Parsetree.Psig_class_type _ as tp -> take_item tp
+        | Parsetree.Psig_type (rf, types) ->
+          (match List.filter (fun td -> not (Name.Set.mem td.Parsetree.ptype_name.txt erased)) types with
+          | [] -> acc
+          | types -> take_item (Parsetree.Psig_type (rf, types)))
+        | Parsetree.Psig_module {Parsetree.pmd_name=name}
+        | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
+          if Name.Set.mem name.txt erased then acc else take_item m
+        | Parsetree.Psig_recmodule mods ->
+          (match List.filter (fun pmd -> not (Name.Set.mem pmd.Parsetree.pmd_name.txt erased)) mods with
+          | [] -> acc
+          | mods -> take_item (Parsetree.Psig_recmodule mods)))
+        signature []
+
+    (** Analysis of the elements of a class, from the information in the parsetree and in the class
+       signature. @return the couple (inherited_class list, elements).*)
+    let analyse_class_elements env current_class_name last_pos pos_limit
+        class_type_field_list class_signature =
+      let get_pos_limit2 q =
+        match q with
+          [] -> pos_limit
+          | ele2 :: _ ->
+              let loc = ele2.Parsetree.pctf_loc in
+            match ele2.Parsetree.pctf_desc with
+              Parsetree.Pctf_val (_, _, _, _)
+            | Parsetree.Pctf_method (_, _, _, _)
+            | Parsetree.Pctf_constraint (_, _)
+            | Parsetree.Pctf_attribute _ -> Loc.start loc
+            | Parsetree.Pctf_inherit class_type ->
+                Loc.start class_type.Parsetree.pcty_loc
+            | Parsetree.Pctf_extension _ -> assert false
+      in
+      let get_method name comment_opt private_flag loc q =
+        let complete_name = Name.concat current_class_name name in
+        let typ =
+          try Signature_search.search_method_type name class_signature
+          with Not_found ->
+            raise (Failure (Odoc_messages.method_type_not_found current_class_name name))
+        in
+        let subst_typ = Odoc_env.subst_type env typ in
+        let met =
+          {
+            met_value =
+            {
+              val_name = complete_name ;
+              val_info = comment_opt ;
+              val_type = subst_typ ;
+              val_recursive = false ;
+              val_parameters = Odoc_value.dummy_parameter_list subst_typ ;
+              val_code = None ;
+              val_loc = { loc_impl = None ; loc_inter = Some loc };
+            } ;
+            met_private = private_flag = Asttypes.Private ;
+            met_virtual = false ;
+          }
+        in
+        let pos_limit2 = get_pos_limit2 q in
+        let pos_end = Loc.end_ loc in
+        let (maybe_more, info_after_opt) =
+          My_ir.just_after_special
+            !file_name
+            (get_string_of_file pos_end pos_limit2)
+        in
+        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 =
+        match class_type_field_list with
+          [] ->
+            let s = get_string_of_file last_pos pos_limit in
+            let (_, ele_coms) = My_ir.all_special !file_name s in
+            let ele_comments =
+              List.fold_left
+                (fun acc -> fun sc ->
+                  match sc.Odoc_types.i_desc with
+                    None ->
+                      acc
+                  | Some t ->
+                      acc @ [Class_comment t])
+                []
+                ele_coms
+            in
+            ([], ele_comments)
+
+          | item :: q ->
+              let loc = item.Parsetree.pctf_loc in
+              match item.Parsetree.pctf_desc with
+
+        | Parsetree.Pctf_val ({txt=name}, mutable_flag, virtual_flag, _) ->
+            (* of (string * mutable_flag * core_type option * Location.t)*)
+            let (comment_opt, eles_comments) = get_comments_in_class last_pos
+                (Loc.start loc) in
+            let complete_name = Name.concat current_class_name name in
+            let typ =
+              try Signature_search.search_attribute_type name class_signature
+              with Not_found ->
+                raise (Failure (Odoc_messages.attribute_type_not_found current_class_name name))
+            in
+            let subst_typ = Odoc_env.subst_type env typ in
+            let att =
+              {
+                att_value =
+                {
+                  val_name = complete_name ;
+                  val_info = comment_opt ;
+                  val_type = subst_typ;
+                  val_recursive = false ;
+                  val_parameters = [] ;
+                  val_code = None ;
+                  val_loc = { loc_impl = None ; loc_inter = Some loc} ;
+                } ;
+                att_mutable = mutable_flag = Asttypes.Mutable ;
+                att_virtual = virtual_flag = Asttypes.Virtual ;
+              }
+            in
+            let pos_limit2 = get_pos_limit2 q in
+            let pos_end = Loc.end_ loc in
+            let (maybe_more, info_after_opt) =
+              My_ir.just_after_special
+                !file_name
+                (get_string_of_file pos_end pos_limit2)
+            in
+            att.att_value.val_info <- merge_infos att.att_value.val_info info_after_opt ;
+            let (inher_l, eles) = f (pos_end + maybe_more) q in
+            (inher_l, eles_comments @ ((Class_attribute att) :: eles))
+
+        | Parsetree.Pctf_method ({txt=name}, private_flag, virtual_flag, _) ->
+            (* of (string * private_flag * virtual_flag * core_type) *)
+            let (comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start  loc) in
+            let (met, maybe_more) = get_method name comment_opt private_flag loc q in
+            let met2 =
+              match virtual_flag with
+              | Concrete -> met
+              | Virtual -> { met with met_virtual = true }
+            in
+            let (inher_l, eles) = f (Loc.end_ loc + maybe_more) q in
+            (inher_l, eles_comments @ ((Class_method met2) :: eles))
+
+        | (Parsetree.Pctf_constraint (_, _)) ->
+            (* of (core_type * core_type) *)
+            (* FIXME: this corresponds to constraints, isn't it? We don't keep them for now *)
+            let (_comment_opt, eles_comments) = get_comments_in_class last_pos
+                (Loc.start loc) in
+            let (inher_l, eles) = f (Loc.end_ loc) q in
+            (inher_l, eles_comments @ eles)
+
+        | Parsetree.Pctf_inherit class_type ->
+            let loc = class_type.Parsetree.pcty_loc in
+            let (comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start loc) in
+            let pos_limit2 = get_pos_limit2 q in
+            let pos_end = Loc.end_ loc in
+            let (maybe_more, info_after_opt) =
+             just_after_special pos_end pos_limit2
+            in
+            let comment_opt2 = merge_infos comment_opt info_after_opt in
+            let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in
+            let inh  =
+              match class_type.Parsetree.pcty_desc with
+                Parsetree.Pcty_constr (longident, _) ->
+                  (*of Longident.t * core_type list*)
+                  let name = Name.from_longident longident.txt in
+                  {
+                    ic_name = Odoc_env.full_class_or_class_type_name env name ;
+                    ic_class = None ;
+                    ic_text = text_opt ;
+                  }
+
+              | Parsetree.Pcty_signature _
+              | Parsetree.Pcty_arrow _ ->
+                    (* we don't have a name for the class signature, so we call it "object ... end"  *)
+                  {
+                    ic_name = Odoc_messages.object_end ;
+                    ic_class = None ;
+                    ic_text = text_opt ;
+                  }
+              | Parsetree.Pcty_extension _ -> assert false
+            in
+            let (inher_l, eles) = f (pos_end + maybe_more) q in
+            (inh :: inher_l , eles_comments @ eles)
+        | Parsetree.Pctf_attribute _ ->
+            let (_comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start loc) in
+            let (inher_l, eles) = f (Loc.end_ loc) q in
+            (inher_l, eles_comments @ eles)
+
+        | Parsetree.Pctf_extension _ -> assert false
+      in
+      f last_pos class_type_field_list
+
+    (** Analyse of a .mli parse tree, to get the corresponding elements.
+       last_pos is the position of the first character which may be used to look for special comments.
+    *)
+    let rec analyse_parsetree env signat current_module_name last_pos pos_limit sig_item_list =
+      let table = Signature_search.table signat in
+      (* we look for the comment of each item then analyse the item *)
+      let rec f acc_eles acc_env last_pos = function
+          [] ->
+            let s = get_string_of_file last_pos pos_limit in
+            let (_, ele_coms) = My_ir.all_special !file_name s in
+            let ele_comments =
+              List.fold_left
+                (fun acc -> fun sc ->
+                  match sc.Odoc_types.i_desc with
+                    None ->
+                      acc
+                  | Some t ->
+                      acc @ [Element_module_comment t])
+                []
+                ele_coms
+            in
+            acc_eles @ ele_comments
+
+        | ele :: q ->
+            let (assoc_com, ele_comments) =
+              get_comments_in_module last_pos (Loc.psig_start ele)
+            in
+            let (maybe_more, new_env, elements) = analyse_signature_item_desc
+                acc_env
+                signat
+                table
+                current_module_name
+                ele.Parsetree.psig_loc
+                (Loc.psig_start ele)
+                (Loc.psig_end ele)
+                (match q with
+                  [] -> pos_limit
+                | ele2 :: _ -> Loc.psig_start ele2
+                )
+                assoc_com
+                ele.Parsetree.psig_desc
+            in
+            let new_pos = Loc.psig_end ele + maybe_more
+              (* for the comments of constructors in types,
+                 which are after the constructor definition and can
+                 go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *)
+            in
+            f (acc_eles @ (ele_comments @ elements))
+              new_env
+              new_pos
+              q
+      in
+      f [] env last_pos sig_item_list
+
+    (** Analyse the given signature_item_desc to create the corresponding module element
+       (with the given attached comment).*)
+    and analyse_signature_item_desc env _signat table current_module_name
+        sig_item_loc pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc =
+        match sig_item_desc with
+          Parsetree.Psig_value value_desc ->
+            let name_pre = value_desc.Parsetree.pval_name in
+            let type_expr =
+              try Signature_search.search_value table name_pre.txt
+              with Not_found ->
+                raise (Failure (Odoc_messages.value_not_found current_module_name name_pre.txt))
+            in
+            let name = Name.parens_if_infix name_pre.txt in
+            let subst_typ = Odoc_env.subst_type env type_expr in
+            let v =
+              {
+                val_name = Name.concat current_module_name name ;
+                val_info = comment_opt ;
+                val_type = subst_typ ;
+                val_recursive = false ;
+                val_parameters = Odoc_value.dummy_parameter_list subst_typ ;
+                val_code = None ;
+                val_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ;
+              }
+            in
+            let (maybe_more, info_after_opt) =
+              My_ir.just_after_special
+                !file_name
+                (get_string_of_file pos_end_ele pos_limit)
+            in
+            v.val_info <- merge_infos v.val_info info_after_opt ;
+            (* update the parameter description *)
+            Odoc_value.update_value_parameters_text v;
+
+            let new_env = Odoc_env.add_value env v.val_name in
+            (maybe_more, new_env, [ Element_value v ])
+
+        | Parsetree.Psig_typext tyext ->
+          let new_env, types_ext_list, last_ext =
+            List.fold_left
+              (fun (env_acc, exts_acc, _) -> fun {Parsetree.pext_name = { txt = name }} ->
+                let complete_name = Name.concat current_module_name name in
+                let env_acc = Odoc_env.add_extension env_acc complete_name in
+                let types_ext =
+                  try Signature_search.search_extension table name
+                  with Not_found ->
+                    raise (Failure (Odoc_messages.extension_not_found current_module_name name))
+                in
+                  env_acc, ((name, types_ext) :: exts_acc), Some types_ext
+              )
+              (env, [], None)
+              tyext.Parsetree.ptyext_constructors
+          in
+          let types_ext_list = List.rev types_ext_list in
+          let ty_path, ty_params, priv =
+            match last_ext with
+              None -> assert false
+            | Some ext -> ext.ext_type_path, ext.ext_type_params, ext.ext_private
+          in
+          let new_te =
+            {
+              te_info = comment_opt;
+              te_type_name =
+                Odoc_env.full_type_name new_env (Name.from_path ty_path);
+              te_type_parameters =
+                List.map (Odoc_env.subst_type new_env) ty_params;
+              te_private = priv;
+              te_constructors = [];
+              te_loc = { loc_impl = None ; loc_inter = Some sig_item_loc} ;
+              te_code =
+                (
+                  if !Odoc_global.keep_code then
+                    Some (get_string_of_file pos_start_ele pos_end_ele)
+                  else
+                    None
+                ) ;
+            }
+          in
+          let rec analyse_extension_constructors maybe_more exts_acc types_ext_list =
+            match types_ext_list with
+              [] -> (maybe_more, List.rev exts_acc)
+            | (name, types_ext) :: q ->
+              let ext_loc_end =  Loc.end_ types_ext.Types.ext_loc in
+              let xt_args =
+                match types_ext.ext_args with
+                | Cstr_tuple l ->
+                    Cstr_tuple (List.map (Odoc_env.subst_type new_env) l)
+                | Cstr_record l ->
+                    let docs = Record.(doc types ext_loc_end) l in
+                    Cstr_record (List.map (get_field new_env docs) l)
+              in
+              let new_x =
+                {
+                  xt_name = Name.concat current_module_name name ;
+                  xt_args;
+                  xt_ret = may_map (Odoc_env.subst_type new_env) types_ext.ext_ret_type ;
+                  xt_type_extension = new_te;
+                  xt_alias = None ;
+                  xt_loc = { loc_impl = None ; loc_inter = Some types_ext.Types.ext_loc} ;
+                  xt_text = None;
+                }
+              in
+              let pos_limit2 =
+                match q with
+                  [] -> pos_limit
+                | (_, next) :: _ -> Loc.start (next.Types.ext_loc)
+              in
+              let (maybe_more, comment_opt) =
+                just_after_special ext_loc_end pos_limit2 in
+                new_x.xt_text <- comment_opt;
+                analyse_extension_constructors maybe_more (new_x :: exts_acc) q
+          in
+          let (maybe_more, exts) = analyse_extension_constructors 0 [] types_ext_list in
+            new_te.te_constructors <- exts;
+            let (maybe_more2, info_after_opt) =
+              just_after_special (pos_end_ele + maybe_more) pos_limit
+            in
+              new_te.te_info <- merge_infos new_te.te_info info_after_opt ;
+              (maybe_more + maybe_more2, new_env, [ Element_type_extension new_te ])
+
+        | Parsetree.Psig_exception ext ->
+            let name = ext.Parsetree.pext_name in
+            let types_ext =
+              try Signature_search.search_extension table name.txt
+              with Not_found ->
+                raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt))
+            in
+            let ex_args =
+              let pos_end = Loc.end_ types_ext.ext_loc in
+              match types_ext.ext_args with
+              | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l)
+              | Cstr_record l ->
+                  let docs = Record.(doc types) pos_end l in
+                  Cstr_record (List.map (get_field env docs) l)
+            in
+            let e =
+              {
+                ex_name = Name.concat current_module_name name.txt ;
+                ex_info = comment_opt ;
+                ex_args;
+                ex_ret = may_map (Odoc_env.subst_type env) types_ext.ext_ret_type ;
+                ex_alias = None ;
+                ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ;
+                ex_code =
+                   (
+                    if !Odoc_global.keep_code then
+                      Some (get_string_of_file pos_start_ele pos_end_ele)
+                    else
+                      None
+                   ) ;
+              }
+            in
+            let (maybe_more, info_after_opt) =
+              My_ir.just_after_special
+                !file_name
+                (get_string_of_file pos_end_ele pos_limit)
+            in
+            e.ex_info <- merge_infos e.ex_info info_after_opt ;
+            let new_env = Odoc_env.add_extension env e.ex_name in
+            (maybe_more, new_env, [ Element_exception e ])
+
+        | Parsetree.Psig_type (rf, name_type_decl_list) ->
+            let extended_env =
+              List.fold_left
+                (fun acc_env td ->
+                  let complete_name = Name.concat current_module_name td.Parsetree.ptype_name.txt in
+                  Odoc_env.add_type acc_env complete_name
+                )
+                env
+                name_type_decl_list
+            in
+            let env =
+              match rf with
+              | Recursive -> extended_env
+              | Nonrecursive -> env
+            in
+            let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list =
+              match name_type_decl_list with
+                [] ->
+                  (acc_maybe_more, [])
+              | type_decl :: q ->
+                  let name = type_decl.Parsetree.ptype_name in
+                  let (assoc_com, ele_comments) =
+                    if first then
+                      (comment_opt, [])
+                    else
+                      get_comments_in_module
+                        last_pos
+                        (Loc.start type_decl.Parsetree.ptype_loc)
+                  in
+                  let pos_limit2 =
+                    match q with
+                      [] -> pos_limit
+                    | td :: _ -> Loc.start (td.Parsetree.ptype_loc)
+                  in
+                  let (maybe_more, name_comment_list) =
+                    name_comment_from_type_decl
+                      (Loc.end_ type_decl.Parsetree.ptype_loc)
+                      pos_limit2
+                      type_decl
+                  in
+(* DEBUG *)       begin
+(* DEBUG *)         let comm =
+(* DEBUG *)           match assoc_com with
+(* DEBUG *)           | None -> "sans commentaire"
+(* DEBUG *)           | Some c -> Odoc_misc.string_of_info c
+(* DEBUG *)         in
+(* DEBUG *)         print_DEBUG ("Type "^name.txt^" : "^comm);
+(* DEBUG *)         let f_DEBUG (name, c_opt) =
+(* DEBUG *)           let comm =
+(* DEBUG *)             match c_opt with
+(* DEBUG *)             | None -> "sans commentaire"
+(* DEBUG *)             | Some c -> Odoc_misc.string_of_info c
+(* DEBUG *)           in
+(* DEBUG *)           print_DEBUG ("constructor/field "^name^": "^comm)
+(* DEBUG *)         in
+(* DEBUG *)         List.iter f_DEBUG name_comment_list;
+(* DEBUG *)       end;
+                  (* get the information for the type in the signature *)
+                  let sig_type_decl =
+                    try Signature_search.search_type table name.txt
+                    with Not_found ->
+                      raise (Failure (Odoc_messages.type_not_found current_module_name name.txt))
+                  in
+                  (* get the type kind with the associated comments *)
+                  let type_kind = get_type_kind env name_comment_list sig_type_decl.Types.type_kind in
+                  let loc_start = Loc.start type_decl.Parsetree.ptype_loc in
+                  let new_end = Loc.end_ type_decl.Parsetree.ptype_loc
+                                + maybe_more in
+                  (* associate the comments to each constructor and build the [Type.t_type] *)
+                  let new_type =
+                    {
+                      ty_name = Name.concat current_module_name name.txt ;
+                      ty_info = assoc_com ;
+                      ty_parameters =
+                        List.map2 (fun p v ->
+                          let (co, cn) = Types.Variance.get_upper v in
+                          (Odoc_env.subst_type env p,co, cn))
+                        sig_type_decl.Types.type_params
+                        sig_type_decl.Types.type_variance;
+                      ty_kind = type_kind;
+                      ty_private = sig_type_decl.Types.type_private;
+                      ty_manifest =
+                        begin match sig_type_decl.Types.type_manifest with
+                        | None   -> None
+                        | Some t ->
+                          Some (manifest_structure env name_comment_list t)
+                        end ;
+                      ty_loc = { loc_impl = None ;  loc_inter = Some sig_item_loc } ;
+                      ty_code =
+                        (
+                         if !Odoc_global.keep_code then
+                           Some (get_string_of_file loc_start new_end)
+                         else
+                           None
+                        ) ;
+                    }
+                  in
+                  let (maybe_more2, info_after_opt) =
+                    My_ir.just_after_special
+                      !file_name
+                      (get_string_of_file new_end pos_limit2)
+                  in
+                  new_type.ty_info <- merge_infos new_type.ty_info info_after_opt ;
+                  let (new_maybe_more, eles) = f
+                      (maybe_more + maybe_more2)
+                      (new_end + maybe_more2)
+                      q
+                  in
+                  (new_maybe_more, (ele_comments @ [Element_type new_type]) @ eles)
+            in
+            let (maybe_more, types) = f ~first: true 0 pos_start_ele name_type_decl_list in
+            (maybe_more, extended_env, types)
+
+        | Parsetree.Psig_open _ -> (* FIXME *)
+            let ele_comments = match comment_opt with
+              None -> []
+            | Some i ->
+                match i.i_desc with
+                  None -> []
+                | Some t -> [Element_module_comment t]
+            in
+            (0, env, ele_comments)
+
+        | Parsetree.Psig_module {Parsetree.pmd_name=name; pmd_type=module_type} ->
+            let complete_name = Name.concat current_module_name name.txt in
+            (* get the the module type in the signature by the module name *)
+            let sig_module_type =
+              try Signature_search.search_module table name.txt
+              with Not_found ->
+                raise (Failure (Odoc_messages.module_not_found current_module_name name.txt))
+            in
+            let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
+            let code_intf =
+              if !Odoc_global.keep_code then
+                let loc = module_type.Parsetree.pmty_loc in
+                let st = Loc.start loc in
+                let en = Loc.end_ loc in
+                Some (get_string_of_file st en)
+              else
+                None
+            in
+            let new_module =
+              {
+                m_name = complete_name ;
+                m_type = sig_module_type;
+                m_info = comment_opt ;
+                m_is_interface = true ;
+                m_file = !file_name ;
+                m_kind = module_kind ;
+                m_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ;
+                m_top_deps = [] ;
+                m_code = None ;
+                m_code_intf = code_intf ;
+                m_text_only = false ;
+              }
+            in
+            let (maybe_more, info_after_opt) =
+              My_ir.just_after_special
+                !file_name
+                (get_string_of_file pos_end_ele pos_limit)
+            in
+            new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
+            let new_env = Odoc_env.add_module env new_module.m_name in
+            let new_env2 =
+              match new_module.m_type with (* FIXME : can this be a Tmty_ident? in this case, we would'nt have the signature *)
+                Types.Mty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s
+              | _ -> new_env
+            in
+            (maybe_more, new_env2, [ Element_module new_module ])
+
+        | Parsetree.Psig_recmodule decls ->
+            (* we start by extending the environment *)
+            let new_env =
+              List.fold_left
+                (fun acc_env {Parsetree.pmd_name={txt=name}} ->
+                  let complete_name = Name.concat current_module_name name in
+                  let e = Odoc_env.add_module acc_env complete_name in
+                  (* get the information for the module in the signature *)
+                  let sig_module_type =
+                    try Signature_search.search_module table name
+                    with Not_found ->
+                      raise (Failure (Odoc_messages.module_not_found current_module_name name))
+                  in
+                  match sig_module_type with
+                    (* FIXME : can this be a Tmty_ident? in this case, we would'nt have the signature *)
+                    Types.Mty_signature s ->
+                      Odoc_env.add_signature e complete_name ~rel: name s
+                  | _ ->
+                      print_DEBUG "not a Tmty_signature";
+                      e
+                )
+                env
+                decls
+            in
+            let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list =
+              match name_mtype_list with
+                [] ->
+                  (acc_maybe_more, [])
+              | {Parsetree.pmd_name=name; pmd_type=modtype} :: q ->
+                  let complete_name = Name.concat current_module_name name.txt in
+                  let loc = modtype.Parsetree.pmty_loc in
+                  let loc_start = Loc.start loc in
+                  let loc_end = Loc.end_ loc in
+                  let (assoc_com, ele_comments) =
+                    if first then
+                      (comment_opt, [])
+                    else
+                      get_comments_in_module
+                        last_pos
+                        loc_start
+                  in
+                  let pos_limit2 =
+                    match q with
+                      [] -> pos_limit
+                    | _ :: _ -> Loc.start loc
+                  in
+                  (* get the information for the module in the signature *)
+                  let sig_module_type =
+                    try Signature_search.search_module table name.txt
+                    with Not_found ->
+                      raise (Failure (Odoc_messages.module_not_found current_module_name name.txt))
+                  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_global.keep_code then
+                      let st = Loc.start loc in
+                      let en = Loc.end_ loc in
+                      Some (get_string_of_file st en)
+                    else
+                      None
+                  in
+                  let new_module =
+                    {
+                      m_name = complete_name ;
+                      m_type = sig_module_type;
+                      m_info = assoc_com ;
+                      m_is_interface = true ;
+                      m_file = !file_name ;
+                      m_kind = module_kind ;
+                      m_loc = { loc_impl = None ; loc_inter = Some loc } ;
+                      m_top_deps = [] ;
+                      m_code = None ;
+                      m_code_intf = code_intf ;
+                      m_text_only = false ;
+                    }
+                  in
+                  let (maybe_more, info_after_opt) =
+                    My_ir.just_after_special
+                      !file_name
+                      (get_string_of_file loc_end pos_limit2)
+                  in
+                  new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
+
+                  let (maybe_more2, eles) = f
+                      maybe_more
+                      (loc_end + maybe_more)
+                      q
+                  in
+                  (maybe_more2, (ele_comments @ [Element_module new_module]) @ eles)
+            in
+            let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in
+            (maybe_more, new_env, mods)
+
+        | Parsetree.Psig_modtype {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl} ->
+            let complete_name = Name.concat current_module_name name.txt in
+            let sig_mtype =
+              try Signature_search.search_module_type table name.txt
+              with Not_found ->
+                raise (Failure (Odoc_messages.module_type_not_found current_module_name name.txt))
+            in
+            let module_type_kind =
+              match pmodtype_decl with
+                None -> None
+              | Some module_type ->
+                match sig_mtype with
+                | Some sig_mtype -> Some (analyse_module_type_kind env complete_name module_type sig_mtype)
+                | None -> None
+            in
+
+            let mt =
+              {
+                mt_name = complete_name ;
+                mt_info = comment_opt ;
+                mt_type = sig_mtype ;
+                mt_is_interface = true ;
+                mt_file = !file_name ;
+                mt_kind = module_type_kind ;
+                mt_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ;
+              }
+            in
+            let (maybe_more, info_after_opt) =
+              My_ir.just_after_special
+                !file_name
+                (get_string_of_file pos_end_ele pos_limit)
+            in
+            mt.mt_info <- merge_infos mt.mt_info info_after_opt ;
+            let new_env = Odoc_env.add_module_type env mt.mt_name in
+            let new_env2 =
+              match sig_mtype with (* FIXME : can this be a Tmty_ident? in this case, we would'nt have the signature *)
+                Some (Types.Mty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
+              | _ -> new_env
+            in
+            (maybe_more, new_env2, [ Element_module_type mt ])
+
+        | Parsetree.Psig_include incl ->
+            let rec f = function
+                Parsetree.Pmty_ident longident ->
+                  Name.from_longident longident.txt
+              | Parsetree.Pmty_alias longident ->
+                  Name.from_longident longident.txt
+              | Parsetree.Pmty_signature _ ->
+                  "??"
+              | Parsetree.Pmty_functor _ ->
+                  "??"
+              | Parsetree.Pmty_with (mt, _) ->
+                  f mt.Parsetree.pmty_desc
+              | Parsetree.Pmty_typeof mexpr ->
+                  begin match mexpr.Parsetree.pmod_desc with
+                    Parsetree.Pmod_ident longident -> Name.from_longident longident.txt
+                  | _ -> "??"
+                  end
+              | Parsetree.Pmty_extension _ -> assert false
+            in
+            let name = f incl.Parsetree.pincl_mod.Parsetree.pmty_desc in
+            let full_name = Odoc_env.full_module_or_module_type_name env name in
+            let im =
+              {
+                im_name = full_name ;
+                im_module = None ;
+                im_info = comment_opt;
+              }
+            in
+            (0, env, [ Element_included_module im ]) (* FIXME : extend the environment? How? *)
+
+        | Parsetree.Psig_class class_description_list ->
+            (* we start by extending the environment *)
+            let new_env =
+              List.fold_left
+                (fun acc_env -> fun class_desc ->
+                  let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name.txt in
+                  Odoc_env.add_class acc_env complete_name
+                )
+                env
+                class_description_list
+            in
+            let rec f ?(first=false) acc_maybe_more last_pos class_description_list =
+              match class_description_list with
+                [] ->
+                  (acc_maybe_more, [])
+              | class_desc :: q ->
+                  let (assoc_com, ele_comments) =
+                    if first then
+                      (comment_opt, [])
+                    else
+                      get_comments_in_module
+                        last_pos
+                        (Loc.start class_desc.Parsetree.pci_loc)
+                  in
+                  let pos_end = Loc.end_ class_desc.Parsetree.pci_loc in
+                  let pos_limit2 =
+                    match q with
+                      [] -> pos_limit
+                    | cd :: _ -> Loc.start cd.Parsetree.pci_loc in
+                  let name = class_desc.Parsetree.pci_name in
+                  let complete_name = Name.concat current_module_name name.txt in
+                  let sig_class_decl =
+                    try Signature_search.search_class table name.txt
+                    with Not_found ->
+                      raise (Failure (Odoc_messages.class_not_found current_module_name name.txt))
+                  in
+                  let sig_class_type = sig_class_decl.Types.cty_type in
+                  let (parameters, class_kind) =
+                    analyse_class_kind
+                     new_env
+                     complete_name
+                     (Loc.start class_desc.Parsetree.pci_loc)
+                     class_desc.Parsetree.pci_expr
+                     sig_class_type
+                 in
+                 let new_class =
+                   {
+                     cl_name = complete_name ;
+                     cl_info = assoc_com ;
+                     cl_type = Odoc_env.subst_class_type env sig_class_type ;
+                     cl_type_parameters = sig_class_decl.Types.cty_params;
+                     cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ;
+                     cl_kind = class_kind ;
+                     cl_parameters = parameters ;
+                     cl_loc = { loc_impl = None ; loc_inter = Some class_desc.Parsetree.pci_loc } ;
+                   }
+                 in
+                 let (maybe_more, info_after_opt) =
+                   just_after_special pos_end pos_limit2 in
+                 new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ;
+                 Odoc_class.class_update_parameters_text new_class ;
+                 let (new_maybe_more, eles) =
+                   f maybe_more (pos_end + maybe_more) q
+                 in
+                 (new_maybe_more,
+                  ele_comments @ (( Element_class new_class ) :: eles))
+            in
+            let (maybe_more, eles) =
+              f ~first: true 0 pos_start_ele class_description_list
+            in
+            (maybe_more, new_env, eles)
+
+        | Parsetree.Psig_class_type class_type_declaration_list ->
+            (* we start by extending the environment *)
+            let new_env =
+              List.fold_left
+                (fun acc_env -> fun class_type_decl ->
+                  let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name.txt in
+                  Odoc_env.add_class_type acc_env complete_name
+                )
+                env
+                class_type_declaration_list
+            in
+            let rec f ?(first=false) acc_maybe_more last_pos class_type_description_list =
+              match class_type_description_list with
+                [] ->
+                  (acc_maybe_more, [])
+              | ct_decl :: q ->
+                  let (assoc_com, ele_comments) =
+                    if first then
+                      (comment_opt, [])
+                    else
+                      get_comments_in_module
+                        last_pos
+                        (Loc.start ct_decl.Parsetree.pci_loc)
+                  in
+                  let pos_end = Loc.end_ ct_decl.Parsetree.pci_loc in
+                  let pos_limit2 =
+                    match q with
+                      [] -> pos_limit
+                    | ct_decl2 :: _ -> Loc.start ct_decl2.Parsetree.pci_loc
+                  in
+                  let name = ct_decl.Parsetree.pci_name in
+                  let complete_name = Name.concat current_module_name name.txt in
+                  let sig_cltype_decl =
+                    try Signature_search.search_class_type table name.txt
+                    with Not_found ->
+                      raise (Failure (Odoc_messages.class_type_not_found current_module_name name.txt))
+                  in
+                  let sig_class_type = sig_cltype_decl.Types.clty_type in
+                  let kind = analyse_class_type_kind
+                      new_env
+                      complete_name
+                      (Loc.start ct_decl.Parsetree.pci_loc)
+                      ct_decl.Parsetree.pci_expr
+                      sig_class_type
+                  in
+                  let ct =
+                    {
+                      clt_name = complete_name ;
+                      clt_info = assoc_com ;
+                      clt_type = Odoc_env.subst_class_type env sig_class_type ;
+                      clt_type_parameters = sig_cltype_decl.clty_params ;
+                      clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ;
+                      clt_kind = kind ;
+                      clt_loc = { loc_impl = None ; loc_inter = Some ct_decl.Parsetree.pci_loc } ;
+                    }
+                  in
+                  let (maybe_more, info_after_opt) =
+                    just_after_special pos_end pos_limit2
+                  in
+                  ct.clt_info <- merge_infos ct.clt_info info_after_opt ;
+                  let (new_maybe_more, eles) =
+                    f maybe_more (pos_end + maybe_more) q
+                  in
+                 (new_maybe_more,
+                  ele_comments @ (( Element_class_type ct) :: eles))
+            in
+            let (maybe_more, eles) =
+              f ~first: true 0 pos_start_ele class_type_declaration_list
+            in
+            (maybe_more, new_env, eles)
+        | Parsetree.Psig_attribute _
+        | Parsetree.Psig_extension _ ->
+            (0, env, [])
+
+    (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
+    and analyse_module_type_kind
+      ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
+      match module_type.Parsetree.pmty_desc with
+        Parsetree.Pmty_ident longident ->
+          let name =
+            match sig_module_type with
+              Types.Mty_ident path -> Name.from_path path
+            | _ -> Name.from_longident longident.txt
+              (* FIXME this happens for module type F : functor ... -> Toto, Toto is not an ident but a structure *)
+          in
+          Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ;
+                              mta_module = None }
+
+      | Parsetree.Pmty_alias longident ->
+          let name =
+            match sig_module_type with
+              Types.Mty_alias(_, path) -> Name.from_path path
+            | _ -> Name.from_longident longident.txt
+          in
+          (* Wrong naming... *)
+          Module_type_alias { mta_name = Odoc_env.full_module_name env name ;
+                              mta_module = None }
+
+      | Parsetree.Pmty_signature ast ->
+          (
+           let ast = filter_out_erased_items_from_signature erased ast in
+           (* we must have a signature in the module type *)
+           match sig_module_type with
+             Types.Mty_signature signat ->
+               let pos_start = Loc.start module_type.Parsetree.pmty_loc in
+               let pos_end = Loc.end_ module_type.Parsetree.pmty_loc in
+               let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in
+               Module_type_struct elements
+           | _ ->
+               raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat")
+          )
+
+      | Parsetree.Pmty_functor (_, pmodule_type2, module_type2) ->
+          (
+           let loc = match pmodule_type2 with None -> Location.none
+                     | Some pmty -> pmty.Parsetree.pmty_loc in
+           let loc_start = Loc.start loc in
+           let loc_end = Loc.end_ loc 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.Mty_functor (ident, param_module_type, body_module_type) ->
+               let mp_kind =
+                 match pmodule_type2, param_module_type with
+                   Some pmty, Some mty ->
+                     analyse_module_type_kind env current_module_name pmty mty
+                 | _ -> Module_type_struct []
+               in
+               let param =
+                 {
+                   mp_name = Name.from_ident ident ;
+                   mp_type =
+                    Misc.may_map (Odoc_env.subst_module_type env)
+                      param_module_type;
+                   mp_type_code = mp_type_code ;
+                   mp_kind = mp_kind ;
+                 }
+               in
+               let k = analyse_module_type_kind ~erased env
+                   current_module_name
+                   module_type2
+                   body_module_type
+               in
+               Module_type_functor (param, k)
+
+           | _ ->
+               (* if we're here something's wrong *)
+               raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _")
+          )
+
+      | Parsetree.Pmty_with (module_type2, constraints) ->
+          (* of module_type * (Longident.t * with_constraint) list *)
+          (
+           let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
+           let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
+           let s = get_string_of_file loc_start loc_end in
+           let erased = erased_names_of_constraints constraints erased in
+           let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in
+
+           Module_type_with (k, s)
+          )
+
+      | Parsetree.Pmty_typeof module_expr ->
+          let loc_start = Loc.start module_expr.Parsetree.pmod_loc in
+          let loc_end = Loc.end_ module_expr.Parsetree.pmod_loc in
+          let s = get_string_of_file loc_start loc_end in
+          Module_type_typeof s
+
+      | Parsetree.Pmty_extension _ -> assert false
+
+    (** analyse of a Parsetree.module_type and a Types.module_type.*)
+    and analyse_module_kind
+        ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
+      match module_type.Parsetree.pmty_desc with
+      | 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_alias _longident ->
+          begin
+            match sig_module_type with
+              Types.Mty_alias(_, path) ->
+                let alias_name = Odoc_env.full_module_name env (Name.from_path path) in
+                let ma = { ma_name = alias_name ; ma_module = None } in
+                Module_alias ma
+            | _ ->
+              raise (Failure "Parsetree.Pmty_alias _ but not Types.Mty_alias _")
+           end
+      | Parsetree.Pmty_signature signature ->
+          (
+           let signature = filter_out_erased_items_from_signature erased signature in
+           match sig_module_type with
+             Types.Mty_signature signat ->
+               Module_struct
+                 (analyse_parsetree
+                    env
+                    signat
+                    current_module_name
+                    (Loc.start module_type.Parsetree.pmty_loc)
+                    (Loc.end_ module_type.Parsetree.pmty_loc)
+                    signature
+                 )
+           | _ ->
+               (* if we're here something's wrong *)
+               raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat")
+          )
+      | Parsetree.Pmty_functor (_, pmodule_type2,module_type2) (* of string * module_type * module_type *) ->
+          (
+           match sig_module_type with
+             Types.Mty_functor (ident, param_module_type, body_module_type) ->
+               let loc = match pmodule_type2 with None -> Location.none
+                     | Some pmty -> pmty.Parsetree.pmty_loc in
+               let loc_start = Loc.start loc in
+               let loc_end = Loc.end_ loc 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 =
+                 match pmodule_type2, param_module_type with
+                   Some pmty, Some mty ->
+                     analyse_module_type_kind env current_module_name pmty mty
+                 | _ -> Module_type_struct []
+               in
+               let param =
+                 {
+                   mp_name = Name.from_ident ident ;
+                   mp_type = Misc.may_map
+                    (Odoc_env.subst_module_type env) param_module_type ;
+                   mp_type_code = mp_type_code ;
+                   mp_kind = mp_kind ;
+                 }
+               in
+               let k = analyse_module_kind ~erased env
+                   current_module_name
+                   module_type2
+                   body_module_type
+               in
+               Module_functor (param, k)
+
+           | _ ->
+               (* if we're here something's wrong *)
+               raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _")
+          )
+      | Parsetree.Pmty_with (module_type2, constraints) ->
+          (*of module_type * (Longident.t * with_constraint) list*)
+          (
+           let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
+           let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
+           let s = get_string_of_file loc_start loc_end in
+           let erased = erased_names_of_constraints constraints erased in
+           let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in
+           Module_with (k, s)
+          )
+      | Parsetree.Pmty_typeof module_expr ->
+          let loc_start = Loc.start module_expr.Parsetree.pmod_loc in
+          let loc_end = Loc.end_ module_expr.Parsetree.pmod_loc in
+          let s = get_string_of_file loc_start loc_end in
+          Module_typeof s
+
+      | Parsetree.Pmty_extension _ -> assert false
+
+
+    (** Analyse of a Parsetree.class_type and a Types.class_type to return a couple
+       (class parameters, class_kind).*)
+    and analyse_class_kind env current_class_name last_pos parse_class_type sig_class_type =
+      match parse_class_type.Parsetree.pcty_desc, sig_class_type with
+        (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *),
+         Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) ->
+          print_DEBUG "Cty_constr _";
+           let path_name = Name.from_path p in
+           let name = Odoc_env.full_class_or_class_type_name env path_name in
+           let k =
+             Class_constr
+               {
+                 cco_name = name ;
+                 cco_class = None ;
+                 cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list
+               }
+           in
+           ([], k)
+
+      | (Parsetree.Pcty_signature { Parsetree.pcsig_fields = class_type_field_list }, Types.Cty_signature class_signature) ->
+          (* 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
+              (Loc.end_ parse_class_type.Parsetree.pcty_loc)
+              class_type_field_list
+              class_signature
+          in
+          ([], Class_structure (inher_l, ele))
+
+      | (Parsetree.Pcty_arrow (parse_label, _, pclass_type), Types.Cty_arrow (label, type_expr, class_type)) ->
+          (* label = string. In signature, there is no parameter names inside tuples *)
+          (* if label = "", no label . Here we have the information to determine if a label is explicit or not. *)
+          if parse_label = label then
+            (
+             let new_param = Simple_name
+                 {
+                   sn_name = Btype.label_name label ;
+                   sn_type = Odoc_env.subst_type env type_expr ;
+                   sn_text = None ; (* will be updated when the class will be created *)
+                 }
+             in
+             let (l, k) = analyse_class_kind env current_class_name last_pos pclass_type class_type in
+             ( (new_param :: l), k )
+            )
+          else
+            (
+             raise (Failure "Parsetree.Pcty_arrow (parse_label, _, pclass_type), labels differents")
+            )
+
+      | _ ->
+          raise (Failure "analyse_class_kind pas de correspondance dans le match")
+
+    (** Analyse of a Parsetree.class_type and a Types.class_type to return a class_type_kind.*)
+    and analyse_class_type_kind env current_class_name last_pos parse_class_type sig_class_type =
+      match parse_class_type.Parsetree.pcty_desc, sig_class_type with
+        (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *),
+         Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) ->
+          print_DEBUG "Cty_constr _";
+          Class_type
+            {
+              cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ;
+              cta_class = None ;
+              cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list
+            }
+
+        | (Parsetree.Pcty_signature {
+              Parsetree.pcsig_fields = class_type_field_list;
+              }, Types.Cty_signature class_signature) ->
+          (* 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
+              (Loc.end_ parse_class_type.Parsetree.pcty_loc)
+              class_type_field_list
+              class_signature
+          in
+          Class_signature (inher_l, ele)
+
+      | (Parsetree.Pcty_arrow _, Types.Cty_arrow _) ->
+          raise (Failure "analyse_class_type_kind : Parsetree.Pcty_arrow (...) with Types.Cty_arrow (...)")
+(*
+      | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),
+         Types.Cty_signature class_signature) ->
+           (* FIXME : this for the case of class contraints :
+              class type cons = object
+                method m : int
+              end
+
+              class ['a] maxou x =
+                (object
+                  val a = (x : 'a)
+                  method m = a
+                end : cons )
+                    ^^^^^^
+           *)
+           let k =
+             Class_type
+               {
+                 cta_name = Odoc_env.full_class_name env (Name.from_longident longident) ;
+                 cta_class = None ;
+                 cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list (* ?? *)
+               }
+           in
+           ([], k)
+*)
+      | _ ->
+          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) =
+      prepare_file source_file input_file;
+      (* We create the t_module for this file. *)
+      let mod_name = String.capitalize_ascii
+          (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 code_intf =
+        if !Odoc_global.keep_code then
+          Some !file
+        else
+          None
+      in
+      {
+        m_name = mod_name ;
+        m_type = Types.Mty_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 (Location.in_file !file_name) } ;
+        m_top_deps = [] ;
+        m_code = None ;
+        m_code_intf = code_intf ;
+        m_text_only = false ;
+      }
+
+    end
diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
new file mode 100644
index 00000000..b5318987
--- /dev/null
+++ b/ocamldoc/odoc_sig.mli
@@ -0,0 +1,192 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The module for analysing a signature and source code and creating modules, classes, ..., elements.*)
+
+(** The functions used to retrieve information from a signature. *)
+module Signature_search :
+    sig
+      type ele
+      type tab = (ele, Types.signature_item) Hashtbl.t
+
+      (** Create a table from a signature. This table is used by some
+         of the search functions below. *)
+      val table : Types.signature -> tab
+
+      (** This function returns the type expression for the value whose name is given,
+         in the given signature.
+         @raise Not_found if error.*)
+      val search_value : tab -> string -> Types.type_expr
+
+      (** This function returns the Types.extension_constructor for the extension whose name is given,
+         in the given table.
+         @raise Not_found if error.*)
+      val search_extension : tab -> string -> Types.extension_constructor
+
+      (** This function returns the Types.type_declaration  for the type whose name is given,
+         in the given table.
+         @raise Not_found if error.*)
+      val search_type : tab -> string -> Types.type_declaration
+
+      (** This function returns the Types.class_declaration  for the class whose name is given,
+         in the given table.
+         @raise Not_found if error.*)
+      val search_class : tab -> string -> Types.class_declaration
+
+      (** This function returns the Types.class_type_declaration  for the class type whose name is given,
+         in the given table.
+         @raise Not_found if error.*)
+      val search_class_type : tab -> string -> Types.class_type_declaration
+
+      (** This function returns the Types.module_type  for the module whose name is given,
+         in the given table.
+         @raise Not_found if error.*)
+      val search_module : tab -> string -> Types.module_type
+
+      (** This function returns the optional Types.module_type  for the module type whose name is given,
+         in the given table.
+         @raise Not_found if error.*)
+      val search_module_type : tab -> string -> Types.module_type option
+
+      (** This function returns the Types.type_expr  for the given val name
+         in the given class signature.
+         @raise Not_found if error.*)
+      val search_attribute_type :
+          Types.Vars.key -> Types.class_signature -> Types.type_expr
+
+     (** This function returns the Types.type_expr  for the given method name
+        in the given class signature.
+        @raise Not_found if error.*)
+      val search_method_type :
+          string -> Types.class_signature -> Types.type_expr
+    end
+
+(** Functions to retrieve simple and special comments from strings. *)
+module type Info_retriever =
+  sig
+    (** Return the couple [(n, list)] where [n] is the number of
+       characters read to retrieve [list], which is the list
+       of special comments found in the string. *)
+    val all_special :
+        string -> string -> int * Odoc_types.info list
+
+    (** Return true if the given string contains a blank line. *)
+    val blank_line_outside_simple :
+        string -> string -> bool
+
+   (** [just_after_special file str] return the pair ([length], [info_opt])
+      where [info_opt] is the first optional special comment found
+      in [str], without any blank line before. [length] is the number
+      of chars from the beginning of [str] to the end of the special comment. *)
+    val just_after_special :
+        string -> string -> (int * Odoc_types.info option)
+
+   (** [first_special file str] return the pair ([length], [info_opt])
+      where [info_opt] is the first optional special comment found
+      in [str]. [length] is the number of chars from the beginning of [str]
+      to the end of the special comment. *)
+    val first_special :
+        string -> string -> (int * Odoc_types.info option)
+
+    (** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special
+       comment found in the given string and not followed by a blank line,
+       and [element_comment_list] the list of values built from the other
+       special comments found and the given function. *)
+    val get_comments :
+        (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list)
+
+  end
+
+module Analyser :
+  functor (My_ir : Info_retriever) ->
+    sig
+      (** This variable is used to load a file as a string and retrieve characters from it.*)
+      val file : string ref
+
+      (** The name of the analysed file. *)
+      val file_name : string ref
+
+      (** This function takes two indexes (start and end) and return the string
+         corresponding to the indexes in the file global variable. The function
+         prepare_file must have been called to fill the file global variable.*)
+      val get_string_of_file : int -> int -> string
+
+      (** [prepare_file f input_f] sets [file_name] with [f] and loads the file
+         [input_f] into [file].*)
+      val prepare_file : string -> string -> unit
+
+      (** The function used to get the comments in a class. *)
+      val get_comments_in_class : int -> int ->
+        (Odoc_types.info option * Odoc_class.class_element list)
+
+      (** The function used to get the comments in a module. *)
+      val get_comments_in_module : int -> int ->
+        (Odoc_types.info option * Odoc_module.module_element list)
+
+      (** [name_comment_from_type_kind pos_end pos_limit type_kind].
+         This function takes a [Parsetree.type_kind] and returns the list of
+         (name, optional comment) for the various fields/constructors of the type,
+         or an empty list for an abstract type.
+         [pos_end] is last char of the complete type definition.
+         [pos_limit] is the position of the last char we could use to look for a comment,
+         i.e. usually the beginning on the next element.*)
+      val name_comment_from_type_decl :
+          int -> int -> Parsetree.type_declaration -> int * (string * Odoc_types.info option) list
+
+      (** This function converts a [Types.type_expr] into a [Odoc_type.type_kind],
+         by associating the comment found in the parstree of each object field, if any. *)
+      val manifest_structure :
+          Odoc_env.env -> (string * Odoc_types.info option) list ->
+            Types.type_expr -> Odoc_type.type_manifest
+
+      (** This function converts a [Types.type_kind] into a [Odoc_type.type_kind],
+         by associating the comment found in the parsetree of each constructor/field, if any.*)
+      val get_type_kind :
+          Odoc_env.env -> (string * Odoc_types.info option) list ->
+            Types.type_kind -> Odoc_type.type_kind
+
+      (** This function converts a [Types.constructor_arguments] into a
+          [Odoc_type.constructor_args], by associating the comment found
+          in the parsetree of each inner record field, if any.*)
+      val get_cstr_args:
+        Odoc_env.env -> int -> Typedtree.constructor_arguments ->
+        Odoc_type.constructor_args
+
+      (** This function merge two optional info structures. *)
+      val merge_infos :
+          Odoc_types.info option -> Odoc_types.info option ->
+            Odoc_types.info option
+
+      (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
+      val analyse_module_type_kind :
+          ?erased:Odoc_name.Set.t -> Odoc_env.env -> Odoc_name.t ->
+            Parsetree.module_type -> Types.module_type ->
+              Odoc_module.module_type_kind
+
+      (** Analysis of a Parsetree.class_type and a Types.class_type to
+         return a class_type_kind.*)
+      val analyse_class_type_kind : Odoc_env.env ->
+        Odoc_name.t -> int -> Parsetree.class_type -> Types.class_type ->
+          Odoc_class.class_type_kind
+
+      (** This function takes an interface file name, a file containg the code, a parse tree
+         and the signature obtained from the compiler.
+         It goes through the parse tree, creating values for encountered
+         functions, modules, ..., looking in the source file for comments,
+         and in the signature for types information. *)
+      val analyse_signature :
+        string -> string ->
+        Parsetree.signature -> Types.signature -> Odoc_module.t_module
+    end
diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
new file mode 100644
index 00000000..44d03db1
--- /dev/null
+++ b/ocamldoc/odoc_str.ml
@@ -0,0 +1,394 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The functions to get a string from different kinds of elements (types, modules, ...). *)
+
+module Name = Odoc_name
+
+let string_of_variance t (co,cn) =
+  if ( t.Odoc_type.ty_kind = Odoc_type.Type_abstract ||
+      t.Odoc_type.ty_kind = Odoc_type.Type_open ) &&
+    t.Odoc_type.ty_manifest = None
+  then
+    match (co, cn) with
+      (true, false) -> "+"
+    | (false, true) -> "-"
+    | _ -> ""
+  else
+    ""
+let rec is_arrow_type t =
+  match t.Types.desc with
+    Types.Tarrow _ -> true
+  | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
+  | Types.Ttuple _
+  | Types.Tconstr _
+  | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
+  | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
+
+let raw_string_of_type_list sep type_list =
+  let buf = Buffer.create 256 in
+  let fmt = Format.formatter_of_buffer buf in
+  let rec need_parent t =
+    match t.Types.desc with
+      Types.Tarrow _ | Types.Ttuple _ -> true
+    | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
+    | Types.Tconstr _ ->
+        false
+    | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
+    | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
+  in
+  let print_one_type variance t =
+    Printtyp.mark_loops t;
+    if need_parent t then
+      (
+       Format.fprintf fmt "(%s" variance;
+       Printtyp.type_scheme_max ~b_reset_names: false fmt t;
+       Format.fprintf fmt ")"
+      )
+    else
+      (
+       Format.fprintf fmt "%s" variance;
+       Printtyp.type_scheme_max ~b_reset_names: false fmt t
+      )
+  in
+  begin match type_list with
+    [] -> ()
+  | [(variance, ty)] -> print_one_type variance ty
+  | (variance, ty) :: tyl ->
+      Format.fprintf fmt "@[<hov 2>";
+      print_one_type variance ty;
+      List.iter
+        (fun (variance, t) ->
+          Format.fprintf fmt "@,%s" sep;
+          print_one_type variance t
+        )
+        tyl;
+      Format.fprintf fmt "@]"
+  end;
+  Format.pp_print_flush fmt ();
+  Buffer.contents buf
+
+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 =
+  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_type_extension_param_list te =
+  let par =
+    match te.Odoc_extension.te_type_parameters with
+      [] | [_] -> false
+    | _ -> true
+  in
+  Printf.sprintf "%s%s%s"
+    (if par then "(" else "")
+    (raw_string_of_type_list ", "
+       (List.map
+          (fun typ -> ("", typ))
+          te.Odoc_extension.te_type_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_class_params c =
+  let b = Buffer.create 256 in
+  let rec iter = function
+      Types.Cty_arrow (label, t, ctype) ->
+        let parent = is_arrow_type t in
+        Printf.bprintf b "%s%s%s%s -> "
+          (
+           match label with
+             Asttypes.Nolabel -> ""
+           | s -> Printtyp.string_of_label s ^":"
+          )
+          (if parent then "(" else "")
+          (Odoc_print.string_of_type_expr
+             (if Odoc_misc.is_optional label then
+               Odoc_misc.remove_option t
+             else
+               t
+             )
+          )
+          (if parent then ")" else "");
+        iter ctype
+    | Types.Cty_signature _
+    | Types.Cty_constr _ -> ()
+  in
+  iter c.Odoc_class.cl_type;
+  Buffer.contents b
+
+let bool_of_private = function
+  | Asttypes.Private -> true
+  | _ -> false
+
+let field_doc_str = function
+  | None -> ""
+  | Some t -> Printf.sprintf "(* %s *)" (Odoc_misc.string_of_info t)
+
+let string_of_record l =
+  let module M = Odoc_type in
+  let module P = Printf in
+  P.sprintf "{\n%s\n}" (
+    String.concat "\n" (
+      List.map (fun field ->
+          P.sprintf "   %s%s : %s;%s"
+            (if field.M.rf_mutable then "mutable " else "") field.M.rf_name
+            (Odoc_print.string_of_type_expr field.M.rf_type)
+            (field_doc_str field.M.rf_text)
+        ) l
+    )
+  )
+
+let string_of_type t =
+  let module M = Odoc_type in
+   let module P = Printf in
+   let priv = bool_of_private t.M.ty_private in
+   let parameters_str =
+     String.concat " " (
+       List.map (fun (p, co, cn) ->
+         (string_of_variance t (co, cn)) ^ (Odoc_print.string_of_type_expr p)
+       ) t.M.ty_parameters
+     )
+   in
+   let manifest_str =
+     match t.M.ty_manifest with
+     | None -> ""
+     | Some (M.Object_type fields) ->
+       P.sprintf "= %s<\n%s\n>\n" (if priv then "private " else "") (
+         String.concat "\n" (
+           List.map (fun field ->
+             P.sprintf "   %s : %s;%s" field.M.of_name
+               (Odoc_print.string_of_type_expr field.M.of_type)
+               (field_doc_str field.M.of_text)
+           ) fields
+        )
+     )
+   | Some (M.Other typ) ->
+     "= " ^ (if priv then "private " else "" ) ^
+       (Odoc_print.string_of_type_expr typ) ^ " "
+ in
+ let type_kind_str =
+   match t.M.ty_kind with
+   | M.Type_abstract -> ""
+   | M.Type_variant l ->
+     P.sprintf "=%s\n%s\n" (if priv then " private" else "") (
+       String.concat "\n" (
+         List.map (fun cons ->
+           let comment =
+             match cons.M.vc_text with
+             | None -> ""
+             | Some t -> P.sprintf "(* %s *)" (Odoc_misc.string_of_info t)
+           in
+           let string_of_parameters = function
+             | M.Cstr_tuple l ->
+                 String.concat " * " (
+                   List.map (fun t -> "("^Odoc_print.string_of_type_expr t^")") l
+                 )
+             | M.Cstr_record l ->
+                 string_of_record l
+           in
+           P.sprintf "  | %s%s%s" cons.M.vc_name (
+             match cons.M.vc_args, cons.M.vc_ret with
+              | M.Cstr_tuple [], None -> ""
+              | li, None -> " of " ^ (string_of_parameters li)
+              | M.Cstr_tuple [], Some r -> " : " ^ Odoc_print.string_of_type_expr r
+              | li, Some r ->
+                 P.sprintf " : %s -> %s" (string_of_parameters li)
+                   (Odoc_print.string_of_type_expr r)
+             ) comment
+           ) l
+        )
+      )
+
+  | M.Type_open ->
+      "= .." (* FIXME MG: when introducing new constuctors next time,
+                thanks to setup a minimal correct output *)
+  | M.Type_record l ->
+     P.sprintf "= %s{\n%s\n}\n" (if priv then "private " else "")
+       (string_of_record l)
+ in
+ P.sprintf "type %s %s %s%s%s" parameters_str (Name.simple t.M.ty_name)
+   manifest_str type_kind_str
+   (match t.M.ty_info with
+    | None -> ""
+    | Some info -> Odoc_misc.string_of_info info)
+
+let string_of_type_extension te =
+  let module M = Odoc_extension in
+  let module T = Odoc_type in
+    "type "
+    ^(String.concat ""
+        (List.map
+           (fun p -> (Odoc_print.string_of_type_expr p)^" ")
+           te.M.te_type_parameters
+        ))
+    ^te.M.te_type_name
+    ^" += "
+    ^(if (bool_of_private te.M.te_private) then "private " else "")
+    ^"\n"
+    ^(String.concat ""
+        (List.map
+           (fun x ->
+              "  | "
+              ^(Name.simple x.M.xt_name)
+              ^(match x.M.xt_args, x.M.xt_ret with
+                  | T.Cstr_tuple [], None -> ""
+                  | T.Cstr_tuple l, None ->
+                      " of " ^
+                        (String.concat " * "
+                           (List.map
+                              (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
+                  | T.Cstr_tuple [], Some r -> " : " ^ Odoc_print.string_of_type_expr r
+                  | T.Cstr_tuple l, Some r ->
+                      " : " ^
+                        (String.concat " * "
+                           (List.map
+                              (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
+                      ^ " -> " ^ Odoc_print.string_of_type_expr r
+                  | T.Cstr_record l, None ->
+                      " of " ^  string_of_record l
+                  | T.Cstr_record l, Some r ->
+                      " : " ^ string_of_record l ^ " -> "
+                      ^ Odoc_print.string_of_type_expr r
+               )
+              ^(match x.M.xt_alias with
+                    None -> ""
+                  | Some xa ->
+                      " = "^
+                        (match xa.M.xa_xt with
+                             None -> xa.M.xa_name
+                           | Some x2 -> x2.M.xt_name
+                        )
+               )
+              ^(match x.M.xt_text with
+                    None ->
+                      ""
+                  | Some t ->
+                      "(* "^(Odoc_misc.string_of_info t)^" *)"
+               )^"\n"
+           )
+           te.M.te_constructors))
+    ^(match te.M.te_info with
+          None -> ""
+        | Some i -> Odoc_misc.string_of_info i
+     )
+
+let string_of_exception e =
+  let module T = Odoc_type in
+  let module M = Odoc_exception in
+  "exception "^(Name.simple e.M.ex_name)^
+  (match e.M.ex_args, e.M.ex_ret with
+     T.Cstr_tuple [], None -> ""
+   | T.Cstr_tuple l,None ->
+       " of "^
+       (String.concat " * "
+         (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))
+   | T.Cstr_tuple [],Some r ->
+       " : "^
+       (Odoc_print.string_of_type_expr r)
+   | T.Cstr_tuple l,Some r ->
+       " : "^
+       (String.concat " * "
+         (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))^
+       " -> "^
+       (Odoc_print.string_of_type_expr r)
+   | T.Cstr_record l, None ->
+       " of " ^  string_of_record l
+   | T.Cstr_record l, Some r ->
+       " : " ^ string_of_record l ^ " -> "
+       ^ Odoc_print.string_of_type_expr r
+  )^
+  (match e.M.ex_alias with
+    None -> ""
+  | Some ea ->
+      " = "^
+      (match ea.M.ea_ex with
+        None -> ea.M.ea_name
+      | Some e2 -> e2.M.ex_name
+      )
+  )^"\n"^
+  (match e.M.ex_info with
+    None -> ""
+  | Some i -> Odoc_misc.string_of_info i)
+
+let string_of_value v =
+  let module M = Odoc_value in
+  "val "^(Name.simple v.M.val_name)^" : "^
+  (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)
+
+let string_of_attribute a =
+  let module M = Odoc_value in
+  "val "^
+  (if a.M.att_virtual then "virtual " else "")^
+  (if a.M.att_mutable then Odoc_messages.mutab^" " else "")^
+  (Name.simple a.M.att_value.M.val_name)^" : "^
+  (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)
+
+let string_of_method m =
+  let module M = Odoc_value in
+  "method "^
+  (if m.M.met_private then Odoc_messages.privat^" " else "")^
+  (Name.simple m.M.met_value.M.val_name)^" : "^
+  (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)
diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli
new file mode 100644
index 00000000..3cb52b4b
--- /dev/null
+++ b/ocamldoc/odoc_str.mli
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The functions to get a string from different kinds of elements (types, modules, ...). *)
+
+(** @return the variance string for the given type and (covariant, contravariant) information. *)
+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.
+   @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. *)
+val string_of_type_param_list : Odoc_type.t_type -> string
+
+(** This function returns a string to represent the list of type parameters
+   for the given type extension. *)
+val string_of_type_extension_param_list : Odoc_extension.t_type_extension -> 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
+
+val string_of_record : Odoc_type.record_field list -> string
+
+(** @return a string to display the parameters of the given class,
+   in the same form as the compiler. *)
+val string_of_class_params : Odoc_class.t_class -> string
+
+(** @return a string to describe the given type extension. *)
+val string_of_type_extension : Odoc_extension.t_type_extension -> string
+
+(** @return a string to describe the given exception. *)
+val string_of_exception : Odoc_exception.t_exception -> string
+
+(** @return a string to describe the given value. *)
+val string_of_value : Odoc_value.t_value -> string
+
+(** @return a string to describe the given attribute. *)
+val string_of_attribute : Odoc_value.t_attribute -> string
+
+(** @return a string to describe the given method. *)
+val string_of_method : Odoc_value.t_method -> string
diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
new file mode 100644
index 00000000..dec7a1ec
--- /dev/null
+++ b/ocamldoc/odoc_test.ml
@@ -0,0 +1,126 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 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
+
+module Generator (G : Odoc_gen.Base) =
+struct
+  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 :\n<[%s]>\n"
+               (match t.ty_manifest with
+                 None -> "None"
+               | Some (Object_type _fields) -> "< object type >" (* TODO *)
+               | Some (Other 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.Global.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
+
+  class generator =
+    let g = new string_gen in
+    object
+      inherit G.generator as base
+
+      method! generate l =
+        base#generate l;
+        g#generate l
+    end
+end;;
+
+let _ = Odoc_args.extend_base_generator (module Generator : Odoc_gen.Base_functor);;
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
new file mode 100644
index 00000000..b52e0358
--- /dev/null
+++ b/ocamldoc/odoc_texi.ml
@@ -0,0 +1,1315 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*       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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Generation of Texinfo documentation. *)
+
+open Odoc_info
+open Value
+open Type
+open Extension
+open Exception
+open Class
+open Module
+
+let esc_8bits = ref false
+
+let info_section = ref "OCaml"
+
+let info_entry = ref []
+
+(** {2 Some small helper functions} *)
+
+let puts_nl chan s =
+  output_string chan s ;
+  output_char chan '\n'
+let puts chan s =
+  output_string chan s
+let nl chan =
+  output_char chan '\n'
+
+let is = function
+  | None -> false
+  | Some _ -> true
+
+let pad_to n s =
+  let len = String.length s in
+  if len < n then s ^ String.make (n - len) ' ' else s
+
+let indent nb_sp s =
+  let c = ref 0 in
+  let len = pred (String.length s) in
+  for i = 0 to len do if s.[i] = '\n' then incr c done ;
+  let s' = Bytes.make (succ len + (succ !c) * nb_sp ) ' ' in
+  c := nb_sp ;
+  for i = 0 to len do
+    Bytes.set s' !c s.[i] ;
+    if s.[i] = '\n' then c := !c + nb_sp ;
+    incr c
+  done ;
+  Bytes.to_string s'
+
+type subparts = [
+  | `Module of Odoc_info.Module.t_module
+  | `Module_type of Odoc_info.Module.t_module_type
+  | `Class of Odoc_info.Class.t_class
+  | `Class_type of Odoc_info.Class.t_class_type
+  ]
+
+type menu_data = [
+  | subparts
+  | `Blank
+  | `Comment of string
+  | `Texi of string
+  | `Index of string
+] list
+
+let nothing = Verbatim ""
+
+let module_subparts =
+  let rec iter acc = function
+    | [] -> List.rev acc
+    (* skip aliases *)
+    | Element_module { m_kind = Module_alias _ } :: n ->
+        iter acc n
+    | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n ->
+        iter acc n
+    (* keep modules, module types, classes and class types *)
+    | Element_module m :: n ->
+        iter (`Module m :: acc) n
+    | Element_module_type mt :: n ->
+        iter (`Module_type mt :: acc) n
+    | Element_class c :: n ->
+        iter (`Class c :: acc) n
+    | Element_class_type ct :: n ->
+        iter (`Class_type ct :: acc) n
+    (* forget the rest *)
+    | _ :: n -> iter acc n
+  in
+  iter []
+
+type indices = [
+  | `Type
+  | `Extension
+  | `Exception
+  | `Value
+  | `Class_att
+  | `Method
+  | `Class
+  | `Class_type
+  | `Module
+  | `Module_type
+]
+
+let indices = function
+  | `Type        -> "ty"
+  | `Extension   -> "xt"
+  | `Exception   -> "ex"
+  | `Value       -> "va"
+  | `Class_att   -> "ca"
+  | `Method      -> "me"
+  | `Class       -> "cl"
+  | `Class_type  -> "ct"
+  | `Module      -> "mo"
+  | `Module_type -> "mt"
+
+let indices_names = [
+  "Types"           , "ty" ;
+  "Extensions"      , "xt" ;
+  "Exceptions"      , "ex" ;
+  "Values"          , "va" ;
+  "Class attributes", "ca" ;
+  "Methods"         , "me" ;
+  "Classes"         , "cl" ;
+  "Class types"     , "ct" ;
+  "Modules"         , "mo" ;
+  "Module types"    , "mt" ; ]
+
+
+
+(** Module for generating various Texinfo things (menus, xrefs, ...) *)
+module Texi =
+struct
+  (** Associations of strings to subsitute in Texinfo code. *)
+  let subst_strings = [
+    (Str.regexp "@", "@@") ;
+    (Str.regexp "{", "@{") ;
+    (Str.regexp "}", "@}") ;
+    (Str.regexp "\\.\\.\\.", "@dots{}") ;
+  ] @
+    (if !esc_8bits
+    then [
+    (Str.regexp "\xE0", "@`a") ;
+    (Str.regexp "\xE2", "@^a") ;
+    (Str.regexp "\xE9", "@'e") ;
+    (Str.regexp "\xE8", "@`e") ;
+    (Str.regexp "\xEA", "@^e") ;
+    (Str.regexp "\xEB", "@\"e") ;
+    (Str.regexp "\xF7", "@,{c}") ;
+    (Str.regexp "\xF4", "@^o") ;
+    (Str.regexp "\xF6", "@\"o") ;
+    (Str.regexp "\xEE", "@^i") ;
+    (Str.regexp "\xEF", "@\"i") ;
+    (Str.regexp "\xF9", "@`u") ;
+    (Str.regexp "\xFB", "@^u") ;
+    (Str.regexp "\xE6", "@ae{}" ) ;
+    (Str.regexp "\xC6", "@AE{}" ) ;
+    (Str.regexp "\xDF", "@ss{}" ) ;
+    (Str.regexp "\xA9", "@copyright{}" ) ;
+    ]
+    else [])
+
+  (** Escape the strings which would clash with Texinfo syntax. *)
+  let escape s =
+    List.fold_left
+      (fun acc (p, r) -> Str.global_replace p r acc)
+      s subst_strings
+
+  (** Removes dots (no good for a node name). *)
+  let fix_nodename s =
+    Str.global_replace (Str.regexp "\\.") "/" (escape s)
+
+  (** Generates a Texinfo menu. *)
+  let generate_menu chan subpart_list =
+    if subpart_list <> []
+    then begin
+      let menu_line part_qual name =
+        let sname = Name.simple name in
+        if sname = name
+        then (
+          puts chan (pad_to 35
+                       ("* " ^ sname ^ ":: ")) ;
+          puts_nl chan part_qual )
+        else (
+          puts chan (pad_to 35
+                       ("* " ^ sname ^ ": " ^ (fix_nodename name) ^ ". " )) ;
+          puts_nl chan part_qual )
+      in
+      puts_nl chan "@menu" ;
+      List.iter
+        (function
+        | `Module { m_name = name } ->
+            menu_line Odoc_messages.modul name
+        | `Module_type { mt_name = name } ->
+            menu_line Odoc_messages.module_type name
+        | `Class { cl_name = name } ->
+            menu_line Odoc_messages.clas name
+        | `Class_type { clt_name = name } ->
+            menu_line Odoc_messages.class_type name
+        | `Blank -> nl chan
+        | `Comment c -> puts_nl chan (escape c)
+        | `Texi t -> puts_nl chan t
+        | `Index ind -> Printf.fprintf chan "* %s::\n" ind)
+      subpart_list ;
+    puts_nl chan "@end menu"
+  end
+
+  (** cross reference to node [name] *)
+  let xref ?xname name =
+    "@xref{" ^ (fix_nodename name) ^
+    (match xname with | None -> "" | Some s -> "," ^ s) ^
+    "}."
+
+  (** enclose the string between [\@ifinfo] tags *)
+  let ifinfo s =
+    String.concat "\n"
+      [ "@ifinfo" ; s ; "@end ifinfo" ; "" ]
+
+  (** [install-info] information *)
+  let dirsection sec =
+    "@dircategory " ^ (escape sec)
+
+  let direntry ent =
+    [ "@direntry" ] @
+      (List.map escape ent) @
+    [ "@end direntry" ]
+end
+
+
+
+
+
+(** {2 Generation of Texinfo code} *)
+
+(** This class generates Texinfo code from text structures *)
+class text =
+  object(self)
+
+  (** Associations between a title number and texinfo code. *)
+    val titles = [
+      1, "@chapter " ;
+      2, "@section " ;
+      3, "@subsection " ;
+      4, "@subsubsection " ;
+    ]
+
+    val fallback_title =
+      "@unnumberedsubsubsec "
+
+    val headings = [
+      1, "@majorheading " ;
+      2, "@heading " ;
+      3, "@subheading " ;
+      4, "@subsubheading " ;
+    ]
+
+    val fallback_heading =
+      "@subsubheading "
+
+    method escape =
+      Texi.escape
+
+    (** this method is not used here but is virtual
+        in a class we will inherit later *)
+    method label ?no_:(_ : bool option) (_ : string) : string =
+      failwith "gni"
+
+    (** Return the Texinfo code corresponding to the [text] parameter.*)
+    method texi_of_text t =
+      String.concat ""
+        (List.map self#texi_of_text_element t)
+
+
+    (** {3 Conversion methods}
+       [texi_of_????] converts a [text_element] to a Texinfo string. *)
+
+    (** Return the Texinfo code for the [text_element] in parameter. *)
+    method texi_of_text_element = function
+      | Verbatim s | Latex s -> self#texi_of_Verbatim s
+      | Raw s -> self#texi_of_Raw s
+      | Code s -> self#texi_of_Code s
+      | CodePre s -> self#texi_of_CodePre s
+      | Bold t -> self#texi_of_Bold t
+      | Italic t -> self#texi_of_Italic t
+      | Emphasize t -> self#texi_of_Emphasize t
+      | Center t -> self#texi_of_Center t
+      | Left t -> self#texi_of_Left t
+      | Right t -> self#texi_of_Right t
+      | List tl -> self#texi_of_List tl
+      | Enum tl -> self#texi_of_Enum tl
+      | Newline -> self#texi_of_Newline
+      | Block t -> self#texi_of_Block t
+      | Title (n, _, t) -> self#texi_of_Title n t
+      | Link (s, t) -> self#texi_of_Link s t
+      | 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 -> ""
+      | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t
+      | Odoc_info.Target (target, code) -> self#texi_of_Target ~target ~code
+
+    method texi_of_custom_text _ _ = ""
+
+    method texi_of_Target ~target ~code =
+      if String.lowercase_ascii target = "texi" then code else ""
+
+    method texi_of_Verbatim s = s
+    method texi_of_Raw s = self#escape s
+    method texi_of_Code s = "@code{" ^ (self#escape s) ^ "}"
+    method texi_of_CodePre s =
+      String.concat "\n"
+        [ "" ;  "@example" ; self#escape s ; "@end example" ; "" ]
+    method texi_of_Bold t = "@strong{" ^ (self#texi_of_text t) ^ "}"
+    method texi_of_Italic t = "@i{" ^ (self#texi_of_text t) ^ "}"
+    method texi_of_Emphasize t = "@emph{" ^ (self#texi_of_text t) ^ "}"
+    method texi_of_Center t =
+      let sl = Str.split (Str.regexp "\n") (self#texi_of_text t) in
+      String.concat ""
+        ((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ])
+    method texi_of_Left t =
+      String.concat "\n"
+        [ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ]
+    method texi_of_Right t =
+      String.concat "\n"
+        [ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ]
+    method texi_of_List tl =
+      String.concat "\n"
+        ( [ "" ; "@itemize" ] @
+          (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @
+          [ "@end itemize"; "" ] )
+    method texi_of_Enum tl =
+      String.concat "\n"
+        ( [ "" ; "@enumerate" ] @
+          (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @
+          [ "@end enumerate"; "" ] )
+    method texi_of_Newline = "\n"
+    method texi_of_Block t =
+      String.concat "\n"
+        [ "@format" ; self#texi_of_text t ; "@end format" ; "" ]
+    method texi_of_Title n t =
+      let t_begin =
+        try List.assoc n titles
+        with Not_found -> fallback_title in
+      t_begin ^ (self#texi_of_text t) ^ "\n"
+    method texi_of_Link s t =
+      String.concat ""
+        [ "@uref{" ; s ;  "," ; self#texi_of_text t ; "}" ]
+    method texi_of_Ref name kind =
+      let xname =
+        match kind with
+        | Some RK_module ->
+            Odoc_messages.modul ^ " " ^ (Name.simple name)
+        | Some RK_module_type ->
+            Odoc_messages.module_type ^ " " ^ (Name.simple name)
+        | Some RK_class ->
+            Odoc_messages.clas ^ " " ^ (Name.simple name)
+        | Some RK_class_type ->
+            Odoc_messages.class_type ^ " " ^ (Name.simple name)
+        | _ -> ""
+      in
+      if xname = "" then self#escape name else Texi.xref ~xname name
+    method texi_of_Superscript t =
+      "^@{" ^ (self#texi_of_text t) ^ "@}"
+    method texi_of_Subscript t =
+      "_@{" ^ (self#texi_of_text t) ^ "@}"
+
+    method heading n t =
+      let f =
+        try List.assoc n headings
+        with Not_found -> fallback_heading
+      in
+      f ^ (self#texi_of_text t) ^ "\n"
+
+    method fixedblock t =
+      Block ( ( Verbatim "@t{" :: t ) @ [ Verbatim "}" ] )
+
+  end
+
+exception Aliased_node
+
+module Generator =
+struct
+
+(** This class is used to create objects which can generate a simple
+    Texinfo documentation. *)
+class texi =
+  object (self)
+    inherit text
+    inherit Odoc_to_text.to_text as to_text
+
+    (** {3 Small helper stuff.} *)
+
+    val maxdepth = 4
+
+    val bullet = Verbatim " @bullet{} "
+    val minus  = Verbatim " @minus{} "
+    val linebreak =  Verbatim "@*\n"
+
+    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
+
+    method index (ind : indices) ent =
+      Verbatim
+        (if !Global.with_index
+        then (assert(List.mem ind indices_to_build) ;
+              String.concat ""
+                [ "@" ; indices ind ; "index " ;
+                  Texi.escape (Name.simple ent) ; "\n" ])
+        else "")
+
+
+    (** Two hacks to fix linebreaks in the descriptions.*)
+    method private fix_linebreaks =
+      let re = Str.regexp "\n[ \t]*" in
+      fun t ->
+        List.map
+          (function
+            | Newline -> Raw "\n"
+            | Raw s -> Raw (Str.global_replace re "\n" s)
+            | List tel -> List (List.map self#fix_linebreaks tel)
+            | Enum tel -> Enum (List.map self#fix_linebreaks tel)
+            | txt -> txt) t
+
+    method private soft_fix_linebreaks =
+      let re = Str.regexp "\n[ \t]*" in
+      fun ind t ->
+        let rep = "\n" ^ String.make ind ' ' in
+        List.map
+          (function
+            | Raw s -> Raw (Str.global_replace re rep s)
+            | txt -> txt) t
+
+    (** {3 [text] values generation}
+       Generates [text] values out of description parts.
+       Redefines some of methods of {! Odoc_to_text.to_text}. *)
+
+    method text_of_desc = function
+      | None -> []
+      | Some [ Raw "" ] -> []
+      | Some t -> (self#fix_linebreaks t) @ [ Newline ]
+
+    method text_of_sees_opt see_l =
+      List.concat
+        (List.map
+           (function
+             | (See_url s, t) ->
+                 [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ;
+                   Raw " " ; Link (s, t) ; Newline ]
+             | (See_file s, t)
+             | (See_doc s, t)  ->
+                 [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ;
+                   Raw " " ; Raw s ] @ t @ [ Newline ])
+           see_l)
+
+    method! text_of_before l =
+      List.flatten
+      (List.map
+        (fun x -> linebreak :: (to_text#text_of_before [x])) l)
+
+    method text_of_params params_list =
+        List.concat
+          (List.map
+             (fun (s, t) ->
+               [ linebreak ;
+                 Bold [ Raw Odoc_messages.parameters ] ;
+                 Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] )
+             params_list)
+
+    method! text_of_raised_exceptions = function
+      | [] -> []
+      | (s, t) :: [] ->
+          [ linebreak ;
+            Bold [ Raw Odoc_messages.raises ] ;
+            Raw " " ; Code s ; Raw " " ]
+          @ t @ [ Newline ]
+      | l ->
+          [ linebreak ;
+            Bold [ Raw Odoc_messages.raises ] ;
+            Raw " :" ;
+            List
+              (List.map
+                 (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ;
+            Newline ]
+
+    method! text_of_return_opt = function
+      | None -> []
+      | Some t ->
+          (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ]
+
+    method! text_of_custom c_l =
+      List.flatten
+        (List.rev
+           (List.fold_left
+              (fun acc -> fun (tag, text) ->
+                try
+                  let f = List.assoc tag tag_functions in
+                  ( linebreak :: (f text) @ [ Newline ] ) :: acc
+                with
+               Not_found ->
+                 Odoc_info.warning (Odoc_messages.tag_not_handled tag) ;
+                 acc
+              ) [] c_l))
+
+    method! text_of_info ?(block=false) = function
+      | None -> []
+      | Some info ->
+          let t =
+            List.concat
+                 [ ( match info.i_deprecated with
+                 | None -> []
+                 | Some t ->
+                     (Raw (Odoc_messages.deprecated ^ " ")) ::
+                     (self#fix_linebreaks t)
+                     @ [ Newline ; Newline ] ) ;
+                   self#text_of_desc info.i_desc ;
+                   if info.i_authors <> []
+                   then ( linebreak ::
+                          self#text_of_author_list info.i_authors )
+                   else [] ;
+                   if is info.i_version
+                   then ( linebreak ::
+                          self#text_of_version_opt info.i_version )
+                   else [] ;
+                   self#text_of_sees_opt info.i_sees ;
+                   self#text_of_before info.i_before ;
+                   if is info.i_since
+                   then ( linebreak ::
+                          self#text_of_since_opt info.i_since )
+                   else [] ;
+                   self#text_of_params info.i_params ;
+                   self#text_of_raised_exceptions info.i_raised_exceptions ;
+                   if is info.i_return_value
+                   then ( linebreak ::
+                          self#text_of_return_opt info.i_return_value )
+                   else [] ;
+                   self#text_of_custom info.i_custom ;
+                 ] in
+          if block
+          then [ Block t ]
+          else (t @ [ Newline ] )
+
+    method texi_of_info i =
+      self#texi_of_text (self#text_of_info i)
+
+    (** {3 Conversion of [module_elements] into Texinfo strings}
+       The following functions convert [module_elements] and their
+       description to [text] values then to Texinfo strings using the
+       functions above. *)
+
+    method text_el_of_type_expr m_name typ =
+      Raw (indent 5
+             (self#relative_idents m_name
+                (Odoc_info.string_of_type_expr typ)))
+
+    method! text_of_short_type_expr m_name typ =
+      [ Raw (self#normal_type m_name typ) ]
+
+    (** Return Texinfo code for a value. *)
+    method texi_of_value v =
+      Odoc_info.reset_type_names () ;
+      let t = [ self#fixedblock
+                  [ Newline ; minus ;
+                    Raw ("val " ^ (Name.simple v.val_name) ^ " :\n") ;
+                    self#text_el_of_type_expr
+                      (Name.father v.val_name) v.val_type ] ;
+                self#index `Value v.val_name ; Newline  ] @
+                (self#text_of_info v.val_info) in
+      self#texi_of_text t
+
+
+    (** Return Texinfo code for a class attribute. *)
+    method texi_of_attribute a =
+      Odoc_info.reset_type_names () ;
+      let t = [ self#fixedblock
+                  [ Newline ; minus ;
+                    Raw "val " ;
+                    Raw (if a.att_virtual then "virtual " else "") ;
+                    Raw (if a.att_mutable then "mutable " else "") ;
+                    Raw (Name.simple a.att_value.val_name) ;
+                    Raw " :\n" ;
+                    self#text_el_of_type_expr
+                      (Name.father a.att_value.val_name)
+                      a.att_value.val_type ] ;
+                self#index `Class_att a.att_value.val_name  ; Newline ] @
+        (self#text_of_info a.att_value.val_info) in
+      self#texi_of_text t
+
+
+    (** Return Texinfo code for a class method. *)
+    method texi_of_method m =
+      Odoc_info.reset_type_names () ;
+      let t = [ self#fixedblock
+                  [ Newline ; minus ; Raw "method " ;
+                    Raw (if m.met_private then "private " else "") ;
+                    Raw (if m.met_virtual then "virtual " else "") ;
+                    Raw (Name.simple m.met_value.val_name) ;
+                    Raw " :\n" ;
+                    self#text_el_of_type_expr
+                      (Name.father m.met_value.val_name)
+                      m.met_value.val_type ] ;
+                self#index `Method m.met_value.val_name ; Newline ] @
+        (self#text_of_info m.met_value.val_info) in
+      self#texi_of_text t
+
+
+    method string_of_type_parameters t =
+      let f (tp, co, cn) =
+        Printf.sprintf "%s%s"
+          (Odoc_info.string_of_variance t (co, cn))
+          (Odoc_info.string_of_type_expr tp)
+      in
+      match t.ty_parameters with
+      | [] -> ""
+      | [ (tp, co, cn) ] ->
+          (f (tp, co, cn))^" "
+      | l ->
+          Printf.sprintf "(%s) "
+            (String.concat ", " (List.map f l))
+
+    method string_of_type_args (args:constructor_args) (ret:Types.type_expr option) =
+      let f = function
+        | Cstr_tuple l -> Odoc_info.string_of_type_list " * " l
+        | Cstr_record l -> Odoc_info.string_of_record l
+      in
+      match args, ret with
+      | Cstr_tuple [], None -> ""
+      | args, None -> " of " ^ (f args)
+      | Cstr_tuple [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r)
+      | args, Some r -> " : " ^ (f args) ^
+                                " -> " ^ (Odoc_info.string_of_type_expr r)
+
+    (** Return Texinfo code for a type. *)
+    method texi_of_type ty =
+      Odoc_info.reset_type_names () ;
+      let entry_doc = function
+        | None -> [ Newline ]
+        | Some t ->
+          (Raw (indent 5 "\n(*\n") :: (self#soft_fix_linebreaks 8 (self#text_of_info (Some t))))
+          @ [ Raw " *)" ; Newline ]
+      in
+      let t =
+        [ self#fixedblock (
+          [ Newline ; minus ; Raw "type " ;
+            Raw (self#string_of_type_parameters ty) ;
+            Raw (Name.simple ty.ty_name) ] @
+          let priv = ty.ty_private = Asttypes.Private in
+          ( match ty.ty_manifest with
+          | None -> []
+          | Some (Other typ) ->
+              (Raw " = ") ::
+              (Raw (if priv then "private " else "")) ::
+              (self#text_of_short_type_expr (Name.father ty.ty_name) typ)
+          | Some (Object_type l) ->
+               (Raw (" = "^(if priv then "private " else "")^"{\n")) ::
+               (List.flatten
+                  (List.map
+                     (fun r ->
+                       [ Raw ("  " ^ r.of_name ^ " : ") ] @
+                       (self#text_of_short_type_expr
+                          (Name.father r.of_name)
+                          r.of_type) @
+                       [ Raw " ;" ] @
+                       (entry_doc r.of_text))
+                     l ) )
+               @  [ Raw " }" ]
+          ) @
+          (
+           match ty.ty_kind with
+           | Type_abstract -> [ Newline ]
+           | Type_variant l ->
+               (Raw (" ="^(if priv then " private" else "")^"\n")) ::
+               (List.flatten
+                  (List.map
+                     (fun constr ->
+                       (Raw ("  | " ^ constr.vc_name)) ::
+                       (Raw (self#string_of_type_args
+                               constr.vc_args constr.vc_ret)) ::
+                         (entry_doc constr.vc_text)
+                         ) l ) )
+           | Type_record l ->
+               (Raw (" = "^(if priv then "private " else "")^"{\n")) ::
+               (List.flatten
+                  (List.map
+                     (fun r ->
+                       [ Raw ("  " ^ r.rf_name ^ " : ") ] @
+                       (self#text_of_short_type_expr
+                          (Name.father r.rf_name)
+                          r.rf_type) @
+                       [ Raw " ;" ] @
+                        (entry_doc r.rf_text)
+                        )
+                     l ) )
+               @  [ Raw " }" ]
+           | Type_open -> [ Raw " = .." ; Newline ]
+          ) ) ;
+          self#index `Type ty.ty_name ; Newline ] @
+        (self#text_of_info ty.ty_info) in
+      self#texi_of_text t
+
+    (** Return Texinfo code for a type extension. *)
+    method texi_of_type_extension m_name te =
+      Odoc_info.reset_type_names () ;
+      let t =
+        ( self#fixedblock (
+            [ Newline ; minus ;
+              Raw "type " ;
+              Raw (match te.te_type_parameters with
+                     | [] -> ""
+                     | [ tp ] ->
+                         Printf.sprintf "%s "
+                           (Odoc_info.string_of_type_expr tp)
+                     | l ->
+                         Printf.sprintf "(%s) "
+                           (String.concat ", "
+                              (List.map Odoc_info.string_of_type_expr l))) ;
+              Raw (self#relative_idents m_name te.te_type_name) ;
+              Raw (" +=" ^
+                      (if te.te_private = Asttypes.Private
+                       then " private" else "")^"\n") ] @
+              (List.flatten
+                 (List.map
+                    (fun x ->
+                       (Raw ("  | " ^ (Name.simple x.xt_name))) ::
+                         (Raw (self#string_of_type_args
+                                 x.xt_args x.xt_ret)) ::
+                         (match x.xt_alias with
+                            | None -> []
+                            | Some xa ->
+                                [ Raw " = " ;
+                                  Raw ( match xa.xa_xt with
+                                          | None -> xa.xa_name
+                                          | Some x -> x.xt_name ) ]) @
+                         (match x.xt_text with
+                            | None -> [ Newline ]
+                            | Some t ->
+                                (Raw (indent 5 "\n(* ") ::
+                                   self#soft_fix_linebreaks 8
+                                     (self#text_of_info (Some t))) @
+                                  [ Raw " *)" ; Newline ] ) @
+                         [self#index `Extension x.xt_name ] )
+                    te.te_constructors ) ) ) ) ::
+          (self#text_of_info te.te_info) in
+        self#texi_of_text t
+
+    (** Return Texinfo code for an exception. *)
+    method texi_of_exception e =
+      Odoc_info.reset_type_names () ;
+      let t =
+        [ self#fixedblock
+            ( [ Newline ; minus ; Raw "exception " ;
+                Raw (Name.simple e.ex_name) ;
+                Raw (self#string_of_type_args e.ex_args e.ex_ret) ] @
+              (match e.ex_alias with
+              | None -> []
+              | Some ea -> [ Raw " = " ; Raw
+                               ( match ea.ea_ex with
+                               | None -> ea.ea_name
+                               | Some e -> e.ex_name ) ; ]
+              ) ) ;
+          self#index `Exception e.ex_name ; Newline ] @
+        (self#text_of_info e.ex_info) in
+      self#texi_of_text t
+
+
+    (** Return the Texinfo code for the given module. *)
+    method texi_of_module m =
+      let is_alias = function
+        | { m_kind = Module_alias _ } -> true
+        | _ -> false in
+      let is_alias_there = function
+        | { m_kind = Module_alias { ma_module = None } } -> false
+        | _ -> true in
+      let resolve_alias_name = function
+        | { m_kind = Module_alias { ma_name = name } } -> name
+        | { m_name = name } -> name in
+      let t =
+        [ [ self#fixedblock
+              [ Newline ; minus ; Raw "module " ;
+                Raw (Name.simple m.m_name) ;
+                Raw (if is_alias m
+                then " = " ^ (resolve_alias_name m)
+                else "" ) ] ] ;
+          ( if is_alias_there m
+          then [ Ref (resolve_alias_name m, Some RK_module, None) ;
+                 Newline ; ]
+          else [] ) ;
+          ( if is_alias m
+          then [ self#index `Module m.m_name ; Newline ]
+          else [ Newline ] ) ;
+          self#text_of_info m.m_info ]
+      in
+      self#texi_of_text (List.flatten t)
+
+    (** Return the Texinfo code for the given module type. *)
+    method texi_of_module_type mt =
+      let is_alias = function
+        | { mt_kind = Some (Module_type_alias _) } -> true
+        | _ -> false in
+      let is_alias_there = function
+        | { mt_kind = Some (Module_type_alias { mta_module = None }) } -> false
+        | _ -> true in
+      let resolve_alias_name = function
+        | { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name
+        | { mt_name = name } -> name in
+      let t =
+        [ [ self#fixedblock
+              [ Newline ; minus ; Raw "module type " ;
+                Raw (Name.simple mt.mt_name) ;
+                Raw (if is_alias mt
+                then " = " ^ (resolve_alias_name mt)
+                else "" ) ] ] ;
+          ( if is_alias_there mt
+          then [ Ref (resolve_alias_name mt, Some RK_module_type, None) ;
+                 Newline ; ]
+          else [] ) ;
+          ( if is_alias mt
+          then [ self#index `Module_type mt.mt_name ; Newline ]
+          else [ Newline ] ) ;
+          self#text_of_info mt.mt_info ]
+      in
+      self#texi_of_text (List.flatten t)
+
+    (** Return the Texinfo code for the given included module. *)
+    method texi_of_included_module im =
+      let t = [ self#fixedblock
+                  ( Newline :: minus :: (Raw "include ") ::
+                    ( match im.im_module with
+                    | None ->
+                        [ Raw im.im_name ]
+                    | Some (Mod { m_name = name }) ->
+                        [ Raw name ; Raw "\n     " ;
+                          Ref (name, Some RK_module, None) ]
+                    | Some (Modtype { mt_name = name }) ->
+                        [ Raw name ; Raw "\n     " ;
+                          Ref (name, Some RK_module_type, None) ]
+                    ) @
+                   [ Newline ] @
+                   (self#text_of_info im.im_info)
+                  )
+              ]
+      in
+      self#texi_of_text t
+
+    (** Return the Texinfo code for the given class. *)
+    method texi_of_class c =
+      Odoc_info.reset_type_names () ;
+      let t = [ self#fixedblock
+                  [ Newline ; minus ; Raw "class " ;
+                    Raw (Name.simple c.cl_name) ] ;
+                Ref (c.cl_name, Some RK_class, None) ; Newline ;
+                Newline ] @ (self#text_of_info c.cl_info) in
+      self#texi_of_text t
+
+    (** Return the Texinfo code for the given class type. *)
+    method texi_of_class_type ct =
+      Odoc_info.reset_type_names () ;
+      let t = [ self#fixedblock
+                  [ Newline ; minus ; Raw "class type " ;
+                    Raw (Name.simple ct.clt_name) ] ;
+                Ref (ct.clt_name, Some RK_class_type, None) ; Newline ;
+                Newline ] @ (self#text_of_info ct.clt_info) in
+      self#texi_of_text t
+
+    (** Return the Texinfo code for the given class element. *)
+    method texi_of_class_element _class_name class_ele =
+      match class_ele with
+      | Class_attribute att -> self#texi_of_attribute att
+      | Class_method met -> self#texi_of_method met
+      | Class_comment t -> self#texi_of_text t
+
+    (** Return the Texinfo code for the given module element. *)
+    method texi_of_module_element module_name module_ele =
+      (match module_ele with
+      | Element_module m -> self#texi_of_module m
+      | Element_module_type mt -> self#texi_of_module_type mt
+      | Element_included_module im -> self#texi_of_included_module im
+      | Element_class c -> self#texi_of_class c
+      | Element_class_type ct -> self#texi_of_class_type ct
+      | Element_value v -> self#texi_of_value v
+      | Element_type_extension te -> self#texi_of_type_extension module_name te
+      | Element_exception e -> self#texi_of_exception e
+      | Element_type t -> self#texi_of_type t
+      | Element_module_comment t ->
+          self#texi_of_text (Newline :: t @ [Newline])
+      )
+
+    (** {3 Generating methods }
+       These methods write Texinfo code to an [out_channel] *)
+
+    (** Generate the Texinfo code for the given list of inherited classes.*)
+    method generate_inheritance_info chanout inher_l =
+      let f inh =
+        match inh.ic_class with
+        | None -> (* we can't make the reference *)
+            (Code inh.ic_name) ::
+            (match inh.ic_text with
+            | None -> []
+            | Some t -> Newline :: t)
+        | Some cct -> (* we can create the reference *)
+            let kind =
+              match cct with
+              | Cl _ -> Some RK_class
+              | Cltype _ -> Some RK_class_type in
+            (Code inh.ic_name) ::
+            (Ref (inh.ic_name, kind, None)) ::
+            ( match inh.ic_text with
+            | None -> []
+            | Some t -> Newline :: t)
+      in
+      let text = [
+        Bold [ Raw Odoc_messages.inherits ] ;
+        List (List.map f inher_l) ; Newline ]
+      in
+      puts chanout (self#texi_of_text text)
+
+
+
+    (** Generate the Texinfo code for the inherited classes
+       of the given class. *)
+    method generate_class_inheritance_info chanout cl =
+      let rec iter_kind = function
+        | Class_structure ([], _) -> ()
+        | Class_structure (l, _) ->
+            self#generate_inheritance_info chanout l
+        | Class_constraint (k, _) -> iter_kind k
+        | Class_apply _
+        | Class_constr _ -> ()
+      in
+      iter_kind cl.cl_kind
+
+
+
+    (** Generate the Texinfo code for the inherited classes
+       of the given class type. *)
+    method generate_class_type_inheritance_info chanout clt =
+      match clt.clt_kind with
+      | Class_signature ([], _) ->
+          ()
+      | Class_signature (l, _) ->
+          self#generate_inheritance_info chanout l
+      | Class_type _ ->
+          ()
+
+    (** 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 = [
+        self#node depth c.cl_name ;
+        Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ;
+                                    Code c.cl_name ]) ;
+        self#index `Class c.cl_name ] in
+      puts chanout (self#texi_of_text title) ;
+
+      if is c.cl_info
+      then begin
+        let descr = [ Title (succ depth, None,
+                             [ Raw Odoc_messages.description ]) ] in
+        puts chanout (self#texi_of_text descr) ;
+        puts chanout (self#texi_of_info c.cl_info)
+      end ;
+
+      let intf = [ Title (succ depth, None,
+                          [ Raw Odoc_messages.interface]) ] in
+      puts chanout (self#texi_of_text intf);
+      self#generate_class_inheritance_info chanout c ;
+      List.iter
+        (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 = [
+        self#node depth ct.clt_name ;
+        Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ;
+                                    Code ct.clt_name ]) ;
+        self#index `Class_type ct.clt_name ] in
+      puts chanout (self#texi_of_text title) ;
+
+      if is ct.clt_info
+      then begin
+        let descr = [ Title (succ depth, None,
+                             [ Raw Odoc_messages.description ]) ] in
+        puts chanout (self#texi_of_text descr) ;
+        puts chanout (self#texi_of_info ct.clt_info)
+      end ;
+
+      let intf = [ Title (succ depth, None,
+                          [ Raw Odoc_messages.interface ]) ] in
+      puts chanout (self#texi_of_text intf) ;
+      self#generate_class_type_inheritance_info chanout ct;
+      List.iter
+        (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 ;
+        Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ;
+                              Code mt.mt_name ]) ;
+        self#index `Module_type mt.mt_name ; Newline ] in
+      puts chanout (self#texi_of_text title) ;
+
+      if is mt.mt_info
+      then begin
+        let descr = [ Title (succ depth, None,
+                             [ Raw Odoc_messages.description ]) ] in
+        puts chanout (self#texi_of_text descr) ;
+        puts chanout (self#texi_of_info mt.mt_info)
+      end ;
+
+      let mt_ele = Module.module_type_elements ~trans:true mt in
+      let subparts = module_subparts mt_ele in
+      if depth < maxdepth && subparts <> []
+      then begin
+        let menu = Texi.ifinfo
+            ( self#heading (succ depth) [ Raw "Subparts" ]) in
+        puts chanout menu ;
+        Texi.generate_menu chanout (subparts :> menu_data)
+      end ;
+
+      let intf = [ Title (succ depth, None,
+                          [ Raw Odoc_messages.interface ]) ] in
+      puts chanout (self#texi_of_text intf) ;
+      List.iter
+        (fun ele -> puts chanout
+            (self#texi_of_module_element mt.mt_name ele))
+        mt_ele ;
+
+      (* create sub parts for modules, module types, classes and class types *)
+      List.iter
+        (function
+          | `Module m -> self#generate_for_module chanout m
+          | `Module_type mt -> self#generate_for_module_type chanout mt
+          | `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 = [
+        self#node depth m.m_name ;
+        Title (depth, None,
+               if m.m_text_only then
+                 [ Raw m.m_name ]
+               else
+                 [ Raw (Odoc_messages.modul ^ " ") ;
+                   Code m.m_name ]
+              ) ;
+        self#index `Module m.m_name ; Newline ] in
+      puts chanout (self#texi_of_text title) ;
+
+      if is m.m_info
+      then begin
+        let descr = [ Title (succ depth, None,
+                             [ Raw Odoc_messages.description ]) ] in
+        puts chanout (self#texi_of_text descr) ;
+        puts chanout (self#texi_of_info m.m_info)
+      end ;
+
+      let m_ele = Module.module_elements ~trans:true m in
+      let subparts = module_subparts m_ele in
+      if depth < maxdepth && subparts <> []
+      then begin
+        let menu = Texi.ifinfo
+            ( self#heading (succ depth) [ Raw "Subparts" ]) in
+        puts chanout menu ;
+        Texi.generate_menu chanout (subparts :> menu_data)
+      end ;
+
+      let intf = [ Title (succ depth, None,
+                          [ Raw Odoc_messages.interface]) ] in
+      puts chanout (self#texi_of_text intf) ;
+
+      List.iter
+        (fun ele -> puts chanout
+            (self#texi_of_module_element m.m_name ele))
+        m_ele ;
+
+      (* create sub nodes for modules, module types, classes and class types *)
+      List.iter
+        (function
+          | `Module m -> self#generate_for_module chanout m
+          | `Module_type mt -> self#generate_for_module_type chanout mt
+          | `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 TeXinfo document. *)
+    method generate_texi_header chan texi_filename m_list =
+      let title = match !Global.title with
+      | None -> ""
+      | Some s -> self#escape s in
+      let filename =
+        if texi_filename <> "ocamldoc.texi"
+        then
+          let fn = Filename.basename texi_filename in
+          (if Filename.check_suffix fn ".texi"
+          then Filename.chop_suffix fn ".texi"
+          else fn) ^ ".info"
+        else
+          if title <> ""
+          then title ^ ".info"
+          else "doc.info"
+      in
+      (* write a standard Texinfo header *)
+      List.iter
+        (puts_nl chan)
+        (List.flatten
+           [ [ "\\input texinfo   @c -*-texinfo-*-" ;
+               "@c %**start of header" ;
+               "@setfilename " ^ filename ;
+               "@settitle " ^ title ;
+               "@c %**end of header" ; ] ;
+
+             (if !Global.with_index then
+               List.map
+                 (fun ind ->
+                   "@defcodeindex " ^ (indices ind))
+                 indices_to_build
+             else []) ;
+
+             [ Texi.dirsection !info_section ] ;
+
+             Texi.direntry
+               (if !info_entry <> []
+               then !info_entry
+               else [ Printf.sprintf "* %s: (%s)."
+                        title
+                        (Filename.chop_suffix filename ".info") ]) ;
+
+             [ "@ifinfo" ;
+               "This file was generated by Ocamldoc using the Texinfo generator." ;
+               "@end ifinfo" ;
+
+               "@c no titlepage." ;
+
+               "@node Top, , , (dir)" ;
+               "@top "^ title ; ]
+           ] ) ;
+
+      (* insert the intro file *)
+      begin
+        match !Odoc_info.Global.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 m_list f)))
+      end ;
+
+      (* write a top menu *)
+      Texi.generate_menu chan
+        ((List.map (fun m -> `Module m) m_list) @
+         (if !Global.with_index then
+           let indices_names_to_build = List.map indices indices_to_build in
+           List.rev
+             (List.fold_left
+                (fun acc ->
+                  function (longname, shortname)
+                      when List.mem shortname indices_names_to_build ->
+                        (`Index (longname ^ " index")) :: acc
+                    | _ -> acc)
+                [ `Comment "Indices :" ; `Blank ]
+                indices_names )
+         else [] ))
+
+
+    (** Writes the trailer of the TeXinfo document. *)
+    method generate_texi_trailer chan =
+      nl chan ;
+      if !Global.with_index
+      then
+        let indices_names_to_build = List.map indices indices_to_build in
+        List.iter (puts_nl chan)
+          (List.flatten
+             (List.map
+                (fun (longname, shortname) ->
+                  if List.mem shortname indices_names_to_build
+                  then [ "@node " ^ longname ^ " index," ;
+                         "@unnumbered " ^ longname ^ " index" ;
+                         "@printindex " ^ shortname ; ]
+                  else [])
+                indices_names )) ;
+      if !Global.with_toc
+      then puts_nl chan "@contents" ;
+      puts_nl chan "@bye"
+
+
+    method do_index it =
+      if not (List.mem it indices_to_build)
+      then indices_to_build <- it :: indices_to_build
+
+   (** Scan the whole module information to know which indices need to be build *)
+    method scan_for_index : subparts -> unit = function
+      | `Module m ->
+          let m_ele = Module.module_elements ~trans:true m in
+          List.iter self#scan_for_index_in_mod m_ele
+      | `Module_type mt ->
+          let m_ele = Module.module_type_elements ~trans:true mt in
+          List.iter self#scan_for_index_in_mod m_ele
+      | `Class c ->
+          let c_ele = Class.class_elements ~trans:true c in
+          List.iter self#scan_for_index_in_class c_ele
+      | `Class_type ct ->
+          let c_ele = Class.class_type_elements ~trans:true ct in
+          List.iter self#scan_for_index_in_class c_ele
+
+    method scan_for_index_in_mod = function
+        (* no recursion *)
+      | Element_value _ -> self#do_index `Value
+      | Element_type_extension _ -> self#do_index `Extension
+      | Element_exception _ -> self#do_index `Exception
+      | Element_type _ -> self#do_index `Type
+      | Element_included_module _
+      | Element_module_comment _ -> ()
+         (* recursion *)
+      | Element_module m -> self#do_index `Module ;
+          self#scan_for_index (`Module m)
+      | Element_module_type mt -> self#do_index `Module_type ;
+          self#scan_for_index (`Module_type mt)
+      | Element_class c -> self#do_index `Class ;
+          self#scan_for_index (`Class c)
+      | Element_class_type ct -> self#do_index `Class_type ;
+          self#scan_for_index (`Class_type ct)
+
+    method scan_for_index_in_class = function
+      | Class_attribute _ -> self#do_index `Class_att
+      | Class_method _ -> self#do_index `Method
+      | Class_comment _ -> ()
+
+
+    (** Generate the Texinfo file from a module list,
+       in the {!Odoc_info.Global.out_file} file. *)
+    method generate module_list =
+      Hashtbl.clear node_tbl ;
+      let filename =
+        if !Global.out_file = Odoc_messages.default_out_file
+        then "ocamldoc.texi"
+        else !Global.out_file in
+      if !Global.with_index
+      then List.iter self#scan_for_index
+          (List.map (fun m -> `Module m) module_list) ;
+      try
+        let chanout = open_out
+            (Filename.concat !Global.target_dir filename) in
+        if !Global.with_header
+        then self#generate_texi_header chanout filename module_list ;
+        List.iter
+          (self#generate_for_module chanout)
+          module_list ;
+        if !Global.with_trailer
+        then self#generate_texi_trailer chanout ;
+        close_out chanout
+      with
+      | Failure s
+      | Sys_error s ->
+          prerr_endline s ;
+          incr Odoc_info.errors
+  end
+end
+
+module type Texi_generator = module type of Generator
diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml
new file mode 100644
index 00000000..889bb5fb
--- /dev/null
+++ b/ocamldoc/odoc_text.ml
@@ -0,0 +1,169 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Text_syntax of int * int * string (* line, char, string *)
+
+open Odoc_types
+
+module Texter =
+  struct
+    (* builds a text structure from a string. *)
+    let text_of_string s =
+      let lexbuf = Lexing.from_string s in
+      try
+        Odoc_text_lexer.init ();
+        Odoc_text_parser.main Odoc_text_lexer.main lexbuf
+      with
+        _ ->
+          raise (Text_syntax (!Odoc_text_lexer.line_number,
+                              !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 (name, kind_opt, text_opt) ->
+        begin
+          p b "%s{!%s%s}"
+            (match text_opt with None -> "" | Some _ -> "{")
+            (match kind_opt with
+               None -> ""
+             | Some k ->
+                 let s =
+                   match k with
+                     RK_module -> "module"
+                   | RK_module_type -> "modtype"
+                   | RK_class -> "class"
+                   | RK_class_type -> "classtype"
+                   | RK_value -> "val"
+                   | RK_type -> "type"
+                   | RK_extension -> "extension"
+                   | RK_exception -> "exception"
+                   | RK_attribute -> "attribute"
+                   | RK_method -> "method"
+                   | RK_section _ -> "section"
+                   | RK_recfield -> "recfield"
+                   | RK_const -> "const"
+                 in
+                 s^":"
+            )
+            name;
+          match text_opt with
+            None -> ()
+          | Some t -> p_text b t; p b "}"
+        end
+      | 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}"
+      | Custom (s,t) ->
+          p b "{%s " s;
+          p_text b t;
+          p b "}"
+      | Target (target, code) ->
+          p b "{%%%s: %s}" target (escape_raw code)
+
+    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
new file mode 100644
index 00000000..409acaad
--- /dev/null
+++ b/ocamldoc/odoc_text.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** A module with a function to parse strings to obtain a [Odoc_types.text] value. *)
+
+(** Syntax error in a text. *)
+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
+      val string_of_text : Odoc_types.text -> string
+    end
diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll
new file mode 100644
index 00000000..62f996cb
--- /dev/null
+++ b/ocamldoc/odoc_text_lexer.mll
@@ -0,0 +1,857 @@
+{
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The lexer for string to build text structures. *)
+
+open Lexing
+open Odoc_text_parser
+
+let line_number = ref 0
+let char_number = ref 0
+
+let string_buffer = Buffer.create 32
+
+(** Reset the buffer *)
+let reset_string_buffer () = Buffer.reset string_buffer
+
+(** Add a character to the buffer *)
+let add_char_string = Buffer.add_char string_buffer
+
+(** Add a string to the buffer. *)
+let add_string = Buffer.add_string string_buffer
+
+let read_string () = Buffer.contents string_buffer
+
+
+(** the variable which will contain the description string.
+   Is initialized when we encounter the start of a special comment. *)
+
+let description = ref ""
+
+let blank = "[ \013\009\012]"
+
+
+let print_DEBUG s = print_string s; print_newline ()
+
+(** this flag indicates whether we're in a string between begin_code and end_code tokens, to
+   remember the number of open '[' and handle ']' correctly. *)
+let open_brackets = ref 0
+
+(** this flag indicates if we're in verbatim mode or not, to handle any special expression
+   like a string when we're in verbatim mode.*)
+let verb_mode = ref false
+
+(** this flag indicates if we're in "target format" mode or not, to handle any special expression
+   like a string when we're in this mode.*)
+let target_mode = ref false
+
+(** this flag indicates if we're in shortcut list mode or not, to handle end_shortcut_list correctly.*)
+let shortcut_list_mode = ref false
+
+(** this flag indicates if we're in an element reference. *)
+let ele_ref_mode = ref false
+
+(** this flag indicates if we're in a preformatted code string. *)
+let code_pre_mode = ref false
+
+let init () =
+  open_brackets := 0;
+  verb_mode := false;
+  target_mode := false;
+  shortcut_list_mode := false;
+  ele_ref_mode := false ;
+  code_pre_mode := false ;
+  line_number := 0 ;
+  char_number := 0
+
+let incr_cpts lexbuf =
+  let s = Lexing.lexeme lexbuf in
+  let l = Str.split_delim (Str.regexp_string "\n") s in
+  match List.rev l with
+    [] -> () (* should not occur *)
+  | [s2] -> (* no newline *)
+      char_number := !char_number + (String.length s2)
+  | s2 :: _ ->
+      line_number := !line_number + ((List.length l) - 1) ;
+      char_number := String.length s2
+
+}
+
+(** html marks, to use as alternative possible special strings *)
+
+let html_bold = "<"('b'|'B')">"
+let html_end_bold = "</"('b'|'B')">"
+let html_italic = "<"('i'|'I')">"
+let html_end_italic = "</"('i'|'I')">"
+let html_title = "<"('h'|'H')(['0'-'9'])+">"
+let html_end_title = "</"('h'|'H')(['0'-'9'])+">"
+let html_list = "<"('u'|'U')('l'|'L')">"
+let html_end_list = "</"('u'|'U')('l'|'L')">"
+let html_enum = "<"('o'|'O')('l'|'L')">"
+let html_end_enum = "</"('o'|'O')('l'|'L')">"
+let html_item = "<"('l'|'L')('i'|'I')">"
+let html_end_item = "</"('l'|'L')('i'|'I')">"
+let html_code = "<"('c'|'C')('o'|'O')('d'|'D')('e'|'E')">"
+let html_end_code = "</"('c'|'C')('o'|'O')('d'|'D')('e'|'E')">"
+let html_center = "<"('c'|'C')('e'|'E')('n'|'N')('t'|'T')('e'|'E')('r'|'R')">"
+let html_end_center = "</"('c'|'C')('e'|'E')('n'|'N')('t'|'T')('e'|'E')('r'|'R')">"
+let html_left = "<"('l'|'L')('e'|'E')('f'|'F')('t'|'T')">"
+let html_end_left = "</"('l'|'L')('e'|'E')('f'|'F')('t'|'T')">"
+let html_right = "<"('r'|'R')('i'|'I')('g'|'G')('h'|'H')('t'|'T')">"
+let html_end_right = "</"('r'|'R')('i'|'I')('g'|'G')('h'|'H')('t'|'T')">"
+
+
+let blank = [' ' '\013' '\009' '\012']
+let blank_nl = [' ' '\013' '\009' '\012' '\010']
+let label = ['a'-'z']+['a'-'z' 'A'-'Z' '0'-'9' '_']*
+
+(** special strings *)
+
+let end = "}"
+  | html_end_bold
+  | html_end_italic
+  | html_end_title
+  | html_end_list
+  | html_end_enum
+  | html_end_item
+  | html_end_center
+let begin_title =
+  ("{" ['0'-'9']+(":"label)? blank_nl)
+  | html_title
+
+let begin_bold = "{b"blank_nl | html_bold
+let begin_emp = "{e"blank_nl
+let begin_center = "{C"blank_nl | html_center
+let begin_left = "{L"blank_nl
+let begin_right = "{R"blank_nl
+let begin_italic = "{i"blank_nl | html_italic
+let begin_list = "{ul"blank_nl? | html_list
+let begin_enum = "{ol"blank_nl? | html_enum
+let begin_item = "{li"blank_nl | "{- " | html_item
+let begin_link = "{{:"
+let begin_target = "{%"['a'-'z''A'-'Z''0'-'9''-''_']+":"blank_nl?
+let begin_latex = "{%"blank_nl
+let end_target = "%}"
+let begin_code = "[" | html_code
+let end_code = "]" | html_end_code
+let begin_code_pre = "{["
+let end_code_pre = "]}"
+let begin_verb = "{v"blank_nl
+let end_verb = blank_nl"v}"
+
+let begin_ele_ref = "{!"blank_nl | "{!"
+let begin_val_ref = "{!val:"blank_nl | "{!val:"
+let begin_typ_ref = "{!type:"blank_nl | "{!type:"
+let begin_ext_ref = "{!extension:"blank_nl | "{!extension:"
+let begin_exc_ref = "{!exception:"blank_nl | "{!exception:"
+let begin_mod_ref = "{!module:"blank_nl | "{!module:"
+let begin_modt_ref = "{!modtype:"blank_nl | "{!modtype:"
+let begin_cla_ref = "{!class:"blank_nl | "{!class:"
+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_recf_ref = "{!recfield:"blank_nl | "{!recfield:"
+let begin_const_ref = "{!const:"blank_nl | "{!const:"
+let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:"
+let index_list = "{!indexlist}"
+let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']*
+let begin_superscript = "{^"blank_nl | "{^"
+let begin_subscript = "{_"blank_nl | "{_"
+
+let shortcut_list_item = '\n'blank*"- "
+let shortcut_enum_item = '\n'blank*"+ "
+let end_shortcut_list = '\n'(blank*'\n')+
+
+rule main = parse
+| "\\{"
+| "\\}"
+| "\\["
+| "\\]"
+    {
+      incr_cpts lexbuf ;
+      let s = Lexing.lexeme lexbuf in
+      Char (String.sub s 1 1)
+    }
+
+| end
+    {
+      print_DEBUG "end";
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) then
+        Char (Lexing.lexeme lexbuf)
+      else begin
+        if !ele_ref_mode then
+          ele_ref_mode := false;
+        END
+      end
+    }
+| begin_title
+    {
+      print_DEBUG "begin_title";
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        let s = Lexing.lexeme lexbuf in
+        try
+          (* chech if the "{..." or html_title mark was used. *)
+          if s.[0] = '<' then
+            let (n, l) = (2, (String.length s - 3)) in
+            let s2 = String.sub s n l in
+            Title (int_of_string s2, None)
+          else
+            let (n, l) = (1, (String.length s - 2)) in
+            let s2 = String.sub s n l in
+            try
+              let i = String.index s2 ':' in
+              let s_n = String.sub s2 0 i in
+              let s_label = String.sub s2 (i+1) (l-i-1) in
+              Title (int_of_string s_n, Some s_label)
+            with
+              Not_found ->
+                Title (int_of_string s2, None)
+        with
+          _ ->
+            Title (1, None)
+    }
+| begin_bold
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        BOLD
+    }
+| begin_italic
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        ITALIC
+    }
+| begin_link
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        LINK
+    }
+| begin_emp
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        EMP
+    }
+| begin_superscript
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        SUPERSCRIPT
+    }
+| begin_subscript
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        SUBSCRIPT
+    }
+| begin_center
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        CENTER
+    }
+| begin_left
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        LEFT
+    }
+| begin_right
+     {
+      incr_cpts lexbuf ;
+       if !verb_mode || !target_mode || !code_pre_mode
+           || (!open_brackets >= 1) || !ele_ref_mode then
+         Char (Lexing.lexeme lexbuf)
+       else
+         RIGHT
+     }
+| begin_list
+    {
+      print_DEBUG "LIST";
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        LIST
+    }
+| begin_enum
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        ENUM
+    }
+| begin_item
+    {
+      print_DEBUG "ITEM";
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        ITEM
+    }
+| begin_target
+   {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        (
+         let s = Lexing.lexeme lexbuf in
+         let fmt =
+           let p1 = String.index s '%' in
+           let p2 = String.index s ':' in
+           String.sub s (p1 + 1) (p2 - p1 - 1)
+         in
+         target_mode := true;
+         Target fmt
+        )
+    }
+| begin_latex
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        (
+         target_mode := true;
+         LATEX
+        )
+    }
+| end_target
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || (!open_brackets >= 1) || !code_pre_mode ||
+        !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        (
+         target_mode := false;
+         END_TARGET
+        )
+    }
+| begin_code end_code
+    {
+      incr_cpts lexbuf ;
+      Char (Lexing.lexeme lexbuf)
+    }
+
+| begin_code
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if !open_brackets <= 0 then
+          (
+           open_brackets := 1;
+           CODE
+          )
+        else
+          (
+           incr open_brackets;
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+| end_code
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if !open_brackets > 1 then
+          (
+           decr open_brackets;
+           Char "]"
+          )
+        else
+          (
+           open_brackets := 0;
+           END_CODE
+          )
+    }
+
+| begin_code_pre end_code_pre
+    {
+      incr_cpts lexbuf ;
+      Char (Lexing.lexeme lexbuf)
+    }
+
+| begin_code_pre
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        (
+         code_pre_mode := true;
+         CODE_PRE
+        )
+    }
+| end_code_pre
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        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
+    {
+      incr_cpts lexbuf ;
+      Char (Lexing.lexeme lexbuf)
+    }
+
+| begin_ele_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           ELE_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+
+| begin_val_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           VAL_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_typ_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           TYP_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_ext_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           EXT_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_exc_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           EXC_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_mod_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           MOD_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_modt_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           MODT_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_cla_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           CLA_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_clt_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           CLT_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_att_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           ATT_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_met_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           MET_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| begin_sec_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           SEC_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+| begin_recf_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           RECF_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+| begin_const_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           CONST_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+| begin_mod_list_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode || !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 || !target_mode || !code_pre_mode || !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          INDEX_LIST
+        else
+          Char (Lexing.lexeme lexbuf)
+    }
+
+| begin_verb
+    {
+      incr_cpts lexbuf ;
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        (
+         verb_mode := true;
+         VERB
+        )
+    }
+| end_verb
+    {
+      incr_cpts lexbuf ;
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        (
+         verb_mode := false;
+         END_VERB
+        )
+    }
+
+| shortcut_list_item
+    {
+      incr_cpts lexbuf ;
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode
+          || !ele_ref_mode || !verb_mode then
+        Char (Lexing.lexeme lexbuf)
+      else if !shortcut_list_mode then
+        (
+         SHORTCUT_LIST_ITEM
+        )
+      else
+        (
+         shortcut_list_mode := true;
+         BEGIN_SHORTCUT_LIST_ITEM
+        )
+    }
+
+| shortcut_enum_item
+    {
+      incr_cpts lexbuf ;
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode
+         || !ele_ref_mode || !verb_mode then
+        Char (Lexing.lexeme lexbuf)
+      else if !shortcut_list_mode then
+        SHORTCUT_ENUM_ITEM
+      else
+        (
+         shortcut_list_mode := true;
+         BEGIN_SHORTCUT_ENUM_ITEM
+        )
+    }
+| end_shortcut_list
+    {
+      incr_cpts lexbuf ;
+      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 line_number ;
+      if !shortcut_list_mode then
+        (
+         shortcut_list_mode := false;
+                        (* go back one char to re-use the last '\n', so we can
+                           restart another shortcut-list with a single blank line,
+                           and not two.*)
+         END_SHORTCUT_LIST
+        )
+      else
+        if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode || !verb_mode then
+          Char (Lexing.lexeme lexbuf)
+        else
+          BLANK_LINE
+    }
+
+| eof           { EOF }
+
+| begin_custom
+    {
+      print_DEBUG "begin_custom";
+      incr_cpts lexbuf ;
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        let s = Lexing.lexeme lexbuf in
+        let len = String.length s in
+        (* remove this starting '{' *)
+        let tag = Odoc_misc.no_blanks (String.sub s 1 (len - 1)) in
+        CUSTOM tag
+    }
+
+|  "{"
+    {
+      incr_cpts lexbuf ;
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
+        Char (Lexing.lexeme lexbuf)
+      else
+        LBRACE
+    }
+| '\r' { main lexbuf }
+| _
+    {
+      incr_cpts lexbuf ;
+      Char (Lexing.lexeme lexbuf)
+    }
diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
new file mode 100644
index 00000000..f71ab377
--- /dev/null
+++ b/ocamldoc/odoc_text_parser.mly
@@ -0,0 +1,214 @@
+%{
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Odoc_types
+
+let blank = "[ \010\013\009\012]"
+
+let remove_beginning_blanks s =
+  Str.global_replace (Str.regexp ("^"^blank^"+")) "" s
+
+let remove_trailing_blanks s =
+  Str.global_replace (Str.regexp (blank^"+$")) "" s
+
+let print_DEBUG s = print_string s; print_newline ()
+%}
+
+%token END
+%token <int * string option> Title
+%token BOLD
+%token EMP
+%token CENTER
+%token LEFT
+%token RIGHT
+%token ITALIC
+%token <string> CUSTOM
+%token LIST
+%token ENUM
+%token ITEM
+%token LINK
+%token CODE
+%token END_CODE
+%token CODE_PRE
+%token END_CODE_PRE
+%token VERB
+%token END_VERB
+%token LATEX
+%token <string> Target
+%token END_TARGET
+%token LBRACE
+
+%token ELE_REF
+%token VAL_REF
+%token TYP_REF
+%token EXT_REF
+%token EXC_REF
+%token MOD_REF
+%token MODT_REF
+%token CLA_REF
+%token CLT_REF
+%token ATT_REF
+%token MET_REF
+%token SEC_REF
+%token RECF_REF
+%token CONST_REF
+%token MOD_LIST_REF
+%token INDEX_LIST
+
+%token SUPERSCRIPT
+%token SUBSCRIPT
+
+%token BEGIN_SHORTCUT_LIST_ITEM
+%token BEGIN_SHORTCUT_ENUM_ITEM
+%token SHORTCUT_LIST_ITEM
+%token SHORTCUT_ENUM_ITEM
+%token END_SHORTCUT_LIST
+
+%token BLANK_LINE
+
+%token EOF
+%token <string> Char
+
+/* Start Symbols */
+%start main located_element_list
+%type <Odoc_types.text> main
+%type <(int * int * Odoc_types.text_element) list> located_element_list
+
+%%
+main:
+  text EOF { $1 }
+| EOF { [Raw ""] }
+;
+
+text:
+  text_element_list { $1 }
+;
+
+text_element_list:
+  text_element { [ $1 ] }
+| text_element text_element_list { $1 :: $2 }
+;
+
+located_element_list:
+  located_element { [ $1 ] }
+| located_element located_element_list { $1 :: $2 }
+;
+
+located_element:
+  text_element { Parsing.symbol_start (), Parsing.symbol_end (), $1}
+;
+
+
+ele_ref_kind:
+  ELE_REF { None }
+| VAL_REF { Some RK_value }
+| TYP_REF { Some RK_type }
+| EXT_REF { Some RK_extension }
+| EXC_REF { Some RK_exception }
+| MOD_REF { Some RK_module }
+| MODT_REF { Some RK_module_type }
+| CLA_REF { Some RK_class }
+| CLT_REF { Some RK_class_type }
+| ATT_REF { Some RK_attribute }
+| MET_REF { Some RK_method }
+| SEC_REF { Some (RK_section [])}
+| RECF_REF { Some RK_recfield }
+| CONST_REF { Some RK_const }
+;
+
+text_element:
+  Title text END { let n, l_opt = $1 in Title (n, l_opt, $2) }
+| BOLD text END { Bold $2 }
+| ITALIC text END { Italic $2 }
+| CUSTOM text END { Custom ($1, $2) }
+| EMP text END { Emphasize $2 }
+| SUPERSCRIPT text END { Superscript $2 }
+| SUBSCRIPT text END { Subscript $2 }
+| CENTER text END { Center $2 }
+| LEFT text END { Left $2 }
+| RIGHT text END { Right $2 }
+| LIST list END { List $2 }
+| ENUM list END { Enum $2 }
+| CODE string END_CODE { Code $2 }
+| CODE_PRE string END_CODE_PRE { CodePre $2 }
+| ele_ref_kind string END  {
+      let s2 = remove_beginning_blanks $2 in
+      let s3 = remove_trailing_blanks s2 in
+      Ref (s3, $1, None)
+     }
+| LBRACE ele_ref_kind string END text END {
+      let s2 = remove_beginning_blanks $3 in
+      let s3 = remove_trailing_blanks s2 in
+      Ref (s3, $2, Some $5)
+    }
+
+| 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_TARGET { Latex $2 }
+| Target string END_TARGET { Target ($1, $2) }
+| LINK string END text END { Link ($2, $4) }
+| BLANK_LINE { Newline }
+| BEGIN_SHORTCUT_LIST_ITEM shortcut_list END_SHORTCUT_LIST { List $2 }
+| BEGIN_SHORTCUT_LIST_ITEM shortcut_list EOF { List $2 }
+| BEGIN_SHORTCUT_ENUM_ITEM shortcut_enum END_SHORTCUT_LIST { Enum $2 }
+| BEGIN_SHORTCUT_ENUM_ITEM shortcut_enum EOF { Enum $2 }
+| string { Raw $1 }
+;
+
+list:
+| string { [] (* TODO: a test to check that there is only space characters *) }
+| string list { $2 }
+| list string  { $1 }
+| item { [ $1 ] }
+| item list { $1 :: $2 }
+
+;
+
+item:
+    ITEM text END { $2 }
+;
+
+shortcut_list:
+    text shortcut_list2  { $1 :: $2 }
+| text { [ $1 ] }
+;
+
+shortcut_list2:
+| SHORTCUT_LIST_ITEM shortcut_list { $2 }
+;
+
+shortcut_enum:
+    text shortcut_enum2  { $1 :: $2 }
+| text { [ $1 ] }
+;
+
+shortcut_enum2:
+| SHORTCUT_ENUM_ITEM shortcut_enum { $2 }
+;
+
+
+string:
+    Char { $1 }
+| Char string { $1^$2 }
+;
+
+%%
diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
new file mode 100644
index 00000000..fd650510
--- /dev/null
+++ b/ocamldoc/odoc_to_text.ml
@@ -0,0 +1,608 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Text generation.
+
+   This module contains the class [to_text] with methods used to transform
+   information about elements to a [text] structure.*)
+
+open Odoc_info
+open Exception
+open Type
+open Value
+open Module
+open Class
+
+(** A class used to get a [text] for info structures. *)
+class virtual info =
+  object (self)
+    (** The list of pairs [(tag, f)] where [f] is a function taking
+       the [text] associated to [tag] and returning a [text].
+       Add a pair here to handle a tag.*)
+    val mutable tag_functions = ([] : (string * (Odoc_info.text -> Odoc_info.text)) list)
+
+    (** @return [etxt] value for an authors list. *)
+    method text_of_author_list l =
+      match l with
+        [] ->
+          []
+      | _ ->
+          [ Bold [Raw (Odoc_messages.authors^": ")] ;
+            Raw (String.concat ", " l) ;
+            Newline
+          ]
+
+    (** @return [text] value for the given optional version information.*)
+    method text_of_version_opt v_opt =
+      match v_opt with
+        None -> []
+      | Some v -> [ Bold [Raw (Odoc_messages.version^": ")] ;
+                    Raw v ;
+                    Newline
+                  ]
+
+    (** @return [text] value for the given optional since information.*)
+    method text_of_since_opt s_opt =
+      match s_opt with
+        None -> []
+      | Some s -> [ Bold [Raw (Odoc_messages.since^": ")] ;
+                    Raw s ;
+                    Newline
+                  ]
+
+    (** @return [text] value to represent the list of "before" information. *)
+    method text_of_before = function
+      [] -> []
+    | l ->
+        let f (v, text) =
+          (Bold [Raw (Printf.sprintf "%s %s " Odoc_messages.before v) ]) ::
+            text @
+            [Newline]
+        in
+        List.flatten (List.map f l)
+
+    (** @return [text] value for the given list of raised exceptions.*)
+    method text_of_raised_exceptions l =
+      match l with
+        [] -> []
+      | (s, t) :: [] ->
+          [ Bold [ Raw Odoc_messages.raises ] ;
+            Raw " " ;
+            Code s ;
+            Raw " "
+          ]
+          @ t
+          @ [ Newline ]
+      | _ ->
+          [ Bold [ Raw Odoc_messages.raises ] ;
+            Raw " " ;
+            List
+              (List.map
+                (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc )
+                 l
+              ) ;
+            Newline
+          ]
+
+    (** Return [text] value for the given "see also" reference. *)
+    method text_of_see (see_ref, t)  =
+      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
+
+    (** Return [text] value for the given list of "see also" references.*)
+    method text_of_sees l =
+      match l with
+        [] -> []
+      | see :: [] ->
+          (Bold [ Raw Odoc_messages.see_also ]) ::
+          (Raw " ") ::
+          (self#text_of_see see) @ [ Newline ]
+      | _ ->
+          (Bold [ Raw Odoc_messages.see_also ]) ::
+          [ List
+              (List.map
+                 (fun see -> self#text_of_see see)
+                 l
+              );
+            Newline
+          ]
+
+    (** @return [text] value for the given optional return information.*)
+    method text_of_return_opt return_opt =
+      match return_opt with
+        None -> []
+      | Some t -> (Bold [Raw (Odoc_messages.returns^" ")]) :: t @ [ Newline ]
+
+    (** Return a [text] for the given list of custom tagged texts. *)
+    method text_of_custom l =
+      List.fold_left
+        (fun acc -> fun (tag, text) ->
+          try
+            let f = List.assoc tag tag_functions in
+            match acc with
+              [] -> f text
+            | _ -> acc @ (Newline :: (f text))
+          with
+            Not_found ->
+              Odoc_info.warning (Odoc_messages.tag_not_handled tag) ;
+              acc
+        )
+        []
+        l
+
+    (** @return [text] value for a description, except for the i_params field. *)
+    method text_of_info ?(block=true) info_opt =
+      match info_opt with
+        None ->
+          []
+      | Some info ->
+          let t =
+            (match info.i_deprecated with
+              None -> []
+            | Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t
+             ) @
+            (match info.i_desc with
+              None -> []
+            | Some t when t = [Odoc_info.Raw ""] -> []
+            | Some t -> t @ [ Newline ]
+            ) @
+            (self#text_of_author_list info.i_authors) @
+            (self#text_of_version_opt info.i_version) @
+            (self#text_of_before info.i_before) @
+            (self#text_of_since_opt info.i_since) @
+            (self#text_of_raised_exceptions info.i_raised_exceptions) @
+            (self#text_of_return_opt info.i_return_value) @
+            (self#text_of_sees info.i_sees) @
+            (self#text_of_custom info.i_custom)
+          in
+          if block then
+            [Block t]
+          else
+            t
+  end
+
+(** This class defines methods to generate a [text] structure from elements. *)
+class virtual to_text =
+  object (self)
+    inherit info
+
+    method virtual label : ?no_: bool -> string -> string
+
+    (** 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_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
+      Str.global_substitute
+        (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)")
+        f
+        s
+
+    (** 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
+      Str.global_substitute
+        (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)")
+        f
+        s
+
+    (** 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 ?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 ?par m_name sep t =
+      self#relative_idents m_name (Odoc_info.string_of_type_list ?par sep t)
+
+    method normal_cstr_args ?par m_name = function
+      | Cstr_tuple l -> self#normal_type_list ?par m_name " * " l
+      | Cstr_record r -> self#relative_idents m_name
+                            (Odoc_str.string_of_record r)
+
+    (** 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)
+
+    (** Get a string for the parameters of a class (with arrows) where all idents are relative. *)
+    method normal_class_params m_name c =
+      let s = Odoc_info.string_of_class_params c in
+      self#relative_idents m_name
+        (Odoc_info.remove_ending_newline s)
+
+    (** @return [text] value to represent a [Types.type_expr].*)
+    method text_of_type_expr module_name t =
+      List.flatten
+        (List.map
+           (fun s -> [Code s ; Newline ])
+           (Str.split (Str.regexp "\n")
+              (self#normal_type module_name t))
+        )
+
+    (** Return [text] value for a given short [Types.type_expr].*)
+    method text_of_short_type_expr module_name t =
+      [ Code (self#normal_type module_name t) ]
+
+    (** Return [text] value or the given list of [Types.type_expr], with
+       the given separator. *)
+    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 parameters of a class (with arraows).*)
+    method text_of_class_params module_name c =
+      Odoc_info.text_concat
+        [Newline]
+        (List.map
+           (fun s -> [Code s])
+           (Str.split (Str.regexp "\n")
+              (self#normal_class_params module_name c))
+        )
+
+    (** @return [text] value to represent a [Types.module_type]. *)
+    method text_of_module_type t =
+      let s = String.concat "\n"
+          (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t))
+      in
+      [ Code s ]
+
+    (** @return [text] value for a value. *)
+    method text_of_value v =
+      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
+          (self#normal_type (Name.father v.val_name) v.val_type);
+        Format.flush_str_formatter ()
+      in
+      [ CodePre s ] @
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
+      (self#text_of_info v.val_info)
+
+    (** @return [text] value for a class attribute. *)
+    method text_of_attribute a =
+      let s_name = Name.simple a.att_value.val_name in
+      let mod_name = Name.father a.att_value.val_name in
+      let s =
+        Format.fprintf Format.str_formatter "@[<hov 2>val %s%s%s :@ %s"
+          (if a.att_virtual then "virtual " else "")
+          (if a.att_mutable then "mutable " else "")
+          s_name
+          (self#normal_type mod_name a.att_value.val_type);
+        Format.flush_str_formatter ()
+      in
+      (CodePre s) ::
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
+      (self#text_of_info a.att_value.val_info)
+
+    (** @return [text] value for a class method. *)
+    method text_of_method m =
+      let s_name = Name.simple m.met_value.val_name in
+      let mod_name = Name.father m.met_value.val_name in
+      let s =
+        Format.fprintf Format.str_formatter "@[<hov 2>method %s%s%s :@ %s"
+          (if m.met_private then "private " else "")
+          (if m.met_virtual then "virtual " else "")
+          s_name
+          (self#normal_type mod_name m.met_value.val_type);
+        Format.flush_str_formatter ()
+      in
+      (CodePre s) ::
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
+      (self#text_of_info m.met_value.val_info)
+
+
+    (** @return [text] value for an exception. *)
+    method text_of_exception e =
+      let s_name = Name.simple e.ex_name in
+      let father = Name.father e.ex_name in
+      Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ;
+      (match e.ex_args, e.ex_ret with
+         Cstr_tuple [], None -> ()
+       | Cstr_tuple [], Some r ->
+           Format.fprintf Format.str_formatter " %s@ %s"
+             ":"
+             (self#normal_type father r)
+       | args, None ->
+           Format.fprintf Format.str_formatter " %s@ %s"
+             "of"
+             (self#normal_cstr_args ~par:false father args)
+       | args, Some r ->
+           Format.fprintf Format.str_formatter " %s@ %s@ %s@ %s"
+             ":"
+             (self#normal_cstr_args ~par:false father args)
+             "->"
+             (self#normal_type father r)
+      );
+      (match e.ex_alias with
+         None -> ()
+       | Some ea ->
+           Format.fprintf Format.str_formatter " = %s"
+            (
+              match ea.ea_ex with
+                None -> ea.ea_name
+              | Some e -> e.ex_name
+            )
+      );
+      let s2 = Format.flush_str_formatter () in
+      [ CodePre s2 ] @
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
+      (self#text_of_info e.ex_info)
+
+    (** Return [text] value for the description of a function parameter. *)
+    method text_of_parameter_description 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 -> 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
+          match l2 with
+            [] -> []
+          | _ ->
+              [List
+                  (List.map
+                     (fun n ->
+                       match Parameter.desc_by_name p n with
+                         None -> [] (* should not occur *)
+                       | Some t -> [Code (n^" ") ; Raw ": "] @ t
+                     )
+                     l2
+                  )
+              ]
+
+
+    (** Return [text] value for a list of parameters. *)
+    method text_of_parameter_list m_name l =
+      match l with
+        [] ->
+          []
+      | _ ->
+          [ Bold [Raw Odoc_messages.parameters] ;
+            Raw ":" ;
+            List
+              (List.map
+                 (fun p ->
+                   (match Parameter.complete_name p with
+                     "" -> Code "?"
+                   | s -> Code s
+                   ) ::
+                   [Code " : "] @
+                   (self#text_of_short_type_expr m_name (Parameter.typ p)) @
+                   [Newline] @
+                   (self#text_of_parameter_description p)
+                 )
+                 l
+              )
+          ]
+
+    (** Return [text] value for a list of module parameters. *)
+    method text_of_module_parameter_list l =
+      match l with
+        [] ->
+          []
+      | _ ->
+          [ Newline ;
+            Bold [Raw Odoc_messages.parameters] ;
+            Raw ":" ;
+            List
+              (List.map
+                 (fun (p, desc_opt) ->
+                   begin match p.mp_type with None -> [Raw ""]
+                   | Some mty ->
+                       [Code (p.mp_name^" : ")] @
+                       (self#text_of_module_type mty)
+                   end @
+                   (match desc_opt with
+                     None -> []
+                   | Some t -> (Raw " ") :: t)
+                 )
+                 l
+              )
+          ]
+
+(**/**)
+
+    (** Return [text] value for the given [class_kind].*)
+    method text_of_class_kind father ckind =
+      match ckind with
+        Class_structure _ ->
+          [Code Odoc_messages.object_end]
+
+      | Class_apply capp ->
+          [Code
+              (
+               (
+                match capp.capp_class with
+                  None -> capp.capp_name
+                | Some cl -> cl.cl_name
+               )^
+               " "^
+               (String.concat " "
+                  (List.map
+                     (fun s -> "("^s^")")
+                     capp.capp_params_code))
+              )
+          ]
+
+      | Class_constr cco ->
+          (
+           match cco.cco_type_parameters with
+             [] -> []
+           | l ->
+               (Code "[")::
+               (self#text_of_type_expr_list father ", " l)@
+               [Code "] "]
+          )@
+          [Code (
+            match cco.cco_class with
+              None -> cco.cco_name
+            | Some (Cl cl) -> Name.get_relative father cl.cl_name
+            | Some (Cltype (clt,_)) -> Name.get_relative father clt.clt_name
+           )
+          ]
+
+      | Class_constraint (ck, ctk) ->
+          [Code "( "] @
+          (self#text_of_class_kind father ck) @
+          [Code " : "] @
+          (self#text_of_class_type_kind father ctk) @
+          [Code " )"]
+
+
+    (** Return [text] value for the given [class_type_kind].*)
+    method text_of_class_type_kind father ctkind =
+      match ctkind with
+        Class_type cta ->
+          (
+           match cta.cta_type_parameters with
+             [] -> []
+           | l ->
+               (Code "[") ::
+               (self#text_of_class_type_param_expr_list father l) @
+               [Code "] "]
+          ) @
+          (
+           match cta.cta_class with
+             None -> [ Code cta.cta_name ]
+           | Some (Cltype (clt, _)) ->
+               let rel = Name.get_relative father clt.clt_name in
+               [Code rel]
+           | Some (Cl cl) ->
+               let rel = Name.get_relative father cl.cl_name in
+               [Code rel]
+          )
+      | Class_signature _ ->
+          [Code Odoc_messages.object_end]
+
+    (** Return [text] value for a [module_kind]. *)
+    method text_of_module_kind ?(with_def_syntax=true) k =
+      match k with
+        Module_alias m_alias ->
+          (match m_alias.ma_module with
+            None ->
+              [Code ((if with_def_syntax then " = " else "")^m_alias.ma_name)]
+          | Some (Mod m) ->
+              [Code ((if with_def_syntax then " = " else "")^m.m_name)]
+          | Some (Modtype mt) ->
+              [Code ((if with_def_syntax then " = " else "")^mt.mt_name)]
+          )
+      | Module_apply (k1, k2) ->
+          (if with_def_syntax then [Code " = "] else []) @
+          (self#text_of_module_kind ~with_def_syntax: false k1) @
+          [Code " ( "] @
+          (self#text_of_module_kind ~with_def_syntax: false k2) @
+          [Code " ) "]
+
+      | Module_with (tk, code) ->
+          (if with_def_syntax then [Code " : "] else []) @
+          (self#text_of_module_type_kind ~with_def_syntax: false tk) @
+          [Code code]
+
+      | Module_constraint (k, tk) ->
+          (if with_def_syntax then [Code " : "] else []) @
+          [Code "( "] @
+          (self#text_of_module_kind ~with_def_syntax: false k) @
+          [Code " : "] @
+          (self#text_of_module_type_kind ~with_def_syntax: false tk) @
+          [Code " )"]
+
+      | Module_struct _ ->
+          [Code ((if with_def_syntax then " : " else "")^
+                 Odoc_messages.struct_end^" ")]
+
+      | Module_functor (_, k)  ->
+          (if with_def_syntax then [Code " : "] else []) @
+          [Code "functor ... "] @
+          [Code " -> "] @
+          (self#text_of_module_kind ~with_def_syntax: false k)
+
+      | Module_typeof s ->
+          let code = Printf.sprintf "%smodule type of %s"
+            (if with_def_syntax then " : " else "")
+            s
+          in
+          [Code code]
+      | Module_unpack (code, _) ->
+          let code = Printf.sprintf "%s%s"
+            (if with_def_syntax then " : " else "")
+            code
+          in
+          [Code code]
+
+    (** 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 (p, k) ->
+          let t1 =
+            [Code ("("^p.mp_name^" : ")] @
+            (self#text_of_module_type_kind p.mp_kind) @
+            [Code ") -> "]
+          in
+          let t2 = self#text_of_module_type_kind ~with_def_syntax: false k in
+          (if with_def_syntax then [Code " = "] else []) @ t1 @ t2
+
+      | Module_type_with (tk2, code) ->
+          let t = self#text_of_module_type_kind ~with_def_syntax: false tk2 in
+          (if with_def_syntax then [Code " = "] else []) @
+          t @ [Code code]
+
+      | Module_type_alias mt_alias ->
+          [Code ((if with_def_syntax then " = " else "")^
+                 (match mt_alias.mta_module with
+                   None -> mt_alias.mta_name
+                 | Some mt -> mt.mt_name))
+          ]
+
+      | Odoc_module.Module_type_typeof s ->
+          let code = Printf.sprintf "%smodule type of %s"
+            (if with_def_syntax then " = " else "") s
+          in
+          [ Code code ]
+  end
diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
new file mode 100644
index 00000000..7320f550
--- /dev/null
+++ b/ocamldoc/odoc_type.ml
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Representation and manipulation of a type, but not class nor module type.*)
+
+module Name = Odoc_name
+
+type private_flag = Asttypes.private_flag =
+    Private | Public
+
+(** Description of a record type field. *)
+type record_field = {
+    rf_name : string ;
+    rf_mutable : bool ; (** true if mutable *)
+    rf_type : Types.type_expr ;
+    mutable rf_text : Odoc_types.info option ; (** optional user description *)
+  }
+
+type constructor_args =
+  | Cstr_record of record_field list
+  | Cstr_tuple of Types.type_expr list
+
+(** Description of a variant type constructor. *)
+type variant_constructor = {
+    vc_name : string ;
+    vc_args : constructor_args ;
+    vc_ret : Types.type_expr option ;
+    mutable vc_text : Odoc_types.info option ; (** optional user description *)
+  }
+
+(** The various kinds of type. *)
+type type_kind =
+    Type_abstract
+  | Type_variant of variant_constructor list
+                   (** constructors *)
+  | Type_record of record_field list
+                   (** fields *)
+  | Type_open
+
+type object_field = {
+  of_name : string ;
+  of_type : Types.type_expr ;
+  mutable of_text : Odoc_types.info option ; (** optional user description *)
+}
+
+type type_manifest =
+  | Other of Types.type_expr (** Type manifest directly taken from Typedtre. *)
+  | Object_type of object_field list
+
+(** Representation of a type. *)
+type t_type = {
+    ty_name : Name.t ;
+    mutable ty_info : Odoc_types.info option ; (** optional user information *)
+    ty_parameters : (Types.type_expr * bool * bool) list ;
+                    (** type parameters: (type, covariant, contravariant) *)
+    ty_kind : type_kind ;
+    ty_private : private_flag;
+    ty_manifest : type_manifest option;
+    mutable ty_loc : Odoc_types.location ;
+    mutable ty_code : string option;
+  }
diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml
new file mode 100644
index 00000000..2baf1f2f
--- /dev/null
+++ b/ocamldoc/odoc_types.ml
@@ -0,0 +1,143 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ref_kind =
+    RK_module
+  | RK_module_type
+  | RK_class
+  | RK_class_type
+  | RK_value
+  | RK_type
+  | RK_extension
+  | RK_exception
+  | RK_attribute
+  | RK_method
+  | RK_section of text
+  | RK_recfield
+  | RK_const
+
+and text_element =
+  | Raw of string
+  | Code of string
+  | CodePre of string
+  | Verbatim of string
+  | Bold of text
+  | Italic of text
+  | Emphasize of text
+  | Center of text
+  | Left of text
+  | Right of text
+  | List of text list
+  | Enum of text list
+  | Newline
+  | Block of text
+  | Title of int * string option * text
+  | Latex of string
+  | Link of string * text
+  | Ref of string * ref_kind option * text option
+  | Superscript of text
+  | Subscript of text
+  | Module_list of string list
+  | Index_list
+  | Custom of string * text
+  | Target of string * string
+
+and text = text_element list
+
+type see_ref =
+    See_url of string
+  | See_file of string
+  | See_doc of string
+
+type see = see_ref * text
+
+type param = (string * text)
+
+type raised_exception = (string * text)
+
+type info = {
+    i_desc : text option;
+    i_authors : string list;
+    i_version : string option;
+    i_sees : see list;
+    i_since : string option;
+    i_before : (string * text) list;
+    i_deprecated : text option;
+    i_params : param list;
+    i_raised_exceptions : raised_exception list;
+    i_return_value : text option ;
+    i_custom : (string * text) list ;
+  }
+
+let dummy_info = {
+  i_desc = None ;
+  i_authors = [] ;
+  i_version = None ;
+  i_sees = [] ;
+  i_since = None ;
+  i_before = [] ;
+  i_deprecated = None ;
+  i_params = [] ;
+  i_raised_exceptions = [] ;
+  i_return_value = None ;
+  i_custom = [] ;
+}
+
+type location = {
+    loc_impl : Location.t option ;
+    loc_inter : Location.t option ;
+  }
+
+let dummy_loc = { loc_impl = None ; loc_inter = None }
+
+type merge_option =
+  | Merge_description
+  | Merge_author
+  | Merge_version
+  | Merge_see
+  | Merge_since
+  | Merge_before
+  | Merge_deprecated
+  | Merge_param
+  | Merge_raised_exception
+  | Merge_return_value
+  | Merge_custom
+
+let all_merge_options = [
+  Merge_description ;
+  Merge_author ;
+  Merge_version ;
+  Merge_see ;
+  Merge_since ;
+  Merge_before ;
+  Merge_deprecated ;
+  Merge_param ;
+  Merge_raised_exception ;
+  Merge_return_value ;
+  Merge_custom ;
+]
+
+type magic = string
+
+let magic = Odoc_messages.magic
+
+type 'a dump = Dump of magic * 'a
+
+let make_dump a = Dump (magic, a)
+
+let open_dump = function
+    Dump (m, a) ->
+      if m = magic then a
+      else raise (Failure Odoc_messages.bad_magic_number)
diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli
new file mode 100644
index 00000000..fddd6d2f
--- /dev/null
+++ b/ocamldoc/odoc_types.mli
@@ -0,0 +1,142 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Types for the information collected in comments. *)
+
+(** The differents kinds of element references. *)
+type ref_kind =
+    RK_module
+  | RK_module_type
+  | RK_class
+  | RK_class_type
+  | RK_value
+  | RK_type
+  | RK_extension
+  | RK_exception
+  | RK_attribute
+  | RK_method
+  | RK_section of text
+  | RK_recfield
+  | RK_const
+
+and text_element =
+  | Raw of string (** Raw text. *)
+  | Code of string (** The string is source code. *)
+  | CodePre of string (** The string is pre-formatted source code. *)
+  | Verbatim of string (** String 'as is'. *)
+  | Bold of text (** Text in bold style. *)
+  | Italic of text (** Text in italic. *)
+  | Emphasize of text (** Emphasized text. *)
+  | Center of text (** Centered text. *)
+  | Left of text (** Left alignment. *)
+  | Right of text (** Right alignment. *)
+  | List of text list (** A list. *)
+  | Enum of text list (** An enumerated list. *)
+  | Newline   (** To force a line break. *)
+  | Block of text (** Like html's block quote. *)
+  | Title of int * string option * text
+              (** Style number, optional label, and text. *)
+  | Latex of string (** A string for latex. *)
+  | Link of string * text (** A reference string and the link text. *)
+  | Ref of string * ref_kind option * text option
+    (** A reference to an element. Complete name and kind. An optional
+        text can be given to display this text instead of the element name.*)
+  | 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, ...) *)
+  | Custom of string * text (** to extend \{foo syntax *)
+  | Target of string * string (** (target, code) : to specify code for a specific target format *)
+
+(** [text] is a list of text_elements. The order matters. *)
+and text = text_element list
+
+(** The different forms of references in \@see tags. *)
+type see_ref =
+    See_url of string
+  | See_file of string
+  | See_doc of string
+
+(** The information in a \@see tag. *)
+type see = see_ref * text
+
+(** Parameter name and description. *)
+type param = (string * text)
+
+(** Raised exception name and description. *)
+type raised_exception = (string * text)
+
+(** Information in a special comment. *)
+type info = {
+    i_desc : text option; (** The description text. *)
+    i_authors : string list; (** The list of authors in \@author tags. *)
+    i_version : string option; (** The string in the \@version tag. *)
+    i_sees : see list; (** The list of \@see tags. *)
+    i_since : string option; (** The string in the \@since tag. *)
+    i_before : (string * text) list; (** the version number and text in \@before tag *)
+    i_deprecated : text option; (** The of the \@deprecated tag. *)
+    i_params : param list; (** The list of parameter descriptions. *)
+    i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *)
+    i_return_value : text option ; (** The description text of the return value. *)
+    i_custom : (string * text) list ; (** A text associated to a custom @-tag. *)
+  }
+
+(** An empty info structure. *)
+val dummy_info : info
+
+(** Location of elements in implementation and interface files. *)
+type location = {
+    loc_impl : Location.t option ; (** implementation location *)
+    loc_inter : Location.t option ; (** interface location *)
+  }
+
+(** A dummy location. *)
+val dummy_loc : location
+
+(** The information to merge from two elements when they both have some information. *)
+type merge_option =
+  | Merge_description (** Descriptions are concatenated. *)
+  | Merge_author (** Lists of authors are concatenated. *)
+  | Merge_version (** Versions are concatenated. *)
+  | Merge_see (** See references are concatenated. *)
+  | Merge_since (** Since information are concatenated. *)
+  | Merge_before (** Before information are concatenated. *)
+  | Merge_deprecated (** Deprecated information are concatenated. *)
+  | Merge_param (** Information on each parameter is concatenated,
+                    and all parameters are kept. *)
+  | Merge_raised_exception (** Information on each raised_exception is concatenated,
+                               and all raised exceptions are kept. *)
+  | Merge_return_value (** Information on return value are concatenated. *)
+  | Merge_custom (** Merge custom tags (all pairs (tag, text) are kept). *)
+
+(** The list with all merge options. *)
+val all_merge_options : merge_option list
+
+(** Type of magic numbers. *)
+type magic
+
+(** The magic number for the dumps of this version of ocamldoc. *)
+val magic : magic
+
+(** A dump of a structure. *)
+type 'a dump
+
+(** Create a dump structure. *)
+val make_dump : 'a -> 'a dump
+
+(** Verify that a dump has the correct magic number
+   and return its content. *)
+val open_dump : 'a dump -> 'a
diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
new file mode 100644
index 00000000..d939f64e
--- /dev/null
+++ b/ocamldoc/odoc_value.ml
@@ -0,0 +1,140 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Representation and manipulation of values, class attributes and class methods. *)
+
+module Name = Odoc_name
+
+(** Types *)
+
+(** Representation of a value. *)
+type t_value = {
+    val_name : Name.t ;
+    mutable val_info : Odoc_types.info option ;
+    val_type : Types.type_expr ;
+    val_recursive : bool ;
+    mutable val_parameters : Odoc_parameter.parameter list ;
+    mutable val_code : string option ;
+    mutable val_loc : Odoc_types.location ;
+  }
+
+(** Representation of a class attribute. *)
+type t_attribute = {
+    att_value : t_value ; (** an attribute has almost all the same information
+                             as a value *)
+    att_mutable : bool ;
+    att_virtual : bool ;
+  }
+
+(** Representation of a class method. *)
+type t_method = {
+    met_value : t_value ; (** a method has almost all the same information
+                             as a value *)
+    met_private : bool ;
+    met_virtual : bool ;
+  }
+
+(** Functions *)
+
+(** Returns the text associated to the given parameter name
+   in the given value, or None. *)
+let value_parameter_text_by_name v name =
+  match v.val_info with
+    None -> None
+  | Some i ->
+      try
+        let t = List.assoc name i.Odoc_types.i_params in
+        Some t
+      with
+        Not_found ->
+          None
+
+(** Update the parameters text of a t_value, according to the val_info field. *)
+let update_value_parameters_text v =
+  let f p =
+    Odoc_parameter.update_parameter_text (value_parameter_text_by_name v) p
+  in
+  List.iter f v.val_parameters
+
+(** Create a list of (parameter name, typ) from a type, according to the arrows.
+   [parameter_list_from_arrows t = [ a ; b ]] if t = a -> b -> c.*)
+let parameter_list_from_arrows typ =
+  let rec iter t =
+    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.Tpackage _
+    | Types.Tvariant _ ->
+        []
+  in
+  iter typ
+
+(** Create a list of parameters with dummy names "??" from a type list.
+   Used when we want to merge the parameters of a value, from the .ml
+   and the .mli file. In the .mli file we don't have parameter names
+   so there is nothing to merge. With this dummy list we can merge the
+   parameter names from the .ml and the type from the .mli file. *)
+let dummy_parameter_list typ =
+  let normal_name = Odoc_misc.label_name in
+  Printtyp.mark_loops typ;
+  let liste_param = parameter_list_from_arrows typ in
+  let rec iter (label, t) =
+    match t.Types.desc with
+    | Types.Ttuple l ->
+        let open Asttypes in
+        if label = Nolabel then
+          Odoc_parameter.Tuple
+            (List.map (fun t2 -> iter (Nolabel, t2)) l, t)
+        else
+          (* if there is a label, then we don't want to decompose the tuple *)
+          Odoc_parameter.Simple_name
+            { Odoc_parameter.sn_name = normal_name label ;
+              Odoc_parameter.sn_type = t ;
+              Odoc_parameter.sn_text = None }
+    | Types.Tlink t2
+    | Types.Tsubst t2 ->
+        (iter (label, t2))
+
+    | _ ->
+        Odoc_parameter.Simple_name
+          { Odoc_parameter.sn_name = normal_name label ;
+             Odoc_parameter.sn_type = t ;
+            Odoc_parameter.sn_text = None }
+  in
+  List.map iter liste_param
+
+(** Return true if the value is a function, i.e. has a functional type.*)
+let is_function v =
+  let rec f t =
+    match t.Types.desc with
+      Types.Tarrow _ ->
+        true
+    | Types.Tlink t ->
+        f t
+        | _ ->
+            false
+      in
+  f v.val_type
diff --git a/ocamldoc/remove_DEBUG b/ocamldoc/remove_DEBUG
new file mode 100755
index 00000000..3cb47bb8
--- /dev/null
+++ b/ocamldoc/remove_DEBUG
@@ -0,0 +1,24 @@
+#!/bin/sh
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*             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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# usage: remove_DEBUG <file>
+# remove from <file> every line that contains the string "DEBUG",
+# respecting the cpp # line annotation conventions
+
+echo "# 1 \"$1\""
+LC_ALL=C sed -e '/DEBUG/c\
+(* DEBUG statement removed *)' "$1"
diff --git a/otherlibs/Makefile b/otherlibs/Makefile
new file mode 100644
index 00000000..05a093fd
--- /dev/null
+++ b/otherlibs/Makefile
@@ -0,0 +1,116 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Common Makefile for otherlibs
+
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
+
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
+CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
+        -I $(ROOTDIR)/stdlib
+CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
+
+# Compilation options
+CC=$(BYTECC)
+COMPFLAGS=-absname -w +a-4-9-41-42-44-45-48 -warn-error A -bin-annot -g \
+          -safe-string -strict-sequence -strict-formats $(EXTRACAMLFLAGS)
+ifeq "$(FLAMBDA)" "true"
+OPTCOMPFLAGS=-O3
+else
+OPTCOMPFLAGS=
+endif
+MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
+
+# Variables to be defined by individual libraries:
+#LIBNAME=
+#CLIBNAME=
+#CMIFILES=
+#CAMLOBJS=
+#COBJS=
+#EXTRACFLAGS=
+#EXTRACAMLFLAGS=
+#LINKOPTS=
+#LDOPTS=
+#HEADERS=
+
+CMIFILES ?= $(CAMLOBJS:.cmo=.cmi)
+CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx)
+CLIBNAME ?= $(LIBNAME)
+
+all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
+
+allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
+
+$(LIBNAME).cma: $(CAMLOBJS)
+	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
+	         $(CAMLOBJS) $(LINKOPTS)
+
+$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
+	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
+	         $(CAMLOBJS_NAT) $(LINKOPTS)
+
+$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
+	$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
+
+lib$(CLIBNAME).$(A): $(COBJS)
+	$(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS)
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+
+install::
+	if test -f dll$(CLIBNAME)$(EXT_DLL); then \
+	  cp dll$(CLIBNAME)$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/"; fi
+	cp lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A)
+	cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) \
+          $(CMIFILES:.cmi=.cmti) "$(INSTALL_LIBDIR)/"
+	if test -n "$(HEADERS)"; then \
+	  cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
+
+installopt:
+	cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a
+	if test -f $(LIBNAME).cmxs; then \
+	  cp $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; fi
+
+partialclean:
+	rm -f *.cm*
+
+clean:: partialclean
+	rm -f *.dll *.so *.a *.lib *.o *.obj
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O)
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
+
+.c.$(O):
+	$(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
new file mode 100644
index 00000000..7d75fc25
--- /dev/null
+++ b/otherlibs/bigarray/.depend
@@ -0,0 +1,25 @@
+bigarray_stubs.o: bigarray_stubs.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  bigarray.h ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/intext.h ../../byterun/caml/io.h \
+  ../../byterun/caml/hash.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
+  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
+  ../../byterun/caml/address_class.h ../../byterun/caml/signals.h
+mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/custom.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/io.h \
+  ../../byterun/caml/sys.h ../../byterun/caml/signals.h
+mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/sys.h ../unix/unixsupport.h
+bigarray.cmo : bigarray.cmi
+bigarray.cmx : bigarray.cmi
+bigarray.cmi :
diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
new file mode 100644
index 00000000..5044c724
--- /dev/null
+++ b/otherlibs/bigarray/Makefile
@@ -0,0 +1,37 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+LIBNAME=bigarray
+EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY
+EXTRACAMLFLAGS=-I ../$(UNIXLIB)
+COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
+CAMLOBJS=bigarray.cmo
+HEADERS=bigarray.h
+
+include ../Makefile
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+
+ifeq "$(TOOLCHAIN)" "msvc"
+.depend.nt: .depend
+	sed -e 's/\.o/.$(O)/g' $< > $@
+
+include .depend.nt
+
+else
+include .depend
+endif
diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/otherlibs/bigarray/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h
new file mode 100644
index 00000000..46a3a6a3
--- /dev/null
+++ b/otherlibs/bigarray/bigarray.h
@@ -0,0 +1,125 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_BIGARRAY_H
+#define CAML_BIGARRAY_H
+
+#ifndef CAML_NAME_SPACE
+#include "caml/compatibility.h"
+#endif
+#include "caml/config.h"
+#include "caml/mlvalues.h"
+
+typedef signed char caml_ba_int8;
+typedef unsigned char caml_ba_uint8;
+#if SIZEOF_SHORT == 2
+typedef short caml_ba_int16;
+typedef unsigned short caml_ba_uint16;
+#else
+#error "No 16-bit integer type available"
+#endif
+
+#define CAML_BA_MAX_NUM_DIMS 16
+
+enum caml_ba_kind {
+  CAML_BA_FLOAT32,             /* Single-precision floats */
+  CAML_BA_FLOAT64,             /* Double-precision floats */
+  CAML_BA_SINT8,               /* Signed 8-bit integers */
+  CAML_BA_UINT8,               /* Unsigned 8-bit integers */
+  CAML_BA_SINT16,              /* Signed 16-bit integers */
+  CAML_BA_UINT16,              /* Unsigned 16-bit integers */
+  CAML_BA_INT32,               /* Signed 32-bit integers */
+  CAML_BA_INT64,               /* Signed 64-bit integers */
+  CAML_BA_CAML_INT,            /* OCaml-style integers (signed 31 or 63 bits) */
+  CAML_BA_NATIVE_INT,       /* Platform-native long integers (32 or 64 bits) */
+  CAML_BA_COMPLEX32,           /* Single-precision complex */
+  CAML_BA_COMPLEX64,           /* Double-precision complex */
+  CAML_BA_CHAR,                /* Characters */
+  CAML_BA_KIND_MASK = 0xFF     /* Mask for kind in flags field */
+};
+
+#define Caml_ba_kind_val(v) Int_val(v)
+
+#define Val_caml_ba_kind(k) Val_int(k)
+
+enum caml_ba_layout {
+  CAML_BA_C_LAYOUT = 0,           /* Row major, indices start at 0 */
+  CAML_BA_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */
+  CAML_BA_LAYOUT_MASK = 0x100,    /* Mask for layout in flags field */
+  CAML_BA_LAYOUT_SHIFT = 8        /* Bit offset of layout flag */
+};
+
+#define Caml_ba_layout_val(v) (Int_val(v) << CAML_BA_LAYOUT_SHIFT)
+
+#define Val_caml_ba_layout(l) Val_int(l >> CAML_BA_LAYOUT_SHIFT)
+
+enum caml_ba_managed {
+  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by OCaml */
+  CAML_BA_MANAGED = 0x200,     /* Data is allocated by OCaml */
+  CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */
+  CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */
+};
+
+struct caml_ba_proxy {
+  intnat refcount;              /* Reference count */
+  void * data;                  /* Pointer to base of actual data */
+  uintnat size;                 /* Size of data in bytes (if mapped file) */
+};
+
+struct caml_ba_array {
+  void * data;                /* Pointer to raw data */
+  intnat num_dims;            /* Number of dimensions */
+  intnat flags;  /* Kind of element array + memory layout + allocation status */
+  struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  intnat dim[]  /*[num_dims]*/; /* Size in each dimension */
+#else
+  intnat dim[1] /*[num_dims]*/; /* Size in each dimension */
+#endif
+};
+
+/* Size of struct caml_ba_array, in bytes, without dummy first dimension */
+#if (__STDC_VERSION__ >= 199901L)
+#define SIZEOF_BA_ARRAY sizeof(struct caml_ba_array)
+#else
+#define SIZEOF_BA_ARRAY (sizeof(struct caml_ba_array) - sizeof(intnat))
+#endif
+
+#define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v))
+
+#define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data)
+
+#if defined(IN_OCAML_BIGARRAY)
+#define CAMLBAextern CAMLexport
+#else
+#define CAMLBAextern CAMLextern
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+CAMLBAextern value
+    caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim);
+CAMLBAextern value caml_ba_alloc_dims(int flags, int num_dims, void * data,
+                                 ... /*dimensions, with type intnat */);
+CAMLBAextern uintnat caml_ba_byte_size(struct caml_ba_array * b);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_BIGARRAY_H */
diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
new file mode 100644
index 00000000..8d697150
--- /dev/null
+++ b/otherlibs/bigarray/bigarray.ml
@@ -0,0 +1,349 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Manuel Serrano et Xavier Leroy, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
+
+external init : unit -> unit = "caml_ba_init"
+
+let _ = init()
+
+type float32_elt = Float32_elt
+type float64_elt = Float64_elt
+type int8_signed_elt = Int8_signed_elt
+type int8_unsigned_elt = Int8_unsigned_elt
+type int16_signed_elt = Int16_signed_elt
+type int16_unsigned_elt = Int16_unsigned_elt
+type int32_elt = Int32_elt
+type int64_elt = Int64_elt
+type int_elt = Int_elt
+type nativeint_elt = Nativeint_elt
+type complex32_elt = Complex32_elt
+type complex64_elt = Complex64_elt
+
+type ('a, 'b) kind =
+    Float32 : (float, float32_elt) kind
+  | Float64 : (float, float64_elt) kind
+  | Int8_signed : (int, int8_signed_elt) kind
+  | Int8_unsigned : (int, int8_unsigned_elt) kind
+  | Int16_signed : (int, int16_signed_elt) kind
+  | Int16_unsigned : (int, int16_unsigned_elt) kind
+  | Int32 : (int32, int32_elt) kind
+  | Int64 : (int64, int64_elt) kind
+  | Int : (int, int_elt) kind
+  | Nativeint : (nativeint, nativeint_elt) kind
+  | Complex32 : (Complex.t, complex32_elt) kind
+  | Complex64 : (Complex.t, complex64_elt) kind
+  | Char : (char, int8_unsigned_elt) kind
+
+(* Keep those constants in sync with the caml_ba_kind enumeration
+   in bigarray.h *)
+
+let float32 = Float32
+let float64 = Float64
+let int8_signed = Int8_signed
+let int8_unsigned = Int8_unsigned
+let int16_signed = Int16_signed
+let int16_unsigned = Int16_unsigned
+let int32 = Int32
+let int64 = Int64
+let int = Int
+let nativeint = Nativeint
+let complex32 = Complex32
+let complex64 = Complex64
+let char = Char
+
+let kind_size_in_bytes : type a b. (a, b) kind -> int = function
+  | Float32 -> 4
+  | Float64 -> 8
+  | Int8_signed -> 1
+  | Int8_unsigned -> 1
+  | Int16_signed -> 2
+  | Int16_unsigned -> 2
+  | Int32 -> 4
+  | Int64 -> 8
+  | Int -> Sys.word_size / 8
+  | Nativeint -> Sys.word_size / 8
+  | Complex32 -> 8
+  | Complex64 -> 16
+  | Char -> 1
+
+type c_layout = C_layout_typ
+type fortran_layout = Fortran_layout_typ
+
+type 'a layout =
+    C_layout: c_layout layout
+  | Fortran_layout: fortran_layout layout
+
+(* Keep those constants in sync with the caml_ba_layout enumeration
+   in bigarray.h *)
+
+let c_layout = C_layout
+let fortran_layout = Fortran_layout
+
+module Genarray = struct
+  type ('a, 'b, 'c) t
+  external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
+     = "caml_ba_create"
+  external get: ('a, 'b, 'c) t -> int array -> 'a
+     = "caml_ba_get_generic"
+  external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
+     = "caml_ba_set_generic"
+  external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
+  external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim"
+  let dims a =
+    let n = num_dims a in
+    let d = Array.make n 0 in
+    for i = 0 to n-1 do d.(i) <- nth_dim a i done;
+    d
+
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+     = "caml_ba_change_layout"
+
+  let size_in_bytes arr =
+    (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr))
+
+  external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+     = "caml_ba_sub"
+  external sub_right: ('a, 'b, fortran_layout) t -> int -> int ->
+                          ('a, 'b, fortran_layout) t
+     = "caml_ba_sub"
+  external slice_left: ('a, 'b, c_layout) t -> int array ->
+                          ('a, 'b, c_layout) t
+     = "caml_ba_slice"
+  external slice_right: ('a, 'b, fortran_layout) t -> int array ->
+                          ('a, 'b, fortran_layout) t
+     = "caml_ba_slice"
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+     = "caml_ba_blit"
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
+                     bool -> int array -> int64 -> ('a, 'b, 'c) t
+     = "caml_ba_map_file_bytecode" "caml_ba_map_file"
+  let map_file fd ?(pos = 0L) kind layout shared dims =
+    map_internal fd kind layout shared dims pos
+end
+
+module Array0 = struct
+  type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+  let create kind layout =
+    Genarray.create kind layout [||]
+  let get arr = Genarray.get arr [||]
+  let set arr = Genarray.set arr [||]
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+  let size_in_bytes arr = kind_size_in_bytes (kind arr)
+
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+
+  let of_value kind layout v =
+    let a = create kind layout in
+    set a v;
+    a
+end
+
+module Array1 = struct
+  type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+  let create kind layout dim =
+    Genarray.create kind layout [|dim|]
+  external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
+  external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
+  external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
+  external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
+     = "%caml_ba_unsafe_set_1"
+  external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+  let size_in_bytes arr =
+    (kind_size_in_bytes (kind arr)) * (dim arr)
+
+  external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub"
+  let slice (type t) (a : (_, _, t) Genarray.t) n =
+    match layout a with
+    | C_layout -> (Genarray.slice_left a [|n|] : (_, _, t) Genarray.t)
+    | Fortran_layout -> (Genarray.slice_right a [|n|]: (_, _, t) Genarray.t)
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  let of_array (type t) kind (layout: t layout) data =
+    let ba = create kind layout (Array.length data) in
+    let ofs =
+      match layout with
+        C_layout -> 0
+      | Fortran_layout -> 1
+    in
+    for i = 0 to Array.length data - 1 do unsafe_set ba (i + ofs) data.(i) done;
+    ba
+  let map_file fd ?pos kind layout shared dim =
+    Genarray.map_file fd ?pos kind layout shared [|dim|]
+end
+
+module Array2 = struct
+  type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+  let create kind layout dim1 dim2 =
+    Genarray.create kind layout [|dim1; dim2|]
+  external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
+  external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
+  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
+     = "%caml_ba_unsafe_ref_2"
+  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
+     = "%caml_ba_unsafe_set_2"
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+  let size_in_bytes arr =
+    (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr)
+
+  external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+     = "caml_ba_sub"
+  external sub_right:
+    ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+     = "caml_ba_sub"
+  let slice_left a n = Genarray.slice_left a [|n|]
+  let slice_right a n = Genarray.slice_right a [|n|]
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  let of_array (type t) kind (layout: t layout) data =
+    let dim1 = Array.length data in
+    let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
+    let ba = create kind layout dim1 dim2 in
+    let ofs =
+      match layout with
+        C_layout -> 0
+      | Fortran_layout -> 1
+    in
+    for i = 0 to dim1 - 1 do
+      let row = data.(i) in
+      if Array.length row <> dim2 then
+        invalid_arg("Bigarray.Array2.of_array: non-rectangular data");
+      for j = 0 to dim2 - 1 do
+        unsafe_set ba (i + ofs) (j + ofs) row.(j)
+      done
+    done;
+    ba
+  let map_file fd ?pos kind layout shared dim1 dim2 =
+    Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|]
+end
+
+module Array3 = struct
+  type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+  let create kind layout dim1 dim2 dim3 =
+    Genarray.create kind layout [|dim1; dim2; dim3|]
+  external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
+  external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+     = "%caml_ba_set_3"
+  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
+     = "%caml_ba_unsafe_ref_3"
+  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+     = "%caml_ba_unsafe_set_3"
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+  external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+  let size_in_bytes arr =
+    (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr)
+
+  external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+     = "caml_ba_sub"
+  external sub_right:
+     ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+     = "caml_ba_sub"
+  let slice_left_1 a n m = Genarray.slice_left a [|n; m|]
+  let slice_right_1 a n m = Genarray.slice_right a [|n; m|]
+  let slice_left_2 a n = Genarray.slice_left a [|n|]
+  let slice_right_2 a n = Genarray.slice_right a [|n|]
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  let of_array (type t) kind (layout: t layout) data =
+    let dim1 = Array.length data in
+    let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
+    let dim3 = if dim2 = 0 then 0 else Array.length data.(0).(0) in
+    let ba = create kind layout dim1 dim2 dim3 in
+    let ofs =
+      match layout with
+        C_layout -> 0
+      | Fortran_layout -> 1
+    in
+    for i = 0 to dim1 - 1 do
+      let row = data.(i) in
+      if Array.length row <> dim2 then
+        invalid_arg("Bigarray.Array3.of_array: non-cubic data");
+      for j = 0 to dim2 - 1 do
+        let col = row.(j) in
+        if Array.length col <> dim3 then
+          invalid_arg("Bigarray.Array3.of_array: non-cubic data");
+        for k = 0 to dim3 - 1 do
+          unsafe_set ba (i + ofs) (j + ofs) (k + ofs) col.(k)
+        done
+      done
+    done;
+    ba
+  let map_file fd ?pos kind layout shared dim1 dim2 dim3 =
+    Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|]
+end
+
+external genarray_of_array0: ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t
+   = "%identity"
+external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
+   = "%identity"
+external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
+   = "%identity"
+external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
+   = "%identity"
+let array0_of_genarray a =
+  if Genarray.num_dims a = 0 then a
+  else invalid_arg "Bigarray.array0_of_genarray"
+let array1_of_genarray a =
+  if Genarray.num_dims a = 1 then a
+  else invalid_arg "Bigarray.array1_of_genarray"
+let array2_of_genarray a =
+  if Genarray.num_dims a = 2 then a
+  else invalid_arg "Bigarray.array2_of_genarray"
+let array3_of_genarray a =
+  if Genarray.num_dims a = 3 then a
+  else invalid_arg "Bigarray.array3_of_genarray"
+
+external reshape:
+   ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
+   = "caml_ba_reshape"
+let reshape_0 a = reshape a [||]
+let reshape_1 a dim1 = reshape a [|dim1|]
+let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|]
+let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|]
+
+(* Force caml_ba_get_{1,2,3,N} to be linked in, since we don't refer
+   to those primitives directly in this file *)
+
+let _ =
+  let _ = Genarray.get in
+  let _ = Array1.get in
+  let _ = Array2.get in
+  let _ = Array3.get in
+  ()
+
+[@@@ocaml.warning "-32"]
+external get1: unit -> unit = "caml_ba_get_1"
+external get2: unit -> unit = "caml_ba_get_2"
+external get3: unit -> unit = "caml_ba_get_3"
+external set1: unit -> unit = "caml_ba_set_1"
+external set2: unit -> unit = "caml_ba_set_2"
+external set3: unit -> unit = "caml_ba_set_3"
diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
new file mode 100644
index 00000000..683e1682
--- /dev/null
+++ b/otherlibs/bigarray/bigarray.mli
@@ -0,0 +1,953 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Large, multi-dimensional, numerical arrays.
+
+   This module implements multi-dimensional arrays of integers and
+   floating-point numbers, thereafter referred to as 'big arrays'.
+   The implementation allows efficient sharing of large numerical
+   arrays between OCaml code and C or Fortran numerical libraries.
+
+   Concerning the naming conventions, users of this module are encouraged
+   to do [open Bigarray] in their source, then refer to array types and
+   operations via short dot notation, e.g. [Array1.t] or [Array2.sub].
+
+   Big arrays support all the OCaml ad-hoc polymorphic operations:
+   - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare});
+   - hashing (module [Hash]);
+   - and structured input-output (the functions from the
+     {!Marshal} module, as well as {!Pervasives.output_value}
+     and {!Pervasives.input_value}).
+*)
+
+(** {6 Element kinds} *)
+
+(** Big arrays can contain elements of the following kinds:
+- IEEE single precision (32 bits) floating-point numbers
+   ({!Bigarray.float32_elt}),
+- IEEE double precision (64 bits) floating-point numbers
+   ({!Bigarray.float64_elt}),
+- IEEE single precision (2 * 32 bits) floating-point complex numbers
+   ({!Bigarray.complex32_elt}),
+- IEEE double precision (2 * 64 bits) floating-point complex numbers
+   ({!Bigarray.complex64_elt}),
+- 8-bit integers (signed or unsigned)
+   ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}),
+- 16-bit integers (signed or unsigned)
+   ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}),
+- OCaml integers (signed, 31 bits on 32-bit architectures,
+   63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
+- 32-bit signed integers ({!Bigarray.int32_elt}),
+- 64-bit signed integers ({!Bigarray.int64_elt}),
+- platform-native signed integers (32 bits on 32-bit architectures,
+   64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}).
+
+   Each element kind is represented at the type level by one of the
+   [*_elt] types defined below (defined with a single constructor instead
+   of abstract types for technical injectivity reasons).
+*)
+
+type float32_elt = Float32_elt
+type float64_elt = Float64_elt
+type int8_signed_elt = Int8_signed_elt
+type int8_unsigned_elt = Int8_unsigned_elt
+type int16_signed_elt = Int16_signed_elt
+type int16_unsigned_elt = Int16_unsigned_elt
+type int32_elt = Int32_elt
+type int64_elt = Int64_elt
+type int_elt = Int_elt
+type nativeint_elt = Nativeint_elt
+type complex32_elt = Complex32_elt
+type complex64_elt = Complex64_elt
+
+type ('a, 'b) kind =
+    Float32 : (float, float32_elt) kind
+  | Float64 : (float, float64_elt) kind
+  | Int8_signed : (int, int8_signed_elt) kind
+  | Int8_unsigned : (int, int8_unsigned_elt) kind
+  | Int16_signed : (int, int16_signed_elt) kind
+  | Int16_unsigned : (int, int16_unsigned_elt) kind
+  | Int32 : (int32, int32_elt) kind
+  | Int64 : (int64, int64_elt) kind
+  | Int : (int, int_elt) kind
+  | Nativeint : (nativeint, nativeint_elt) kind
+  | Complex32 : (Complex.t, complex32_elt) kind
+  | Complex64 : (Complex.t, complex64_elt) kind
+  | Char : (char, int8_unsigned_elt) kind (**)
+(** To each element kind is associated an OCaml type, which is
+   the type of OCaml values that can be stored in the big array
+   or read back from it.  This type is not necessarily the same
+   as the type of the array elements proper: for instance,
+   a big array whose elements are of kind [float32_elt] contains
+   32-bit single precision floats, but reading or writing one of
+   its elements from OCaml uses the OCaml type [float], which is
+   64-bit double precision floats.
+
+   The GADT type [('a, 'b) kind] captures this association
+   of an OCaml type ['a] for values read or written in the big array,
+   and of an element kind ['b] which represents the actual contents
+   of the big array. Its constructors list all possible associations
+   of OCaml types with element kinds, and are re-exported below for
+   backward-compatibility reasons.
+
+   Using a generalized algebraic datatype (GADT) here allows to write
+   well-typed polymorphic functions whose return type depend on the
+   argument type, such as:
+
+{[
+  let zero : type a b. (a, b) kind -> a = function
+    | Float32 -> 0.0 | Complex32 -> Complex.zero
+    | Float64 -> 0.0 | Complex64 -> Complex.zero
+    | Int8_signed -> 0 | Int8_unsigned -> 0
+    | Int16_signed -> 0 | Int16_unsigned -> 0
+    | Int32 -> 0l | Int64 -> 0L
+    | Int -> 0 | Nativeint -> 0n
+    | Char -> '\000'
+]}
+*)
+
+val float32 : (float, float32_elt) kind
+(** See {!Bigarray.char}. *)
+
+val float64 : (float, float64_elt) kind
+(** See {!Bigarray.char}. *)
+
+val complex32 : (Complex.t, complex32_elt) kind
+(** See {!Bigarray.char}. *)
+
+val complex64 : (Complex.t, complex64_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int8_signed : (int, int8_signed_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int8_unsigned : (int, int8_unsigned_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int16_signed : (int, int16_signed_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int16_unsigned : (int, int16_unsigned_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int : (int, int_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int32 : (int32, int32_elt) kind
+(** See {!Bigarray.char}. *)
+
+val int64 : (int64, int64_elt) kind
+(** See {!Bigarray.char}. *)
+
+val nativeint : (nativeint, nativeint_elt) kind
+(** See {!Bigarray.char}. *)
+
+val char : (char, int8_unsigned_elt) kind
+(** As shown by the types of the values above,
+   big arrays of kind [float32_elt] and [float64_elt] are
+   accessed using the OCaml type [float].  Big arrays of complex kinds
+   [complex32_elt], [complex64_elt] are accessed with the OCaml type
+   {!Complex.t}. Big arrays of
+   integer kinds are accessed using the smallest OCaml integer
+   type large enough to represent the array elements:
+   [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer
+   bigarrays; [int32] for 32-bit integer bigarrays; [int64]
+   for 64-bit integer bigarrays; and [nativeint] for
+   platform-native integer bigarrays.  Finally, big arrays of
+   kind [int8_unsigned_elt] can also be accessed as arrays of
+   characters instead of arrays of small integers, by using
+   the kind value [char] instead of [int8_unsigned]. *)
+
+val kind_size_in_bytes : ('a, 'b) kind -> int
+(** [kind_size_in_bytes k] is the number of bytes used to store
+   an element of type [k].
+
+   @since 4.03.0 *)
+
+(** {6 Array layouts} *)
+
+type c_layout = C_layout_typ (**)
+(** See {!Bigarray.fortran_layout}.*)
+
+type fortran_layout = Fortran_layout_typ (**)
+(** To facilitate interoperability with existing C and Fortran code,
+   this library supports two different memory layouts for big arrays,
+   one compatible with the C conventions,
+   the other compatible with the Fortran conventions.
+
+   In the C-style layout, array indices start at 0, and
+   multi-dimensional arrays are laid out in row-major format.
+   That is, for a two-dimensional array, all elements of
+   row 0 are contiguous in memory, followed by all elements of
+   row 1, etc.  In other terms, the array elements at [(x,y)]
+   and [(x, y+1)] are adjacent in memory.
+
+   In the Fortran-style layout, array indices start at 1, and
+   multi-dimensional arrays are laid out in column-major format.
+   That is, for a two-dimensional array, all elements of
+   column 0 are contiguous in memory, followed by all elements of
+   column 1, etc.  In other terms, the array elements at [(x,y)]
+   and [(x+1, y)] are adjacent in memory.
+
+   Each layout style is identified at the type level by the
+   phantom types {!Bigarray.c_layout} and {!Bigarray.fortran_layout}
+   respectively. *)
+
+(** {7 Supported layouts}
+
+   The GADT type ['a layout] represents one of the two supported
+   memory layouts: C-style or Fortran-style. Its constructors are
+   re-exported as values below for backward-compatibility reasons.
+*)
+
+type 'a layout =
+    C_layout: c_layout layout
+  | Fortran_layout: fortran_layout layout
+
+val c_layout : c_layout layout
+val fortran_layout : fortran_layout layout
+
+
+(** {6 Generic arrays (of arbitrarily many dimensions)} *)
+
+module Genarray :
+  sig
+  type ('a, 'b, 'c) t
+  (** The type [Genarray.t] is the type of big arrays with variable
+     numbers of dimensions.  Any number of dimensions between 0 and 16
+     is supported.
+
+     The three type parameters to [Genarray.t] identify the array element
+     kind and layout, as follows:
+     - the first parameter, ['a], is the OCaml type for accessing array
+       elements ([float], [int], [int32], [int64], [nativeint]);
+     - the second parameter, ['b], is the actual kind of array elements
+       ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt],
+       etc);
+     - the third parameter, ['c], identifies the array layout
+       ([c_layout] or [fortran_layout]).
+
+     For instance, [(float, float32_elt, fortran_layout) Genarray.t]
+     is the type of generic big arrays containing 32-bit floats
+     in Fortran layout; reads and writes in this array use the
+     OCaml type [float]. *)
+
+  external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
+    = "caml_ba_create"
+  (** [Genarray.create kind layout dimensions] returns a new big array
+     whose element kind is determined by the parameter [kind] (one of
+     [float32], [float64], [int8_signed], etc) and whose layout is
+     determined by the parameter [layout] (one of [c_layout] or
+     [fortran_layout]).  The [dimensions] parameter is an array of
+     integers that indicate the size of the big array in each dimension.
+     The length of [dimensions] determines the number of dimensions
+     of the bigarray.
+
+     For instance, [Genarray.create int32 c_layout [|4;6;8|]]
+     returns a fresh big array of 32-bit integers, in C layout,
+     having three dimensions, the three dimensions being 4, 6 and 8
+     respectively.
+
+     Big arrays returned by [Genarray.create] are not initialized:
+     the initial values of array elements is unspecified.
+
+     [Genarray.create] raises [Invalid_argument] if the number of dimensions
+     is not in the range 0 to 16 inclusive, or if one of the dimensions
+     is negative. *)
+
+  external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
+  (** Return the number of dimensions of the given big array. *)
+
+  val dims : ('a, 'b, 'c) t -> int array
+  (** [Genarray.dims a] returns all dimensions of the big array [a],
+     as an array of integers of length [Genarray.num_dims a]. *)
+
+  external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim"
+  (** [Genarray.nth_dim a n] returns the [n]-th dimension of the
+     big array [a].  The first dimension corresponds to [n = 0];
+     the second dimension corresponds to [n = 1]; the last dimension,
+     to [n = Genarray.num_dims a - 1].
+     Raise [Invalid_argument] if [n] is less than 0 or greater or equal than
+     [Genarray.num_dims a]. *)
+
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  (** Return the kind of the given big array. *)
+
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  (** Return the layout of the given big array. *)
+
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+      = "caml_ba_change_layout"
+  (** [Genarray.change_layout a layout] returns a bigarray with the
+      specified [layout], sharing the data with [a] (and hence having
+      the same dimensions as [a]). No copying of elements is involved: the
+      new array and the original array share the same storage space.
+      The dimensions are reversed, such that [get v [| a; b |]] in
+      C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
+
+      @since 4.04.0
+  *)
+
+  val size_in_bytes : ('a, 'b, 'c) t -> int
+  (** [size_in_bytes a] is the number of elements in [a] multiplied
+    by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
+
+  external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic"
+  (** Read an element of a generic big array.
+     [Genarray.get a [|i1; ...; iN|]] returns the element of [a]
+     whose coordinates are [i1] in the first dimension, [i2] in
+     the second dimension, ..., [iN] in the [N]-th dimension.
+
+     If [a] has C layout, the coordinates must be greater or equal than 0
+     and strictly less than the corresponding dimensions of [a].
+     If [a] has Fortran layout, the coordinates must be greater or equal
+     than 1 and less or equal than the corresponding dimensions of [a].
+     Raise [Invalid_argument] if the array [a] does not have exactly [N]
+     dimensions, or if the coordinates are outside the array bounds.
+
+     If [N > 3], alternate syntax is provided: you can write
+     [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]].
+     (The syntax [a.{...}] with one, two or three coordinates is
+     reserved for accessing one-, two- and three-dimensional arrays
+     as described below.) *)
+
+  external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
+    = "caml_ba_set_generic"
+  (** Assign an element of a generic big array.
+     [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the
+     element of [a] whose coordinates are [i1] in the first dimension,
+     [i2] in the second dimension, ..., [iN] in the [N]-th dimension.
+
+     The array [a] must have exactly [N] dimensions, and all coordinates
+     must lie inside the array bounds, as described for [Genarray.get];
+     otherwise, [Invalid_argument] is raised.
+
+     If [N > 3], alternate syntax is provided: you can write
+     [a.{i1, i2, ..., iN} <- v] instead of
+     [Genarray.set a [|i1; ...; iN|] v].
+     (The syntax [a.{...} <- v] with one, two or three coordinates is
+     reserved for updating one-, two- and three-dimensional arrays
+     as described below.) *)
+
+  external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+    = "caml_ba_sub"
+  (** Extract a sub-array of the given big array by restricting the
+     first (left-most) dimension.  [Genarray.sub_left a ofs len]
+     returns a big array with the same number of dimensions as [a],
+     and the same dimensions as [a], except the first dimension,
+     which corresponds to the interval [[ofs ... ofs + len - 1]]
+     of the first dimension of [a].  No copying of elements is
+     involved: the sub-array and the original array share the same
+     storage space.  In other terms, the element at coordinates
+     [[|i1; ...; iN|]] of the sub-array is identical to the
+     element at coordinates [[|i1+ofs; ...; iN|]] of the original
+     array [a].
+
+     [Genarray.sub_left] applies only to big arrays in C layout.
+     Raise [Invalid_argument] if [ofs] and [len] do not designate
+     a valid sub-array of [a], that is, if [ofs < 0], or [len < 0],
+     or [ofs + len > Genarray.nth_dim a 0]. *)
+
+  external sub_right:
+    ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+    = "caml_ba_sub"
+  (** Extract a sub-array of the given big array by restricting the
+     last (right-most) dimension.  [Genarray.sub_right a ofs len]
+     returns a big array with the same number of dimensions as [a],
+     and the same dimensions as [a], except the last dimension,
+     which corresponds to the interval [[ofs ... ofs + len - 1]]
+     of the last dimension of [a].  No copying of elements is
+     involved: the sub-array and the original array share the same
+     storage space.  In other terms, the element at coordinates
+     [[|i1; ...; iN|]] of the sub-array is identical to the
+     element at coordinates [[|i1; ...; iN+ofs|]] of the original
+     array [a].
+
+     [Genarray.sub_right] applies only to big arrays in Fortran layout.
+     Raise [Invalid_argument] if [ofs] and [len] do not designate
+     a valid sub-array of [a], that is, if [ofs < 1], or [len < 0],
+     or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *)
+
+  external slice_left:
+    ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t
+    = "caml_ba_slice"
+  (** Extract a sub-array of lower dimension from the given big array
+     by fixing one or several of the first (left-most) coordinates.
+     [Genarray.slice_left a [|i1; ... ; iM|]] returns the 'slice'
+     of [a] obtained by setting the first [M] coordinates to
+     [i1], ..., [iM].  If [a] has [N] dimensions, the slice has
+     dimension [N - M], and the element at coordinates
+     [[|j1; ...; j(N-M)|]] in the slice is identical to the element
+     at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original
+     array [a].  No copying of elements is involved: the slice and
+     the original array share the same storage space.
+
+     [Genarray.slice_left] applies only to big arrays in C layout.
+     Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]]
+     is outside the bounds of [a]. *)
+
+  external slice_right:
+    ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t
+    = "caml_ba_slice"
+  (** Extract a sub-array of lower dimension from the given big array
+     by fixing one or several of the last (right-most) coordinates.
+     [Genarray.slice_right a [|i1; ... ; iM|]] returns the 'slice'
+     of [a] obtained by setting the last [M] coordinates to
+     [i1], ..., [iM].  If [a] has [N] dimensions, the slice has
+     dimension [N - M], and the element at coordinates
+     [[|j1; ...; j(N-M)|]] in the slice is identical to the element
+     at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original
+     array [a].  No copying of elements is involved: the slice and
+     the original array share the same storage space.
+
+     [Genarray.slice_right] applies only to big arrays in Fortran layout.
+     Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]]
+     is outside the bounds of [a]. *)
+
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+      = "caml_ba_blit"
+  (** Copy all elements of a big array in another big array.
+     [Genarray.blit src dst] copies all elements of [src] into
+     [dst].  Both arrays [src] and [dst] must have the same number of
+     dimensions and equal dimensions.  Copying a sub-array of [src]
+     to a sub-array of [dst] can be achieved by applying [Genarray.blit]
+     to sub-array or slices of [src] and [dst]. *)
+
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  (** Set all elements of a big array to a given value.
+     [Genarray.fill a v] stores the value [v] in all elements of
+     the big array [a].  Setting only some elements of [a] to [v]
+     can be achieved by applying [Genarray.fill] to a sub-array
+     or a slice of [a]. *)
+
+  val map_file:
+    Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
+    bool -> int array -> ('a, 'b, 'c) t
+  (** Memory mapping of a file as a big array.
+     [Genarray.map_file fd kind layout shared dims]
+     returns a big array of kind [kind], layout [layout],
+     and dimensions as specified in [dims].  The data contained in
+     this big array are the contents of the file referred to by
+     the file descriptor [fd] (as opened previously with
+     [Unix.openfile], for example).  The optional [pos] parameter
+     is the byte offset in the file of the data being mapped;
+     it defaults to 0 (map from the beginning of the file).
+
+     If [shared] is [true], all modifications performed on the array
+     are reflected in the file.  This requires that [fd] be opened
+     with write permissions.  If [shared] is [false], modifications
+     performed on the array are done in memory only, using
+     copy-on-write of the modified pages; the underlying file is not
+     affected.
+
+     [Genarray.map_file] is much more efficient than reading
+     the whole file in a big array, modifying that big array,
+     and writing it afterwards.
+
+     To adjust automatically the dimensions of the big array to
+     the actual size of the file, the major dimension (that is,
+     the first dimension for an array with C layout, and the last
+     dimension for an array with Fortran layout) can be given as
+     [-1].  [Genarray.map_file] then determines the major dimension
+     from the size of the file.  The file must contain an integral
+     number of sub-arrays as determined by the non-major dimensions,
+     otherwise [Failure] is raised.
+
+     If all dimensions of the big array are given, the file size is
+     matched against the size of the big array.  If the file is larger
+     than the big array, only the initial portion of the file is
+     mapped to the big array.  If the file is smaller than the big
+     array, the file is automatically grown to the size of the big array.
+     This requires write permissions on [fd].
+
+     Array accesses are bounds-checked, but the bounds are determined by
+     the initial call to [map_file]. Therefore, you should make sure no
+     other process modifies the mapped file while you're accessing it,
+     or a SIGBUS signal may be raised. This happens, for instance, if the
+     file is shrunk.
+
+     This function raises [Sys_error] in the case of any errors from the
+     underlying system calls.  [Invalid_argument] or [Failure] may be
+     raised in cases where argument validation fails. *)
+
+  end
+
+(** {6 Zero-dimensional arrays} *)
+
+(** Zero-dimensional arrays. The [Array0] structure provides operations
+   similar to those of {!Bigarray.Genarray}, but specialized to the case
+   of zero-dimensional arrays that only contain a single scalar value.
+   Statically knowing the number of dimensions of the array allows
+   faster operations, and more precise static type-checking.
+   @since 4.05.0 *)
+module Array0 : sig
+  type ('a, 'b, 'c) t
+  (** The type of zero-dimensional big arrays whose elements have
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+  val create: ('a, 'b) kind -> 'c layout -> ('a, 'b, 'c) t
+  (** [Array0.create kind layout] returns a new bigarray of zero dimension.
+     [kind] and [layout] determine the array element kind and the array
+     layout as described for {!Genarray.create}. *)
+
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  (** Return the kind of the given big array. *)
+
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  (** Return the layout of the given big array. *)
+
+  val size_in_bytes : ('a, 'b, 'c) t -> int
+  (** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *)
+
+  val get: ('a, 'b, 'c) t -> 'a
+  (** [Array0.get a] returns the only element in [a]. *)
+
+  val set: ('a, 'b, 'c) t -> 'a -> unit
+  (** [Array0.set a x v] stores the value [v] in [a]. *)
+
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+  (** Copy the first big array to the second big array.
+     See {!Genarray.blit} for more details. *)
+
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  (** Fill the given big array with the given value.
+     See {!Genarray.fill} for more details. *)
+
+  val of_value: ('a, 'b) kind -> 'c layout -> 'a -> ('a, 'b, 'c) t
+  (** Build a zero-dimensional big array initialized from the
+     given value.  *)
+
+end
+
+
+(** {6 One-dimensional arrays} *)
+
+(** One-dimensional arrays. The [Array1] structure provides operations
+   similar to those of
+   {!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays.
+   (The {!Array2} and {!Array3} structures below provide operations
+   specialized for two- and three-dimensional arrays.)
+   Statically knowing the number of dimensions of the array allows
+   faster operations, and more precise static type-checking. *)
+module Array1 : sig
+  type ('a, 'b, 'c) t
+  (** The type of one-dimensional big arrays whose elements have
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+  val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
+  (** [Array1.create kind layout dim] returns a new bigarray of
+     one dimension, whose size is [dim].  [kind] and [layout]
+     determine the array element kind and the array layout
+     as described for {!Genarray.create}. *)
+
+  external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  (** Return the size (dimension) of the given one-dimensional
+     big array. *)
+
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  (** Return the kind of the given big array. *)
+
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  (** Return the layout of the given big array. *)
+
+  val size_in_bytes : ('a, 'b, 'c) t -> int
+  (** [size_in_bytes a] is the number of elements in [a]
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
+
+  external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
+  (** [Array1.get a x], or alternatively [a.{x}],
+     returns the element of [a] at index [x].
+     [x] must be greater or equal than [0] and strictly less than
+     [Array1.dim a] if [a] has C layout.  If [a] has Fortran layout,
+     [x] must be greater or equal than [1] and less or equal than
+     [Array1.dim a].  Otherwise, [Invalid_argument] is raised. *)
+
+  external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
+  (** [Array1.set a x v], also written [a.{x} <- v],
+     stores the value [v] at index [x] in [a].
+     [x] must be inside the bounds of [a] as described in
+     {!Bigarray.Array1.get};
+     otherwise, [Invalid_argument] is raised. *)
+
+  external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t
+      = "caml_ba_sub"
+  (** Extract a sub-array of the given one-dimensional big array.
+     See {!Genarray.sub_left} for more details. *)
+
+  val slice: ('a, 'b, 'c) t -> int -> ('a, 'b, 'c) Array0.t
+  (** Extract a scalar (zero-dimensional slice) of the given one-dimensional
+     big array.  The integer parameter is the index of the scalar to
+     extract.  See {!Bigarray.Genarray.slice_left} and
+     {!Bigarray.Genarray.slice_right} for more details.
+     @since 4.05.0 *)
+
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+      = "caml_ba_blit"
+  (** Copy the first big array to the second big array.
+     See {!Genarray.blit} for more details. *)
+
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  (** Fill the given big array with the given value.
+     See {!Genarray.fill} for more details. *)
+
+  val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t
+  (** Build a one-dimensional big array initialized from the
+     given array.  *)
+
+  val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
+    bool -> int -> ('a, 'b, 'c) t
+  (** Memory mapping of a file as a one-dimensional big array.
+     See {!Bigarray.Genarray.map_file} for more details. *)
+
+  external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
+  (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds. *)
+
+  external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
+                     = "%caml_ba_unsafe_set_1"
+  (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds. *)
+
+end
+
+
+(** {6 Two-dimensional arrays} *)
+
+(** Two-dimensional arrays. The [Array2] structure provides operations
+   similar to those of {!Bigarray.Genarray}, but specialized to the
+   case of two-dimensional arrays. *)
+module Array2 :
+  sig
+  type ('a, 'b, 'c) t
+  (** The type of two-dimensional big arrays whose elements have
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+  val create: ('a, 'b) kind ->  'c layout -> int -> int -> ('a, 'b, 'c) t
+  (** [Array2.create kind layout dim1 dim2] returns a new bigarray of
+     two dimension, whose size is [dim1] in the first dimension
+     and [dim2] in the second dimension.  [kind] and [layout]
+     determine the array element kind and the array layout
+     as described for {!Bigarray.Genarray.create}. *)
+
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  (** Return the first dimension of the given two-dimensional big array. *)
+
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+  (** Return the second dimension of the given two-dimensional big array. *)
+
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  (** Return the kind of the given big array. *)
+
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  (** Return the layout of the given big array. *)
+
+  val size_in_bytes : ('a, 'b, 'c) t -> int
+  (** [size_in_bytes a] is the number of elements in [a]
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
+
+  external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
+  (** [Array2.get a x y], also written [a.{x,y}],
+     returns the element of [a] at coordinates ([x], [y]).
+     [x] and [y] must be within the bounds
+     of [a], as described for {!Bigarray.Genarray.get};
+     otherwise, [Invalid_argument] is raised. *)
+
+  external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
+  (** [Array2.set a x y v], or alternatively [a.{x,y} <- v],
+     stores the value [v] at coordinates ([x], [y]) in [a].
+     [x] and [y] must be within the bounds of [a],
+     as described for {!Bigarray.Genarray.set};
+     otherwise, [Invalid_argument] is raised. *)
+
+  external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+    = "caml_ba_sub"
+  (** Extract a two-dimensional sub-array of the given two-dimensional
+     big array by restricting the first dimension.
+     See {!Bigarray.Genarray.sub_left} for more details.
+     [Array2.sub_left] applies only to arrays with C layout. *)
+
+  external sub_right:
+    ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+    = "caml_ba_sub"
+  (** Extract a two-dimensional sub-array of the given two-dimensional
+     big array by restricting the second dimension.
+     See {!Bigarray.Genarray.sub_right} for more details.
+     [Array2.sub_right] applies only to arrays with Fortran layout. *)
+
+  val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t
+  (** Extract a row (one-dimensional slice) of the given two-dimensional
+     big array.  The integer parameter is the index of the row to
+     extract.  See {!Bigarray.Genarray.slice_left} for more details.
+     [Array2.slice_left] applies only to arrays with C layout. *)
+
+  val slice_right:
+    ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t
+  (** Extract a column (one-dimensional slice) of the given
+     two-dimensional big array.  The integer parameter is the
+     index of the column to extract.  See {!Bigarray.Genarray.slice_right}
+     for more details.  [Array2.slice_right] applies only to arrays
+     with Fortran layout. *)
+
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+    = "caml_ba_blit"
+  (** Copy the first big array to the second big array.
+     See {!Bigarray.Genarray.blit} for more details. *)
+
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  (** Fill the given big array with the given value.
+     See {!Bigarray.Genarray.fill} for more details. *)
+
+  val of_array: ('a, 'b) kind -> 'c layout -> 'a array array -> ('a, 'b, 'c) t
+  (** Build a two-dimensional big array initialized from the
+     given array of arrays.  *)
+
+  val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
+                bool -> int -> int -> ('a, 'b, 'c) t
+  (** Memory mapping of a file as a two-dimensional big array.
+     See {!Bigarray.Genarray.map_file} for more details. *)
+
+  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
+                     = "%caml_ba_unsafe_ref_2"
+  (** Like {!Bigarray.Array2.get}, but bounds checking is not always
+      performed. *)
+
+  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
+                     = "%caml_ba_unsafe_set_2"
+  (** Like {!Bigarray.Array2.set}, but bounds checking is not always
+      performed. *)
+
+end
+
+(** {6 Three-dimensional arrays} *)
+
+(** Three-dimensional arrays. The [Array3] structure provides operations
+   similar to those of {!Bigarray.Genarray}, but specialized to the case
+   of three-dimensional arrays. *)
+module Array3 :
+  sig
+  type ('a, 'b, 'c) t
+  (** The type of three-dimensional big arrays whose elements have
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+  val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
+  (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of
+     three dimension, whose size is [dim1] in the first dimension,
+     [dim2] in the second dimension, and [dim3] in the third.
+     [kind] and [layout] determine the array element kind and
+     the array layout as described for {!Bigarray.Genarray.create}. *)
+
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  (** Return the first dimension of the given three-dimensional big array. *)
+
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+  (** Return the second dimension of the given three-dimensional big array. *)
+
+  external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
+  (** Return the third dimension of the given three-dimensional big array. *)
+
+  external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+  (** Return the kind of the given big array. *)
+
+  external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  (** Return the layout of the given big array. *)
+
+  val size_in_bytes : ('a, 'b, 'c) t -> int
+  (** [size_in_bytes a] is the number of elements in [a]
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
+
+  external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
+  (** [Array3.get a x y z], also written [a.{x,y,z}],
+     returns the element of [a] at coordinates ([x], [y], [z]).
+     [x], [y] and [z] must be within the bounds of [a],
+     as described for {!Bigarray.Genarray.get};
+     otherwise, [Invalid_argument] is raised. *)
+
+  external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+    = "%caml_ba_set_3"
+  (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v],
+     stores the value [v] at coordinates ([x], [y], [z]) in [a].
+     [x], [y] and [z] must be within the bounds of [a],
+     as described for {!Bigarray.Genarray.set};
+     otherwise, [Invalid_argument] is raised. *)
+
+  external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
+    = "caml_ba_sub"
+  (** Extract a three-dimensional sub-array of the given
+     three-dimensional big array by restricting the first dimension.
+     See {!Bigarray.Genarray.sub_left} for more details.  [Array3.sub_left]
+     applies only to arrays with C layout. *)
+
+  external sub_right:
+    ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+    = "caml_ba_sub"
+  (** Extract a three-dimensional sub-array of the given
+     three-dimensional big array by restricting the second dimension.
+     See {!Bigarray.Genarray.sub_right} for more details.  [Array3.sub_right]
+     applies only to arrays with Fortran layout. *)
+
+  val slice_left_1:
+    ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t
+  (** Extract a one-dimensional slice of the given three-dimensional
+     big array by fixing the first two coordinates.
+     The integer parameters are the coordinates of the slice to
+     extract.  See {!Bigarray.Genarray.slice_left} for more details.
+     [Array3.slice_left_1] applies only to arrays with C layout. *)
+
+  val slice_right_1:
+    ('a, 'b, fortran_layout) t ->
+    int -> int -> ('a, 'b, fortran_layout) Array1.t
+  (** Extract a one-dimensional slice of the given three-dimensional
+     big array by fixing the last two coordinates.
+     The integer parameters are the coordinates of the slice to
+     extract.  See {!Bigarray.Genarray.slice_right} for more details.
+     [Array3.slice_right_1] applies only to arrays with Fortran
+     layout. *)
+
+  val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t
+  (** Extract a  two-dimensional slice of the given three-dimensional
+     big array by fixing the first coordinate.
+     The integer parameter is the first coordinate of the slice to
+     extract.  See {!Bigarray.Genarray.slice_left} for more details.
+     [Array3.slice_left_2] applies only to arrays with C layout. *)
+
+  val slice_right_2:
+    ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t
+  (** Extract a two-dimensional slice of the given
+     three-dimensional big array by fixing the last coordinate.
+     The integer parameter is the coordinate of the slice
+     to extract.  See {!Bigarray.Genarray.slice_right} for more details.
+     [Array3.slice_right_2] applies only to arrays with Fortran
+     layout. *)
+
+  external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
+    = "caml_ba_blit"
+  (** Copy the first big array to the second big array.
+     See {!Bigarray.Genarray.blit} for more details. *)
+
+  external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+  (** Fill the given big array with the given value.
+     See {!Bigarray.Genarray.fill} for more details. *)
+
+  val of_array:
+    ('a, 'b) kind -> 'c layout -> 'a array array array -> ('a, 'b, 'c) t
+  (** Build a three-dimensional big array initialized from the
+     given array of arrays of arrays.  *)
+
+  val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
+             bool -> int -> int -> int -> ('a, 'b, 'c) t
+  (** Memory mapping of a file as a three-dimensional big array.
+     See {!Bigarray.Genarray.map_file} for more details. *)
+
+  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
+                     = "%caml_ba_unsafe_ref_3"
+  (** Like {!Bigarray.Array3.get}, but bounds checking is not always
+      performed. *)
+
+  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+                     = "%caml_ba_unsafe_set_3"
+  (** Like {!Bigarray.Array3.set}, but bounds checking is not always
+      performed. *)
+
+end
+
+(** {6 Coercions between generic big arrays and fixed-dimension big arrays} *)
+
+external genarray_of_array0 :
+  ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given zero-dimensional
+   big array. @since 4.05.0 *)
+
+external genarray_of_array1 :
+  ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given one-dimensional
+   big array. *)
+
+external genarray_of_array2 :
+  ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given two-dimensional
+   big array. *)
+
+external genarray_of_array3 :
+  ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given three-dimensional
+   big array. *)
+
+val array0_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
+(** Return the zero-dimensional big array corresponding to the given
+   generic big array.  Raise [Invalid_argument] if the generic big array
+   does not have exactly zero dimension.
+   @since 4.05.0 *)
+
+val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t
+(** Return the one-dimensional big array corresponding to the given
+   generic big array.  Raise [Invalid_argument] if the generic big array
+   does not have exactly one dimension. *)
+
+val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t
+(** Return the two-dimensional big array corresponding to the given
+   generic big array.  Raise [Invalid_argument] if the generic big array
+   does not have exactly two dimensions. *)
+
+val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t
+(** Return the three-dimensional big array corresponding to the given
+   generic big array.  Raise [Invalid_argument] if the generic big array
+   does not have exactly three dimensions. *)
+
+
+(** {6 Re-shaping big arrays} *)
+
+val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
+(** [reshape b [|d1;...;dN|]] converts the big array [b] to a
+   [N]-dimensional array of dimensions [d1]...[dN].  The returned
+   array and the original array [b] share their data
+   and have the same layout.  For instance, assuming that [b]
+   is a one-dimensional array of dimension 12, [reshape b [|3;4|]]
+   returns a two-dimensional array [b'] of dimensions 3 and 4.
+   If [b] has C layout, the element [(x,y)] of [b'] corresponds
+   to the element [x * 3 + y] of [b].  If [b] has Fortran layout,
+   the element [(x,y)] of [b'] corresponds to the element
+   [x + (y - 1) * 4] of [b].
+   The returned big array must have exactly the same number of
+   elements as the original big array [b].  That is, the product
+   of the dimensions of [b] must be equal to [i1 * ... * iN].
+   Otherwise, [Invalid_argument] is raised. *)
+
+val reshape_0 : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+   zero-dimensional arrays.
+   @since 4.05.0 *)
+
+val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+   one-dimensional arrays. *)
+
+val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+   two-dimensional arrays. *)
+
+val reshape_3 :
+  ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+   three-dimensional arrays. *)
diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
new file mode 100644
index 00000000..cb38bef7
--- /dev/null
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -0,0 +1,1333 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <stddef.h>
+#include <stdarg.h>
+#include <string.h>
+#include "caml/alloc.h"
+#include "bigarray.h"
+#include "caml/custom.h"
+#include "caml/fail.h"
+#include "caml/intext.h"
+#include "caml/hash.h"
+#include "caml/memory.h"
+#include "caml/mlvalues.h"
+#include "caml/signals.h"
+
+#define int8 caml_ba_int8
+#define uint8 caml_ba_uint8
+#define int16 caml_ba_int16
+#define uint16 caml_ba_uint16
+
+extern void caml_ba_unmap_file(void * addr, uintnat len);
+                                          /* from mmap_xxx.c */
+
+/* Compute the number of elements of a big array */
+
+static uintnat caml_ba_num_elts(struct caml_ba_array * b)
+{
+  uintnat num_elts;
+  int i;
+  num_elts = 1;
+  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
+  return num_elts;
+}
+
+/* Size in bytes of a bigarray element, indexed by bigarray kind */
+
+int caml_ba_element_size[] =
+{ 4 /*FLOAT32*/, 8 /*FLOAT64*/,
+  1 /*SINT8*/, 1 /*UINT8*/,
+  2 /*SINT16*/, 2 /*UINT16*/,
+  4 /*INT32*/, 8 /*INT64*/,
+  sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/,
+  8 /*COMPLEX32*/, 16 /*COMPLEX64*/,
+  1 /*CHAR*/
+};
+
+/* Compute the number of bytes for the elements of a big array */
+
+CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b)
+{
+  return caml_ba_num_elts(b)
+         * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+}
+
+/* Operation table for bigarrays */
+
+static void caml_ba_finalize(value v);
+static int caml_ba_compare(value v1, value v2);
+static intnat caml_ba_hash(value v);
+static void caml_ba_serialize(value, uintnat *, uintnat *);
+uintnat caml_ba_deserialize(void * dst);
+static struct custom_operations caml_ba_ops = {
+  "_bigarray",
+  caml_ba_finalize,
+  caml_ba_compare,
+  caml_ba_hash,
+  caml_ba_serialize,
+  caml_ba_deserialize,
+  custom_compare_ext_default
+};
+
+/* Multiplication of unsigned longs with overflow detection */
+
+static uintnat
+caml_ba_multov(uintnat a, uintnat b, int * overflow)
+{
+#define HALF_SIZE (sizeof(uintnat) * 4)
+#define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1)
+#define LOW_HALF(x) ((x) & HALF_MASK)
+#define HIGH_HALF(x) ((x) >> HALF_SIZE)
+  /* Cut in half words */
+  uintnat al = LOW_HALF(a);
+  uintnat ah = HIGH_HALF(a);
+  uintnat bl = LOW_HALF(b);
+  uintnat 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. */
+  uintnat p1 = al * bh;
+  uintnat p2 = ah * bl;
+  uintnat p = a * b;
+  if (ah != 0 && bh != 0) *overflow = 1;
+  if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) *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 CAML_BA_MAX_MEMORY 1024*1024*1024
+/* 1 Gb -- after allocating that much, it's probably worth speeding
+   up the major GC */
+
+/* [caml_ba_alloc] will allocate a new bigarray object in the heap.
+   If [data] is NULL, the memory for the contents is also allocated
+   (with [malloc]) by [caml_ba_alloc].
+   [data] cannot point into the OCaml heap.
+   [dim] may point into an object in the OCaml heap.
+*/
+CAMLexport value
+caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
+{
+  uintnat num_elts, asize, size;
+  int overflow, i;
+  value res;
+  struct caml_ba_array * b;
+  intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
+
+  Assert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
+  Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
+  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 = caml_ba_multov(num_elts, dimcopy[i], &overflow);
+    }
+    size = caml_ba_multov(num_elts,
+                          caml_ba_element_size[flags & CAML_BA_KIND_MASK],
+                          &overflow);
+    if (overflow) caml_raise_out_of_memory();
+    data = malloc(size);
+    if (data == NULL && size != 0) caml_raise_out_of_memory();
+    flags |= CAML_BA_MANAGED;
+  }
+  asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
+  res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY);
+  b = Caml_ba_array_val(res);
+  b->data = data;
+  b->num_dims = num_dims;
+  b->flags = flags;
+  b->proxy = NULL;
+  for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i];
+  return res;
+}
+
+/* Same as caml_ba_alloc, but dimensions are passed as a list of
+   arguments */
+
+CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
+{
+  va_list ap;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  int i;
+  value res;
+
+  Assert(num_dims <= CAML_BA_MAX_NUM_DIMS);
+  va_start(ap, data);
+  for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
+  va_end(ap);
+  res = caml_ba_alloc(flags, num_dims, data, dim);
+  return res;
+}
+
+/* Allocate a bigarray from OCaml */
+
+CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
+{
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  mlsize_t num_dims;
+  int i, flags;
+
+  num_dims = Wosize_val(vdim);
+  /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
+  if (num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument("Bigarray.create: bad number of dimensions");
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] < 0)
+      caml_invalid_argument("Bigarray.create: negative dimension");
+  }
+  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+  return caml_ba_alloc(flags, num_dims, NULL, dim);
+}
+
+/* Given a big array and a vector of indices, check that the indices
+   are within the bounds and return the offset of the corresponding
+   array element in the data part of the array. */
+
+static long caml_ba_offset(struct caml_ba_array * b, intnat * index)
+{
+  intnat offset;
+  int i;
+
+  offset = 0;
+  if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
+    /* C-style layout: row major, indices start at 0 */
+    for (i = 0; i < b->num_dims; i++) {
+      if ((uintnat) index[i] >= (uintnat) b->dim[i])
+        caml_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 ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i])
+        caml_array_bound_error();
+      offset = offset * b->dim[i] + (index[i] - 1);
+    }
+  }
+  return offset;
+}
+
+/* Helper function to allocate a record of two double floats */
+
+static value copy_two_doubles(double d0, double d1)
+{
+  value res = caml_alloc_small(2 * Double_wosize, Double_array_tag);
+  Store_double_field(res, 0, d0);
+  Store_double_field(res, 1, d1);
+  return res;
+}
+
+/* Generic code to read from a big array */
+
+value caml_ba_get_N(value vb, value * vind, int nind)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  intnat index[CAML_BA_MAX_NUM_DIMS];
+  int i;
+  intnat offset;
+
+  /* Check number of indices = number of dimensions of array
+     (maybe not necessary if ML typing guarantees this) */
+  if (nind != b->num_dims)
+    caml_invalid_argument("Bigarray.get: wrong number of indices");
+  /* Compute offset and check bounds */
+  for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
+  offset = caml_ba_offset(b, index);
+  /* Perform read */
+  switch ((b->flags) & CAML_BA_KIND_MASK) {
+  default:
+    Assert(0);
+  case CAML_BA_FLOAT32:
+    return caml_copy_double(((float *) b->data)[offset]);
+  case CAML_BA_FLOAT64:
+    return caml_copy_double(((double *) b->data)[offset]);
+  case CAML_BA_SINT8:
+    return Val_int(((int8 *) b->data)[offset]);
+  case CAML_BA_UINT8:
+    return Val_int(((uint8 *) b->data)[offset]);
+  case CAML_BA_SINT16:
+    return Val_int(((int16 *) b->data)[offset]);
+  case CAML_BA_UINT16:
+    return Val_int(((uint16 *) b->data)[offset]);
+  case CAML_BA_INT32:
+    return caml_copy_int32(((int32_t *) b->data)[offset]);
+  case CAML_BA_INT64:
+    return caml_copy_int64(((int64_t *) b->data)[offset]);
+  case CAML_BA_NATIVE_INT:
+    return caml_copy_nativeint(((intnat *) b->data)[offset]);
+  case CAML_BA_CAML_INT:
+    return Val_long(((intnat *) b->data)[offset]);
+  case CAML_BA_COMPLEX32:
+    { float * p = ((float *) b->data) + offset * 2;
+      return copy_two_doubles(p[0], p[1]); }
+  case CAML_BA_COMPLEX64:
+    { double * p = ((double *) b->data) + offset * 2;
+      return copy_two_doubles(p[0], p[1]); }
+  case CAML_BA_CHAR:
+    return Val_int(((unsigned char *) b->data)[offset]);
+  }
+}
+
+CAMLprim value caml_ba_get_1(value vb, value vind1)
+{
+  return caml_ba_get_N(vb, &vind1, 1);
+}
+
+CAMLprim value caml_ba_get_2(value vb, value vind1, value vind2)
+{
+  value vind[2];
+  vind[0] = vind1; vind[1] = vind2;
+  return caml_ba_get_N(vb, vind, 2);
+}
+
+CAMLprim value caml_ba_get_3(value vb, value vind1, value vind2, value vind3)
+{
+  value vind[3];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+  return caml_ba_get_N(vb, vind, 3);
+}
+
+#if 0
+CAMLprim value caml_ba_get_4(value vb, value vind1, value vind2,
+                     value vind3, value vind4)
+{
+  value vind[4];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
+  return caml_ba_get_N(vb, vind, 4);
+}
+
+CAMLprim value caml_ba_get_5(value vb, value vind1, value vind2,
+                     value vind3, value vind4, value vind5)
+{
+  value vind[5];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+  vind[3] = vind4; vind[4] = vind5;
+  return caml_ba_get_N(vb, vind, 5);
+}
+
+CAMLprim value caml_ba_get_6(value vb, value vind1, value vind2,
+                     value vind3, value vind4, value vind5, value vind6)
+{
+  value vind[6];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+  vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
+  return caml_ba_get_N(vb, vind, 6);
+}
+#endif
+
+CAMLprim value caml_ba_get_generic(value vb, value vind)
+{
+  return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind));
+}
+
+
+CAMLprim value caml_ba_uint8_get16(value vb, value vind)
+{
+  intnat res;
+  unsigned char b1, b2;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+  b1 = ((unsigned char*) b->data)[idx];
+  b2 = ((unsigned char*) b->data)[idx+1];
+#ifdef ARCH_BIG_ENDIAN
+  res = b1 << 8 | b2;
+#else
+  res = b2 << 8 | b1;
+#endif
+  return Val_int(res);
+}
+
+CAMLprim value caml_ba_uint8_get32(value vb, value vind)
+{
+  intnat res;
+  unsigned char b1, b2, b3, b4;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+  b1 = ((unsigned char*) b->data)[idx];
+  b2 = ((unsigned char*) b->data)[idx+1];
+  b3 = ((unsigned char*) b->data)[idx+2];
+  b4 = ((unsigned char*) b->data)[idx+3];
+#ifdef ARCH_BIG_ENDIAN
+  res = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+#else
+  res = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+  return caml_copy_int32(res);
+}
+
+CAMLprim value caml_ba_uint8_get64(value vb, value vind)
+{
+  uint64_t res;
+  unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+  b1 = ((unsigned char*) b->data)[idx];
+  b2 = ((unsigned char*) b->data)[idx+1];
+  b3 = ((unsigned char*) b->data)[idx+2];
+  b4 = ((unsigned char*) b->data)[idx+3];
+  b5 = ((unsigned char*) b->data)[idx+4];
+  b6 = ((unsigned char*) b->data)[idx+5];
+  b7 = ((unsigned char*) b->data)[idx+6];
+  b8 = ((unsigned char*) b->data)[idx+7];
+#ifdef ARCH_BIG_ENDIAN
+  res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48
+        | (uint64_t) b3 << 40 | (uint64_t) b4 << 32
+        | (uint64_t) b5 << 24 | (uint64_t) b6 << 16
+        | (uint64_t) b7 << 8 | (uint64_t) b8;
+#else
+  res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48
+        | (uint64_t) b6 << 40 | (uint64_t) b5 << 32
+        | (uint64_t) b4 << 24 | (uint64_t) b3 << 16
+        | (uint64_t) b2 << 8 | (uint64_t) b1;
+#endif
+  return caml_copy_int64(res);
+}
+
+/* Generic write to a big array */
+
+static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  intnat index[CAML_BA_MAX_NUM_DIMS];
+  int i;
+  intnat offset;
+
+  /* Check number of indices = number of dimensions of array
+     (maybe not necessary if ML typing guarantees this) */
+  if (nind != b->num_dims)
+    caml_invalid_argument("Bigarray.set: wrong number of indices");
+  /* Compute offset and check bounds */
+  for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
+  offset = caml_ba_offset(b, index);
+  /* Perform write */
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  default:
+    Assert(0);
+  case CAML_BA_FLOAT32:
+    ((float *) b->data)[offset] = Double_val(newval); break;
+  case CAML_BA_FLOAT64:
+    ((double *) b->data)[offset] = Double_val(newval); break;
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8:
+    ((int8 *) b->data)[offset] = Int_val(newval); break;
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16:
+    ((int16 *) b->data)[offset] = Int_val(newval); break;
+  case CAML_BA_INT32:
+    ((int32_t *) b->data)[offset] = Int32_val(newval); break;
+  case CAML_BA_INT64:
+    ((int64_t *) b->data)[offset] = Int64_val(newval); break;
+  case CAML_BA_NATIVE_INT:
+    ((intnat *) b->data)[offset] = Nativeint_val(newval); break;
+  case CAML_BA_CAML_INT:
+    ((intnat *) b->data)[offset] = Long_val(newval); break;
+  case CAML_BA_COMPLEX32:
+    { float * p = ((float *) b->data) + offset * 2;
+      p[0] = Double_field(newval, 0);
+      p[1] = Double_field(newval, 1);
+      break; }
+  case CAML_BA_COMPLEX64:
+    { double * p = ((double *) b->data) + offset * 2;
+      p[0] = Double_field(newval, 0);
+      p[1] = Double_field(newval, 1);
+      break; }
+  }
+  return Val_unit;
+}
+
+CAMLprim value caml_ba_set_1(value vb, value vind1, value newval)
+{
+  return caml_ba_set_aux(vb, &vind1, 1, newval);
+}
+
+CAMLprim value caml_ba_set_2(value vb, value vind1, value vind2, value newval)
+{
+  value vind[2];
+  vind[0] = vind1; vind[1] = vind2;
+  return caml_ba_set_aux(vb, vind, 2, newval);
+}
+
+CAMLprim value caml_ba_set_3(value vb, value vind1, value vind2, value vind3,
+                     value newval)
+{
+  value vind[3];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+  return caml_ba_set_aux(vb, vind, 3, newval);
+}
+
+#if 0
+CAMLprim value caml_ba_set_4(value vb, value vind1, value vind2,
+                     value vind3, value vind4, value newval)
+{
+  value vind[4];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
+  return caml_ba_set_aux(vb, vind, 4, newval);
+}
+
+CAMLprim value caml_ba_set_5(value vb, value vind1, value vind2,
+                     value vind3, value vind4, value vind5, value newval)
+{
+  value vind[5];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+  vind[3] = vind4; vind[4] = vind5;
+  return caml_ba_set_aux(vb, vind, 5, newval);
+}
+
+CAMLprim value caml_ba_set_6(value vb, value vind1, value vind2,
+                     value vind3, value vind4, value vind5,
+                     value vind6, value newval)
+{
+  value vind[6];
+  vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
+  vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
+  return caml_ba_set_aux(vb, vind, 6, newval);
+}
+
+value caml_ba_set_N(value vb, value * vind, int nargs)
+{
+  return caml_ba_set_aux(vb, vind, nargs - 1, vind[nargs - 1]);
+}
+#endif
+
+CAMLprim value caml_ba_set_generic(value vb, value vind, value newval)
+{
+  return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
+}
+
+CAMLprim value caml_ba_uint8_set16(value vb, value vind, value newval)
+{
+  unsigned char b1, b2;
+  intnat val;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+  val = Long_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+  b1 = 0xFF & val >> 8;
+  b2 = 0xFF & val;
+#else
+  b2 = 0xFF & val >> 8;
+  b1 = 0xFF & val;
+#endif
+  ((unsigned char*) b->data)[idx] = b1;
+  ((unsigned char*) b->data)[idx+1] = b2;
+  return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set32(value vb, value vind, value newval)
+{
+  unsigned char b1, b2, b3, b4;
+  intnat idx = Long_val(vind);
+  intnat val;
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+  val = Int32_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+  b1 = 0xFF & val >> 24;
+  b2 = 0xFF & val >> 16;
+  b3 = 0xFF & val >> 8;
+  b4 = 0xFF & val;
+#else
+  b4 = 0xFF & val >> 24;
+  b3 = 0xFF & val >> 16;
+  b2 = 0xFF & val >> 8;
+  b1 = 0xFF & val;
+#endif
+  ((unsigned char*) b->data)[idx] = b1;
+  ((unsigned char*) b->data)[idx+1] = b2;
+  ((unsigned char*) b->data)[idx+2] = b3;
+  ((unsigned char*) b->data)[idx+3] = b4;
+  return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval)
+{
+  unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+  intnat idx = Long_val(vind);
+  int64_t val;
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+  val = Int64_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+  b1 = 0xFF & val >> 56;
+  b2 = 0xFF & val >> 48;
+  b3 = 0xFF & val >> 40;
+  b4 = 0xFF & val >> 32;
+  b5 = 0xFF & val >> 24;
+  b6 = 0xFF & val >> 16;
+  b7 = 0xFF & val >> 8;
+  b8 = 0xFF & val;
+#else
+  b8 = 0xFF & val >> 56;
+  b7 = 0xFF & val >> 48;
+  b6 = 0xFF & val >> 40;
+  b5 = 0xFF & val >> 32;
+  b4 = 0xFF & val >> 24;
+  b3 = 0xFF & val >> 16;
+  b2 = 0xFF & val >> 8;
+  b1 = 0xFF & val;
+#endif
+  ((unsigned char*) b->data)[idx] = b1;
+  ((unsigned char*) b->data)[idx+1] = b2;
+  ((unsigned char*) b->data)[idx+2] = b3;
+  ((unsigned char*) b->data)[idx+3] = b4;
+  ((unsigned char*) b->data)[idx+4] = b5;
+  ((unsigned char*) b->data)[idx+5] = b6;
+  ((unsigned char*) b->data)[idx+6] = b7;
+  ((unsigned char*) b->data)[idx+7] = b8;
+  return Val_unit;
+}
+
+/* Return the number of dimensions of a big array */
+
+CAMLprim value caml_ba_num_dims(value vb)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  return Val_long(b->num_dims);
+}
+
+/* Return the n-th dimension of a big array */
+
+CAMLprim value caml_ba_dim(value vb, value vn)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  intnat n = Long_val(vn);
+  if (n >= b->num_dims) caml_invalid_argument("Bigarray.dim");
+  return Val_long(b->dim[n]);
+}
+
+CAMLprim value caml_ba_dim_1(value vb)
+{
+  return caml_ba_dim(vb, Val_int(0));
+}
+
+CAMLprim value caml_ba_dim_2(value vb)
+{
+  return caml_ba_dim(vb, Val_int(1));
+}
+
+CAMLprim value caml_ba_dim_3(value vb)
+{
+  return caml_ba_dim(vb, Val_int(2));
+}
+
+/* Return the kind of a big array */
+
+CAMLprim value caml_ba_kind(value vb)
+{
+  return Val_caml_ba_kind(Caml_ba_array_val(vb)->flags & CAML_BA_KIND_MASK);
+}
+
+/* Return the layout of a big array */
+
+CAMLprim value caml_ba_layout(value vb)
+{
+  int layout = Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK;
+  return Val_caml_ba_layout(layout);
+}
+
+/* Finalization of a big array */
+
+static void caml_ba_finalize(value v)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+
+  switch (b->flags & CAML_BA_MANAGED_MASK) {
+  case CAML_BA_EXTERNAL:
+    break;
+  case CAML_BA_MANAGED:
+    if (b->proxy == NULL) {
+      free(b->data);
+    } else {
+      if (-- b->proxy->refcount == 0) {
+        free(b->proxy->data);
+        caml_stat_free(b->proxy);
+      }
+    }
+    break;
+  case CAML_BA_MAPPED_FILE:
+    if (b->proxy == NULL) {
+      caml_ba_unmap_file(b->data, caml_ba_byte_size(b));
+    } else {
+      if (-- b->proxy->refcount == 0) {
+        caml_ba_unmap_file(b->proxy->data, b->proxy->size);
+        caml_stat_free(b->proxy);
+      }
+    }
+    break;
+  }
+}
+
+/* Comparison of two big arrays */
+
+static int caml_ba_compare(value v1, value v2)
+{
+  struct caml_ba_array * b1 = Caml_ba_array_val(v1);
+  struct caml_ba_array * b2 = Caml_ba_array_val(v2);
+  uintnat n, num_elts;
+  intnat flags1, flags2;
+  int i;
+
+  /* Compare kind & layout in case the arguments are of different types */
+  flags1 = b1->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
+  flags2 = b2->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
+  if (flags1 != flags2) return flags2 - flags1;
+  /* Compare number of dimensions */
+  if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims;
+  /* Same number of dimensions: compare dimensions lexicographically */
+  for (i = 0; i < b1->num_dims; i++) {
+    intnat d1 = b1->dim[i];
+    intnat d2 = b2->dim[i];
+    if (d1 != d2) return d1 < d2 ? -1 : 1;
+  }
+  /* Same dimensions: compare contents lexicographically */
+  num_elts = caml_ba_num_elts(b1);
+
+#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) { \
+        caml_compare_unordered = 1; \
+        if (e1 == e1) return 1; \
+        if (e2 == e2) return -1; \
+      } \
+    } \
+    return 0; \
+  }
+
+  switch (b1->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_COMPLEX32:
+    num_elts *= 2; /*fallthrough*/
+  case CAML_BA_FLOAT32:
+    DO_FLOAT_COMPARISON(float);
+  case CAML_BA_COMPLEX64:
+    num_elts *= 2; /*fallthrough*/
+  case CAML_BA_FLOAT64:
+    DO_FLOAT_COMPARISON(double);
+  case CAML_BA_CHAR:
+    DO_INTEGER_COMPARISON(uint8);
+  case CAML_BA_SINT8:
+    DO_INTEGER_COMPARISON(int8);
+  case CAML_BA_UINT8:
+    DO_INTEGER_COMPARISON(uint8);
+  case CAML_BA_SINT16:
+    DO_INTEGER_COMPARISON(int16);
+  case CAML_BA_UINT16:
+    DO_INTEGER_COMPARISON(uint16);
+  case CAML_BA_INT32:
+    DO_INTEGER_COMPARISON(int32_t);
+  case CAML_BA_INT64:
+    DO_INTEGER_COMPARISON(int64_t);
+  case CAML_BA_CAML_INT:
+  case CAML_BA_NATIVE_INT:
+    DO_INTEGER_COMPARISON(intnat);
+  default:
+    Assert(0);
+    return 0;                   /* should not happen */
+  }
+#undef DO_INTEGER_COMPARISON
+#undef DO_FLOAT_COMPARISON
+}
+
+/* Hashing of a bigarray */
+
+static intnat caml_ba_hash(value v)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+  intnat num_elts, n;
+  uint32_t h, w;
+  int i;
+
+  num_elts = 1;
+  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
+  h = 0;
+
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8: {
+    uint8 * p = b->data;
+    if (num_elts > 256) num_elts = 256;
+    for (n = 0; n + 4 <= num_elts; n += 4, p += 4) {
+      w = p[0] | (p[1] << 8) | (p[2] << 16) | (p[3] << 24);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    w = 0;
+    switch (num_elts & 3) {
+    case 3: w  = p[2] << 16;    /* fallthrough */
+    case 2: w |= p[1] << 8;     /* fallthrough */
+    case 1: w |= p[0];
+            h = caml_hash_mix_uint32(h, w);
+    }
+    break;
+  }
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16: {
+    uint16 * p = b->data;
+    if (num_elts > 128) num_elts = 128;
+    for (n = 0; n + 2 <= num_elts; n += 2, p += 2) {
+      w = p[0] | (p[1] << 16);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    if ((num_elts & 1) != 0)
+      h = caml_hash_mix_uint32(h, p[0]);
+    break;
+  }
+  case CAML_BA_INT32:
+  {
+    uint32_t * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p);
+    break;
+  }
+  case CAML_BA_CAML_INT:
+  case CAML_BA_NATIVE_INT:
+  {
+    intnat * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_intnat(h, *p);
+    break;
+  }
+  case CAML_BA_INT64:
+  {
+    int64_t * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX32:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT32:
+  {
+    float * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_float(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX64:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT64:
+  {
+    double * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_double(h, *p);
+    break;
+  }
+  }
+  return h;
+}
+
+static void caml_ba_serialize_longarray(void * data,
+                                        intnat num_elts,
+                                        intnat min_val, intnat max_val)
+{
+#ifdef ARCH_SIXTYFOUR
+  int overflow_32 = 0;
+  intnat * p, n;
+  for (n = 0, p = data; n < num_elts; n++, p++) {
+    if (*p < min_val || *p > max_val) { overflow_32 = 1; break; }
+  }
+  if (overflow_32) {
+    caml_serialize_int_1(1);
+    caml_serialize_block_8(data, num_elts);
+  } else {
+    caml_serialize_int_1(0);
+    for (n = 0, p = data; n < num_elts; n++, p++)
+      caml_serialize_int_4((int32_t) *p);
+  }
+#else
+  caml_serialize_int_1(0);
+  caml_serialize_block_4(data, num_elts);
+#endif
+}
+
+static void caml_ba_serialize(value v,
+                              uintnat * wsize_32,
+                              uintnat * wsize_64)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+  intnat num_elts;
+  int i;
+
+  /* Serialize header information */
+  caml_serialize_int_4(b->num_dims);
+  caml_serialize_int_4(b->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK));
+  /* On a 64-bit machine, if any of the dimensions is >= 2^32,
+     the size of the marshaled data will be >= 2^32 and
+     extern_value() will fail.  So, it is safe to write the dimensions
+     as 32-bit unsigned integers. */
+  for (i = 0; i < b->num_dims; i++) caml_serialize_int_4(b->dim[i]);
+  /* Compute total number of elements */
+  num_elts = 1;
+  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
+  /* Serialize elements */
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8:
+    caml_serialize_block_1(b->data, num_elts); break;
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16:
+    caml_serialize_block_2(b->data, num_elts); break;
+  case CAML_BA_FLOAT32:
+  case CAML_BA_INT32:
+    caml_serialize_block_4(b->data, num_elts); break;
+  case CAML_BA_COMPLEX32:
+    caml_serialize_block_4(b->data, num_elts * 2); break;
+  case CAML_BA_FLOAT64:
+  case CAML_BA_INT64:
+    caml_serialize_block_8(b->data, num_elts); break;
+  case CAML_BA_COMPLEX64:
+    caml_serialize_block_8(b->data, num_elts * 2); break;
+  case CAML_BA_CAML_INT:
+    caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF);
+    break;
+  case CAML_BA_NATIVE_INT:
+    caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
+    break;
+  }
+  /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
+     is exactly 4 + num_dims words */
+  Assert(SIZEOF_BA_ARRAY == 4 * sizeof(value));
+  *wsize_32 = (4 + b->num_dims) * 4;
+  *wsize_64 = (4 + b->num_dims) * 8;
+}
+
+static void caml_ba_deserialize_longarray(void * dest, intnat num_elts)
+{
+  int sixty = caml_deserialize_uint_1();
+#ifdef ARCH_SIXTYFOUR
+  if (sixty) {
+    caml_deserialize_block_8(dest, num_elts);
+  } else {
+    intnat * p, n;
+    for (n = 0, p = dest; n < num_elts; n++, p++)
+      *p = caml_deserialize_sint_4();
+  }
+#else
+  if (sixty)
+    caml_deserialize_error("input_value: cannot read bigarray "
+                      "with 64-bit OCaml ints");
+  caml_deserialize_block_4(dest, num_elts);
+#endif
+}
+
+uintnat caml_ba_deserialize(void * dst)
+{
+  struct caml_ba_array * b = dst;
+  int i, elt_size;
+  uintnat num_elts;
+
+  /* Read back header information */
+  b->num_dims = caml_deserialize_uint_4();
+  b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
+  b->proxy = NULL;
+  for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
+  /* Compute total number of elements */
+  num_elts = caml_ba_num_elts(b);
+  /* Determine element size in bytes */
+  if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_CHAR)
+    caml_deserialize_error("input_value: bad bigarray kind");
+  elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+  /* Allocate room for data */
+  b->data = malloc(elt_size * num_elts);
+  if (b->data == NULL)
+    caml_deserialize_error("input_value: out of memory for bigarray");
+  /* Read data */
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8:
+    caml_deserialize_block_1(b->data, num_elts); break;
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16:
+    caml_deserialize_block_2(b->data, num_elts); break;
+  case CAML_BA_FLOAT32:
+  case CAML_BA_INT32:
+    caml_deserialize_block_4(b->data, num_elts); break;
+  case CAML_BA_COMPLEX32:
+    caml_deserialize_block_4(b->data, num_elts * 2); break;
+  case CAML_BA_FLOAT64:
+  case CAML_BA_INT64:
+    caml_deserialize_block_8(b->data, num_elts); break;
+  case CAML_BA_COMPLEX64:
+    caml_deserialize_block_8(b->data, num_elts * 2); break;
+  case CAML_BA_CAML_INT:
+  case CAML_BA_NATIVE_INT:
+    caml_ba_deserialize_longarray(b->data, num_elts); break;
+  }
+  /* PR#5516: use C99's flexible array types if possible */
+  return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
+}
+
+/* Create / update proxy to indicate that b2 is a sub-array of b1 */
+
+static void caml_ba_update_proxy(struct caml_ba_array * b1,
+                                 struct caml_ba_array * b2)
+{
+  struct caml_ba_proxy * proxy;
+  /* Nothing to do for un-managed arrays */
+  if ((b1->flags & CAML_BA_MANAGED_MASK) == CAML_BA_EXTERNAL) return;
+  if (b1->proxy != NULL) {
+    /* If b1 is already a proxy for a larger array, increment refcount of
+       proxy */
+    b2->proxy = b1->proxy;
+    ++ b1->proxy->refcount;
+  } else {
+    /* Otherwise, create proxy and attach it to both b1 and b2 */
+    proxy = caml_stat_alloc(sizeof(struct caml_ba_proxy));
+    proxy->refcount = 2;      /* original array + sub array */
+    proxy->data = b1->data;
+    proxy->size =
+      b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0;
+    b1->proxy = proxy;
+    b2->proxy = proxy;
+  }
+}
+
+/* Slicing */
+
+CAMLprim value caml_ba_slice(value vb, value vind)
+{
+  CAMLparam2 (vb, vind);
+  #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+  CAMLlocal1 (res);
+  intnat index[CAML_BA_MAX_NUM_DIMS];
+  int num_inds, i;
+  intnat offset;
+  intnat * sub_dims;
+  char * sub_data;
+
+  /* Check number of indices <= number of dimensions of array */
+  num_inds = Wosize_val(vind);
+  if (num_inds > b->num_dims)
+    caml_invalid_argument("Bigarray.slice: too many indices");
+  /* Compute offset and check bounds */
+  if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
+    /* We slice from the left */
+    for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i));
+    for (/*nothing*/; i < b->num_dims; i++) index[i] = 0;
+    offset = caml_ba_offset(b, index);
+    sub_dims = b->dim + num_inds;
+  } else {
+    /* We slice from the right */
+    for (i = 0; i < num_inds; i++)
+      index[b->num_dims - num_inds + i] = Long_val(Field(vind, i));
+    for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1;
+    offset = caml_ba_offset(b, index);
+    sub_dims = b->dim;
+  }
+  sub_data =
+    (char *) b->data +
+    offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+  /* Allocate an OCaml bigarray to hold the result */
+  res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
+  /* Create or update proxy in case of managed bigarray */
+  caml_ba_update_proxy(b, Caml_ba_array_val(res));
+  /* Return result */
+  CAMLreturn (res);
+
+  #undef b
+}
+
+/* Changing the layout of an array (memory is shared) */
+
+CAMLprim value caml_ba_change_layout(value vb, value vlayout)
+{
+  CAMLparam2 (vb, vlayout);
+  CAMLlocal1 (res);
+  #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+  /* if the layout is different, change the flags and reverse the dimensions */
+  if (Caml_ba_layout_val(vlayout) != (b->flags & CAML_BA_LAYOUT_MASK)) {
+    /* change the flags to reflect the new layout */
+    int flags = (b->flags & (CAML_BA_KIND_MASK | CAML_BA_MANAGED_MASK))
+                 | Caml_ba_layout_val(vlayout);
+    /* reverse the dimensions */
+    intnat new_dim[CAML_BA_MAX_NUM_DIMS];
+    unsigned int i;
+    for(i = 0; i < b->num_dims; i++) new_dim[i] = b->dim[b->num_dims - i - 1];
+    res = caml_ba_alloc(flags, b->num_dims, b->data, new_dim);
+    caml_ba_update_proxy(b, Caml_ba_array_val(res));
+    CAMLreturn(res);
+  } else {
+    /* otherwise, do nothing */
+    CAMLreturn(vb);
+  }
+  #undef b
+}
+
+
+/* Extracting a sub-array of same number of dimensions */
+
+CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
+{
+  CAMLparam3 (vb, vofs, vlen);
+  CAMLlocal1 (res);
+  #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+  intnat ofs = Long_val(vofs);
+  intnat len = Long_val(vlen);
+  int i, changed_dim;
+  intnat mul;
+  char * sub_data;
+
+  /* Compute offset and check bounds */
+  if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
+    /* We reduce the first dimension */
+    mul = 1;
+    for (i = 1; i < b->num_dims; i++) mul *= b->dim[i];
+    changed_dim = 0;
+  } else {
+    /* We reduce the last dimension */
+    mul = 1;
+    for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i];
+    changed_dim = b->num_dims - 1;
+    ofs--;                      /* Fortran arrays start at 1 */
+  }
+  if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim])
+    caml_invalid_argument("Bigarray.sub: bad sub-array");
+  sub_data =
+    (char *) b->data +
+    ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+  /* Allocate an OCaml bigarray to hold the result */
+  res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
+  /* Doctor the changed dimension */
+  Caml_ba_array_val(res)->dim[changed_dim] = len;
+  /* Create or update proxy in case of managed bigarray */
+  caml_ba_update_proxy(b, Caml_ba_array_val(res));
+  /* Return result */
+  CAMLreturn (res);
+
+  #undef b
+}
+
+/* Copying a big array into another one */
+
+#define LEAVE_RUNTIME_OP_CUTOFF 4096
+#define is_mmapped(ba) ((ba)->flags & CAML_BA_MAPPED_FILE)
+
+CAMLprim value caml_ba_blit(value vsrc, value vdst)
+{
+  CAMLparam2(vsrc, vdst);
+  struct caml_ba_array * src = Caml_ba_array_val(vsrc);
+  struct caml_ba_array * dst = Caml_ba_array_val(vdst);
+  void *src_data = src->data;
+  void *dst_data = dst->data;
+  int i;
+  intnat num_bytes;
+  int leave_runtime;
+
+  /* Check same numbers of dimensions and same dimensions */
+  if (src->num_dims != dst->num_dims) goto blit_error;
+  for (i = 0; i < src->num_dims; i++)
+    if (src->dim[i] != dst->dim[i]) goto blit_error;
+  /* Compute number of bytes in array data */
+  num_bytes =
+    caml_ba_num_elts(src)
+    * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK];
+  leave_runtime =
+    (
+      (num_bytes >= LEAVE_RUNTIME_OP_CUTOFF*sizeof(long))
+      || is_mmapped(src)
+      || is_mmapped(dst)
+    );
+  /* Do the copying */
+  if (leave_runtime) caml_enter_blocking_section();
+  memmove (dst_data, src_data, num_bytes);
+  if (leave_runtime) caml_leave_blocking_section();
+  CAMLreturn (Val_unit);
+ blit_error:
+  caml_invalid_argument("Bigarray.blit: dimension mismatch");
+  CAMLreturn (Val_unit);              /* not reached */
+}
+
+/* Filling a big array with a given value */
+
+#define FILL_GEN_LOOP(n_ops, loop) do{                                       \
+  int leave_runtime = ((n_ops >= LEAVE_RUNTIME_OP_CUTOFF) || is_mmapped(b)); \
+  if (leave_runtime) caml_enter_blocking_section();                          \
+  loop;                                                                      \
+  if (leave_runtime) caml_leave_blocking_section();                          \
+}while(0)
+
+#define FILL_SCALAR_LOOP                                        \
+  FILL_GEN_LOOP(num_elts,                                       \
+    for (p = data; num_elts > 0; p++, num_elts--) *p = init)
+
+#define FILL_COMPLEX_LOOP                                                    \
+  FILL_GEN_LOOP(num_elts + num_elts,                                         \
+    for (p = data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; })
+
+CAMLprim value caml_ba_fill(value vb, value vinit)
+{
+  CAMLparam1(vb);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  void *data = b->data;
+  intnat num_elts = caml_ba_num_elts(b);
+
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  default:
+    Assert(0);
+  case CAML_BA_FLOAT32: {
+    float init = Double_val(vinit);
+    float * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_FLOAT64: {
+    double init = Double_val(vinit);
+    double * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8: {
+    int init = Int_val(vinit);
+    unsigned char * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16: {
+    int init = Int_val(vinit);
+    int16 * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_INT32: {
+    int32_t init = Int32_val(vinit);
+    int32_t * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_INT64: {
+    int64_t init = Int64_val(vinit);
+    int64_t * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_NATIVE_INT: {
+    intnat init = Nativeint_val(vinit);
+    intnat * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_CAML_INT: {
+    intnat init = Long_val(vinit);
+    intnat * p;
+    FILL_SCALAR_LOOP;
+    break;
+  }
+  case CAML_BA_COMPLEX32: {
+    float init0 = Double_field(vinit, 0);
+    float init1 = Double_field(vinit, 1);
+    float * p;
+    FILL_COMPLEX_LOOP;
+    break;
+  }
+  case CAML_BA_COMPLEX64: {
+    double init0 = Double_field(vinit, 0);
+    double init1 = Double_field(vinit, 1);
+    double * p;
+    FILL_COMPLEX_LOOP;
+    break;
+  }
+  }
+  CAMLreturn (Val_unit);
+}
+
+/* Reshape an array: change dimensions and number of dimensions, preserving
+   array contents */
+
+CAMLprim value caml_ba_reshape(value vb, value vdim)
+{
+  CAMLparam2 (vb, vdim);
+  CAMLlocal1 (res);
+#define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  mlsize_t num_dims;
+  uintnat num_elts;
+  int i;
+
+  num_dims = Wosize_val(vdim);
+  /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
+  if (num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument("Bigarray.reshape: bad number of dimensions");
+  num_elts = 1;
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] < 0)
+      caml_invalid_argument("Bigarray.reshape: negative dimension");
+    num_elts *= dim[i];
+  }
+  /* Check that sizes agree */
+  if (num_elts != caml_ba_num_elts(b))
+    caml_invalid_argument("Bigarray.reshape: size mismatch");
+  /* Create bigarray with same data and new dimensions */
+  res = caml_ba_alloc(b->flags, num_dims, b->data, dim);
+  /* Create or update proxy in case of managed bigarray */
+  caml_ba_update_proxy(b, Caml_ba_array_val(res));
+  /* Return result */
+  CAMLreturn (res);
+
+#undef b
+}
+
+/* Initialization */
+
+CAMLprim value caml_ba_init(value unit)
+{
+  caml_register_custom_operations(&caml_ba_ops);
+  return Val_unit;
+}
diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
new file mode 100644
index 00000000..f276514c
--- /dev/null
+++ b/otherlibs/bigarray/mmap_unix.c
@@ -0,0 +1,206 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
+   Must be defined before the first system .h is included. */
+#define _XOPEN_SOURCE 600
+
+#include <stddef.h>
+#include <string.h>
+#include "bigarray.h"
+#include "caml/custom.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/mlvalues.h"
+#include "caml/sys.h"
+#include "caml/signals.h"
+
+extern int caml_ba_element_size[];  /* from bigarray_stubs.c */
+
+#include <errno.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_MMAP
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#endif
+
+#if defined(HAS_MMAP)
+
+#ifndef MAP_FAILED
+#define MAP_FAILED ((void *) -1)
+#endif
+
+/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */
+
+static int caml_grow_file(int fd, file_offset size)
+{
+  char c;
+  int p;
+
+  /* First use pwrite for growing - it is a conservative method, as it
+     can never happen that we shrink by accident
+   */
+#ifdef HAS_PWRITE
+  c = 0;
+  p = pwrite(fd, &c, 1, size - 1);
+#else
+
+  /* Emulate pwrite with lseek. This should only be necessary on ancient
+     systems nowadays
+   */
+  file_offset currpos;
+  currpos = lseek(fd, 0, SEEK_CUR);
+  if (currpos != -1) {
+    p = lseek(fd, size - 1, SEEK_SET);
+    if (p != -1) {
+      c = 0;
+      p = write(fd, &c, 1);
+      if (p != -1)
+        p = lseek(fd, currpos, SEEK_SET);
+    }
+  }
+  else p=-1;
+#endif
+#ifdef HAS_TRUNCATE
+  if (p == -1 && errno == ESPIPE) {
+    /* Plan B. Check if at least ftruncate is possible. There are
+       some non-seekable descriptor types that do not support pwrite
+       but ftruncate, like shared memory. We never get into this case
+       for real files, so there is no danger of truncating persistent
+       data by accident
+     */
+    p = ftruncate(fd, size);
+  }
+#endif
+  return p;
+}
+
+
+CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
+                                value vshared, value vdim, value vstart)
+{
+  int fd, flags, major_dim, shared;
+  intnat num_dims, i;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  file_offset startpos, file_size, data_size;
+  struct stat st;
+  uintnat array_size, page, delta;
+  void * addr;
+
+  fd = Int_val(vfd);
+  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+  startpos = File_offset_val(vstart);
+  num_dims = Wosize_val(vdim);
+  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
+  /* Extract dimensions from OCaml array */
+  num_dims = Wosize_val(vdim);
+  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] == -1 && i == major_dim) continue;
+    if (dim[i] < 0)
+      caml_invalid_argument("Bigarray.create: negative dimension");
+  }
+  /* Determine file size. We avoid lseek here because it is fragile,
+     and because some mappable file types do not support it
+   */
+  caml_enter_blocking_section();
+  if (fstat(fd, &st) == -1) {
+    caml_leave_blocking_section();
+    caml_sys_error(NO_ARG);
+  }
+  file_size = st.st_size;
+  /* Determine array size in bytes (or size of array without the major
+     dimension if that dimension wasn't specified) */
+  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
+  for (i = 0; i < num_dims; i++)
+    if (dim[i] != -1) array_size *= dim[i];
+  /* Check if the major dimension is unknown */
+  if (dim[major_dim] == -1) {
+    /* Determine major dimension from file size */
+    if (file_size < startpos) {
+      caml_leave_blocking_section();
+      caml_failwith("Bigarray.mmap: file position exceeds file size");
+    }
+    data_size = file_size - startpos;
+    dim[major_dim] = (uintnat) (data_size / array_size);
+    array_size = dim[major_dim] * array_size;
+    if (array_size != data_size) {
+      caml_leave_blocking_section();
+      caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
+    }
+  } else {
+    /* Check that file is large enough, and grow it otherwise */
+    if (file_size < startpos + array_size) {
+      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
+        caml_leave_blocking_section();
+        caml_sys_error(NO_ARG);
+      }
+    }
+  }
+  /* Determine offset so that the mapping starts at the given file pos */
+  page = sysconf(_SC_PAGESIZE);
+  delta = (uintnat) startpos % page;
+  /* Do the mmap */
+  shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
+  if (array_size > 0)
+    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
+                shared, fd, startpos - delta);
+  else
+    addr = NULL;                /* PR#5463 - mmap fails on empty region */
+  caml_leave_blocking_section();
+  if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG);
+  addr = (void *) ((uintnat) addr + delta);
+  /* Build and return the OCaml bigarray */
+  return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
+}
+
+#else
+
+CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
+                                value vshared, value vdim, value vpos)
+{
+  caml_invalid_argument("Bigarray.map_file: not supported");
+  return Val_unit;
+}
+
+#endif
+
+CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn)
+{
+  return caml_ba_map_file(argv[0], argv[1], argv[2],
+                          argv[3], argv[4], argv[5]);
+}
+
+void caml_ba_unmap_file(void * addr, uintnat len)
+{
+#if defined(HAS_MMAP)
+  uintnat page = sysconf(_SC_PAGESIZE);
+  uintnat delta = (uintnat) addr % page;
+  if (len == 0) return;         /* PR#5463 */
+  addr = (void *)((uintnat)addr - delta);
+  len  = len + delta;
+#if defined(_POSIX_SYNCHRONIZED_IO)
+  msync(addr, len, MS_ASYNC);   /* PR#3571 */
+#endif
+  munmap(addr, len);
+#endif
+}
diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c
new file mode 100644
index 00000000..89ac6a45
--- /dev/null
+++ b/otherlibs/bigarray/mmap_win32.c
@@ -0,0 +1,155 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stddef.h>
+#include <stdio.h>
+#include <string.h>
+#include "bigarray.h"
+#include "caml/alloc.h"
+#include "caml/custom.h"
+#include "caml/fail.h"
+#include "caml/mlvalues.h"
+#include "caml/sys.h"
+#include "unixsupport.h"
+
+extern int caml_ba_element_size[];  /* from bigarray_stubs.c */
+
+static void caml_ba_sys_error(void);
+
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER (-1)
+#endif
+
+static __int64 caml_ba_set_file_pointer(HANDLE h, __int64 dist, DWORD mode)
+{
+  LARGE_INTEGER i;
+  DWORD err;
+
+  i.QuadPart = dist;
+  i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode);
+  if (i.LowPart == INVALID_SET_FILE_POINTER) return -1;
+  return i.QuadPart;
+}
+
+CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
+                                value vshared, value vdim, value vstart)
+{
+  HANDLE fd, fmap;
+  int flags, major_dim, mode, perm;
+  intnat num_dims, i;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  __int64 currpos, startpos, file_size, data_size;
+  uintnat array_size, page, delta;
+  char c;
+  void * addr;
+  LARGE_INTEGER li;
+  SYSTEM_INFO sysinfo;
+
+  fd = Handle_val(vfd);
+  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+  startpos = Int64_val(vstart);
+  num_dims = Wosize_val(vdim);
+  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
+  /* Extract dimensions from OCaml array */
+  num_dims = Wosize_val(vdim);
+  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] == -1 && i == major_dim) continue;
+    if (dim[i] < 0)
+      caml_invalid_argument("Bigarray.create: negative dimension");
+  }
+  /* Determine file size */
+  currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT);
+  if (currpos == -1) caml_ba_sys_error();
+  file_size = caml_ba_set_file_pointer(fd, 0, FILE_END);
+  if (file_size == -1) caml_ba_sys_error();
+  /* Determine array size in bytes (or size of array without the major
+     dimension if that dimension wasn't specified) */
+  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
+  for (i = 0; i < num_dims; i++)
+    if (dim[i] != -1) array_size *= dim[i];
+  /* Check if the first/last dimension is unknown */
+  if (dim[major_dim] == -1) {
+    /* Determine first/last dimension from file size */
+    if (file_size < startpos)
+      caml_failwith("Bigarray.mmap: file position exceeds file size");
+    data_size = file_size - startpos;
+    dim[major_dim] = (uintnat) (data_size / array_size);
+    array_size = dim[major_dim] * array_size;
+    if (array_size != data_size)
+      caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
+  }
+  /* Restore original file position */
+  caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN);
+  /* Create the file mapping */
+  if (Bool_val(vshared)) {
+    perm = PAGE_READWRITE;
+    mode = FILE_MAP_WRITE;
+  } else {
+    perm = PAGE_READONLY;       /* doesn't work under Win98 */
+    mode = FILE_MAP_COPY;
+  }
+  li.QuadPart = startpos + array_size;
+  fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL);
+  if (fmap == NULL) caml_ba_sys_error();
+  /* Determine offset so that the mapping starts at the given file pos */
+  GetSystemInfo(&sysinfo);
+  delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity);
+  /* Map the mapping in memory */
+  li.QuadPart = startpos - delta;
+  addr =
+    MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta);
+  if (addr == NULL) caml_ba_sys_error();
+  addr = (void *) ((uintnat) addr + delta);
+  /* Close the file mapping */
+  CloseHandle(fmap);
+  /* Build and return the OCaml bigarray */
+  return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
+}
+
+CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn)
+{
+  return caml_ba_map_file(argv[0], argv[1], argv[2],
+                          argv[3], argv[4], argv[5]);
+}
+
+void caml_ba_unmap_file(void * addr, uintnat len)
+{
+  SYSTEM_INFO sysinfo;
+  uintnat delta;
+
+  GetSystemInfo(&sysinfo);
+  delta = (uintnat) addr % sysinfo.dwAllocationGranularity;
+  UnmapViewOfFile((void *)((uintnat)addr - delta));
+}
+
+static void caml_ba_sys_error(void)
+{
+  char buffer[512];
+  DWORD errnum;
+
+  errnum = GetLastError();
+  if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
+                     NULL,
+                     errnum,
+                     0,
+                     buffer,
+                     sizeof(buffer),
+                     NULL))
+    sprintf(buffer, "Unknown error %ld\n", errnum);
+  caml_raise_sys_error(caml_copy_string(buffer));
+}
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
new file mode 100644
index 00000000..8c8c3ae4
--- /dev/null
+++ b/otherlibs/dynlink/Makefile
@@ -0,0 +1,123 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the dynamic link library
+
+# FIXME reduce redundancy by including ../Makefile
+
+include ../../config/Makefile
+CAMLRUN ?= ../../boot/ocamlrun
+CAMLYACC ?= ../../boot/ocamlyacc
+
+ROOTDIR   = ../..
+OCAMLC    = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
+OCAMLOPT  = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib
+
+INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -bin-annot -g \
+   -I ../../stdlib -warn-error A \
+   -safe-string -strict-sequence -strict-formats
+ifeq "$(FLAMBDA)" "true"
+OPTCOMPFLAGS=-O3
+else
+OPTCOMPFLAGS=
+endif
+
+OBJS=dynlinkaux.cmo dynlink.cmo
+
+COMPILEROBJS=\
+  ../../utils/misc.cmo ../../utils/config.cmo \
+  ../../utils/identifiable.cmo ../../utils/numbers.cmo \
+  ../../utils/arg_helper.cmo ../../utils/clflags.cmo \
+  ../../utils/tbl.cmo ../../utils/consistbl.cmo \
+  ../../utils/terminfo.cmo ../../utils/warnings.cmo \
+  ../../parsing/asttypes.cmi \
+  ../../parsing/location.cmo ../../parsing/longident.cmo \
+  ../../parsing/docstrings.cmo ../../parsing/syntaxerr.cmo \
+  ../../parsing/ast_helper.cmo \
+  ../../parsing/ast_mapper.cmo ../../parsing/ast_iterator.cmo \
+  ../../parsing/attr_helper.cmo \
+  ../../parsing/builtin_attributes.cmo \
+  ../../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/cmi_format.cmo ../../typing/env.cmo \
+  ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \
+  ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \
+  ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \
+  ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \
+  ../../bytecomp/symtable.cmo
+
+NATOBJS=dynlink.cmx
+
+all: dynlink.cma extract_crc
+
+allopt: dynlink.cmxa
+
+dynlink.cma: $(OBJS)
+	$(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \
+	         $(OBJS)
+
+dynlink.cmxa: $(NATOBJS)
+	$(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \
+	           $(NATOBJS)
+
+dynlinkaux.cmo: $(COMPILEROBJS)
+	$(OCAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS)
+
+dynlinkaux.cmi: dynlinkaux.cmo
+
+dynlink.cmx: dynlink.cmi natdynlink.ml
+	cp natdynlink.ml  dynlink.mlopt
+	$(OCAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt
+	rm -f dynlink.mlopt
+
+extract_crc: dynlink.cma extract_crc.cmo
+	$(OCAMLC) -o extract_crc dynlink.cma extract_crc.cmo
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+install:
+	cp dynlink.cmi dynlink.cmti dynlink.cma dynlink.mli "$(INSTALL_LIBDIR)"
+	cp extract_crc "$(INSTALL_LIBDIR)/extract_crc$(EXE)"
+
+installopt:
+	if $(NATDYNLINK); then \
+	  cp $(NATOBJS) dynlink.cmxa dynlink.$(A) "$(INSTALL_LIBDIR)" && \
+	  cd "$(INSTALL_LIBDIR)" && $(RANLIB) dynlink.$(A); \
+	fi
+
+partialclean:
+	rm -f extract_crc *.cm[ioaxt] *.cmti *.cmxa
+
+clean: partialclean
+	rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.mli.cmi:
+	$(OCAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(OCAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(OCAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
+
+depend:
+
+dynlink.cmi: dynlinkaux.cmi
+dynlink.cmo: dynlink.cmi dynlinkaux.cmo
+extract_crc.cmo: dynlink.cmi
diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt
new file mode 100644
index 00000000..2fb4e17b
--- /dev/null
+++ b/otherlibs/dynlink/Makefile.nt
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the dynamic link library
+
+include Makefile
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
new file mode 100644
index 00000000..cbb15194
--- /dev/null
+++ b/otherlibs/dynlink/dynlink.ml
@@ -0,0 +1,338 @@
+#2 "otherlibs/dynlink/dynlink.ml"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Dynamic loading of .cmo files *)
+
+open Dynlinkaux  (* REMOVE_ME for ../../debugger/dynlink.ml *)
+open Cmo_format
+
+type linking_error =
+    Undefined_global of string
+  | Unavailable_primitive of string
+  | Uninitialized_global of string
+
+type error =
+    Not_a_bytecode_file of string
+  | Inconsistent_import of string
+  | Unavailable_unit of string
+  | Unsafe_file
+  | Linking_error of string * linking_error
+  | Corrupted_interface of string
+  | File_not_found of string
+  | Cannot_open_dll of string
+  | Inconsistent_implementation of string
+
+exception Error of error
+
+let () =
+  Printexc.register_printer
+    (function
+      | Error err ->
+          let msg = match err with
+          | Not_a_bytecode_file s ->
+              Printf.sprintf "Not_a_bytecode_file %S" s
+          | Inconsistent_import s ->
+              Printf.sprintf "Inconsistent_import %S" s
+          | Unavailable_unit s ->
+              Printf.sprintf "Unavailable_unit %S" s
+          | Unsafe_file ->
+              "Unsafe_file"
+          | Linking_error (s, Undefined_global s') ->
+              Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)"
+                             s s'
+          | Linking_error (s, Unavailable_primitive s') ->
+              Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive \
+                              %S)" s s'
+          | Linking_error (s, Uninitialized_global s') ->
+              Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global \
+                              %S)" s s'
+          | Corrupted_interface s ->
+              Printf.sprintf "Corrupted_interface %S" s
+          | File_not_found s ->
+              Printf.sprintf "File_not_found %S" s
+          | Cannot_open_dll s ->
+              Printf.sprintf "Cannot_open_dll %S" s
+          | Inconsistent_implementation s ->
+              Printf.sprintf "Inconsistent_implementation %S" s in
+          Some (Printf.sprintf "Dynlink.Error(Dynlink.%s)" msg)
+      | _ -> None)
+
+(* Management of interface CRCs *)
+
+let crc_interfaces = ref (Consistbl.create ())
+let allow_extension = ref true
+
+(* Check that the object file being loaded has been compiled against
+   the same interfaces as the program itself. In addition, check that
+   only authorized compilation units are referenced. *)
+
+let check_consistency file_name cu =
+  try
+    List.iter
+      (fun (name, crco) ->
+         match crco with
+           None -> ()
+         | Some crc ->
+             if name = cu.cu_name then
+               Consistbl.set !crc_interfaces name crc file_name
+             else if !allow_extension then
+               Consistbl.check !crc_interfaces name crc file_name
+             else
+               Consistbl.check_noadd !crc_interfaces name crc file_name)
+      cu.cu_imports
+  with Consistbl.Inconsistency(name, _user, _auth) ->
+         raise(Error(Inconsistent_import name))
+     | Consistbl.Not_available(name) ->
+         raise(Error(Unavailable_unit name))
+
+(* Empty the crc_interfaces table *)
+
+let clear_available_units () =
+  Consistbl.clear !crc_interfaces;
+  allow_extension := false
+
+(* Allow only access to the units with the given names *)
+
+let allow_only names =
+  Consistbl.filter (fun name -> List.mem name names) !crc_interfaces;
+  allow_extension := false
+
+(* Prohibit access to the units with the given names *)
+
+let prohibit names =
+  Consistbl.filter (fun name -> not (List.mem name names)) !crc_interfaces;
+  allow_extension := false
+
+(* Initialize the crc_interfaces table with a list of units with fixed CRCs *)
+
+let add_available_units units =
+  List.iter
+    (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "")
+    units
+
+(* Default interface CRCs: those found in the current executable *)
+let default_crcs = ref []
+
+let default_available_units () =
+  clear_available_units();
+  List.iter
+    (fun (unit, crco) ->
+       match crco with
+         None -> ()
+       | Some crc -> Consistbl.set !crc_interfaces unit crc "")
+    !default_crcs;
+  allow_extension := true
+
+(* Initialize the linker tables and everything *)
+
+let inited = ref false
+
+let init () =
+  if not !inited then begin
+    if !Sys.interactive then (* PR#6802 *)
+      invalid_arg "The dynlink.cma library cannot be used \
+                   inside the OCaml toplevel";
+    default_crcs := Symtable.init_toplevel();
+    default_available_units ();
+    inited := true;
+  end
+
+let clear_available_units () = init(); clear_available_units ()
+let allow_only l = init(); allow_only l
+let prohibit l = init(); prohibit l
+let add_available_units l = init(); add_available_units l
+let default_available_units () = init(); default_available_units ()
+
+(* Read the CRC of an interface from its .cmi file *)
+
+let digest_interface unit loadpath =
+  let filename =
+    let shortname = unit ^ ".cmi" in
+    try
+      Misc.find_in_path_uncap loadpath shortname
+    with Not_found ->
+      raise (Error(File_not_found shortname)) in
+  let ic = open_in_bin filename in
+  try
+    let buffer =
+      really_input_string ic (String.length Config.cmi_magic_number)
+    in
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      raise(Error(Corrupted_interface filename))
+    end;
+    let cmi = Cmi_format.input_cmi ic in
+    close_in ic;
+    let crc =
+      match cmi.Cmi_format.cmi_crcs with
+        (_, Some crc) :: _ -> crc
+      | _             -> raise(Error(Corrupted_interface filename))
+    in
+    crc
+  with End_of_file | Failure _ ->
+    close_in ic;
+    raise(Error(Corrupted_interface filename))
+
+(* Initialize the crc_interfaces table with a list of units.
+   Their CRCs are read from their interfaces. *)
+
+let add_interfaces units loadpath =
+  add_available_units
+    (List.map (fun unit -> (unit, digest_interface unit loadpath)) units)
+
+(* Check whether the object file being loaded was compiled in unsafe mode *)
+
+let unsafe_allowed = ref false
+
+let allow_unsafe_modules b =
+  unsafe_allowed := b
+
+let check_unsafe_module cu =
+  if (not !unsafe_allowed) && cu.cu_primitives <> []
+  then raise(Error(Unsafe_file))
+
+(* Load in-core and execute a bytecode object file *)
+
+external register_code_fragment: bytes -> int -> string -> unit
+                               = "caml_register_code_fragment"
+
+let load_compunit ic file_name file_digest compunit =
+  check_consistency file_name compunit;
+  check_unsafe_module compunit;
+  seek_in ic compunit.cu_pos;
+  let code_size = compunit.cu_codesize + 8 in
+  let code = Meta.static_alloc code_size in
+  unsafe_really_input ic code 0 compunit.cu_codesize;
+  Bytes.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
+  Bytes.unsafe_set code (compunit.cu_codesize + 1) '\000';
+  Bytes.unsafe_set code (compunit.cu_codesize + 2) '\000';
+  Bytes.unsafe_set code (compunit.cu_codesize + 3) '\000';
+  Bytes.unsafe_set code (compunit.cu_codesize + 4) '\001';
+  Bytes.unsafe_set code (compunit.cu_codesize + 5) '\000';
+  Bytes.unsafe_set code (compunit.cu_codesize + 6) '\000';
+  Bytes.unsafe_set code (compunit.cu_codesize + 7) '\000';
+  let initial_symtable = Symtable.current_state() in
+  begin try
+    Symtable.patch_object code compunit.cu_reloc;
+    Symtable.check_global_initialized compunit.cu_reloc;
+    Symtable.update_global_table()
+  with Symtable.Error error ->
+    let new_error =
+      match error with
+        Symtable.Undefined_global s -> Undefined_global s
+      | Symtable.Unavailable_primitive s -> Unavailable_primitive s
+      | Symtable.Uninitialized_global s -> Uninitialized_global s
+      | _ -> assert false in
+    raise(Error(Linking_error (file_name, new_error)))
+  end;
+  (* PR#5215: identify this code fragment by
+     digest of file contents + unit name.
+     Unit name is needed for .cma files, which produce several code fragments.*)
+  let digest = Digest.string (file_digest ^ compunit.cu_name) in
+  register_code_fragment code code_size digest;
+  let events =
+    if compunit.cu_debug = 0 then [| |]
+    else begin
+      seek_in ic compunit.cu_debug;
+      [| input_value ic |]
+    end in
+  Meta.add_debug_info code code_size events;
+  begin try
+    ignore((Meta.reify_bytecode code code_size) ())
+  with exn ->
+    Symtable.restore_state initial_symtable;
+    raise exn
+  end
+
+let loadfile file_name =
+  init();
+  if not (Sys.file_exists file_name)
+    then raise (Error (File_not_found file_name));
+  let ic = open_in_bin file_name in
+  let file_digest = Digest.channel ic (-1) in
+  seek_in ic 0;
+  try
+    let buffer =
+      try really_input_string ic (String.length Config.cmo_magic_number)
+      with End_of_file -> raise (Error (Not_a_bytecode_file file_name))
+    in
+    if buffer = Config.cmo_magic_number then begin
+      let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
+      seek_in ic compunit_pos;
+      let cu = (input_value ic : compilation_unit) in
+      load_compunit ic file_name file_digest cu
+    end else
+    if buffer = Config.cma_magic_number then begin
+      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 Dll.For_execution
+                      (List.map Dll.extract_dll_name lib.lib_dllibs)
+      with Failure reason ->
+        raise(Error(Cannot_open_dll reason))
+      end;
+      List.iter (load_compunit ic file_name file_digest) lib.lib_units
+    end else
+      raise(Error(Not_a_bytecode_file file_name));
+    close_in ic
+  with exc ->
+    close_in ic; raise exc
+
+let loadfile_private file_name =
+  init();
+  let initial_symtable = Symtable.current_state()
+  and initial_crc = !crc_interfaces in
+  try
+    loadfile file_name;
+    Symtable.hide_additions initial_symtable;
+    crc_interfaces := initial_crc
+  with exn ->
+    Symtable.hide_additions initial_symtable;
+    crc_interfaces := initial_crc;
+    raise exn
+
+(* Error report *)
+
+let error_message = function
+    Not_a_bytecode_file name ->
+      name ^ " is not a bytecode object file"
+  | Inconsistent_import name ->
+      "interface mismatch on " ^ name
+  | Unavailable_unit name ->
+      "no implementation available for " ^ name
+  | Unsafe_file ->
+      "this object file uses unsafe features"
+  | Linking_error (name, Undefined_global s) ->
+      "error while linking " ^ name ^ ".\n" ^
+      "Reference to undefined global `" ^ s ^ "'"
+  | Linking_error (name, Unavailable_primitive s) ->
+      "error while linking " ^ name ^ ".\n" ^
+      "The external function `" ^ s ^ "' is not available"
+  | Linking_error (name, Uninitialized_global s) ->
+      "error while linking " ^ name ^ ".\n" ^
+      "The module `" ^ s ^ "' is not yet initialized"
+  | Corrupted_interface name ->
+      "corrupted interface file " ^ name
+  | File_not_found name ->
+      "cannot find file " ^ name ^ " in search path"
+  | Cannot_open_dll reason ->
+      "error loading shared library: " ^ reason
+  | Inconsistent_implementation name ->
+      "implementation mismatch on " ^ name
+
+let is_native = false
+let adapt_filename f = f
diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
new file mode 100644
index 00000000..39b3ea62
--- /dev/null
+++ b/otherlibs/dynlink/dynlink.mli
@@ -0,0 +1,148 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Dynamic loading of object files. *)
+
+val is_native: bool
+(** [true] if the program is native,
+    [false] if the program is bytecode. *)
+
+(** {6 Dynamic loading of compiled files} *)
+
+val loadfile : string -> unit
+(** In bytecode: load the given bytecode object file ([.cmo] file) or
+    bytecode library file ([.cma] file), and link it with the running
+    program. In native code: load the given OCaml plugin file (usually
+    [.cmxs]), and link it with the running
+    program.
+    All toplevel expressions in the loaded compilation units
+    are evaluated. No facilities are provided to
+    access value names defined by the unit. Therefore, the unit
+    must register itself its entry points with the main program,
+    e.g. by modifying tables of functions. *)
+
+val loadfile_private : string -> unit
+(** Same as [loadfile], except that the compilation units just loaded
+    are hidden (cannot be referenced) from other modules dynamically
+    loaded afterwards. *)
+
+val adapt_filename : string -> string
+(** In bytecode, the identity function. In native code, replace the last
+    extension with [.cmxs]. *)
+
+(** {6 Access control} *)
+
+val allow_only: string list -> unit
+(** [allow_only units] restricts the compilation units that
+    dynamically-linked units can reference: it forbids all references
+    to units other than those named in the list [units]. References
+    to any other compilation unit will cause a [Unavailable_unit]
+    error during [loadfile] or [loadfile_private].
+
+    Initially (or after calling [default_available_units]) all
+    compilation units composing the program currently running are
+    available for reference from dynamically-linked units.
+    [allow_only] can be used to restrict access to a subset of these
+    units, e.g. to the units that compose the API for
+    dynamically-linked code, and prevent access to all other units,
+    e.g. private, internal modules of the running program. If
+    [allow_only] is called several times, access will be restricted to
+    the intersection of the given lists (i.e. a call to [allow_only]
+    can never increase the set of available units). *)
+
+val prohibit: string list -> unit
+(** [prohibit units] prohibits dynamically-linked units from referencing
+    the units named in list [units].  This can be used to prevent
+    access to selected units, e.g. private, internal modules of
+    the running program. *)
+
+val default_available_units: unit -> unit
+(** Reset the set of units that can be referenced from dynamically-linked
+    code to its default value, that is, all units composing the currently
+    running program. *)
+
+val allow_unsafe_modules : bool -> unit
+(** Govern whether unsafe object files are allowed to be
+    dynamically linked. A compilation unit is 'unsafe' if it contains
+    declarations of external functions, which can break type safety.
+    By default, dynamic linking of unsafe object files is
+    not allowed. In native code, this function does nothing; object files
+    with external functions are always allowed to be dynamically linked. *)
+
+(** {6 Deprecated, low-level API for access control} *)
+
+(** @deprecated  The functions [add_interfaces], [add_available_units]
+    and [clear_available_units] should not be used in new programs,
+    since the default initialization of allowed units, along with the
+    [allow_only] and [prohibit] function, provides a better, safer
+    mechanism to control access to program units.  The three functions
+    below are provided for backward compatibility only and are not
+    available in native code. *)
+
+val add_interfaces : string list -> string list -> unit
+(** [add_interfaces units path] grants dynamically-linked object
+    files access to the compilation  units named in list [units].
+    The interfaces ([.cmi] files) for these units are searched in
+    [path] (a list of directory names). *)
+
+val add_available_units : (string * Digest.t) list -> unit
+(** Same as {!Dynlink.add_interfaces}, but instead of searching [.cmi] files
+    to find the unit interfaces, uses the interface digests given
+    for each unit. This way, the [.cmi] interface files need not be
+    available at run-time. The digests can be extracted from [.cmi]
+    files using the [extract_crc] program installed in the
+    OCaml standard library directory. *)
+
+val clear_available_units : unit -> unit
+(** Empty the list of compilation units accessible to dynamically-linked
+    programs. *)
+
+(** {6 Deprecated, initialization} *)
+
+val init : unit -> unit
+(** @deprecated Initialize the [Dynlink] library. This function is called
+    automatically when needed. *)
+
+(** {6 Error reporting} *)
+
+type linking_error =
+    Undefined_global of string
+  | Unavailable_primitive of string
+  | Uninitialized_global of string
+
+type error =
+    Not_a_bytecode_file of string
+  | Inconsistent_import of string
+  | Unavailable_unit of string
+  | Unsafe_file
+  | Linking_error of string * linking_error
+  | Corrupted_interface of string
+  | File_not_found of string
+  | Cannot_open_dll of string
+  | Inconsistent_implementation of string
+
+exception Error of error
+(** Errors in dynamic linking are reported by raising the [Error]
+    exception with a description of the error. *)
+
+val error_message : error -> string
+(** Convert an error description to a printable message. *)
+
+
+(**/**)
+
+(** {6 Internal functions} *)
+
+val digest_interface : string -> string list -> Digest.t
diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml
new file mode 100644
index 00000000..9b9dc66c
--- /dev/null
+++ b/otherlibs/dynlink/extract_crc.ml
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Print the digests of unit interfaces *)
+
+let load_path = ref []
+let first = ref true
+
+let print_crc unit =
+  try
+    let crc = Dynlink.digest_interface unit (!load_path @ ["."]) in
+    if !first then first := false else print_string ";\n";
+    print_string "  \""; print_string (String.capitalize_ascii unit);
+    print_string "\",\n    \"";
+    for i = 0 to String.length crc - 1 do
+      Printf.printf "\\%03d" (Char.code crc.[i])
+    done;
+    print_string "\""
+  with exn ->
+    prerr_string "Error while reading the interface for ";
+    prerr_endline unit;
+    begin match exn with
+      Sys_error msg -> prerr_endline msg
+    | 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
+
+let usage = "Usage: extract_crc [-I <dir>] <files>"
+
+let main () =
+  print_string "let crc_unit_list = [\n";
+  Arg.parse
+    ["-I", Arg.String(fun dir -> load_path := !load_path @ [dir]),
+           "<dir>  Add <dir> to the list of include directories"]
+    print_crc usage;
+  print_string "\n]\n"
+
+let _ = main(); exit 0
diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
new file mode 100644
index 00000000..de237728
--- /dev/null
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -0,0 +1,256 @@
+#2 "otherlibs/dynlink/natdynlink.ml"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Dynamic loading of .cmx files *)
+
+open Cmx_format
+
+type handle
+
+type global_map = {
+  name : string;
+  crc_intf : Digest.t;
+  crc_impl : Digest.t;
+  syms : string list
+}
+
+external ndl_open: string -> bool -> handle * dynheader = "caml_natdynlink_open"
+external ndl_run: handle -> string -> unit = "caml_natdynlink_run"
+external ndl_getmap: unit -> global_map list = "caml_natdynlink_getmap"
+external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
+
+type linking_error =
+    Undefined_global of string
+  | Unavailable_primitive of string
+  | Uninitialized_global of string
+
+type error =
+    Not_a_bytecode_file of string
+  | Inconsistent_import of string
+  | Unavailable_unit of string
+  | Unsafe_file
+  | Linking_error of string * linking_error
+  | Corrupted_interface of string
+  | File_not_found of string
+  | Cannot_open_dll of string
+  | Inconsistent_implementation of string
+
+exception Error of error
+
+(* Copied from config.ml to avoid dependencies *)
+let cmxs_magic_number = "Caml2007D002"
+
+let dll_filename fname =
+  if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
+  else fname
+
+let read_file filename priv =
+  let dll = dll_filename filename in
+  if not (Sys.file_exists dll) then raise (Error (File_not_found dll));
+
+  let (handle,header) = try
+      ndl_open dll (not priv)
+    with Failure s -> raise (Error (Cannot_open_dll s)) in
+
+  if header.dynu_magic <> cmxs_magic_number
+  then raise(Error(Not_a_bytecode_file dll));
+  (dll, handle, header.dynu_units)
+
+
+
+(* Management of interface and implementation CRCs *)
+
+module StrMap = Map.Make(String)
+
+type implem_state =
+  | Loaded
+  | Check_inited of int
+
+type state = {
+  ifaces: (string*string) StrMap.t;
+  implems: (string*string*implem_state) StrMap.t;
+}
+
+let empty_state = {
+  ifaces = StrMap.empty;
+  implems = StrMap.empty;
+}
+
+let global_state = ref empty_state
+
+let allow_extension = ref true
+
+let inited = ref false
+
+let default_available_units () =
+  let map  = ndl_getmap () in
+  let exe = Sys.executable_name in
+  let rank = ref 0 in
+  global_state :=
+    List.fold_left
+      (fun st {name;crc_intf;crc_impl;syms} ->
+        rank := !rank + List.length syms;
+        {
+         ifaces = StrMap.add name (crc_intf,exe) st.ifaces;
+         implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems;
+        }
+      )
+      empty_state
+      map;
+  allow_extension := true;
+  inited := true
+
+let init () =
+  if not !inited then default_available_units ()
+
+let add_check_ifaces allow_ext filename ui ifaces =
+  List.fold_left
+    (fun ifaces (name, crco) ->
+       match crco with
+         None -> ifaces
+       | Some crc ->
+           if name = ui.dynu_name
+           then StrMap.add name (crc,filename) ifaces
+           else
+             try
+               let (old_crc, _old_src) = StrMap.find name ifaces in
+                 if old_crc <> crc
+                 then raise(Error(Inconsistent_import name))
+                 else ifaces
+             with Not_found ->
+               if allow_ext then StrMap.add name (crc,filename) ifaces
+               else raise (Error(Unavailable_unit name))
+    ) ifaces ui.dynu_imports_cmi
+
+let check_implems ui implems =
+  List.iter
+    (fun (name, crco) ->
+       match name with
+         |"Out_of_memory"
+         |"Sys_error"
+         |"Failure"
+         |"Invalid_argument"
+         |"End_of_file"
+         |"Division_by_zero"
+         |"Not_found"
+         |"Match_failure"
+         |"Stack_overflow"
+         |"Sys_blocked_io"
+         |"Assert_failure"
+         |"Undefined_recursive_module" -> ()
+         | _ ->
+       try
+         let (old_crc, _old_src, state) = StrMap.find name implems in
+           match crco with
+             Some crc when old_crc <> crc ->
+               raise(Error(Inconsistent_implementation name))
+           | _ ->
+               match state with
+               | Check_inited i ->
+                   if ndl_globals_inited() < i
+                   then raise(Error(Unavailable_unit name))
+               | Loaded -> ()
+       with Not_found ->
+         raise (Error(Unavailable_unit name))
+    ) ui.dynu_imports_cmx
+
+let loadunits filename handle units state =
+  let new_ifaces =
+    List.fold_left
+      (fun accu ui -> add_check_ifaces !allow_extension filename ui accu)
+      state.ifaces units in
+  let new_implems =
+    List.fold_left
+      (fun accu ui ->
+         check_implems ui accu;
+         StrMap.add ui.dynu_name (ui.dynu_crc,filename,Loaded) accu)
+      state.implems units in
+
+  let defines = List.flatten (List.map (fun ui -> ui.dynu_defines) units) in
+
+  ndl_run handle "_shared_startup";
+  List.iter (ndl_run handle) defines;
+  { implems = new_implems; ifaces = new_ifaces }
+
+let load priv filename =
+  init();
+  let (filename,handle,units) = read_file filename priv in
+  let nstate = loadunits filename handle units !global_state in
+  if not priv then global_state := nstate
+
+let loadfile filename = load false filename
+let loadfile_private filename = load true filename
+
+let allow_only names =
+  init();
+  let old = !global_state.ifaces in
+  let ifaces =
+    List.fold_left
+      (fun ifaces name ->
+         try StrMap.add name (StrMap.find name old) ifaces
+         with Not_found -> ifaces)
+      StrMap.empty names in
+  global_state := { !global_state with ifaces = ifaces };
+  allow_extension := false
+
+let prohibit names =
+  init();
+  let ifaces = List.fold_right StrMap.remove names !global_state.ifaces in
+  global_state := { !global_state with ifaces = ifaces };
+  allow_extension := false
+
+let digest_interface _ _ =
+  failwith "Dynlink.digest_interface: not implemented in native code"
+let add_interfaces _ _ =
+  failwith "Dynlink.add_interfaces: not implemented in native code"
+let add_available_units _ =
+  failwith "Dynlink.add_available_units: not implemented in native code"
+let clear_available_units _ =
+  failwith "Dynlink.clear_available_units: not implemented in native code"
+let allow_unsafe_modules _ =
+  ()
+
+(* Error report *)
+
+let error_message = function
+    Not_a_bytecode_file name ->
+      name ^ " is not an object file"
+  | Inconsistent_import name ->
+      "interface mismatch on " ^ name
+  | Unavailable_unit name ->
+      "no implementation available for " ^ name
+  | Unsafe_file ->
+      "this object file uses unsafe features"
+  | Linking_error (name, Undefined_global s) ->
+      "error while linking " ^ name ^ ".\n" ^
+      "Reference to undefined global `" ^ s ^ "'"
+  | Linking_error (name, Unavailable_primitive s) ->
+      "error while linking " ^ name ^ ".\n" ^
+      "The external function `" ^ s ^ "' is not available"
+  | Linking_error (name, Uninitialized_global s) ->
+      "error while linking " ^ name ^ ".\n" ^
+      "The module `" ^ s ^ "' is not yet initialized"
+  | Corrupted_interface name ->
+      "corrupted interface file " ^ name
+  | File_not_found name ->
+      "cannot find file " ^ name ^ " in search path"
+  | Cannot_open_dll reason ->
+      "error loading shared library: " ^ reason
+  | Inconsistent_implementation name ->
+      "implementation mismatch on " ^ name
+
+let is_native = true
+let adapt_filename f = Filename.chop_extension f ^ ".cmxs"
diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
new file mode 100644
index 00000000..ada82fd6
--- /dev/null
+++ b/otherlibs/graph/.depend
@@ -0,0 +1,100 @@
+color.o: color.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+ 
+draw.o: draw.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h
+dump_img.o: dump_img.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h
+events.o: events.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/signals.h
+fill.o: fill.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h
+image.o: image.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/custom.h
+make_img.o: make_img.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
+  ../../byterun/caml/memory.h
+open.o: open.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/memory.h
+point_col.o: point_col.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h
+sound.o: sound.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h
+subwindow.o: subwindow.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h
+text.o: text.c libgraph.h \
+  \
+  \
+  \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h
+graphics.cmo : graphics.cmi
+graphics.cmx : graphics.cmi
+graphics.cmi :
+graphicsX11.cmo : graphics.cmi graphicsX11.cmi
+graphicsX11.cmx : graphics.cmx graphicsX11.cmi
+graphicsX11.cmi :
diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
new file mode 100644
index 00000000..68875543
--- /dev/null
+++ b/otherlibs/graph/Makefile
@@ -0,0 +1,34 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the portable graphics library
+
+LIBNAME=graphics
+COBJS=open.o draw.o fill.o color.o text.o \
+  image.o make_img.o dump_img.o point_col.o sound.o events.o \
+  subwindow.o
+CAMLOBJS=graphics.cmo graphicsX11.cmo
+LINKOPTS=-cclib "\"$(X11_LINK)\""
+LDOPTS=-ldopt "$(X11_LINK)"
+
+EXTRACFLAGS=$(X11_INCLUDES)
+
+include ../Makefile
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c
new file mode 100644
index 00000000..5d7bafc7
--- /dev/null
+++ b/otherlibs/graph/color.c
@@ -0,0 +1,233 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include <X11/Xatom.h>
+
+/* Cache to speed up the translation rgb -> pixel value. */
+
+struct color_cache_entry {
+  int rgb;                      /* RGB value with format 0xRRGGBB */
+  unsigned long pixel;          /* Pixel value */
+};
+
+#define Color_cache_size 512
+static struct color_cache_entry color_cache[Color_cache_size];
+#define Empty (-1)
+#define Hash_rgb(r,g,b) \
+  ((((r) & 0xE0) << 1) + (((g) & 0xE0) >> 2) + (((b) & 0xE0) >> 5))
+#define Color_cache_slack 16
+
+static int num_overflows = 0;
+
+/* rgb -> pixel conversion *without* display connection */
+
+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 caml_gr_red_vals[256];
+unsigned long caml_gr_green_vals[256];
+unsigned long caml_gr_blue_vals[256];
+
+void caml_gr_get_shifts( unsigned long mask, int *lsl, int *lsr )
+{
+  int l = 0;
+  int r = 0;
+  int bit = 1;
+  if ( mask == 0 ){ *lsl = -1; *lsr = -1; return; }
+
+  for( l = 0; l < 32; l++ ){
+    if( bit & mask ){ break; }
+    bit = bit << 1;
+  }
+  for( r = l; r < 32; r++ ){
+    if( ! (bit & mask) ){ break; }
+    bit = bit << 1;
+  }
+  /* fix r */
+  if ( r == 32 ) { r = 31; }
+  *lsl = l;
+  *lsr = 16 - (r - l);
+}
+
+void caml_gr_init_direct_rgb_to_pixel(void)
+{
+  Visual *visual;
+  int i;
+
+  visual = DefaultVisual(caml_gr_display,caml_gr_screen);
+
+  if ( visual->class == TrueColor || visual->class == DirectColor ){
+
+    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",
+            caml_gr_red_mask,
+            caml_gr_green_mask,
+            caml_gr_blue_mask);
+#endif
+
+    caml_gr_get_shifts(caml_gr_red_mask, &caml_gr_red_l, &caml_gr_red_r);
+#ifdef QUICKCOLORDEBUG
+    fprintf(stderr, "red %d %d\n", caml_gr_red_l, caml_gr_red_r);
+#endif
+    for(i=0; i<256; i++){
+      caml_gr_red_vals[i] = (((i << 8) + i) >> caml_gr_red_r) << caml_gr_red_l;
+    }
+
+    caml_gr_get_shifts(caml_gr_green_mask, &caml_gr_green_l, &caml_gr_green_r);
+#ifdef QUICKCOLORDEBUG
+    fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r);
+#endif
+    for(i=0; i<256; i++){
+      caml_gr_green_vals[i] =
+        (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l;
+    }
+
+    caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r);
+#ifdef QUICKCOLORDEBUG
+    fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r);
+#endif
+    for(i=0; i<256; i++){
+      caml_gr_blue_vals[i] =
+        (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l;
+    }
+
+    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
+      caml_gr_direct_rgb = False;
+    } else {
+#ifdef QUICKCOLORDEBUG
+      fprintf(stderr, "Boost ok\n");
+#endif
+      caml_gr_direct_rgb = True;
+    }
+  } else {
+    /* we cannot use direct_rgb_to_pixel */
+#ifdef QUICKCOLORDEBUG
+    fprintf(stderr, "No boost!\n");
+#endif
+    caml_gr_direct_rgb = False;
+  }
+}
+
+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 = caml_gr_black;
+  i = Hash_rgb(0xFF, 0xFF, 0xFF);
+  color_cache[i].rgb = 0xFFFFFF;
+  color_cache[i].pixel = caml_gr_white;
+}
+
+unsigned long caml_gr_pixel_rgb(int rgb)
+{
+  unsigned int r, g, b;
+  int h, i;
+  XColor color;
+
+  r = (rgb >> 16) & 0xFF;
+  g = (rgb >> 8) & 0xFF;
+  b = rgb & 0xFF;
+
+  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);
+  i = h;
+  while(1) {
+    if (color_cache[i].rgb == Empty) break;
+    if (color_cache[i].rgb == rgb) return color_cache[i].pixel;
+    i = (i + 1) & (Color_cache_size - 1);
+    if (i == h) {
+        /* Cache is full.  Instead of inserting at slot h, which causes
+           thrashing if many colors hash to the same value,
+           insert at h + n where n is pseudo-random and
+           smaller than Color_cache_slack */
+        int slack = num_overflows++ & (Color_cache_slack - 1);
+        i = (i + slack) & (Color_cache_size - 1);
+        break;
+    }
+  }
+  color.red = r * 0x101;
+  color.green = g * 0x101;
+  color.blue = b * 0x101;
+  XAllocColor(caml_gr_display, caml_gr_colormap, &color);
+  color_cache[i].rgb = rgb;
+  color_cache[i].pixel = color.pixel;
+  return color.pixel;
+}
+
+int caml_gr_rgb_pixel(long unsigned int pixel)
+{
+  register int r,g,b;
+
+  XColor color;
+  int i;
+
+  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 == 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++) {
+    if (color_cache[i].rgb != Empty && color_cache[i].pixel == pixel)
+      return color_cache[i].rgb;
+  }
+  color.pixel = pixel;
+  XQueryColor(caml_gr_display, caml_gr_colormap, &color);
+  return
+    ((color.red >> 8) << 16) + ((color.green >> 8) << 8) + (color.blue >> 8);
+}
+
+value caml_gr_set_color(value vrgb)
+{
+  int 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(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
new file mode 100644
index 00000000..6e0f9373
--- /dev/null
+++ b/otherlibs/graph/draw.c
@@ -0,0 +1,127 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include <caml/alloc.h>
+
+value caml_gr_plot(value vx, value vy)
+{
+  int x = Int_val(vx);
+  int y = Int_val(vy);
+  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 caml_gr_moveto(value vx, value vy)
+{
+  caml_gr_x = Int_val(vx);
+  caml_gr_y = Int_val(vy);
+  return Val_unit;
+}
+
+value caml_gr_current_x(void)
+{
+  return Val_int(caml_gr_x);
+}
+
+value caml_gr_current_y(void)
+{
+  return Val_int(caml_gr_y);
+}
+
+value caml_gr_lineto(value vx, value vy)
+{
+  int x = Int_val(vx);
+  int y = Int_val(vy);
+  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);
+  }
+  caml_gr_x = x;
+  caml_gr_y = y;
+  return Val_unit;
+}
+
+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);
+
+  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 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);
+  int rx = Int_val(vrx);
+  int ry = Int_val(vry);
+  int a1 = Int_val(va1);
+  int a2 = Int_val(va2);
+
+  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(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(caml_gr_display);
+  }
+  return Val_unit;
+}
+
+value caml_gr_draw_arc(value *argv, int argc)
+{
+  return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4],
+                              argv[5]);
+}
+
+value caml_gr_set_line_width(value vwidth)
+{
+  int width = Int_val(vwidth);
+
+  caml_gr_check_open();
+  XSetLineAttributes(caml_gr_display, caml_gr_window.gc,
+                     width, LineSolid, CapRound, JoinRound);
+  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
new file mode 100644
index 00000000..6d9be709
--- /dev/null
+++ b/otherlibs/graph/dump_img.c
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include "image.h"
+#include <caml/alloc.h>
+#include <caml/memory.h>
+
+value caml_gr_dump_image(value image)
+{
+  int width, height, i, j;
+  XImage * idata, * imask;
+  value m = Val_unit;
+
+  Begin_roots2(image, m);
+    caml_gr_check_open();
+    width = Width_im(image);
+    height = Height_im(image);
+    m = caml_alloc(height, 0);
+    for (i = 0; i < height; i++) {
+      value v = caml_alloc(width, 0);
+      caml_modify(&Field(m, i), v);
+    }
+
+    idata =
+      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(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
+    XDestroyImage(idata);
+
+    if (Mask_im(image) != None) {
+      imask =
+        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)
+            Field(Field(m, i), j) = Val_int(Transparent);
+      XDestroyImage(imask);
+    }
+  End_roots();
+  return m;
+}
diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
new file mode 100644
index 00000000..37146c9d
--- /dev/null
+++ b/otherlibs/graph/events.c
@@ -0,0 +1,279 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <signal.h>
+#include "libgraph.h"
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#ifdef HAS_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+#include <string.h>
+#include <unistd.h>
+
+struct event_data {
+  short kind;
+  short mouse_x, mouse_y;
+  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 */
+
+#define QueueIsEmpty (caml_gr_tail == caml_gr_head)
+
+static void caml_gr_enqueue_event(int kind, int mouse_x, int mouse_y,
+                             int button, int key)
+{
+  struct event_data * ev;
+
+  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;
+  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;
+}
+
+#define BUTTON_STATE(state) \
+  ((state) & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask))
+
+void caml_gr_handle_event(XEvent * event)
+{
+  switch (event->type) {
+
+  case Expose:
+    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(caml_gr_display);
+    break;
+
+  case ConfigureNotify:
+    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(caml_gr_window.w, caml_gr_bstore.w);
+      newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h);
+      newbstore.win =
+        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(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(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(caml_gr_display, caml_gr_bstore.gc);
+      XFreePixmap(caml_gr_display, caml_gr_bstore.win);
+
+      /* Use the new backing store */
+      caml_gr_bstore = newbstore;
+      XFlush(caml_gr_display);
+    }
+    break;
+
+  case MappingNotify:
+    XRefreshKeyboardMapping(&(event->xmapping));
+    break;
+
+  case KeyPress:
+    { KeySym thekey;
+      char keytxt[256];
+      int nchars;
+      char * p;
+      nchars = XLookupString(&(event->xkey), keytxt, sizeof(keytxt),
+                             &thekey, 0);
+      for (p = keytxt; nchars > 0; p++, nchars--)
+        caml_gr_enqueue_event(event->type, event->xkey.x, event->xkey.y,
+                         BUTTON_STATE(event->xkey.state), *p);
+      break;
+    }
+
+  case ButtonPress:
+  case ButtonRelease:
+    caml_gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y,
+                     event->type == ButtonPress, 0);
+    break;
+
+  case MotionNotify:
+    caml_gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y,
+                     BUTTON_STATE(event->xmotion.state), 0);
+    break;
+  }
+}
+
+static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button,
+                                     int keypressed, int key)
+{
+  value res = caml_alloc_small(5, 0);
+  Field(res, 0) = Val_int(mouse_x);
+  Field(res, 1) = Val_int(mouse_y == -1 ? -1 : Wcvt(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 mouse_x, mouse_y, button, key, keypressed;
+  Window rootwin, childwin;
+  int root_x, root_y, win_x, win_y;
+  unsigned int modifiers;
+  unsigned int i;
+
+  caml_process_pending_signals ();
+  if (XQueryPointer(caml_gr_display, caml_gr_window.win,
+                    &rootwin, &childwin,
+                    &root_x, &root_y, &win_x, &win_y,
+                    &modifiers)) {
+    mouse_x = win_x;
+    mouse_y = win_y;
+  } else {
+    mouse_x = -1;
+    mouse_y = -1;
+  }
+  button = modifiers & (Button1Mask | Button2Mask | Button3Mask
+                          | Button4Mask | Button5Mask);
+  /* Look inside event queue for pending KeyPress events */
+  key = 0;
+  keypressed = False;
+  for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) {
+    if (caml_gr_queue[i].kind == KeyPress) {
+      keypressed = True;
+      key = caml_gr_queue[i].key;
+      break;
+    }
+  }
+  return
+    caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
+}
+
+static value caml_gr_wait_event_in_queue(long mask)
+{
+  struct event_data * ev;
+  /* Pop events in queue until one matches mask. */
+  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 caml_gr_wait_allocate_result(ev->mouse_x, ev->mouse_y,
+                                     ev->button, ev->kind == KeyPress,
+                                     ev->key);
+  }
+  return Val_false;
+}
+
+static value caml_gr_wait_event_blocking(long mask)
+{
+  XEvent event;
+  fd_set readfds;
+  value res;
+
+  /* First see if we have a matching event in the queue */
+  res = caml_gr_wait_event_in_queue(mask);
+  if (res != Val_false) return res;
+
+  /* Increase the selected events if required */
+  if ((mask & ~caml_gr_selected_events) != 0) {
+    caml_gr_selected_events |= mask;
+    XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events);
+  }
+
+  /* Replenish our event queue from that of X11 */
+  caml_gr_ignore_sigio = True;
+  while (1) {
+    if (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &event)) {
+      /* One event available: add it to our queue */
+      caml_gr_handle_event(&event);
+      /* See if we now have a matching event */
+      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(caml_gr_display), &readfds);
+      caml_enter_blocking_section();
+      select(FD_SETSIZE, &readfds, NULL, NULL, NULL);
+      caml_leave_blocking_section();
+      caml_gr_check_open(); /* in case another thread closed the display */
+    }
+  }
+  caml_gr_ignore_sigio = False;
+
+  /* Return result */
+  return res;
+}
+
+value caml_gr_wait_event(value eventlist) /* ML */
+{
+  int mask;
+  Bool poll;
+
+  caml_gr_check_open();
+  mask = 0;
+  poll = False;
+  while (eventlist != Val_int(0)) {
+    switch (Int_val(Field(eventlist, 0))) {
+    case 0:                     /* Button_down */
+      mask |= ButtonPressMask | OwnerGrabButtonMask; break;
+    case 1:                     /* Button_up */
+      mask |= ButtonReleaseMask | OwnerGrabButtonMask; break;
+    case 2:                     /* Key_pressed */
+      mask |= KeyPressMask; break;
+    case 3:                     /* Mouse_motion */
+      mask |= PointerMotionMask; break;
+    case 4:                     /* Poll */
+      poll = True; 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/graph/fill.c b/otherlibs/graph/fill.c
new file mode 100644
index 00000000..0eb307f9
--- /dev/null
+++ b/otherlibs/graph/fill.c
@@ -0,0 +1,90 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include <caml/memory.h>
+
+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);
+
+  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 caml_gr_fill_poly(value array)
+{
+  XPoint * points;
+  int npoints, i;
+
+  caml_gr_check_open();
+  npoints = Wosize_val(array);
+  points = (XPoint *) caml_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(caml_gr_remember_modeflag)
+    XFillPolygon(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, points,
+                 npoints, Complex, CoordModeOrigin);
+  if(caml_gr_display_modeflag) {
+    for (i = 0; i < npoints; i++)
+      points[i].y = BtoW(points[i].y);
+    XFillPolygon(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, points,
+         npoints, Complex, CoordModeOrigin);
+    XFlush(caml_gr_display);
+  }
+  caml_stat_free((char *) points);
+  return Val_unit;
+}
+
+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);
+  int rx = Int_val(vrx);
+  int ry = Int_val(vry);
+  int a1 = Int_val(va1);
+  int a2 = Int_val(va2);
+
+  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(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(caml_gr_display);
+  }
+  return Val_unit;
+}
+
+value caml_gr_fill_arc(value *argv, int argc)
+{
+  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
new file mode 100644
index 00000000..36328986
--- /dev/null
+++ b/otherlibs/graph/graphics.ml
@@ -0,0 +1,266 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Graphic_failure of string
+
+(* Initializations *)
+
+let _ =
+  Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "")
+
+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);
+  raw_open_graph arg
+
+let unix_close_graph () =
+  Sys.set_signal (sigio_signal()) Sys.Signal_ignore;
+  raw_close_graph ()
+
+let (open_graph, close_graph) =
+  match Sys.os_type with
+  | "Unix" | "Cygwin" -> (unix_open_graph, unix_close_graph)
+  | "Win32" -> (raw_open_graph, raw_close_graph)
+  | "MacOS" -> (raw_open_graph, raw_close_graph)
+  | _ -> invalid_arg ("Graphics: unknown OS type: " ^ Sys.os_type)
+
+external set_window_title : string -> unit = "caml_gr_set_window_title"
+external resize_window : int -> int -> unit = "caml_gr_resize_window"
+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 = "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 ()
+  | false -> display_mode false; remember_mode true
+;;
+
+
+(* Colors *)
+
+type color = int
+
+let rgb r g b = (r lsl 16) + (g lsl 8) + b
+
+external set_color : color -> unit = "caml_gr_set_color"
+
+let black   = 0x000000
+and white   = 0xFFFFFF
+and red     = 0xFF0000
+and green   = 0x00FF00
+and blue    = 0x0000FF
+and yellow  = 0xFFFF00
+and cyan    = 0x00FFFF
+and magenta = 0xFF00FF
+
+let background = white
+and foreground = black
+
+(* Drawing *)
+
+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 = "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 = "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 raw_draw_rect : int -> int -> int -> int -> unit = "caml_gr_draw_rect"
+let draw_rect x y w h =
+  if w < 0 || h < 0 then raise (Invalid_argument "draw_rect")
+  else raw_draw_rect x y w h
+;;
+
+let draw_poly, draw_poly_line =
+  let dodraw close_flag points =
+    if Array.length points > 0 then begin
+      let (savex, savey) = current_point () in
+      moveto (fst points.(0)) (snd points.(0));
+      for i = 1 to Array.length points - 1 do
+        let (x, y) = points.(i) in
+        lineto x y;
+      done;
+      if close_flag then lineto (fst points.(0)) (snd points.(0));
+      moveto savex savey;
+    end;
+  in dodraw true, dodraw false
+;;
+let draw_segments segs =
+  let (savex, savey) = current_point () in
+  for i = 0 to Array.length segs - 1 do
+    let (x1, y1, x2, y2) = segs.(i) in
+    moveto x1 y1;
+    lineto x2 y2;
+  done;
+  moveto savex savey;
+;;
+
+external raw_draw_arc : int -> int -> int -> int -> int -> int -> unit
+               = "caml_gr_draw_arc" "caml_gr_draw_arc_nat"
+let draw_arc x y rx ry a1 a2 =
+  if rx < 0 || ry < 0 then raise (Invalid_argument "draw_arc/ellipse/circle")
+  else raw_draw_arc x y rx ry a1 a2
+;;
+
+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 raw_set_line_width : int -> unit = "caml_gr_set_line_width"
+let set_line_width w =
+  if w < 0 then raise (Invalid_argument "set_line_width")
+  else raw_set_line_width w
+;;
+
+external raw_fill_rect : int -> int -> int -> int -> unit = "caml_gr_fill_rect"
+let fill_rect x y w h =
+  if w < 0 || h < 0 then raise (Invalid_argument "fill_rect")
+  else raw_fill_rect x y w h
+;;
+
+external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly"
+external raw_fill_arc : int -> int -> int -> int -> int -> int -> unit
+               = "caml_gr_fill_arc" "caml_gr_fill_arc_nat"
+let fill_arc x y rx ry a1 a2 =
+  if rx < 0 || ry < 0 then raise (Invalid_argument "fill_arc/ellipse/circle")
+  else raw_fill_arc x y rx ry a1 a2
+;;
+
+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 = "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 *)
+
+type image
+
+let transp = -1
+
+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
+  blit_image image x y;
+  image
+
+(* Events *)
+
+type status =
+  { mouse_x : int;
+    mouse_y : int;
+    button : bool;
+    keypressed : bool;
+    key : char }
+
+type event =
+    Button_down
+  | Button_up
+  | Key_pressed
+  | Mouse_motion
+  | Poll
+
+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)
+
+let button_down () =
+  let e = wait_next_event [Poll] in e.button
+
+let read_key () =
+  let e = wait_next_event [Key_pressed] in e.key
+
+let key_pressed () =
+  let e = wait_next_event [Poll] in e.keypressed
+
+let loop_at_exit events handler =
+  let events = List.filter (fun e -> e <> Poll) events in
+  at_exit (fun _ ->
+    try
+      while true do
+        let e = wait_next_event events in
+        handler e
+      done
+    with Exit -> close_graph ()
+       | e -> close_graph (); raise e
+  )
+
+(*** Sound *)
+
+external sound : int -> int -> unit = "caml_gr_sound"
+
+(* Splines *)
+let sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2)
+and middle (x1, y1) (x2, y2) = ((x1 +. x2) /. 2.0,  (y1 +. y2) /. 2.0)
+and area (x1, y1) (x2, y2) = abs_float (x1 *. y2 -. x2 *. y1)
+and norm (x1, y1) = sqrt (x1 *. x1 +. y1 *. y1);;
+
+let test a b c d =
+ let v = sub d a in
+ let s = norm v in
+ area v (sub a b) <= s && area v (sub a c) <= s;;
+
+let spline a b c d =
+  let rec spl accu a b c d =
+   if test a b c d then d :: accu else
+   let a' = middle a b
+   and o = middle b c in
+   let b' = middle a' o
+   and d' = middle c d in
+   let c' = middle o d' in
+   let i = middle b' c' in
+   spl  (spl accu a a' b' i) i c' d' d in
+  spl [a] a b c d;;
+
+let curveto b c (x, y as d) =
+ let float_point (x, y) = (float_of_int x, float_of_int y) in
+ let round f = int_of_float (f +. 0.5) in
+ let int_point (x, y) = (round x, round y) in
+ let points =
+   spline
+    (float_point (current_point ()))
+    (float_point b) (float_point c) (float_point d) in
+ draw_poly_line
+  (Array.of_list (List.map int_point points));
+ moveto x y;;
diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli
new file mode 100644
index 00000000..e364f6e0
--- /dev/null
+++ b/otherlibs/graph/graphics.mli
@@ -0,0 +1,388 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Machine-independent graphics primitives. *)
+
+exception Graphic_failure of string
+(** Raised by the functions below when they encounter an error. *)
+
+
+(** {6 Initializations} *)
+
+val open_graph : string -> unit
+(** Show the graphics window or switch the screen to graphic mode.
+   The graphics window is cleared and the current point is set
+   to (0, 0). The string argument is used to pass optional
+   information on the desired graphics mode, the graphics window
+   size, and so on. Its interpretation is implementation-dependent.
+   If the empty string is given, a sensible default is selected. *)
+
+val close_graph : unit -> unit
+(** Delete the graphics window or switch the screen back to text mode. *)
+
+val set_window_title : string -> unit
+(** Set the title of the graphics window. *)
+
+val resize_window : int -> int -> unit
+(** Resize and erase the graphics window. *)
+
+external clear_graph : unit -> unit = "caml_gr_clear_graph"
+(** Erase the graphics window. *)
+
+external size_x : unit -> int = "caml_gr_size_x"
+(** See {!Graphics.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
+   an error. The origin (0,0) is at the lower left corner. 
+   Some implementation (e.g. X Windows) represent coordinates by
+   16-bit integers, hence wrong clipping may occur with coordinates
+   below [-32768] or above [32676]. *)
+
+(** {6 Colors} *)
+
+type color = int
+(** A color is specified by its R, G, B components. Each component
+   is in the range [0..255]. The three components are packed in
+   an [int]: [0xRRGGBB], where [RR] are the two hexadecimal digits for
+   the red component, [GG] for the green component, [BB] for the
+   blue component. *)
+
+val rgb : int -> int -> int -> color
+(** [rgb r g b] returns the integer encoding the color with red
+   component [r], green component [g], and blue component [b].
+   [r], [g] and [b] are in the range [0..255]. *)
+
+external set_color : color -> unit = "caml_gr_set_color"
+(** Set the current drawing color. *)
+
+val background : color
+(** See {!Graphics.foreground}.*)
+
+val foreground : color
+(** Default background and foreground colors (usually, either black
+   foreground on a white background or white foreground on a
+   black background).
+   {!Graphics.clear_graph} fills the screen with the [background] color.
+   The initial drawing color is [foreground]. *)
+
+
+(** {7 Some predefined colors} *)
+
+val black : color
+val white : color
+val red : color
+val green : color
+val blue : color
+val yellow : color
+val cyan : color
+val magenta : color
+
+
+(** {6 Point and line drawing} *)
+
+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 = "caml_gr_point_color"
+(** Return the color of the given point in the backing store
+   (see "Double buffering" below). *)
+
+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 = "caml_gr_current_x"
+(** Return the abscissa of the current point. *)
+
+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 = "caml_gr_lineto"
+(** Draw a line with endpoints the current point and the given point,
+   and move the current point to the given point. *)
+
+val rlineto : int -> int -> unit
+(** Draw a line with endpoints the current point and the
+   current point translated of the given vector,
+   and move the current point to this point. *)
+
+val curveto : int * int -> int * int -> int * int -> unit
+(** [curveto b c d] draws a cubic Bezier curve starting from
+   the current point to point [d], with control points [b] and
+   [c], and moves the current point to [d]. *)
+
+val draw_rect : int -> int -> int -> int -> unit
+(** [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.
+   Raise [Invalid_argument] if [w] or [h] is negative. *)
+
+val draw_poly_line : (int * int) array -> unit
+(** [draw_poly_line points] draws the line that joins the
+   points given by the array argument.
+   The array contains the coordinates of the vertices of the
+   polygonal line, which need not be closed.
+   The current point is unchanged. *)
+
+val draw_poly : (int * int) array -> unit
+(** [draw_poly polygon] draws the given polygon.
+   The array contains the coordinates of the vertices of the
+   polygon.
+   The current point is unchanged. *)
+
+val draw_segments : (int * int * int * int) array -> unit
+(** [draw_segments segments] draws the segments given in the array
+   argument. Each segment is specified as a quadruple
+   [(x0, y0, x1, y1)] where [(x0, y0)] and [(x1, y1)] are
+   the coordinates of the end points of the segment.
+   The current point is unchanged. *)
+
+val draw_arc : int -> int -> int -> int -> int -> int -> unit
+(** [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.
+   Raise [Invalid_argument] if [rx] or [ry] is negative. *)
+
+val draw_ellipse : int -> int -> int -> int -> unit
+(** [draw_ellipse x y rx ry] draws an ellipse with center
+   [x,y], horizontal radius [rx] and vertical radius [ry].
+   The current point is unchanged.
+   Raise [Invalid_argument] if [rx] or [ry] is negative. *)
+
+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.
+   Raise [Invalid_argument] if [r] is negative. *)
+
+val set_line_width : int -> unit
+(** 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
+   used when [set_line_width 1] is specified.
+   Raise [Invalid_argument] if the argument is negative. *)
+
+(** {6 Text drawing} *)
+
+external draw_char : char -> unit = "caml_gr_draw_char"
+(** See {!Graphics.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 = "caml_gr_set_font"
+(** Set the font used for drawing text.
+   The interpretation of the argument to [set_font]
+   is implementation-dependent. *)
+
+val set_text_size : int -> unit
+(** Set the character size used for drawing text.
+   The interpretation of the argument to [set_text_size]
+   is implementation-dependent. *)
+
+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} *)
+
+val fill_rect : int -> int -> int -> int -> unit
+(** [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.
+   Raise [Invalid_argument] if [w] or [h] is negative. *)
+
+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. *)
+
+val fill_arc : int -> int -> int -> int -> int -> int -> unit
+(** Fill an elliptical pie slice with the current color. The
+   parameters are the same as for {!Graphics.draw_arc}. *)
+
+val fill_ellipse : int -> int -> int -> int -> unit
+(** Fill an ellipse with the current color. The
+   parameters are the same as for {!Graphics.draw_ellipse}. *)
+
+val fill_circle : int -> int -> int -> unit
+(** Fill a circle with the current color. The
+   parameters are the same as for {!Graphics.draw_circle}. *)
+
+
+(** {6 Images} *)
+
+type image
+(** The abstract type for images, in internal representation.
+   Externally, images are represented as matrices of colors. *)
+
+val transp : color
+(** In matrices of colors, this color represent a 'transparent'
+   point: when drawing the corresponding image, all pixels on the
+   screen corresponding to a transparent pixel in the image will
+   not be modified, while other points will be set to the color
+   of the corresponding point in the image. This allows superimposing
+   an image over an existing background. *)
+
+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 = "caml_gr_dump_image"
+(** Convert an image to a color matrix. *)
+
+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 = "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 = "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
+   equal to those of the image. Pixels that were transparent in
+   [img] are left unchanged. *)
+
+
+(** {6 Mouse and keyboard events} *)
+
+type status =
+  { mouse_x : int;              (** X coordinate of the mouse *)
+    mouse_y : int;              (** Y coordinate of the mouse *)
+    button : bool;              (** true if a mouse button is pressed *)
+    keypressed : bool;          (** true if a key has been pressed *)
+    key : char;                 (** the character for the key pressed *)
+  }
+(** To report events. *)
+
+
+type event =
+    Button_down                 (** A mouse button is pressed *)
+  | Button_up                   (** A mouse button is released *)
+  | Key_pressed                 (** A key is pressed *)
+  | Mouse_motion                (** The mouse is moved *)
+  | Poll                        (** Don't wait; return immediately *)
+(** To specify events to wait for. *)
+
+
+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
+   with the current status. If the mouse cursor is outside of the
+   graphics window, the [mouse_x] and [mouse_y] fields of the event are
+   outside the range [0..size_x()-1, 0..size_y()-1]. Keypresses
+   are queued, and dequeued one by one when the [Key_pressed]
+   event is specified and the [Poll] event is not specified. *)
+
+val loop_at_exit : event list -> (status -> unit) -> unit
+(** Loop before exiting the program, the list given as argument is the
+    list of handlers and the events on which these handlers are called.
+    To exit cleanly the loop, the handler should raise Exit. Any other
+    exception will be propagated outside of the loop.
+    @since 4.01
+*)
+
+(** {6 Mouse and keyboard polling} *)
+
+val mouse_pos : unit -> int * int
+(** Return the position of the mouse cursor, relative to the
+   graphics window. If the mouse cursor is outside of the graphics
+   window, [mouse_pos()] returns a point outside of the range
+   [0..size_x()-1, 0..size_y()-1]. *)
+
+val button_down : unit -> bool
+(** Return [true] if the mouse button is pressed, [false] otherwise. *)
+
+val read_key : unit -> char
+(** Wait for a key to be pressed, and return the corresponding
+   character. Keypresses are queued. *)
+
+val key_pressed : unit -> bool
+(** Return [true] if a keypress is available; that is, if [read_key]
+   would not block. *)
+
+
+(** {6 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). *)
+
+(** {6 Double buffering} *)
+
+val auto_synchronize : bool -> unit
+(** By default, drawing takes place both on the window displayed
+   on screen, and in a memory area (the 'backing store').
+   The backing store image is used to re-paint the on-screen
+   window when necessary.
+
+   To avoid flicker during animations, it is possible to turn
+   off on-screen drawing, perform a number of drawing operations
+   in the backing store only, then refresh the on-screen window
+   explicitly.
+
+   [auto_synchronize false] turns on-screen drawing off.  All
+   subsequent drawing commands are performed on the backing store
+   only.
+
+   [auto_synchronize true] refreshes the on-screen window from
+   the backing store (as per [synchronize]), then turns on-screen
+   drawing back on.  All subsequent drawing commands are performed
+   both on screen and in the backing store.
+
+   The default drawing mode corresponds to [auto_synchronize true]. *)
+
+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 = "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
+   drawing into the backing store (see the function {!Graphics.remember_mode}
+   below). Default display mode is on. *)
+
+
+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
+   onto the graphics window (see the function {!Graphics.display_mode} above).
+   Default remember mode is on.  *)
diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml
new file mode 100644
index 00000000..10f39f32
--- /dev/null
+++ b/otherlibs/graph/graphicsX11.ml
@@ -0,0 +1,42 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     Pierre Weis and Jun Furuse, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [GraphicsX11]: additional graphics primitives for
+   the X Windows system *)
+
+type window_id = string
+
+external window_id : unit -> window_id = "caml_gr_window_id"
+
+let subwindows = Hashtbl.create 13
+
+external open_subwindow : int -> int -> int -> int -> window_id
+    = "caml_gr_open_subwindow"
+external close_subwindow : window_id -> unit
+    = "caml_gr_close_subwindow"
+
+let open_subwindow ~x ~y ~width ~height =
+  let wid = open_subwindow x y width height in
+  Hashtbl.add subwindows wid ();
+  wid
+;;
+
+let close_subwindow wid =
+  if Hashtbl.mem subwindows wid then begin
+    close_subwindow wid;
+    Hashtbl.remove subwindows wid
+  end else
+    raise (Graphics.Graphic_failure("close_subwindow: no such subwindow: "^wid))
+;;
diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli
new file mode 100644
index 00000000..e0229996
--- /dev/null
+++ b/otherlibs/graph/graphicsX11.mli
@@ -0,0 +1,30 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     Pierre Weis and Jun Furuse, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Additional graphics primitives for the X Windows system. *)
+
+type window_id = string
+
+val window_id : unit -> window_id
+(** Return the unique identifier of the OCaml graphics window.
+   The returned string is an unsigned 32 bits integer
+   in decimal form. *)
+
+val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id
+(** Create a sub-window of the current OCaml graphics window
+   and return its identifier. *)
+
+val close_subwindow : window_id -> unit
+(** Close the sub-window having the given identifier. *)
diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c
new file mode 100644
index 00000000..1d72e0da
--- /dev/null
+++ b/otherlibs/graph/image.c
@@ -0,0 +1,108 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include "image.h"
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+static void caml_gr_free_image(value 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",
+  caml_gr_free_image,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+#define Max_image_mem 2000000
+
+value caml_gr_new_image(int w, int h)
+{
+  value res = caml_alloc_custom(&image_ops, sizeof(struct grimage),
+                           w * h, Max_image_mem);
+  Width_im(res) = w;
+  Height_im(res) = h;
+  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 caml_gr_create_image(value vw, value vh)
+{
+  caml_gr_check_open();
+  return caml_gr_new_image(Int_val(vw), Int_val(vh));
+}
+
+value caml_gr_blit_image(value im, value vx, value vy)
+{
+  int x = Int_val(vx);
+  int y = Int_val(vy);
+  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 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);
+
+  caml_gr_check_open();
+  if (Mask_im(im) != None) {
+    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(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(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(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(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(caml_gr_display_modeflag)
+    XFlush(caml_gr_display);
+  return Val_unit;
+}
diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h
new file mode 100644
index 00000000..acb85110
--- /dev/null
+++ b/otherlibs/graph/image.h
@@ -0,0 +1,29 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+struct grimage {
+  int width, height;            /* Dimensions of the image */
+  Pixmap data;                  /* Pixels */
+  Pixmap mask;                  /* Mask for transparent points, or None */
+};
+
+#define Width_im(i) (((struct grimage *)Data_custom_val(i))->width)
+#define Height_im(i) (((struct grimage *)Data_custom_val(i))->height)
+#define Data_im(i) (((struct grimage *)Data_custom_val(i))->data)
+#define Mask_im(i) (((struct grimage *)Data_custom_val(i))->mask)
+
+#define Transparent (-1)
+
+value caml_gr_new_image(int w, int h);
diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
new file mode 100644
index 00000000..5eb397af
--- /dev/null
+++ b/otherlibs/graph/libgraph.h
@@ -0,0 +1,89 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#include <caml/mlvalues.h>
+#include <caml/misc.h>
+
+struct canvas {
+  int w, h;                     /* Dimensions of the drawable */
+  Drawable win;                 /* The drawable itself */
+  GC gc;                        /* The associated graphics context */
+};
+
+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 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 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) (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))
+
+#define DEFAULT_SCREEN_WIDTH 600
+#define DEFAULT_SCREEN_HEIGHT 450
+#define BORDER_WIDTH 2
+#define DEFAULT_WINDOW_NAME "OCaml graphics"
+#define DEFAULT_SELECTED_EVENTS \
+            (ExposureMask | KeyPressMask | StructureNotifyMask)
+#define DEFAULT_FONT "fixed"
+#define SIZE_QUEUE 256
+
+/* To handle events asynchronously */
+#ifdef HAS_ASYNC_IO
+#define USE_ASYNC_IO
+#define EVENT_SIGNAL SIGIO
+#else
+#ifdef HAS_SETITIMER
+#define USE_INTERVAL_TIMER
+#define EVENT_SIGNAL SIGALRM
+#else
+#define USE_ALARM
+#define EVENT_SIGNAL SIGALRM
+#endif
+#endif
+
+CAMLnoreturn_start
+extern void caml_gr_fail(char *fmt, char *arg)
+CAMLnoreturn_end;
+
+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
new file mode 100644
index 00000000..f1cd761d
--- /dev/null
+++ b/otherlibs/graph/make_img.c
@@ -0,0 +1,99 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include "image.h"
+#include <caml/memory.h>
+
+value caml_gr_make_image(value m)
+{
+  int width, height;
+  value im;
+  Bool has_transp;
+  XImage * idata, * imask;
+  char * bdata, * bmask;
+  int i, j, rgb;
+  value line;
+  GC gc;
+
+  caml_gr_check_open();
+  height = Wosize_val(m);
+  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)
+      caml_gr_fail("make_image: lines of different lengths", NULL);
+
+  /* Build an XImage for the data part of the image */
+  idata =
+    XCreateImage(caml_gr_display,
+                 DefaultVisual(caml_gr_display, caml_gr_screen),
+                 XDefaultDepth(caml_gr_display, caml_gr_screen),
+                 ZPixmap, 0, NULL, width, height,
+                 BitmapPad(caml_gr_display), 0);
+
+  bdata = (char *) caml_stat_alloc(height * idata->bytes_per_line);
+  idata->data = bdata;
+  has_transp = False;
+
+  for (i = 0; i < height; i++) {
+    line = Field(m, i);
+    for (j = 0; j < width; j++) {
+      rgb = Int_val(Field(line, j));
+      if (rgb == Transparent) { has_transp = True; rgb = 0; }
+      XPutPixel(idata, j, i, caml_gr_pixel_rgb(rgb));
+    }
+  }
+
+  /* If the matrix contains transparent points,
+     build an XImage for the mask part of the image */
+  if (has_transp) {
+    imask =
+      XCreateImage(caml_gr_display,
+                   DefaultVisual(caml_gr_display, caml_gr_screen),
+                   1, ZPixmap, 0, NULL, width, height,
+                   BitmapPad(caml_gr_display), 0);
+    bmask = (char *) caml_stat_alloc(height * imask->bytes_per_line);
+    imask->data = bmask;
+
+    for (i = 0; i < height; i++) {
+      line = Field(m, i);
+      for (j = 0; j < width; j++) {
+        rgb = Int_val(Field(line, j));
+        XPutPixel(imask, j, i, rgb != Transparent);
+      }
+    }
+  } else {
+    imask = NULL;
+  }
+
+  /* Allocate the image and store the XImages into the Pixmaps */
+  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(caml_gr_display, gc);
+  if (has_transp) {
+    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(caml_gr_display, gc);
+  }
+  XFlush(caml_gr_display);
+  return im;
+}
diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
new file mode 100644
index 00000000..8f6ee07f
--- /dev/null
+++ b/otherlibs/graph/open.c
@@ -0,0 +1,400 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <fcntl.h>
+#include <signal.h>
+#include "libgraph.h"
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_SETITIMER
+#include <sys/time.h>
+#endif
+
+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 caml_gr_error_handler(Display *display, XErrorEvent *error);
+static int caml_gr_ioerror_handler(Display *display);
+value caml_gr_clear_graph(void);
+
+value caml_gr_open_graph(value arg)
+{
+  char display_name[256], geometry_spec[64];
+  char * p, * q;
+  XSizeHints hints;
+  int ret;
+  XEvent event;
+  int x, y, w, h;
+  XWindowAttributes attributes;
+
+  if (caml_gr_initialized) {
+    caml_gr_clear_graph();
+  } else {
+
+    /* Parse the argument */
+    for (p = String_val(arg), q = display_name; *p != 0 && *p != ' '; p++)
+      if (q < display_name + sizeof(display_name) - 1) *q++ = *p;
+    *q = 0;
+    while (*p == ' ') p++;
+    for (q = geometry_spec; *p != 0; p++)
+      if (q < geometry_spec + sizeof(geometry_spec) - 1) *q++ = *p;
+    *q = 0;
+
+    /* Open the display */
+    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(caml_gr_error_handler);
+    XSetIOErrorHandler(caml_gr_ioerror_handler);
+
+    /* Parse the geometry specification */
+    hints.x = 0;
+    hints.y = 0;
+    hints.width = DEFAULT_SCREEN_WIDTH;
+    hints.height = DEFAULT_SCREEN_HEIGHT;
+    hints.flags = PPosition | PSize;
+    hints.win_gravity = 0;
+
+    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;
+    }
+    if (ret & (WidthValue | HeightValue)) {
+      hints.width = w; hints.height = h; hints.flags |= USSize;
+    }
+
+    /* Initial drawing color is black */
+    caml_gr_color = 0; /* CAML COLOR */
+
+    /* Create the on-screen window */
+    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, caml_gr_black, caml_gr_background);
+    p = window_name;
+    if (p == NULL) p = DEFAULT_WINDOW_NAME;
+    /* What not use XSetWMProperties? */
+    XSetStandardProperties(caml_gr_display, caml_gr_window.win, p, p,
+                           None, NULL, 0, &hints);
+    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 */
+    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(caml_gr_display, caml_gr_window.win);
+    do { XNextEvent(caml_gr_display, &event); } while (event.type != Expose);
+
+    /* Get the actual window dimensions */
+    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 */
+    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(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 */
+    caml_gr_display_modeflag = True ;
+    caml_gr_remember_modeflag = True ;
+
+    /* The global data structures are now correctly initialized.
+       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. */
+#ifdef POSIX_SIGNALS
+#ifdef SA_RESTART
+    { struct sigaction action;
+      sigaction(EVENT_SIGNAL, NULL, &action);
+      action.sa_flags |= SA_RESTART;
+      sigaction(EVENT_SIGNAL, &action, NULL);
+    }
+#endif
+#endif
+
+#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(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
+  /* If BSD-style interval timers are provided, use the real-time timer
+     to poll events. */
+  { struct itimerval it;
+    it.it_interval.tv_sec = 0;
+    it.it_interval.tv_usec = 250000;
+    it.it_value.tv_sec = 0;
+    it.it_value.tv_usec = 250000;
+    setitimer(ITIMER_REAL, &it, NULL);
+  }
+#endif
+#ifdef USE_ALARM
+  /* The poor man's solution: use alarm to poll events. */
+  alarm(1);
+#endif
+  /* Position the current point at origin */
+  caml_gr_x = 0;
+  caml_gr_y = 0;
+  /* Reset the color cache */
+  caml_gr_init_color_cache();
+  caml_gr_init_direct_rgb_to_pixel();
+  return Val_unit;
+}
+
+value caml_gr_close_graph(void)
+{
+  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
+    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);
+    XCloseDisplay (caml_gr_display);
+    caml_gr_display = NULL;
+  }
+  return Val_unit;
+}
+
+value caml_gr_id_of_window(Window win)
+{
+  char tmp[256];
+
+  sprintf(tmp, "%lu", (unsigned long)win);
+  return caml_copy_string( tmp );
+}
+
+value caml_gr_window_id(void)
+{
+  caml_gr_check_open();
+  return caml_gr_id_of_window(caml_gr_window.win);
+}
+
+value caml_gr_set_window_title(value n)
+{
+  if (window_name != NULL) caml_stat_free(window_name);
+  window_name = caml_strdup(String_val(n));
+  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 caml_gr_resize_window (value vx, value vy)
+{
+  caml_gr_check_open ();
+
+  caml_gr_window.w = Int_val (vx);
+  caml_gr_window.h = Int_val (vy);
+  XResizeWindow (caml_gr_display, caml_gr_window.win, caml_gr_window.w,
+                 caml_gr_window.h);
+
+  XFreeGC(caml_gr_display, caml_gr_bstore.gc);
+  XFreePixmap(caml_gr_display, caml_gr_bstore.win);
+
+  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);
+
+  caml_gr_clear_graph ();
+  return Val_unit;
+}
+
+value caml_gr_clear_graph(void)
+{
+  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(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);
+  }
+  caml_gr_init_color_cache();
+  caml_gr_init_direct_rgb_to_pixel();
+  return Val_unit;
+}
+
+value caml_gr_size_x(void)
+{
+  caml_gr_check_open();
+  return Val_int(caml_gr_window.w);
+}
+
+value caml_gr_size_y(void)
+{
+  caml_gr_check_open();
+  return Val_int(caml_gr_window.h);
+}
+
+value caml_gr_synchronize(void)
+{
+  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(caml_gr_display);
+  return Val_unit ;
+}
+
+value caml_gr_display_mode(value flag)
+{
+  caml_gr_display_modeflag = Bool_val (flag);
+  return Val_unit ;
+}
+
+value caml_gr_remember_mode(value flag)
+{
+  caml_gr_remember_modeflag = Bool_val(flag);
+  return Val_unit ;
+}
+
+/* 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 caml_gr_sigio_signal(value unit)
+{
+  return Val_int(EVENT_SIGNAL);
+}
+
+value caml_gr_sigio_handler(void)
+{
+  XEvent 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
+  alarm(1);
+#endif
+  return Val_unit;
+}
+
+/* Processing of graphic errors */
+
+static value * graphic_failure_exn = NULL;
+
+void caml_gr_fail(char *fmt, char *arg)
+{
+  char buffer[1024];
+
+  if (graphic_failure_exn == NULL) {
+    graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
+    if (graphic_failure_exn == NULL)
+      caml_invalid_argument("Exception Graphics.Graphic_failure not initialized,"
+                       " must link graphics.cma");
+  }
+  sprintf(buffer, fmt, arg);
+  caml_raise_with_string(*graphic_failure_exn, buffer);
+}
+
+void caml_gr_check_open(void)
+{
+  if (!caml_gr_initialized) caml_gr_fail("graphic screen not opened", NULL);
+}
+
+static int caml_gr_error_handler(Display *display, XErrorEvent *error)
+{
+  char errmsg[512];
+  XGetErrorText(error->display, error->error_code, errmsg, sizeof(errmsg));
+  caml_gr_fail("Xlib error: %s", errmsg);
+  return 0;
+}
+
+static int caml_gr_ioerror_handler(Display *display)
+{
+  caml_gr_fail("fatal I/O error", NULL);
+  return 0;
+}
diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c
new file mode 100644
index 00000000..3c3d33db
--- /dev/null
+++ b/otherlibs/graph/point_col.c
@@ -0,0 +1,31 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+
+value caml_gr_point_color(value vx, value vy)
+{
+  int x = Int_val(vx);
+  int y = Int_val(vy);
+  XImage * im;
+  int rgb;
+
+  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
new file mode 100644
index 00000000..75ab2a57
--- /dev/null
+++ b/otherlibs/graph/sound.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+
+value caml_gr_sound(value vfreq, value vdur)
+{
+  XKeyboardControl kbdcontrol;
+
+  caml_gr_check_open();
+  kbdcontrol.bell_pitch = Int_val(vfreq);
+  kbdcontrol.bell_duration = Int_val(vdur);
+  XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration,
+                         &kbdcontrol);
+  XBell(caml_gr_display, 0);
+  kbdcontrol.bell_pitch = -1;   /* restore default value */
+  kbdcontrol.bell_duration = -1; /* restore default value */
+  XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration,
+                         &kbdcontrol);
+  XFlush(caml_gr_display);
+  return Val_unit;
+}
diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c
new file mode 100644
index 00000000..8ccd78fb
--- /dev/null
+++ b/otherlibs/graph/subwindow.c
@@ -0,0 +1,45 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*               Jun Furuse, 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+
+value caml_gr_open_subwindow(value vx, value vy, value width, value height)
+{
+  Window win;
+
+  int h = Int_val(height);
+  int w = Int_val(width);
+  int x = Int_val(vx);
+  int y = Int_val(vy);
+
+  caml_gr_check_open();
+  win = XCreateSimpleWindow(caml_gr_display, caml_gr_window.win,
+                            x, Wcvt(y + h), w, h,
+                            0, caml_gr_black, caml_gr_background);
+  XMapWindow(caml_gr_display, win);
+  XFlush(caml_gr_display);
+  return (caml_gr_id_of_window (win));
+}
+
+value caml_gr_close_subwindow(value wid)
+{
+  Window win;
+
+  caml_gr_check_open();
+  sscanf( String_val(wid), "%lu", (unsigned long *)(&win) );
+  XDestroyWindow(caml_gr_display, win);
+  XFlush(caml_gr_display);
+  return Val_unit;
+}
diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
new file mode 100644
index 00000000..7328967d
--- /dev/null
+++ b/otherlibs/graph/text.c
@@ -0,0 +1,86 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "libgraph.h"
+#include <caml/alloc.h>
+
+XFontStruct * caml_gr_font = NULL;
+
+static void caml_gr_get_font(char *fontname)
+{
+  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 caml_gr_set_font(value fontname)
+{
+  caml_gr_check_open();
+  caml_gr_get_font(String_val(fontname));
+  return Val_unit;
+}
+
+value caml_gr_set_text_size (value sz)
+{
+  return Val_unit;
+}
+
+static void caml_gr_draw_text(char *txt, int len)
+{
+  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);
+  }
+  caml_gr_x += XTextWidth(caml_gr_font, txt, len);
+}
+
+value caml_gr_draw_char(value chr)
+{
+  char str[1];
+  caml_gr_check_open();
+  str[0] = Int_val(chr);
+  caml_gr_draw_text(str, 1);
+  return Val_unit;
+}
+
+value caml_gr_draw_string(value str)
+{
+  caml_gr_check_open();
+  caml_gr_draw_text(String_val(str), caml_string_length(str));
+  return Val_unit;
+}
+
+value caml_gr_text_size(value str)
+{
+  int width;
+  value res;
+  caml_gr_check_open();
+  if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
+  width = XTextWidth(caml_gr_font, String_val(str), caml_string_length(str));
+  res = caml_alloc_small(2, 0);
+  Field(res, 0) = Val_int(width);
+  Field(res, 1) = Val_int(caml_gr_font->ascent + caml_gr_font->descent);
+  return res;
+}
diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
new file mode 100644
index 00000000..906bca5e
--- /dev/null
+++ b/otherlibs/num/.depend
@@ -0,0 +1,41 @@
+bng.o: bng.c bng.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/compatibility.h \
+  bng_amd64.c bng_digit.c
+bng_amd64.o: bng_amd64.c
+bng_arm64.o: bng_arm64.c
+bng_digit.o: bng_digit.c
+bng_ia32.o: bng_ia32.c
+bng_ppc.o: bng_ppc.c
+bng_sparc.o: bng_sparc.c
+nat_stubs.o: nat_stubs.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/custom.h ../../byterun/caml/intext.h \
+  ../../byterun/caml/io.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/hash.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
+  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
+  ../../byterun/caml/address_class.h bng.h nat.h
+arith_flags.cmo : arith_flags.cmi
+arith_flags.cmx : arith_flags.cmi
+arith_flags.cmi :
+arith_status.cmo : arith_flags.cmi arith_status.cmi
+arith_status.cmx : arith_flags.cmx arith_status.cmi
+arith_status.cmi :
+big_int.cmo : nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx : nat.cmx int_misc.cmx big_int.cmi
+big_int.cmi : nat.cmi
+int_misc.cmo : int_misc.cmi
+int_misc.cmx : int_misc.cmi
+int_misc.cmi :
+nat.cmo : int_misc.cmi nat.cmi
+nat.cmx : int_misc.cmx nat.cmi
+nat.cmi :
+num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+num.cmi : ratio.cmi nat.cmi big_int.cmi
+ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+ratio.cmi : nat.cmi big_int.cmi
diff --git a/otherlibs/num/.depend.nt b/otherlibs/num/.depend.nt
new file mode 100644
index 00000000..a22644ba
--- /dev/null
+++ b/otherlibs/num/.depend.nt
@@ -0,0 +1,66 @@
+bng.dobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c
+bng_alpha.dobj: bng_alpha.c
+bng_amd64.dobj: bng_amd64.c
+bng_digit.dobj: bng_digit.c
+bng_ia32.dobj: bng_ia32.c
+bng_mips.dobj: bng_mips.c
+bng_ppc.dobj: bng_ppc.c
+bng_sparc.dobj: bng_sparc.c
+nat_stubs.dobj: 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: ratio.cmi nat.cmi big_int.cmi
+ratio.cmi: nat.cmi big_int.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: nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx: nat.cmx int_misc.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: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+bng.sobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c
+bng_alpha.sobj: bng_alpha.c
+bng_amd64.sobj: bng_amd64.c
+bng_digit.sobj: bng_digit.c
+bng_ia32.sobj: bng_ia32.c
+bng_mips.sobj: bng_mips.c
+bng_ppc.sobj: bng_ppc.c
+bng_sparc.sobj: bng_sparc.c
+nat_stubs.sobj: 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: ratio.cmi nat.cmi big_int.cmi
+ratio.cmi: nat.cmi big_int.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: nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx: nat.cmx int_misc.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: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
new file mode 100644
index 00000000..ccd077d3
--- /dev/null
+++ b/otherlibs/num/Makefile
@@ -0,0 +1,48 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the "num" (exact rational arithmetic) library
+
+LIBNAME=nums
+EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
+CAMLOBJS=int_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)
+
+include ../Makefile
+
+clean::
+	rm -f *~
+
+bng.$(O): bng.h bng_digit.c \
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+
+# At the moment, the following rule only works with gcc
+# It is not a big deal since the .depend file it produces is stored
+# in the repository
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+
+ifeq "$(TOOLCHAIN)" "msvc"
+
+.depend.nt: .depend
+	sed -e 's/\.o/.$(O)/g' $< > $@
+
+include .depend.nt
+else
+include .depend
+endif
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/otherlibs/num/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/num/README b/otherlibs/num/README
new file mode 100644
index 00000000..a979356d
--- /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..a1ca0b02
--- /dev/null
+++ b/otherlibs/num/arith_flags.ml
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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..7dd6bc79
--- /dev/null
+++ b/otherlibs/num/arith_flags.mli
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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..2fbdd4a6
--- /dev/null
+++ b/otherlibs/num/arith_status.ml
@@ -0,0 +1,100 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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..ba604347
--- /dev/null
+++ b/otherlibs/num/arith_status.mli
@@ -0,0 +1,64 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 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..45cea9ca
--- /dev/null
+++ b/otherlibs/num/big_int.ml
@@ -0,0 +1,898 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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)
+
+(* Number of bits in a big_int *)
+let num_bits_big_int bi =
+  let nd = num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value) in
+  (* nd = 1 if bi = 0 *)
+  let lz = num_leading_zero_bits_in_digit bi.abs_value (nd - 1) in
+  (* lz = length_of_digit if bi = 0 *)
+  nd * length_of_digit - lz
+  (* = 0 if bi = 0 *)
+
+(* 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
+            ignore (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;
+          ignore (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
+            ignore (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;
+          ignore (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;
+                 ignore
+                   (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;
+                ignore (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
+                 (ignore (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
+                 (ignore (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;
+                   ignore (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;
+            ignore (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
+          ignore (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 (ignore (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2
+                           (bi1.abs_value) 0 size_bi1);res)
+           else (ignore (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1
+                           (bi2.abs_value) 0 size_bi2);res) }
+
+(* (quotient, remainder ) 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, remains 1, -1/2  -> -1, remains 1 *)
+            (* 1/-2 -> 0, remains 1, -1/-2 -> 1, remains 1 *)
+             if bi1.sign >= 0 then
+               (big_int_of_int 0, bi1)
+             else if bi2.sign >= 0 then
+               (big_int_of_int(-1), add_big_int bi2 bi1)
+             else
+               (big_int_of_int 1, sub_big_int bi1 bi2)
+    | 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;
+                               ignore (incr_nat q 0 size_q 1); q) },
+                { sign = 1;
+                 abs_value =
+                      (ignore (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";;
+
+let int_of_big_int_opt bi =
+  try Some (int_of_big_int bi) with Failure _ -> None
+
+let big_int_of_nativeint i =
+  if i = 0n then
+    zero_big_int
+  else if i > 0n then begin
+    let res = create_nat 1 in
+    set_digit_nat_native res 0 i;
+    { sign = 1; abs_value = res }
+  end else begin
+    let res = create_nat 1 in
+    set_digit_nat_native res 0 (Nativeint.neg i);
+    { sign = -1; abs_value = res }
+  end
+
+let nativeint_of_big_int bi =
+  if num_digits_big_int bi > 1 then failwith "nativeint_of_big_int";
+  let i = nth_digit_nat_native bi.abs_value 0 in
+  if bi.sign >= 0 then
+    if i >= 0n then i else failwith "nativeint_of_big_int"
+  else
+    if i >= 0n || i = Nativeint.min_int
+    then Nativeint.neg i
+    else failwith "nativeint_of_big_int"
+
+let nativeint_of_big_int_opt bi =
+  try Some (nativeint_of_big_int bi) with Failure _ -> None
+
+let big_int_of_int32 i = big_int_of_nativeint (Nativeint.of_int32 i)
+
+let int32_of_big_int bi =
+  let i = nativeint_of_big_int bi in
+  if i <= 0x7FFF_FFFFn && i >= -0x8000_0000n
+  then Nativeint.to_int32 i
+  else failwith "int32_of_big_int"
+
+let int32_of_big_int_opt bi =
+  try Some (int32_of_big_int bi) with Failure _ -> None
+
+let big_int_of_int64 i =
+  if Sys.word_size = 64 then
+    big_int_of_nativeint (Int64.to_nativeint i)
+  else begin
+    let (sg, absi) =
+      if i = 0L then (0, 0L)
+      else if i > 0L then (1, i)
+      else (-1, Int64.neg i) in
+    let res = create_nat 2 in
+    set_digit_nat_native res 0 (Int64.to_nativeint absi);
+    set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_right absi 32));
+    { sign = sg; abs_value = res }
+  end
+
+let int64_of_big_int bi =
+  if Sys.word_size = 64 then
+    Int64.of_nativeint (nativeint_of_big_int bi)
+  else begin
+    let i =
+      match num_digits_big_int bi with
+      | 1 -> Int64.logand
+               (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0))
+               0xFFFFFFFFL
+      | 2 -> Int64.logor
+               (Int64.logand
+                 (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0))
+                 0xFFFFFFFFL)
+               (Int64.shift_left
+                 (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 1))
+                 32)
+      | _ -> failwith "int64_of_big_int" in
+    if bi.sign >= 0 then
+      if i >= 0L then i else failwith "int64_of_big_int"
+    else
+      if i >= 0L || i = Int64.min_int
+      then Int64.neg i
+      else failwith "int64_of_big_int"
+  end
+
+let int64_of_big_int_opt bi =
+  try Some (int64_of_big_int bi) with Failure _ -> None
+
+(* 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 base =
+  if len < 1 then failwith "sys_big_int_of_string";
+  let n = sys_nat_of_string base 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_base s ofs len sgn =
+  if len < 1 then failwith "sys_big_int_of_string";
+  if len < 2 then sys_big_int_of_string_aux s ofs len sgn 10
+  else
+    match (s.[ofs], s.[ofs+1]) with
+    | ('0', 'x') | ('0', 'X') ->
+        sys_big_int_of_string_aux s (ofs+2) (len-2) sgn 16
+    | ('0', 'o') | ('0', 'O') ->
+        sys_big_int_of_string_aux s (ofs+2) (len-2) sgn 8
+    | ('0', 'b') | ('0', 'B') ->
+        sys_big_int_of_string_aux s (ofs+2) (len-2) sgn 2
+    | _ -> sys_big_int_of_string_aux s ofs len sgn 10
+;;
+
+let sys_big_int_of_string s ofs len =
+  if len < 1 then failwith "sys_big_int_of_string";
+  match s.[ofs] with
+  | '-' -> sys_big_int_of_string_base s (ofs+1) (len-1) (-1)
+  | '+' -> sys_big_int_of_string_base s (ofs+1) (len-1) 1
+  | _ -> sys_big_int_of_string_base s ofs len 1
+;;
+
+let big_int_of_string s =
+  sys_big_int_of_string s 0 (String.length s)
+
+let big_int_of_string_opt s =
+  try Some (big_int_of_string s) with Failure _ -> None
+
+let power_base_nat base nat off len =
+  if base = 0 then nat_of_int 0 else
+  if is_zero_nat nat off len || base = 1 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
+      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
+          ignore (square_nat res2 0 len2 res 0 len);
+          begin
+           if n land (1 lsl i) > 0
+              then (set_to_zero_nat res 0 len;
+                    ignore (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
+      done;
+    if rem > 0
+     then (ignore (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
+         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
+           set_to_zero_nat res2 0 len2;
+           ignore (square_nat res2 0 len2 res 0 len);
+           if n land (1 lsl i) > 0 then begin
+             let lenp = min res_len (len2 + bi_len) in
+             set_to_zero_nat res 0 lenp;
+             ignore(mult_nat res 0 lenp res2 0 len2 (bi.abs_value) 0 bi_len)
+           end else begin
+             blit_nat res 0 res2 0 len2
+           end
+         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"
+  | _ -> try
+           power_big_int_positive_int bi1 (int_of_big_int bi2)
+         with Failure _ ->
+         try
+           power_int_positive_big_int (int_of_big_int bi1) bi2
+         with Failure _ ->
+           raise Out_of_memory
+           (* If neither bi1 nor bi2 is a small integer, bi1^bi2 is not
+              representable.  Indeed, on a 32-bit platform,
+              |bi1| >= 2 and |bi2| >= 2^30, hence bi1^bi2 has at least
+              2^30 bits = 2^27 bytes, greater than the max size of
+              allocated blocks.  On a 64-bit platform,
+              |bi1| >= 2 and |bi2| >= 2^62, hence bi1^bi2 has at least
+              2^62 bits = 2^59 bytes, greater than the max size of
+              allocated blocks. *)
+
+(* 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
+         ignore
+           (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
+
+(* 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
+  ignore (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(Bytes.get s l) >= Char.code '5'
+    then
+     let rec round_rec l =
+       if l < off_set then true else begin
+         let current_char = Bytes.get s l in
+         if current_char = '9' then
+           (Bytes.set s l '0'; round_rec (pred l))
+         else
+           (Bytes.set s l (Char.chr (succ (Char.code current_char)));
+            false)
+       end
+     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 =
+    Bytes.unsafe_of_string
+      (string_of_big_int (div_big_int bi (power_int_positive_int 10 n)))
+  in
+  let (sign, off) =
+    if Bytes.get s 0 = '-'
+       then ("-", 1)
+       else ("", 0) in
+  if (round_futur_last_digit s off (succ prec))
+       then (sign^"1."^(String.make prec '0')^"e"^
+             (string_of_int (n + 1 - off + Bytes.length s)))
+       else (sign^(Bytes.sub_string s off 1)^"."^
+             (Bytes.sub_string s (succ off) (pred prec))
+             ^"e"^(string_of_int (n - succ off + Bytes.length s)))
+
+(* Logical operations *)
+
+(* Shift left by N bits *)
+
+let shift_left_big_int bi n =
+  if n < 0 then invalid_arg "shift_left_big_int"
+  else if n = 0 then bi
+  else if bi.sign = 0 then bi
+  else begin
+    let size_bi = num_digits_big_int bi in
+    let size_res = size_bi + ((n + length_of_digit - 1) / length_of_digit) in
+    let res = create_nat size_res in
+    let ndigits = n / length_of_digit in
+    set_to_zero_nat res 0 ndigits;
+    blit_nat res ndigits bi.abs_value 0 size_bi;
+    let nbits = n mod length_of_digit in
+    if nbits > 0 then
+      shift_left_nat res ndigits size_bi res (ndigits + size_bi) nbits;
+    { sign = bi.sign; abs_value = res }
+  end
+
+(* Shift right by N bits (rounds toward zero) *)
+
+let shift_right_towards_zero_big_int bi n =
+  if n < 0 then invalid_arg "shift_right_towards_zero_big_int"
+  else if n = 0 then bi
+  else if bi.sign = 0 then bi
+  else begin
+    let size_bi = num_digits_big_int bi in
+    let ndigits = n / length_of_digit in
+    let nbits = n mod length_of_digit in
+    if ndigits >= size_bi then zero_big_int else begin
+      let size_res = size_bi - ndigits in
+      let res = create_nat size_res in
+      blit_nat res 0 bi.abs_value ndigits size_res;
+      if nbits > 0 then begin
+        let tmp = create_nat 1 in
+        shift_right_nat res 0 size_res tmp 0 nbits
+      end;
+      if is_zero_nat res 0 size_res
+      then zero_big_int
+      else { sign = bi.sign; abs_value = res }
+    end
+  end
+
+(* Compute 2^n - 1 *)
+
+let two_power_m1_big_int n =
+  if n < 0 then invalid_arg "two_power_m1_big_int"
+  else if n = 0 then zero_big_int
+  else begin
+    let idx = n / length_of_digit in
+    let size_res = idx + 1 in
+    let res = make_nat size_res in
+    set_digit_nat_native res idx
+                         (Nativeint.shift_left 1n (n mod length_of_digit));
+    ignore (decr_nat res 0 size_res 0);
+    { sign = 1; abs_value = res }
+  end
+
+(* Shift right by N bits (rounds toward minus infinity) *)
+
+let shift_right_big_int bi n =
+  if n < 0 then invalid_arg "shift_right_big_int"
+  else if bi.sign >= 0 then shift_right_towards_zero_big_int bi n
+  else
+    shift_right_towards_zero_big_int (sub_big_int bi (two_power_m1_big_int n)) n
+
+(* Extract N bits starting at ofs.
+   Treats bi in two's complement.
+   Result is always positive. *)
+
+let extract_big_int bi ofs n =
+  if ofs < 0 || n < 0 then invalid_arg "extract_big_int"
+  else if bi.sign = 0 then bi
+  else begin
+    let size_bi = num_digits_big_int bi in
+    let size_res = (n + length_of_digit - 1) / length_of_digit in
+    let ndigits = ofs / length_of_digit in
+    let nbits = ofs mod length_of_digit in
+    let res = make_nat size_res in
+    if ndigits < size_bi then
+      blit_nat res 0 bi.abs_value ndigits (min size_res (size_bi - ndigits));
+    if bi.sign < 0 then begin
+      (* Two's complement *)
+      complement_nat res 0 size_res;
+      (* PR#6010: need to increment res iff digits 0...ndigits-1 of bi are 0.
+         In this case, digits 0...ndigits-1 of not(bi) are all 0xFF...FF,
+         and adding 1 to them produces a carry out at ndigits. *)
+      let rec carry_incr i =
+        i >= ndigits || i >= size_bi ||
+          (is_digit_zero bi.abs_value i && carry_incr (i + 1)) in
+      if carry_incr 0 then ignore (incr_nat res 0 size_res 1)
+    end;
+    if nbits > 0 then begin
+      let tmp = create_nat 1 in
+      shift_right_nat res 0 size_res tmp 0 nbits
+    end;
+    let n' = n mod length_of_digit in
+    if n' > 0 then begin
+      let tmp = create_nat 1 in
+      set_digit_nat_native tmp 0
+          (Nativeint.shift_right_logical (-1n) (length_of_digit - n'));
+      land_digit_nat res (size_res - 1) tmp 0
+    end;
+    if is_zero_nat res 0 size_res
+    then zero_big_int
+    else { sign = 1; abs_value = res }
+  end
+
+(* Bitwise logical operations.  Arguments must be >= 0. *)
+
+let and_big_int a b =
+  if a.sign < 0 || b.sign < 0 then invalid_arg "and_big_int"
+  else if a.sign = 0 || b.sign = 0 then zero_big_int
+  else begin
+    let size_a = num_digits_big_int a
+    and size_b = num_digits_big_int b in
+    let size_res = min size_a size_b in
+    let res = create_nat size_res in
+    blit_nat res 0 a.abs_value 0 size_res;
+    for i = 0 to size_res - 1 do
+      land_digit_nat res i b.abs_value i
+    done;
+    if is_zero_nat res 0 size_res
+    then zero_big_int
+    else { sign = 1; abs_value = res }
+  end
+
+let or_big_int a b =
+  if a.sign < 0 || b.sign < 0 then invalid_arg "or_big_int"
+  else if a.sign = 0 then b
+  else if b.sign = 0 then a
+  else begin
+    let size_a = num_digits_big_int a
+    and size_b = num_digits_big_int b in
+    let size_res = max size_a size_b in
+    let res = create_nat size_res in
+    let or_aux a' b' size_b' =
+      blit_nat res 0 a'.abs_value 0 size_res;
+      for i = 0 to size_b' - 1 do
+        lor_digit_nat res i b'.abs_value i
+      done in
+    if size_a >= size_b
+    then or_aux a b size_b
+    else or_aux b a size_a;
+    if is_zero_nat res 0 size_res
+    then zero_big_int
+    else { sign = 1; abs_value = res }
+  end
+
+let xor_big_int a b =
+  if a.sign < 0 || b.sign < 0 then invalid_arg "xor_big_int"
+  else if a.sign = 0 then b
+  else if b.sign = 0 then a
+  else begin
+    let size_a = num_digits_big_int a
+    and size_b = num_digits_big_int b in
+    let size_res = max size_a size_b in
+    let res = create_nat size_res in
+    let xor_aux a' b' size_b' =
+      blit_nat res 0 a'.abs_value 0 size_res;
+      for i = 0 to size_b' - 1 do
+        lxor_digit_nat res i b'.abs_value i
+      done in
+    if size_a >= size_b
+    then xor_aux a b size_b
+    else xor_aux b a size_a;
+    if is_zero_nat res 0 size_res
+    then zero_big_int
+    else { sign = 1; abs_value = res }
+  end
+
+(* Coercion with float type *)
+
+(* Consider a real number [r] such that
+   - the integral part of [r] is the bigint [x]
+   - 2^54 <= |x| < 2^63
+   - the fractional part of [r] is 0 if [exact = true],
+     nonzero if [exact = false].
+   Then, the following function returns [r] correctly rounded to
+   the nearest double-precision floating-point number.
+   This is an instance of the "round to odd" technique formalized in
+   "When double rounding is odd" by S. Boldo and G. Melquiond.
+   The claim above is lemma Fappli_IEEE_extra.round_odd_fix
+   from the CompCert Coq development. *)
+
+let round_big_int_to_float x exact =
+  assert (let n = num_bits_big_int x in 55 <= n && n <= 63);
+  let m = int64_of_big_int x in
+  (* Unless the fractional part is exactly 0, round m to an odd integer *)
+  let m = if exact then m else Int64.logor m 1L in
+  (* Then convert m to float, with the normal rounding mode. *)
+  Int64.to_float m
+
+let float_of_big_int x =
+  let n = num_bits_big_int x in
+  if n <= 63 then
+    Int64.to_float (int64_of_big_int x)
+  else begin
+    let n = n - 55 in
+    (* Extract top 55 bits of x *)
+    let top = shift_right_big_int x n in
+    (* Check if the other bits are all zero *)
+    let exact = eq_big_int x (shift_left_big_int top n) in
+    (* Round to float and apply exponent *)
+    ldexp (round_big_int_to_float top exact) n
+  end
diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
new file mode 100644
index 00000000..07c40729
--- /dev/null
+++ b/otherlibs/num/big_int.mli
@@ -0,0 +1,276 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 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.  *)
+
+val num_bits_big_int : big_int -> int
+        (** Return the number of significant bits in the absolute
+            value of the given big integer.  [num_bits_big_int a]
+            returns 0 if [a] is 0; otherwise it returns a positive
+            integer [n] such that [2^(n-1) <= |a| < 2^n].
+
+            @since 4.03.0 *)
+
+(** {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. *)
+(* TODO: document error condition. *)
+
+val big_int_of_string_opt: string -> big_int option
+(** Convert a string to a big integer, in decimal.
+    The string consists of an optional [-] or [+] sign,
+    followed by one or several decimal digits. Other the function
+    returns [None].
+    @since 4.05
+*)
+
+
+(** {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 int_of_big_int_opt: big_int -> int option
+(** Convert a big integer to a small integer (type [int]).  Return
+    [None] if the big integer is not representable as a small
+    integer.
+    @since 4.05
+*)
+
+val big_int_of_int32 : int32 -> big_int
+(** Convert a 32-bit integer to a big integer. *)
+
+val big_int_of_nativeint : nativeint -> big_int
+(** Convert a native integer to a big integer. *)
+
+val big_int_of_int64 : int64 -> big_int
+(** Convert a 64-bit integer to a big integer. *)
+
+val int32_of_big_int : big_int -> int32
+        (** Convert a big integer to a 32-bit integer.
+            Raises [Failure] if the big integer is outside the
+            range \[-2{^31}, 2{^31}-1\]. *)
+
+val int32_of_big_int_opt: big_int -> int32 option
+(** Convert a big integer to a 32-bit integer.  Return [None] if the
+    big integer is outside the range \[-2{^31}, 2{^31}-1\].
+    @since 4.05
+*)
+
+val nativeint_of_big_int : big_int -> nativeint
+        (** Convert a big integer to a native integer.
+            Raises [Failure] if the big integer is outside the
+            range [[Nativeint.min_int, Nativeint.max_int]]. *)
+
+val nativeint_of_big_int_opt: big_int -> nativeint option
+(** Convert a big integer to a native integer. Return [None] if the
+    big integer is outside the range [[Nativeint.min_int,
+    Nativeint.max_int]];
+    @since 4.05
+*)
+
+val int64_of_big_int : big_int -> int64
+        (** Convert a big integer to a 64-bit integer.
+            Raises [Failure] if the big integer is outside the
+            range \[-2{^63}, 2{^63}-1\]. *)
+
+val int64_of_big_int_opt: big_int -> int64 option
+(** Convert a big integer to a 64-bit integer. Return [None] if the
+    big integer is outside the range \[-2{^63}, 2{^63}-1\].
+    @since 4.05
+*)
+
+val float_of_big_int : big_int -> float
+        (** Returns a floating-point number approximating the
+           given big integer. *)
+
+(** {6 Bit-oriented operations} *)
+
+val and_big_int : big_int -> big_int -> big_int
+        (** Bitwise logical 'and'.
+            The arguments must be positive or zero. *)
+
+val or_big_int : big_int -> big_int -> big_int
+        (** Bitwise logical 'or'.
+            The arguments must be positive or zero. *)
+
+val xor_big_int : big_int -> big_int -> big_int
+        (** Bitwise logical 'exclusive or'.
+            The arguments must be positive or zero. *)
+
+val shift_left_big_int : big_int -> int -> big_int
+        (** [shift_left_big_int b n] returns [b] shifted left by [n] bits.
+            Equivalent to multiplication by 2^n. *)
+
+val shift_right_big_int : big_int -> int -> big_int
+        (** [shift_right_big_int b n] returns [b] shifted right by [n] bits.
+            Equivalent to division by 2^n with the result being
+            rounded towards minus infinity. *)
+
+val shift_right_towards_zero_big_int : big_int -> int -> big_int
+        (** [shift_right_towards_zero_big_int b n] returns [b] shifted
+            right by [n] bits.  The shift is performed on the absolute
+            value of [b], and the result has the same sign as [b].
+            Equivalent to division by 2^n with the result being
+            rounded towards zero. *)
+
+val extract_big_int : big_int -> int -> int -> big_int
+        (** [extract_big_int bi ofs n] returns a nonnegative number
+            corresponding to bits [ofs] to [ofs + n - 1] of the
+            binary representation of [bi].  If [bi] is negative,
+            a two's complement representation is used. *)
+
+(**/**)
+
+(** {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 : bytes -> int -> int -> bool
+val approx_big_int: int -> big_int -> string
+
+val round_big_int_to_float: big_int -> bool -> float
+(** @since 4.03.0 *)
diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
new file mode 100644
index 00000000..c4d0ea1a
--- /dev/null
+++ b/otherlibs/num/bng.c
@@ -0,0 +1,433 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "bng.h"
+#include "caml/config.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_sparc)
+#include "bng_sparc.c"
+#elif defined (BNG_ARCH_arm64)
+#include "bng_arm64.c"
+#endif
+#endif
+
+#include "bng_digit.c"
+
+/**** Operations that cannot be overridden ****/
+
+/* 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;
+  intnat 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..406117dd
--- /dev/null
+++ b/otherlibs/num/bng.h
@@ -0,0 +1,156 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include "caml/config.h"
+
+typedef uintnat bngdigit;
+typedef bngdigit * bng;
+typedef unsigned int bngcarry;
+typedef uintnat 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/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
new file mode 100644
index 00000000..585900e9
--- /dev/null
+++ b/otherlibs/num/bng_amd64.c
@@ -0,0 +1,195 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* 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_arm64.c b/otherlibs/num/bng_arm64.c
new file mode 100644
index 00000000..b900b803
--- /dev/null
+++ b/otherlibs/num/bng_arm64.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2013 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Code specific for the ARM 64 (AArch64) architecture */
+
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("mul %0, %2, %3 \n\t"                                                 \
+      "umulh %1, %2, %3"                                                    \
+      : "=&r" (resl), "=&r" (resh)                                          \
+      : "r" (arg1), "r" (arg2))
diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
new file mode 100644
index 00000000..6983af65
--- /dev/null
+++ b/otherlibs/num/bng_digit.c
@@ -0,0 +1,178 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/**** 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) & (((bngdigit)1 << 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. */
+#if SIZEOF_PTR == 4 && defined(ARCH_UINT64_TYPE)
+#define BngMult(resh,resl,arg1,arg2) {                                      \
+  ARCH_UINT64_TYPE p = (ARCH_UINT64_TYPE)(arg1) * (ARCH_UINT64_TYPE)(arg2); \
+  resh = p >> 32;                                                           \
+  resl = p;                                                                 \
+}
+#else
+#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
+#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..6b6cabd2
--- /dev/null
+++ b/otherlibs/num/bng_ia32.c
@@ -0,0 +1,411 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* 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), "+&r" (blen), "=m" (out)
+        : "m" (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), "=m" (blen), "=m" (out), "=&r" (tmp)
+        : "m" (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_ppc.c b/otherlibs/num/bng_ppc.c
new file mode 100644
index 00000000..f4c098cf
--- /dev/null
+++ b/otherlibs/num/bng_ppc.c
@@ -0,0 +1,94 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* 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))
+
+#if defined(__ppc64__) || defined(__PPC64__)
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("mulld %0, %2, %3 \n\t"                                               \
+      "mulhdu %1, %2, %3"                                                   \
+      : "=&r" (resl), "=r" (resh)                                           \
+      : "r" (arg1), "r" (arg2))
+#else
+#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))
+#endif
diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
new file mode 100644
index 00000000..c007cb77
--- /dev/null
+++ b/otherlibs/num/bng_sparc.c
@@ -0,0 +1,77 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* 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..d7d7190e
--- /dev/null
+++ b/otherlibs/num/int_misc.ml
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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..1ee11ba5
--- /dev/null
+++ b/otherlibs/num/int_misc.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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/otherlibs/num/nat.h b/otherlibs/num/nat.h
new file mode 100644
index 00000000..45e7b957
--- /dev/null
+++ b/otherlibs/num/nat.h
@@ -0,0 +1,18 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Nats are represented as unstructured blocks with tag Custom_tag. */
+
+#define Digit_val(nat,pos) (((bng) Data_custom_val(nat))[pos])
diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
new file mode 100644
index 00000000..c7a26698
--- /dev/null
+++ b/otherlibs/num/nat.ml
@@ -0,0 +1,594 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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 set_digit_nat_native: nat -> int -> nativeint -> unit
+                             = "set_digit_nat_native"
+external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native"
+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
+
+(* Integer square root using newton method (nearest integer by default) *)
+
+(* Theorem: the sequence x_{n+1} = ( x_n + a/x_n )/2 converges toward
+   the integer square root (by default) of a for any starting value x_0
+   strictly greater than the square root of a except if a + 1 is a
+   perfect square. In this situation, the sequence alternates between
+   the excess and default integer square root. In any case, the last
+   strictly decreasing term is the expected result *)
+
+let sqrt_nat rad off len =
+ let len = num_digits_nat rad off len in
+ (* Working copy of radicand *)
+ 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
+ (* Candidate square root cand = "|FFFF .... |" *)
+ let cand = make_nat cand_len in
+ (* Improve starting square root:
+    We compute nbb, the number of significant bits of the first digit of the
+    candidate
+    (half of the number of significant bits in the first two digits
+     of the radicand extended to an even length).
+    shift_cand is word_size - nbb *)
+ let shift_cand =
+   ((num_leading_zero_bits_in_digit rad (len-1)) +
+     Sys.word_size * len_parity) / 2 in
+ (* All radicand bits are zeroed, we give back 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 (strong weight) <- next_cand (strong weight) + cand,
+              i.e. next_cand <- cand + rad / cand *)
+   ignore (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);
+      ignore
+        (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 = Bytes.make (max_superscript_10_power_in_int+1) '0' in
+            Bytes.set result 0 (Char.chr (48 + leading_digits));
+            String.blit s1 0 result (Bytes.length result - len) len;
+            Bytes.to_string result
+       end else begin
+            let result = Bytes.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 (Bytes.length result - len) len;
+            Bytes.to_string 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.
+
+   |   Deletion of string_of_digit and sys_string_of_digit.
+   The copy is already done in string_of_nat which is the only
+   public entry point in this 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
+
+*******)
+
+(*
+   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.
+
+   This function returns [(pmax, pint)] where:
+   [pmax] is the index of the digit of [power_base] that contains the
+     the maximum power of [base] that fits in a digit. This is also one
+     less than the exponent of that power.
+   [pint] is the exponent of the maximum power of [base] that fits in an [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
+     ignore
+       (mult_digit_nat power_base !i 2
+          power_base (pred !i) 1
+          power_base 0)
+   done;
+   while !j < !i - 1 && is_digit_int power_base !j do incr j done;
+  (!i - 2, !j)
+
+(*
+(*
+   int_to_string places the representation of the integer int in base 'base'
+   in the string s by starting from the end position pos and going towards
+   the start, for 'times' places and updates the value of pos.
+*)
+let digits = "0123456789ABCDEF"
+
+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
+        Bytes.set s !pos_ref (String.get digits (!i mod base));
+        decr pos_ref;
+        decr j;
+        i := !i / base
+     done
+*)
+
+let power_base_int base i =
+  if i = 0 || base = 1 then
+    nat_of_int 1
+  else if base = 0 then
+    nat_of_int 0
+  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
+                 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
+                     ignore (square_nat res2 0 len2 res 0 len);
+                     if n land (1 lsl i) > 0 then begin
+                       set_to_zero_nat res 0 len;
+                       ignore
+                         (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
+                 done;
+               if rem > 0 then begin
+                 ignore
+                   (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.
+  |    the original code have been specialized to a length_of_digit = 32. *)
+(* Now deleted (useless?) *)
+
+(******
+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"
+******)
+
+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 = Bytes.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);
+                      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;
+                   Bytes.unsafe_to_string 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)
+
+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 if n >= 97 && n <= 97 + base - 11 then n - 87
+    else failwith "invalid digit"
+
+(*
+   The substring (s, off, len) represents a nat in base 'base' which is
+determined here
+*)
+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
+    (*
+       we read (at most) pint digits, we transform them in a int
+       and integrate it to the number
+     *)
+      let c = String.get s i  in
+        begin match c with
+          ' ' | '\t' | '\n' | '\r' | '\\' -> ()
+        | '_' when i > off -> ()
+        | _ -> 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;
+           ignore
+             (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;
+  (*
+     We reframe 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..803a6537
--- /dev/null
+++ b/otherlibs/num/nat.mli
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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"
+external set_digit_nat_native: nat -> int -> nativeint -> unit
+                             = "set_digit_nat_native"
+external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native"
+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..5a07a801
--- /dev/null
+++ b/otherlibs/num/nat_stubs.c
@@ -0,0 +1,421 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include "caml/alloc.h"
+#include "caml/config.h"
+#include "caml/custom.h"
+#include "caml/intext.h"
+#include "caml/fail.h"
+#include "caml/hash.h"
+#include "caml/memory.h"
+#include "caml/mlvalues.h"
+
+#include "bng.h"
+#include "nat.h"
+
+/* Stub code for the Nat module. */
+
+static intnat hash_nat(value);
+static void serialize_nat(value, uintnat *, uintnat *);
+static uintnat deserialize_nat(void * dst);
+
+static struct custom_operations nat_operations = {
+  "_nat",
+  custom_finalize_default,
+  custom_compare_default,
+  hash_nat,
+  serialize_nat,
+  deserialize_nat,
+  custom_compare_ext_default
+};
+
+CAMLprim value initialize_nat(value unit)
+{
+  bng_init();
+  caml_register_custom_operations(&nat_operations);
+  return Val_unit;
+}
+
+CAMLprim value create_nat(value size)
+{
+  mlsize_t sz = Long_val(size);
+
+  return caml_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 set_digit_nat_native(value nat, value ofs, value digit)
+{
+  Digit_val(nat, Long_val(ofs)) = Nativeint_val(digit);
+  return Val_unit;
+}
+
+CAMLprim value nth_digit_nat_native(value nat, value ofs)
+{
+  return caml_copy_nativeint(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))
+             & ((bngdigit)1 << (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 caml_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,
+                          uintnat * wsize_32,
+                          uintnat * 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 >= ((mlsize_t)1 << 32))
+    caml_failwith("output_value: nat too big");
+#endif
+  caml_serialize_int_4((int32_t) len);
+#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
+  { int32_t * p;
+    mlsize_t i;
+    for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
+      caml_serialize_int_4(p[1]);    /* low 32 bits of 64-bit digit */
+      caml_serialize_int_4(p[0]);    /* high 32 bits of 64-bit digit */
+    }
+  }
+#else
+  caml_serialize_block_4(Data_custom_val(nat), len);
+#endif
+  *wsize_32 = len * 4;
+  *wsize_64 = len * 4;
+}
+
+static uintnat deserialize_nat(void * dst)
+{
+  mlsize_t len;
+
+  len = caml_deserialize_uint_4();
+#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
+  { uint32_t * p;
+    mlsize_t i;
+    for (i = len, p = dst; i > 1; i -= 2, p += 2) {
+      p[1] = caml_deserialize_uint_4();   /* low 32 bits of 64-bit digit */
+      p[0] = caml_deserialize_uint_4();   /* high 32 bits of 64-bit digit */
+    }
+    if (i > 0){
+      p[1] = caml_deserialize_uint_4();   /* low 32 bits of 64-bit digit */
+      p[0] = 0;                      /* high 32 bits of 64-bit digit */
+      ++ len;
+    }
+  }
+#else
+  caml_deserialize_block_4(dst, len);
+#if defined(ARCH_SIXTYFOUR)
+  if (len & 1){
+    ((uint32_t *) dst)[len] = 0;
+    ++ len;
+  }
+#endif
+#endif
+  return len * 4;
+}
+
+static intnat hash_nat(value v)
+{
+  bngsize len, i;
+  uint32_t h;
+
+  len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1);
+  h = 0;
+  for (i = 0; i < len; i++) {
+    bngdigit d = Digit_val(v, i);
+#ifdef ARCH_SIXTYFOUR
+    /* Mix the two 32-bit halves as if we were on a 32-bit platform,
+       namely low 32 bits first, then high 32 bits.
+       Also, ignore final 32 bits if they are zero. */
+    h = caml_hash_mix_uint32(h, (uint32_t) d);
+    d = d >> 32;
+    if (d == 0 && i + 1 == len) break;
+    h = caml_hash_mix_uint32(h, (uint32_t) d);
+#else
+    h = caml_hash_mix_uint32(h, d);
+#endif
+  }
+  return h;
+}
diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
new file mode 100644
index 00000000..46b70a13
--- /dev/null
+++ b/otherlibs/num/num.ml
@@ -0,0 +1,450 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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 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 =
+ ignore (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 _ as n -> n
+| Big_int _ as n -> n
+| Ratio r -> num_of_big_int (floor_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
+;;
+
+(* Euclidean division and remainder.  The specification is:
+
+      a = b * quo_num a b + mod_num a b
+      quo_num a b is an integer (Z)
+      0 <= mod_num a b < |b|
+
+A correct but slow implementation is:
+
+      quo_num a b =
+        if b >= 0 then floor_num (div_num a b)
+                  else minus_num (floor_num (div_num a (minus_num b)))
+
+      mod_num a b =
+        sub_num a (mult_num b (quo_num a b))
+
+  However, this definition is vastly inefficient (cf PR #3473):
+  we define here a better way of computing the same thing.
+
+  PR#6753: the previous implementation was based on
+    quo_num a b = floor_num (div_num a b)
+  which is incorrect for negative b.
+*)
+
+let quo_num n1 n2 =
+  match n1, n2 with
+  | Int i1, Int i2 ->
+      let q = i1 / i2 and r = i1 mod i2 in
+      Int (if r >= 0 then q else if i2 > 0 then q - 1 else q + 1)
+  | Int i1, Big_int bi2 ->
+      num_of_big_int (div_big_int (big_int_of_int i1) bi2)
+  | Int i1, Ratio r2 ->
+      num_of_big_int (report_sign_ratio r2
+                         (floor_ratio (div_int_ratio i1 (abs_ratio r2))))
+  | Big_int bi1, Int i2 ->
+      num_of_big_int (div_big_int bi1 (big_int_of_int i2))
+  | Big_int bi1, Big_int bi2 ->
+      num_of_big_int (div_big_int bi1 bi2)
+  | Big_int bi1, Ratio r2 ->
+      num_of_big_int (report_sign_ratio r2
+                        (floor_ratio (div_big_int_ratio bi1 (abs_ratio r2))))
+  | Ratio r1, _ ->
+      let r2 = ratio_of_num n2 in
+      num_of_big_int (report_sign_ratio r2
+                        (floor_ratio (div_ratio r1 (abs_ratio r2))))
+
+let mod_num n1 n2 =
+  match n1, n2 with
+  | Int i1, Int i2 ->
+      let r = i1 mod i2 in
+      Int (if r >= 0 then r else if i2 > 0 then r + i2 else r - i2)
+  | Int i1, Big_int bi2 ->
+      num_of_big_int (mod_big_int (big_int_of_int i1) bi2)
+  | Big_int bi1, Int i2 ->
+      num_of_big_int (mod_big_int bi1 (big_int_of_int i2))
+  | Big_int bi1, Big_int bi2 ->
+      num_of_big_int (mod_big_int bi1 bi2)
+  | _, _ ->
+      sub_num n1 (mult_num n2 (quo_num n1 n2))
+
+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 _ as n -> n
+| Big_int _ as n -> n
+| Ratio r -> num_of_big_int (integer_ratio r)
+
+and round_num = function
+  Int _ as n -> n
+| Big_int _ as n -> n
+| Ratio r -> num_of_big_int (round_ratio r)
+
+and ceiling_num = function
+  Int _ as n -> n
+| Big_int _ 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
+
+let int_of_num_opt = function
+  Int i -> Some i
+| Big_int bi -> int_of_big_int_opt bi
+| Ratio r -> (try Some (int_of_ratio r) with Failure _ -> None)
+
+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)
+
+let nat_of_num_opt x =
+  try Some (nat_of_num x) with Failure _ -> None
+
+(* 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
+
+let big_int_of_num_opt x =
+  try Some (big_int_of_num x) with Failure _ -> None
+
+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 *)
+
+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"
+
+let num_of_string_opt s =
+  try Some (num_of_string s) with Failure _ -> None
+
+(* 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
+
+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..4d3793b9
--- /dev/null
+++ b/otherlibs/num/num.mli
@@ -0,0 +1,191 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 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.
+   Raise [Failure "num_of_string"] if the given string is not
+   a valid representation of an integer *)
+
+val num_of_string_opt: string -> num option
+(** Convert a string to a number.
+    Return [None] if the given string is not
+    a valid representation of an integer.
+
+    @since 4.05
+*)
+
+(** {6 Coercions between numerical types} *)
+
+(* TODO: document the functions below (truncating behavior and error conditions). *)
+
+val int_of_num : num -> int
+val int_of_num_opt: num -> int option
+(** @since 4.05.0 *)
+
+val num_of_int : int -> num
+val nat_of_num : num -> nat
+val nat_of_num_opt: num -> nat option
+(** @since 4.05.0 *)
+
+val num_of_nat : nat -> num
+val num_of_big_int : big_int -> num
+val big_int_of_num : num -> big_int
+val big_int_of_num_opt: num -> big_int option
+(** @since 4.05.0 *)
+
+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..04f9c5e8
--- /dev/null
+++ b/otherlibs/num/ratio.ml
@@ -0,0 +1,619 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Int_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 =
+  ignore (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 =
+  ignore (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 =
+  ignore (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 =
+ ignore (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 =
+ ignore (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 =
+ ignore (normalize_ratio r1);
+ ignore (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 =
+ ignore (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 =
+ ignore (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 =
+ ignore (normalize_ratio r);
+ if is_integer_ratio r
+  then r.numerator
+ else failwith "big_int_of_ratio"
+
+let div_int_ratio i r =
+  ignore (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 =
+  ignore (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 =
+ ignore (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
+       s1 contains one more digit than desired for the round off operation *)
+     if n >= 0 then begin
+       let s1 =
+         string_of_nat
+           (nat_of_big_int
+                (div_big_int
+                   (base_power_big_int
+                       10 (succ n) (abs_big_int r.numerator))
+                   r.denominator)) in
+       (* Round up and add 1 in front if needed *)
+       let s2 =
+         if round_futur_last_digit (Bytes.unsafe_of_string s1) 0
+                                   (String.length s1)
+         then "1" ^ s1
+         else s1 in
+       let l2 = String.length s2 - 1 in
+       (*   if s2 without last digit is xxxxyyy with n 'yyy' digits:
+               <sign> xxxx . yyy
+            if s2 without last digit is      yy with <= n digits:
+               <sign> 0 . 0yy *)
+       if l2 > n then begin
+         let s = Bytes.make (l2 + 2) '0' in
+         Bytes.set s 0  (if sign_r = -1 then '-' else '+');
+         String.blit s2 0 s 1 (l2 - n);
+         Bytes.set s (l2 - n + 1) '.';
+         String.blit s2 (l2 - n) s (l2 - n + 2) n;
+         Bytes.unsafe_to_string s
+       end else begin
+         let s = Bytes.make (n + 3) '0' in
+         Bytes.set s 0  (if sign_r = -1 then '-' else '+');
+         Bytes.set s 2 '.';
+         String.blit s2 0 s (n + 3 - l2) l2;
+         Bytes.unsafe_to_string s
+       end
+     end else begin
+       (* Dubious; what is this code supposed to do? *)
+       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' = Bytes.make len '0' in
+        Bytes.set s' 0 (if sign_r = -1 then '-' else '+');
+        String.blit s 0 s' 1 (pred len);
+        Bytes.unsafe_to_string 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
+     String.concat "" ["+0."; String.make n '0'; "e0"]
+   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 (Bytes.unsafe_of_string s) 0
+                               (String.length s)
+      then
+       let m = num_decimal_digits_int (succ msd) in
+       let str = Bytes.make (n + m + 4) '0' in
+         (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3);
+         Bytes.set str !i ('e');
+         incr i;
+         (if m = 0
+          then Bytes.set str !i '0'
+          else String.blit (string_of_int (succ msd)) 0 str !i m);
+         Bytes.unsafe_to_string str
+     else
+      let m = num_decimal_digits_int (succ msd)
+      and p = n + 3 in
+      let str = Bytes.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);
+        Bytes.set str p 'e';
+        (if m = 0
+          then Bytes.set str (succ p) '0'
+          else (String.blit (string_of_int (succ msd)) 0 str (succ p) m));
+        Bytes.unsafe_to_string 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 =
+ ignore (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.
+  | I have strongly simplified "ratio_of_string" by deleting scientific notation
+*)
+
+let ratio_of_string s =
+  try
+    let n = String.index s '/' in
+    create_ratio (sys_big_int_of_string s 0 n)
+                 (sys_big_int_of_string s (n+1) (String.length s - n - 1))
+  with Not_found ->
+    { numerator = big_int_of_string s;
+      denominator = unit_big_int;
+      normalized = true }
+
+(* Coercion with type float *)
+
+let float_of_ratio r =
+  let p = r.numerator and q = r.denominator in
+  (* Special cases 0/0, 0/q and p/0 *)
+  if sign_big_int q = 0 then begin
+    match sign_big_int p with
+    | 0 -> nan
+    | 1 -> infinity
+    | -1 -> neg_infinity
+    | _ -> assert false
+    end
+  else if sign_big_int p = 0 then 0.0
+  else begin
+    let np = num_bits_big_int p and nq = num_bits_big_int q in
+    if np <= 53 && nq <= 53 then
+      (* p and q convert to floats exactly; use FP division to get the
+         correctly-rounded result. *)
+      Int64.to_float (int64_of_big_int p)
+         /. Int64.to_float (int64_of_big_int q)
+    else begin
+      let ap = abs_big_int p in
+      (* |p| is in [2^(np-1), 2^np)
+         q is in [2^(nq-1), 2^nq)
+         hence |p|/q is in (2^(np-nq-1), 2^(np-nq+1)).
+         We define n such that |p|/q*2^n is in [2^54, 2^56).
+         >= 2^54 so that the round to odd technique applies.
+         < 2^56 so that the integral part is representable as an int64. *)
+      let n = 55 - (np - nq) in
+      (* Scaling |p|/q by 2^n *)
+      let (p', q') =
+        if n >= 0
+        then (shift_left_big_int ap n, q)
+        else (ap, shift_left_big_int q (-n)) in
+      (* Euclidean division of p' by q' *)
+      let (quo, rem) = quomod_big_int p' q' in
+      (* quo is the integral part of |p|/q*2^n
+         rem/q' is the fractional part. *)
+      (* Round quo to float *)
+      let f = round_big_int_to_float quo (sign_big_int rem = 0) in
+      (* Apply exponent *)
+      let f = ldexp f (-n) in
+      (* Apply sign *)
+      if sign_big_int p < 0 then -. f else f
+    end
+  end
+
+
+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..4a765051
--- /dev/null
+++ b/otherlibs/num/ratio.mli
@@ -0,0 +1,93 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*     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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Operation on rational numbers.
+
+    This module is used to support the implementation of {!Num} and
+    should not be called directly. *)
+
+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 (* assumes nothing *)
+val create_normalized_ratio : big_int -> big_int -> ratio
+                              (* assumes normalized argument *)
+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/raw_spacetime_lib/.depend b/otherlibs/raw_spacetime_lib/.depend
new file mode 100644
index 00000000..99c90a4a
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/.depend
@@ -0,0 +1,54 @@
+aProf.cmi :
+camlinternalAProf.cmi :
+aProf.cmo : aProf.cmi
+aProf.cmx : aProf.cmi
+camlinternalAProf.cmo : camlinternalAProf.cmi
+camlinternalAProf.cmx : camlinternalAProf.cmi
+aProf.cmi :
+camlinternalAProf.cmi :
+aProf.cmo : camlinternalAProf.cmi aProf.cmi
+aProf.cmx : camlinternalAProf.cmx aProf.cmi
+camlinternalAProf.cmo : camlinternalAProf.cmi
+camlinternalAProf.cmx : camlinternalAProf.cmi
+aProf.cmi :
+rawAProf.cmi :
+aProf.cmo : aProf.cmi
+aProf.cmx : aProf.cmi
+rawAProf.cmo : rawAProf.cmi
+rawAProf.cmx : rawAProf.cmi
+aProf.cmo : rawAProf.cmi aProf.cmi
+aProf.cmx : rawAProf.cmx aProf.cmi
+aProf.cmi :
+rawAProf.cmo : rawAProf.cmi
+rawAProf.cmx : rawAProf.cmi
+rawAProf.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+spacetime_lib.cmo : raw_spacetime_lib.cmi spacetime_lib.cmi
+spacetime_lib.cmx : raw_spacetime_lib.cmx spacetime_lib.cmi
+spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
diff --git a/otherlibs/raw_spacetime_lib/Makefile b/otherlibs/raw_spacetime_lib/Makefile
new file mode 100644
index 00000000..7e4bf2c7
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile
@@ -0,0 +1,83 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for Raw_spacetime_lib
+
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
+CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
+        -I $(ROOTDIR)/stdlib
+CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
+
+# The remainder of this file could probably be simplified by including
+# ../Makefile.
+
+LIBNAME=raw_spacetime_lib
+CAMLOBJS=raw_spacetime_lib.cmo
+
+CC=$(BYTECC)
+COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS)
+
+CMIFILES=$(CAMLOBJS:.cmo=.cmi)
+CAMLOBJS_NAT=$(CAMLOBJS:.cmo=.cmx)
+
+all: $(LIBNAME).cma $(CMIFILES)
+
+allopt: $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
+
+$(LIBNAME).cma: $(CAMLOBJS)
+	$(CAMLC) -a -o $(LIBNAME).cma -linkall $(CAMLOBJS)
+
+$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
+	$(CAMLOPT) -a -o $(LIBNAME).cmxa -linkall $(CAMLOBJS_NAT)
+
+$(LIBNAME).cmxs: $(LIBNAME).cmxa
+	$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+install::
+	cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(INSTALL_LIBDIR)
+
+installopt:
+	cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALL_LIBDIR)/
+	if test -f $(LIBNAME).cmxs; then \
+	  cp $(LIBNAME).cmxs $(INSTALL_LIBDIR)/; \
+	fi
+
+partialclean:
+	rm -f *.cm*
+
+clean:: partialclean
+	rm -f *.a *.o
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+depend:
+	$(CAMLRUN) $(ROOTDIR)/tools/ocamldep *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/raw_spacetime_lib/Makefile.nt b/otherlibs/raw_spacetime_lib/Makefile.nt
new file mode 100644
index 00000000..16e27354
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
new file mode 100644
index 00000000..e1010a9f
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
@@ -0,0 +1,644 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Gc_stats : sig
+  type t
+
+  val minor_words : t -> int
+  val promoted_words : t -> int
+  val major_words : t -> int
+  val minor_collections : t -> int
+  val major_collections : t -> int
+  val heap_words : t -> int
+  val heap_chunks : t -> int
+  val compactions : t -> int
+  val top_heap_words : t -> int
+end = struct
+  type t = {
+    minor_words : int;
+    promoted_words : int;
+    major_words : int;
+    minor_collections : int;
+    major_collections : int;
+    heap_words : int;
+    heap_chunks : int;
+    compactions : int;
+    top_heap_words : int;
+  }
+
+  let minor_words t = t.minor_words
+  let promoted_words t = t.promoted_words
+  let major_words t = t.major_words
+  let minor_collections t = t.minor_collections
+  let major_collections t = t.major_collections
+  let heap_words t = t.heap_words
+  let heap_chunks t = t.heap_chunks
+  let compactions t = t.compactions
+  let top_heap_words t = t.top_heap_words
+end
+
+module Program_counter = struct
+  module OCaml = struct
+    type t = Int64.t
+
+    let to_int64 t = t
+  end
+
+  module Foreign = struct
+    type t = Int64.t
+
+    let to_int64 t = t
+  end
+end
+
+module Function_identifier = struct
+  type t = Int64.t
+
+  let to_int64 t = t
+end
+
+module Function_entry_point = struct
+  type t = Int64.t
+
+  let to_int64 t = t
+end
+
+module Int64_map = Map.Make (Int64)
+
+module Frame_table = struct
+  type raw = (Int64.t * (Printexc.Slot.t list)) list
+
+  type t = Printexc.Slot.t list Int64_map.t
+
+  let demarshal chn : t =
+    let raw : raw = Marshal.from_channel chn in
+    List.fold_left (fun map (pc, rev_location_list) ->
+        Int64_map.add pc (List.rev rev_location_list) map)
+      Int64_map.empty
+      raw
+
+  let find_exn = Int64_map.find
+end
+
+module Shape_table = struct
+  type part_of_shape =
+    | Direct_call of { call_site : Int64.t; callee : Int64.t; }
+    | Indirect_call of Int64.t
+    | Allocation_point of Int64.t
+
+  let _ = Direct_call { call_site = 0L; callee = 0L; }
+  let _ = Indirect_call 0L
+  let _ = Allocation_point 0L
+
+  let part_of_shape_size = function
+    | Direct_call _
+    | Indirect_call _ -> 1
+    | Allocation_point _ -> 3
+
+  type raw = (Int64.t * (part_of_shape list)) list
+
+  type t = part_of_shape list Int64_map.t
+
+  let demarshal chn : t =
+    let raw : raw = Marshal.from_channel chn in
+    List.fold_left (fun map (key, data) -> Int64_map.add key data map)
+      Int64_map.empty
+      raw
+
+  let find_exn = Int64_map.find
+end
+
+module Annotation = struct
+  type t = int
+
+  let to_int t = t
+end
+
+module Trace = struct
+  type node
+  type ocaml_node
+  type foreign_node
+  type uninstrumented_node
+
+  type t = node option
+
+  (* This function unmarshals into malloc blocks, which mean that we
+     obtain a straightforward means of writing [compare] on [node]s. *)
+  external unmarshal : in_channel -> 'a
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_unmarshal_trie"
+
+  let unmarshal in_channel =
+    let trace = unmarshal in_channel in
+    if trace = () then
+      None
+    else
+      Some ((Obj.magic trace) : node)
+
+  let node_is_null (node : node) =
+    ((Obj.magic node) : unit) == ()
+
+  let foreign_node_is_null (node : foreign_node) =
+    ((Obj.magic node) : unit) == ()
+
+  external node_num_header_words : unit -> int
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_node_num_header_words" "noalloc"
+
+  let num_header_words = lazy (node_num_header_words ())
+
+  module OCaml = struct
+    type field_iterator = {
+      node : ocaml_node;
+      offset : int;
+      part_of_shape : Shape_table.part_of_shape;
+      remaining_layout : Shape_table.part_of_shape list;
+      shape_table : Shape_table.t;
+    }
+
+    module Allocation_point = struct
+      type t = field_iterator
+
+      let program_counter t =
+        match t.part_of_shape with
+        | Shape_table.Allocation_point call_site -> call_site
+        | _ -> assert false
+
+      external annotation : ocaml_node -> int -> Annotation.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_allocation_point_annotation"
+          "noalloc"
+
+      let annotation t = annotation t.node t.offset
+
+      external count : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_allocation_point_count"
+          "noalloc"
+
+      let num_words_including_headers t = count t.node t.offset
+    end
+
+    module Direct_call_point = struct
+      type _ t = field_iterator
+
+      let call_site t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call { call_site; _ } -> call_site
+        | _ -> assert false
+
+      let callee t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call { callee; _ } -> callee
+        | _ -> assert false
+
+      external callee_node : ocaml_node -> int -> 'target
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_direct_call_point_callee_node"
+
+      let callee_node (type target) (t : target t) : target =
+        callee_node t.node t.offset
+    end
+
+    module Indirect_call_point = struct
+      type t = field_iterator
+
+      let call_site t =
+        match t.part_of_shape with
+        | Shape_table.Indirect_call call_site -> call_site
+        | _ -> assert false
+
+      module Callee = struct
+        (* CR-soon mshinwell: we should think about the names again.  This is
+           a "c_node" but it isn't foreign. *)
+        type t = foreign_node
+
+        let is_null = foreign_node_is_null
+
+        (* CR-soon mshinwell: maybe rename ...c_node_call_site -> c_node_pc,
+           since it isn't a call site in this case. *)
+        external callee : t -> Function_entry_point.t
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_call_site"
+
+        (* This can return a node satisfying "is_null" in the case of an
+           uninitialised tail call point.  See the comment in the C code. *)
+        external callee_node : t -> node
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_callee_node" "noalloc"
+
+        external next : t -> foreign_node
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_next" "noalloc"
+
+        let next t =
+          let next = next t in
+          if foreign_node_is_null next then None
+          else Some next
+      end
+
+      external callees : ocaml_node -> int -> Callee.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_indirect_call_point_callees"
+          "noalloc"
+
+      let callees t =
+        let callees = callees t.node t.offset in
+        if Callee.is_null callees then None
+        else Some callees
+    end
+
+    module Field = struct
+      type t = field_iterator
+
+      type direct_call_point =
+        | To_ocaml of ocaml_node Direct_call_point.t
+        | To_foreign of foreign_node Direct_call_point.t
+        | To_uninstrumented of
+            uninstrumented_node Direct_call_point.t
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Direct_call of direct_call_point
+        | Indirect_call of Indirect_call_point.t
+
+      external classify_direct_call_point : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_classify_direct_call_point"
+          "noalloc"
+
+      let classify t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call callee ->
+          let direct_call_point =
+            match classify_direct_call_point t.node t.offset with
+            | 0 ->
+              (* We should never classify uninitialised call points here. *)
+              assert false
+            | 1 -> To_ocaml t
+            | 2 -> To_foreign t
+            | _ -> assert false
+          in
+          Direct_call direct_call_point
+        | Shape_table.Indirect_call _ -> Indirect_call t
+        | Shape_table.Allocation_point _ -> Allocation t
+
+      (* CR-soon mshinwell: change to "is_unused"? *)
+      let is_uninitialised t =
+        let offset_to_node_hole =
+          match t.part_of_shape with
+          | Shape_table.Direct_call _ -> Some 0
+          | Shape_table.Indirect_call _ -> Some 0
+          | Shape_table.Allocation_point _ -> None
+        in
+        match offset_to_node_hole with
+        | None -> false
+        | Some offset_to_node_hole ->
+          (* There are actually two cases:
+             1. A normal unused node hole, which says Val_unit;
+             2. An unused tail call point.  This will contain a pointer to the
+                start of the current node, but it also has the bottom bit
+                set. *)
+          let offset = t.offset + offset_to_node_hole in
+          Obj.is_int (Obj.field (Obj.repr t.node) offset)
+
+      let rec next t =
+        match t.remaining_layout with
+        | [] -> None
+        | part_of_shape::remaining_layout ->
+          let size = Shape_table.part_of_shape_size t.part_of_shape in
+          let offset = t.offset + size in
+          assert (offset < Obj.size (Obj.repr t.node));
+          let t =
+            { node = t.node;
+              offset;
+              part_of_shape;
+              remaining_layout;
+              shape_table = t.shape_table;
+            }
+          in
+          skip_uninitialised t
+
+      and skip_uninitialised t =
+        if not (is_uninitialised t) then Some t
+        else next t
+    end
+
+    module Node = struct
+      type t = ocaml_node
+
+      external function_identifier : t -> Function_identifier.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_function_identifier"
+
+      external next_in_tail_call_chain : t -> t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_tail_chain" "noalloc"
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+
+      let fields t ~shape_table =
+        match Shape_table.find_exn (function_identifier t) shape_table with
+        | exception Not_found -> None
+        | [] -> None
+        | part_of_shape::remaining_layout ->
+          let t =
+            { node = t;
+              offset = Lazy.force num_header_words;
+              part_of_shape;
+              remaining_layout;
+              shape_table;
+            }
+          in
+          Field.skip_uninitialised t
+    end
+  end
+
+  module Foreign = struct
+    module Node = struct
+      type t = foreign_node
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+
+      let fields t =
+        if foreign_node_is_null t then None
+        else Some t
+    end
+
+    module Allocation_point = struct
+      type t = foreign_node
+
+      external program_counter : t -> Program_counter.Foreign.t
+        (* This is not a mistake; the same C function works. *)
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_call_site"
+
+      external annotation : t -> Annotation.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_profinfo" "noalloc"
+
+      external num_words_including_headers : t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_allocation_count" "noalloc"
+    end
+
+    module Call_point = struct
+      type t = foreign_node
+
+      external call_site : t -> Program_counter.Foreign.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_call_site"
+
+      (* May return a null node.  See comment above and the C code. *)
+      external callee_node : t -> node
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_callee_node" "noalloc"
+    end
+
+    module Field = struct
+      type t = foreign_node
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Call of Call_point.t
+
+      external is_call : t -> bool
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_is_call" "noalloc"
+
+      let classify t =
+        if is_call t then Call t
+        else Allocation t
+
+      external next : t -> t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_next" "noalloc"
+
+      let next t =
+        let next = next t in
+        if foreign_node_is_null next then None
+        else Some next
+    end
+  end
+
+  module Node = struct
+    module T = struct
+      type t = node
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+    end
+
+    include T
+
+    type classification =
+      | OCaml of OCaml.Node.t
+      | Foreign of Foreign.Node.t
+
+    (* CR-soon lwhite: These functions should work in bytecode *)
+    external is_ocaml_node : t -> bool
+      = "caml_spacetime_only_works_for_native_code"
+        "caml_spacetime_is_ocaml_node" "noalloc"
+
+    let classify t =
+      if is_ocaml_node t then OCaml ((Obj.magic t) : ocaml_node)
+      else Foreign ((Obj.magic t) : foreign_node)
+
+    let of_ocaml_node (node : ocaml_node) : t = Obj.magic node
+    let of_foreign_node (node : foreign_node) : t = Obj.magic node
+
+    module Map = Map.Make (T)
+    module Set = Set.Make (T)
+  end
+
+  let root t = t
+end
+
+module Heap_snapshot = struct
+
+  module Entries = struct
+    type t = int array  (* == "struct snapshot_entries" *)
+
+    let length t =
+      let length = Array.length t in
+      assert (length mod 3 = 0);
+      length / 3
+
+    let annotation t idx = t.(idx*3)
+    let num_blocks t idx = t.(idx*3 + 1)
+    let num_words_including_headers t idx = t.(idx*3 + 2)
+  end
+
+  type total_allocations =
+    | End
+    | Total of {
+        annotation : Annotation.t;
+        count : int;
+        next : total_allocations;
+      }
+
+  let (_ : total_allocations) =  (* suppress compiler warning *)
+    Total { annotation = 0; count = 0; next = End; }
+
+  type t = {
+    timestamp : float;
+    gc_stats : Gc_stats.t;
+    entries : Entries.t;
+    words_scanned : int;
+    words_scanned_with_profinfo : int;
+    total_allocations : total_allocations;
+  }
+
+  type heap_snapshot = t
+
+  let timestamp t = t.timestamp
+  let gc_stats t = t.gc_stats
+  let entries t = t.entries
+  let words_scanned t = t.words_scanned
+  let words_scanned_with_profinfo t = t.words_scanned_with_profinfo
+
+  module Total_allocation = struct
+    type t = total_allocations  (* [End] is forbidden *)
+
+    let annotation = function
+      | End -> assert false
+      | Total { annotation; _ } -> annotation
+
+    let num_words_including_headers = function
+      | End -> assert false
+      | Total { count; _ } -> count
+
+    let next = function
+      | End -> assert false
+      | Total { next = End; _ } -> None
+      | Total { next; _ } -> Some next
+  end
+
+  let total_allocations t =
+    match t.total_allocations with
+    | End -> None
+    | (Total _) as totals -> Some totals
+
+  module Event = struct
+    type t = {
+      event_name : string;
+      time : float;
+    }
+
+    let event_name t = t.event_name
+    let timestamp t = t.time
+  end
+
+  module Series = struct
+    type t = {
+      num_snapshots : int;
+      time_of_writer_close : float;
+      frame_table : Frame_table.t;
+      shape_table : Shape_table.t;
+      traces_by_thread : Trace.t array;
+      finaliser_traces_by_thread : Trace.t array;
+      snapshots : heap_snapshot array;
+      events : Event.t list;
+    }
+
+    let pathname_suffix_trace = "trace"
+
+    (* The order of these constructors must match the C code. *)
+    type what_comes_next =
+      | Snapshot
+      | Traces
+      | Event
+
+    (* Suppress compiler warning 37. *)
+    let _ : what_comes_next list = [Snapshot; Traces; Event;]
+
+    let rec read_snapshots_and_events chn snapshots events =
+      let next : what_comes_next = Marshal.from_channel chn in
+      match next with
+      | Snapshot ->
+        let snapshot : heap_snapshot = Marshal.from_channel chn in
+        read_snapshots_and_events chn (snapshot :: snapshots) events
+      | Event ->
+        let event_name : string = Marshal.from_channel chn in
+        let time : float = Marshal.from_channel chn in
+        let event = { Event. event_name; time; } in
+        read_snapshots_and_events chn snapshots (event :: events)
+      | Traces ->
+        (Array.of_list (List.rev snapshots)), List.rev events
+
+    let read ~path =
+      let chn = open_in path in
+      let magic_number : int = Marshal.from_channel chn in
+      let magic_number_base = magic_number land 0xffff_ffff in
+      let version_number = magic_number lsr 32 in
+      if magic_number_base <> 0xace00ace then begin
+        failwith "Raw_spacetime_lib: not a Spacetime profiling file"
+      end else begin
+        match version_number with
+        | 0 ->
+          let snapshots, events = read_snapshots_and_events chn [] [] in
+          let num_snapshots = Array.length snapshots in
+          let time_of_writer_close : float = Marshal.from_channel chn in
+          let frame_table = Frame_table.demarshal chn in
+          let shape_table = Shape_table.demarshal chn in
+          let num_threads : int = Marshal.from_channel chn in
+          let traces_by_thread = Array.init num_threads (fun _ -> None) in
+          let finaliser_traces_by_thread =
+            Array.init num_threads (fun _ -> None)
+          in
+          for thread = 0 to num_threads - 1 do
+            let trace : Trace.t = Trace.unmarshal chn in
+            let finaliser_trace : Trace.t = Trace.unmarshal chn in
+            traces_by_thread.(thread) <- trace;
+            finaliser_traces_by_thread.(thread) <- finaliser_trace
+          done;
+          close_in chn;
+          { num_snapshots;
+            time_of_writer_close;
+            frame_table;
+            shape_table;
+            traces_by_thread;
+            finaliser_traces_by_thread;
+            snapshots;
+            events;
+          }
+        | _ ->
+          failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
+            version number"
+      end
+
+    type trace_kind = Normal | Finaliser
+
+    let num_threads t = Array.length t.traces_by_thread
+
+    let trace t ~kind ~thread_index =
+      if thread_index < 0 || thread_index >= num_threads t then None
+      else
+        match kind with
+        | Normal -> Some t.traces_by_thread.(thread_index)
+        | Finaliser -> Some t.finaliser_traces_by_thread.(thread_index)
+
+    let num_snapshots t = t.num_snapshots
+    let snapshot t ~index = t.snapshots.(index)
+    let frame_table t = t.frame_table
+    let shape_table t = t.shape_table
+    let time_of_writer_close t = t.time_of_writer_close
+    let events t = t.events
+  end
+end
diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
new file mode 100644
index 00000000..51bbc91f
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
@@ -0,0 +1,349 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Access to the information recorded by the [Spacetime]
+    module.  (It is intended that this module will be used by
+    post-processors rather than users wishing to understand their
+    programs.)
+    For 64-bit targets only.
+    This module may be used from any program, not just one compiled
+    with a compiler configured for Spacetime. *)
+
+module Gc_stats : sig
+  type t
+
+  val minor_words : t -> int
+  val promoted_words : t -> int
+  val major_words : t -> int
+  val minor_collections : t -> int
+  val major_collections : t -> int
+  val heap_words : t -> int
+  val heap_chunks : t -> int
+  val compactions : t -> int
+  val top_heap_words : t -> int
+end
+
+module Annotation : sig
+  (** An annotation written into a value's header.  These may be looked up
+      in a [Trace.t] (see below). *)
+  type t
+
+  (* CR-someday mshinwell: consider using tag and size to increase the
+     available space of annotations.  Need to be careful of [Obj.truncate].
+     Could also randomise the tags on records.
+  *)
+
+  val to_int : t -> int
+end
+
+module Program_counter : sig
+  module OCaml : sig
+    type t
+
+    val to_int64 : t -> Int64.t
+  end
+
+  module Foreign : sig
+    type t
+
+    val to_int64 : t -> Int64.t
+  end
+
+end
+
+module Frame_table : sig
+  (* CR-someday mshinwell: move to [Gc] if dependencies permit? *)
+  (** A value of type [t] corresponds to the frame table of a running
+      OCaml program.  The table is indexed by program counter address
+      (typically, but not always when using Spacetime, return addresses). *)
+  type t
+
+  (** Find the location, including any inlined frames, corresponding to the
+      given program counter address.  Raises [Not_found] if the location
+      could not be resolved. *)
+  val find_exn : Program_counter.OCaml.t -> t -> Printexc.Slot.t list
+end
+
+module Function_entry_point : sig
+  type t
+
+  val to_int64 : t -> Int64.t
+end
+
+module Function_identifier : sig
+  type t
+  (* CR-soon mshinwell: same as [Function_entry_point] now *)
+  val to_int64 : t -> Int64.t
+end
+
+module Shape_table : sig
+  type t
+end
+
+module Trace : sig
+  (** A value of type [t] holds the dynamic call structure of the program
+      (i.e. which functions have called which other functions) together with
+      information required to decode profiling annotations written into
+      values' headers. *)
+  type t
+
+  type node
+  type ocaml_node
+  type foreign_node
+  type uninstrumented_node
+
+  module OCaml : sig
+    module Allocation_point : sig
+      (** A value of type [t] corresponds to an allocation point in OCaml
+          code. *)
+      type t
+
+      (** The program counter at (or close to) the allocation site. *)
+      val program_counter : t -> Program_counter.OCaml.t
+
+      (** The annotation written into the headers of boxed values allocated
+          at the given allocation site. *)
+      val annotation : t -> Annotation.t
+
+      (** The total number of words allocated at this point. *)
+      val num_words_including_headers : t -> int
+    end
+
+    module Direct_call_point : sig
+      (** A value of type ['target t] corresponds to a direct (i.e. known
+          at compile time) call point in OCaml code.  ['target] is the type
+          of the node corresponding to the callee. *)
+      type 'target t
+
+      (** The program counter at (or close to) the call site. *)
+      val call_site : _ t -> Program_counter.OCaml.t
+
+      (** The address of the first instruction of the callee. *)
+      val callee : _ t -> Function_entry_point.t
+
+      (** The node corresponding to the callee. *)
+      val callee_node : 'target t -> 'target
+    end
+
+    module Indirect_call_point : sig
+      (** A value of type [t] corresponds to an indirect call point in OCaml
+          code.  Each such value contains a list of callees to which the
+          call point has branched. *)
+      type t
+
+      (** The program counter at (or close to) the call site. *)
+      val call_site : t -> Program_counter.OCaml.t
+
+      module Callee : sig
+        type t
+
+        (** The address of the first instruction of the callee. *)
+        val callee : t -> Function_entry_point.t
+
+        (** The node corresponding to the callee. *)
+        val callee_node : t -> node
+
+        (** Move to the next callee to which this call point has branched.
+            [None] is returned when the end of the list is reached. *)
+        val next : t -> t option
+      end
+
+      (** The list of callees to which this indirect call point has
+          branched. *)
+      val callees : t -> Callee.t option
+    end
+
+    module Field : sig
+      (** A value of type [t] enables iteration through the contents
+          ("fields") of an OCaml node. *)
+      type t
+
+      type direct_call_point =
+        | To_ocaml of ocaml_node Direct_call_point.t
+        | To_foreign of foreign_node Direct_call_point.t
+        (* CR-soon mshinwell: once everything's finished, "uninstrumented"
+           should be able to go away.  Let's try to do this after the
+           first release. *)
+        | To_uninstrumented of
+            uninstrumented_node Direct_call_point.t
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Direct_call of direct_call_point
+        | Indirect_call of Indirect_call_point.t
+
+      val classify : t -> classification
+      val next : t -> t option
+    end
+
+    module Node : sig
+      (** A node corresponding to an invocation of a function written in
+          OCaml. *)
+      type t = ocaml_node
+
+      val compare : t -> t -> int
+
+      (** A unique identifier for the function corresponding to this node. *)
+      val function_identifier : t -> Function_identifier.t
+
+      (** This function traverses a circular list. *)
+      val next_in_tail_call_chain : t -> t
+
+      val fields : t -> shape_table:Shape_table.t -> Field.t option
+    end
+  end
+
+  module Foreign : sig
+    module Allocation_point : sig
+      (** A value of type [t] corresponds to an allocation point in non-OCaml
+          code. *)
+      type t
+
+      val program_counter : t -> Program_counter.Foreign.t
+      val annotation : t -> Annotation.t
+      val num_words_including_headers : t -> int
+    end
+
+    module Call_point : sig
+      (** A value of type [t] corresponds to a call point from non-OCaml
+          code (to either non-OCaml code, or OCaml code via the usual
+          assembly veneer). *)
+      type t
+
+      (** N.B. The address of the callee (of type [Function_entry_point.t]) is
+          not available.  It must be recovered during post-processing. *)
+      val call_site : t -> Program_counter.Foreign.t
+      val callee_node : t -> node
+    end
+
+    module Field : sig
+      (** A value of type [t] enables iteration through the contents ("fields")
+          of a C node. *)
+      type t
+
+      type classification = private
+        | Allocation of Allocation_point.t
+        | Call of Call_point.t
+
+      val classify : t -> classification
+      val next : t -> t option
+    end
+
+    module Node : sig
+      (** A node corresponding to an invocation of a function written in C
+          (or any other language that is not OCaml). *)
+      type t = foreign_node
+
+      val compare : t -> t -> int
+
+      val fields : t -> Field.t option
+
+    end
+
+  end
+
+  module Node : sig
+    (** Either an OCaml or a foreign node; or an indication that this
+        is a branch of the graph corresponding to uninstrumented
+        code. *)
+    type t = node
+
+    val compare : t -> t -> int
+
+    type classification = private
+      | OCaml of OCaml.Node.t
+      | Foreign of Foreign.Node.t
+
+    val classify : t -> classification
+
+    val of_ocaml_node : OCaml.Node.t -> t
+    val of_foreign_node : Foreign.Node.t -> t
+
+    module Set : Set.S with type elt = t
+    module Map : Map.S with type key = t
+  end
+
+  (** Obtains the root of the graph for traversal.  [None] is returned if
+      the graph is empty. *)
+  val root : t -> Node.t option
+end
+
+module Heap_snapshot : sig
+  type t
+  type heap_snapshot = t
+
+  module Entries : sig
+    (** An immutable array of the total number of blocks (= boxed
+        values) and the total number of words occupied by such blocks
+        (including their headers) for each profiling annotation in
+        the heap. *)
+    type t
+
+    val length : t -> int
+    val annotation : t -> int -> Annotation.t
+    val num_blocks : t -> int -> int
+    val num_words_including_headers : t -> int -> int
+
+  end
+
+  (** The timestamp of a snapshot.  The units are as for [Sys.time]
+      (unless custom timestamps are being provided, cf. the [Spacetime] module
+      in the standard library). *)
+  val timestamp : t -> float
+
+  val gc_stats : t -> Gc_stats.t
+  val entries : t -> Entries.t
+  val words_scanned : t -> int
+  val words_scanned_with_profinfo : t -> int
+
+  module Total_allocation : sig
+    type t
+
+    val annotation : t -> Annotation.t
+    val num_words_including_headers : t -> int
+    val next : t -> t option
+  end
+  (** Total allocations across *all threads*. *)
+  (* CR-someday mshinwell: change the relevant variables to be thread-local *)
+  val total_allocations : t -> Total_allocation.t option
+
+  module Event : sig
+    type t
+
+    val event_name : t -> string
+    val timestamp : t -> float
+  end
+
+  module Series : sig
+    type t
+
+    (** At present, the [Trace.t] associated with a [Series.t] cannot be
+        garbage collected or freed.  This should not be a problem, since
+        the intention is that a post-processor reads the trace and outputs
+        another format. *)
+    val read : path:string -> t
+
+    val time_of_writer_close : t -> float
+    val num_threads : t -> int
+
+    type trace_kind = Normal | Finaliser
+    val trace : t -> kind:trace_kind -> thread_index:int -> Trace.t option
+
+    val frame_table : t -> Frame_table.t
+    val shape_table : t -> Shape_table.t
+    val num_snapshots : t -> int
+    val snapshot : t -> index:int -> heap_snapshot
+    val events : t -> Event.t list
+  end
+end
diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
new file mode 100644
index 00000000..6c0795d8
--- /dev/null
+++ b/otherlibs/str/.depend
@@ -0,0 +1,9 @@
+strstubs.o: strstubs.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/fail.h
+str.cmo : str.cmi
+str.cmx : str.cmi
+str.cmi :
diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
new file mode 100644
index 00000000..1e5d4bb2
--- /dev/null
+++ b/otherlibs/str/Makefile
@@ -0,0 +1,40 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the str library
+
+LIBNAME=str
+COBJS=strstubs.$(O)
+CLIBNAME=camlstr
+CAMLOBJS=str.cmo
+
+include ../Makefile
+
+str.cmo: str.cmi
+str.cmx: str.cmi
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+
+ifeq "$(TOOLCHAIN)" "msvc"
+
+.depend.nt: .depend
+	sed -e 's/\.o/.$(O)/g' $< > $@
+
+include .depend.nt
+else
+include .depend
+endif
diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/otherlibs/str/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
new file mode 100644
index 00000000..6242be7f
--- /dev/null
+++ b/otherlibs/str/str.ml
@@ -0,0 +1,754 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* In this module, [@ocaml.warning "-3"] is used in several places
+   that use deprecated functions to preserve legacy behavior.
+   It overrides -w @3 given on the command line. *)
+
+(** String utilities *)
+
+let string_before s n = String.sub s 0 n
+
+let string_after s n = String.sub s n (String.length s - n)
+
+let first_chars s n = String.sub s 0 n
+
+let last_chars s n = String.sub s (String.length s - n) n
+
+(** Representation of character sets **)
+
+module Charset =
+  struct
+    type t = bytes (* of length 32 *)
+
+    (*let empty = Bytes.make 32 '\000'*)
+    let full = Bytes.make 32 '\255'
+
+    let make_empty () = Bytes.make 32 '\000'
+
+    let add s c =
+      let i = Char.code c in
+      Bytes.set s (i lsr 3)
+                (Char.chr (Char.code (Bytes.get s (i lsr 3))
+                           lor (1 lsl (i land 7))))
+
+    let add_range s c1 c2 =
+      for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done
+
+    let singleton c =
+      let s = make_empty () in add s c; s
+
+    (*let range c1 c2 =
+      let s = make_empty () in add_range s c1 c2; s
+    *)
+    let complement s =
+      let r = Bytes.create 32 in
+      for i = 0 to 31 do
+        Bytes.set r i (Char.chr(Char.code (Bytes.get s i) lxor 0xFF))
+      done;
+      r
+
+    let union s1 s2 =
+      let r = Bytes.create 32 in
+      for i = 0 to 31 do
+        Bytes.set r i (Char.chr(Char.code (Bytes.get s1 i)
+                       lor Char.code (Bytes.get s2 i)))
+      done;
+      r
+
+    let disjoint s1 s2 =
+      try
+        for i = 0 to 31 do
+          if Char.code (Bytes.get s1 i) land Char.code (Bytes.get s2 i)
+             <> 0
+          then raise Exit
+        done;
+        true
+      with Exit ->
+        false
+
+    let iter fn s =
+      for i = 0 to 31 do
+        let c = Char.code (Bytes.get s i) in
+        if c <> 0 then
+          for j = 0 to 7 do
+            if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j))
+          done
+      done
+
+    let expand s =
+      let r = Bytes.make 256 '\000' in
+      iter (fun c -> Bytes.set r (Char.code c) '\001') s;
+      r
+
+    let fold_case s =
+      (let r = make_empty() in
+       iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s;
+       r)[@ocaml.warning "-3"]
+
+  end
+
+(** Abstract syntax tree for regular expressions *)
+
+type re_syntax =
+    Char of char
+  | String of string
+  | CharClass of Charset.t * bool  (* true = complemented, false = normal *)
+  | Seq of re_syntax list
+  | Alt of re_syntax * re_syntax
+  | Star of re_syntax
+  | Plus of re_syntax
+  | Option of re_syntax
+  | Group of int * re_syntax
+  | Refgroup of int
+  | Bol
+  | Eol
+  | Wordboundary
+
+(** Representation of compiled regular expressions *)
+
+type regexp = {
+  prog: int array;         (* bytecode instructions *)
+  cpool: string array;     (* constant pool (string literals) *)
+  normtable: string;       (* case folding table (if any) *)
+  numgroups: int;          (* number of \(...\) groups *)
+  numregisters: int;       (* number of nullable Star or Plus *)
+  startchars: int          (* index of set of starting chars, or -1 if none *)
+}
+
+(** Opcodes for bytecode instructions; see strstubs.c for description *)
+
+let op_CHAR = 0
+let op_CHARNORM = 1
+let op_STRING = 2
+let op_STRINGNORM = 3
+let op_CHARCLASS = 4
+let op_BOL = 5
+let op_EOL = 6
+let op_WORDBOUNDARY = 7
+let op_BEGGROUP = 8
+let op_ENDGROUP = 9
+let op_REFGROUP = 10
+let op_ACCEPT = 11
+let op_SIMPLEOPT = 12
+let op_SIMPLESTAR = 13
+let op_SIMPLEPLUS = 14
+let op_GOTO = 15
+let op_PUSHBACK = 16
+let op_SETMARK = 17
+let op_CHECKPROGRESS = 18
+
+(* Encoding of bytecode instructions *)
+
+let instr opc arg = opc lor (arg lsl 8)
+
+(* Computing relative displacements for GOTO and PUSHBACK instructions *)
+
+let displ dest from = dest - from - 1
+
+(** Compilation of a regular expression *)
+
+(* Determine if a regexp can match the empty string *)
+
+let rec is_nullable = function
+    Char _ -> false
+  | String s -> s = ""
+  | CharClass _ -> false
+  | Seq rl -> List.for_all is_nullable rl
+  | Alt (r1, r2) -> is_nullable r1 || is_nullable r2
+  | Star _ -> true
+  | Plus r -> is_nullable r
+  | Option _ -> true
+  | Group(_, r) -> is_nullable r
+  | Refgroup _ -> true
+  | Bol -> true
+  | Eol -> true
+  | Wordboundary -> true
+
+(* first r returns a set of characters C such that:
+     for all string s, s matches r => the first character of s is in C.
+   For convenience, return Charset.full if r is nullable. *)
+
+let rec first = function
+    Char c -> Charset.singleton c
+  | String s -> if s = "" then Charset.full else Charset.singleton s.[0]
+  | CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl
+  | Seq rl -> first_seq rl
+  | Alt (r1, r2) -> Charset.union (first r1) (first r2)
+  | Star _ -> Charset.full
+  | Plus r -> first r
+  | Option _ -> Charset.full
+  | Group(_, r) -> first r
+  | Refgroup _ -> Charset.full
+  | Bol -> Charset.full
+  | Eol -> Charset.full
+  | Wordboundary -> Charset.full
+
+and first_seq = function
+    [] -> Charset.full
+  | (Bol | Eol | Wordboundary) :: rl -> first_seq rl
+  | Star r :: rl -> Charset.union (first r) (first_seq rl)
+  | Option r :: rl -> Charset.union (first r) (first_seq rl)
+  | r :: _ -> first r
+
+(* Transform a Char or CharClass regexp into a character class *)
+
+let charclass_of_regexp fold_case re =
+  let (cl1, compl) =
+    match re with
+    | Char c -> (Charset.singleton c, false)
+    | CharClass(cl, compl) -> (cl, compl)
+    | _ -> assert false in
+  let cl2 = if fold_case then Charset.fold_case cl1 else cl1 in
+  Bytes.to_string (if compl then Charset.complement cl2 else cl2)
+
+(* The case fold table: maps characters to their lowercase equivalent *)
+
+let fold_case_table =
+  (let t = Bytes.create 256 in
+   for i = 0 to 255 do Bytes.set t i (Char.lowercase(Char.chr i)) done;
+   Bytes.to_string t)[@ocaml.warning "-3"]
+
+module StringMap =
+  Map.Make(struct type t = string let compare (x:t) y = compare x y end)
+
+(* Compilation of a regular expression *)
+
+let compile fold_case re =
+
+  (* Instruction buffering *)
+  let prog = ref (Array.make 32 0)
+  and progpos = ref 0
+  and cpool = ref StringMap.empty
+  and cpoolpos = ref 0
+  and numgroups = ref 1
+  and numregs = ref 0 in
+  (* Add a new instruction *)
+  let emit_instr opc arg =
+    if !progpos >= Array.length !prog then begin
+      let newlen = ref (Array.length !prog) in
+      while !progpos >= !newlen do newlen := !newlen * 2 done;
+      let nprog = Array.make !newlen 0 in
+      Array.blit !prog 0 nprog 0 (Array.length !prog);
+      prog := nprog
+    end;
+    (!prog).(!progpos) <- (instr opc arg);
+    incr progpos in
+  (* Reserve an instruction slot and return its position *)
+  let emit_hole () =
+    let p = !progpos in emit_instr op_CHAR 0; p in
+  (* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *)
+  let patch_instr pos opc dest =
+    (!prog).(pos) <- (instr opc (displ dest pos)) in
+  (* Return the cpool index for the given string, adding it if not
+     already there *)
+  let cpool_index s =
+    try
+      StringMap.find s !cpool
+    with Not_found ->
+      let p = !cpoolpos in
+      cpool := StringMap.add s p !cpool;
+      incr cpoolpos;
+      p in
+  (* Allocate fresh register if regexp is nullable *)
+  let allocate_register_if_nullable r =
+    if is_nullable r then begin
+      let n = !numregs in
+      if n >= 64 then failwith "too many r* or r+ where r is nullable";
+      incr numregs;
+      n
+    end else
+      -1 in
+  (* Main recursive compilation function *)
+  let rec emit_code = function
+    Char c ->
+      if fold_case then
+        emit_instr op_CHARNORM (Char.code (Char.lowercase c))
+          [@ocaml.warning "-3"]
+      else
+        emit_instr op_CHAR (Char.code c)
+  | String s ->
+      begin match String.length s with
+        0 -> ()
+      | 1 ->
+        if fold_case then
+          emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0]))
+            [@ocaml.warning "-3"]
+        else
+          emit_instr op_CHAR (Char.code s.[0])
+      | _ ->
+        try
+          (* null characters are not accepted by the STRING* instructions;
+             if one is found, split string at null character *)
+          let i = String.index s '\000' in
+          emit_code (String (string_before s i));
+          emit_instr op_CHAR 0;
+          emit_code (String (string_after s (i+1)))
+        with Not_found ->
+          if fold_case then
+            emit_instr op_STRINGNORM (cpool_index (String.lowercase s))
+              [@ocaml.warning "-3"]
+          else
+            emit_instr op_STRING (cpool_index s)
+      end
+  | CharClass(cl, compl) ->
+      let cl1 = if fold_case then Charset.fold_case cl else cl in
+      let cl2 = if compl then Charset.complement cl1 else cl1 in
+      emit_instr op_CHARCLASS (cpool_index (Bytes.to_string cl2))
+  | Seq rl ->
+      emit_seq_code rl
+  | Alt(r1, r2) ->
+      (*      PUSHBACK lbl1
+              <match r1>
+              GOTO lbl2
+        lbl1: <match r2>
+        lbl2: ... *)
+      let pos_pushback = emit_hole() in
+      emit_code r1;
+      let pos_goto_end = emit_hole() in
+      let lbl1 = !progpos in
+      emit_code r2;
+      let lbl2 = !progpos in
+      patch_instr pos_pushback op_PUSHBACK lbl1;
+      patch_instr pos_goto_end op_GOTO lbl2
+  | Star r ->
+      (* Implement longest match semantics for compatibility with old Str *)
+      (* General translation:
+           lbl1: PUSHBACK lbl2
+                 SETMARK regno
+                 <match r>
+                 CHECKPROGRESS regno
+                 GOTO lbl1
+           lbl2:
+         If r cannot match the empty string, code can be simplified:
+           lbl1: PUSHBACK lbl2
+                 <match r>
+                 GOTO lbl1
+           lbl2:
+        *)
+      let regno = allocate_register_if_nullable r in
+      let lbl1 = emit_hole() in
+      if regno >= 0 then emit_instr op_SETMARK regno;
+      emit_code r;
+      if regno >= 0 then emit_instr op_CHECKPROGRESS regno;
+      emit_instr op_GOTO (displ lbl1 !progpos);
+      let lbl2 = !progpos in
+      patch_instr lbl1 op_PUSHBACK lbl2
+  | Plus r ->
+      (* Implement longest match semantics for compatibility with old Str *)
+      (* General translation:
+           lbl1: <match r>
+                 CHECKPROGRESS regno
+                 PUSHBACK lbl2
+                 SETMARK regno
+                 GOTO lbl1
+           lbl2:
+         If r cannot match the empty string, code can be simplified:
+           lbl1: <match r>
+                 PUSHBACK lbl2
+                 GOTO_PLUS lbl1
+           lbl2:
+      *)
+      let regno = allocate_register_if_nullable r in
+      let lbl1 = !progpos in
+      emit_code r;
+      if regno >= 0 then emit_instr op_CHECKPROGRESS regno;
+      let pos_pushback = emit_hole() in
+      if regno >= 0 then emit_instr op_SETMARK regno;
+      emit_instr op_GOTO (displ lbl1 !progpos);
+      let lbl2 = !progpos in
+      patch_instr pos_pushback op_PUSHBACK lbl2
+  | Option r ->
+      (* Implement longest match semantics for compatibility with old Str *)
+      (*      PUSHBACK lbl
+              <match r>
+         lbl:
+      *)
+      let pos_pushback = emit_hole() in
+      emit_code r;
+      let lbl = !progpos in
+      patch_instr pos_pushback op_PUSHBACK lbl
+  | Group(n, r) ->
+      emit_instr op_BEGGROUP n;
+      emit_code r;
+      emit_instr op_ENDGROUP n;
+      numgroups := max !numgroups (n+1)
+  | Refgroup n ->
+      emit_instr op_REFGROUP n;
+      numgroups := max !numgroups (n+1)
+  | Bol ->
+      emit_instr op_BOL 0
+  | Eol ->
+      emit_instr op_EOL 0
+  | Wordboundary ->
+      emit_instr op_WORDBOUNDARY 0
+
+  and emit_seq_code = function
+    [] -> ()
+  | Star(Char _ | CharClass _ as r) :: rl
+    when disjoint_modulo_case (first r) (first_seq rl) ->
+      emit_instr op_SIMPLESTAR (cpool_index (charclass_of_regexp fold_case r));
+      emit_seq_code rl
+  | Plus(Char _ | CharClass _ as r) :: rl
+    when disjoint_modulo_case (first r) (first_seq rl) ->
+      emit_instr op_SIMPLEPLUS (cpool_index (charclass_of_regexp fold_case r));
+      emit_seq_code rl
+  | Option(Char _ | CharClass _ as r) :: rl
+    when disjoint_modulo_case (first r) (first_seq rl) ->
+      emit_instr op_SIMPLEOPT (cpool_index (charclass_of_regexp fold_case r));
+      emit_seq_code rl
+  | r :: rl ->
+      emit_code r;
+      emit_seq_code rl
+
+  and disjoint_modulo_case c1 c2 =
+    if fold_case
+    then Charset.disjoint (Charset.fold_case c1) (Charset.fold_case c2)
+    else Charset.disjoint c1 c2
+  in
+
+  emit_code re;
+  emit_instr op_ACCEPT 0;
+  let start = first re in
+  let start' = if fold_case then Charset.fold_case start else start in
+  let start_pos =
+    if start = Charset.full
+    then -1
+    else cpool_index (Bytes.to_string (Charset.expand start')) in
+  let constantpool = Array.make !cpoolpos "" in
+  StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool;
+  { prog = Array.sub !prog 0 !progpos;
+    cpool = constantpool;
+    normtable = if fold_case then fold_case_table else "";
+    numgroups = !numgroups;
+    numregisters = !numregs;
+    startchars = start_pos }
+
+(** Parsing of a regular expression *)
+
+(* Efficient buffering of sequences *)
+
+module SeqBuffer = struct
+
+  type t = { sb_chars: Buffer.t; mutable sb_next: re_syntax list }
+
+  let create() = { sb_chars = Buffer.create 16; sb_next = [] }
+
+  let flush buf =
+    let s = Buffer.contents buf.sb_chars in
+    Buffer.clear buf.sb_chars;
+    match String.length s with
+      0 -> ()
+    | 1 -> buf.sb_next <- Char s.[0] :: buf.sb_next
+    | _ -> buf.sb_next <- String s :: buf.sb_next
+
+  let add buf re =
+    match re with
+      Char c -> Buffer.add_char buf.sb_chars c
+    | _ -> flush buf; buf.sb_next <- re :: buf.sb_next
+
+  let extract buf =
+    flush buf; Seq(List.rev buf.sb_next)
+
+end
+
+(* The character class corresponding to `.' *)
+
+let dotclass = Charset.complement (Charset.singleton '\n')
+
+(* Parse a regular expression *)
+
+let parse s =
+  let len = String.length s in
+  let group_counter = ref 1 in
+
+  let rec regexp0 i =
+    let (r, j) = regexp1 i in
+    regexp0cont r j
+  and regexp0cont r1 i =
+    if i + 2 <= len && s.[i] = '\\' && s.[i+1] = '|' then
+      let (r2, j) = regexp1 (i+2) in
+      regexp0cont (Alt(r1, r2)) j
+    else
+      (r1, i)
+  and regexp1 i =
+    regexp1cont (SeqBuffer.create()) i
+  and regexp1cont sb i =
+    if i >= len
+    || i + 2 <= len && s.[i] = '\\' && (let c = s.[i+1] in c = '|' || c = ')')
+    then
+      (SeqBuffer.extract sb, i)
+    else
+      let (r, j) = regexp2 i in
+      SeqBuffer.add sb r;
+      regexp1cont sb j
+  and regexp2 i =
+    let (r, j) = regexp3 i in
+    regexp2cont r j
+  and regexp2cont r i =
+    if i >= len then (r, i) else
+      match s.[i] with
+        '?' -> regexp2cont (Option r) (i+1)
+      | '*' -> regexp2cont (Star r) (i+1)
+      | '+' -> regexp2cont (Plus r) (i+1)
+      |  _  -> (r, i)
+  and regexp3 i =
+    match s.[i] with
+      '\\' -> regexpbackslash (i+1)
+    | '['  -> let (c, compl, j) = regexpclass0 (i+1) in
+              (CharClass(c, compl), j)
+    | '^'  -> (Bol, i+1)
+    | '$'  -> (Eol, i+1)
+    | '.'  -> (CharClass(dotclass, false), i+1)
+    | c    -> (Char c, i+1)
+  and regexpbackslash i =
+    if i >= len then (Char '\\', i) else
+      match s.[i] with
+        '|' | ')' ->
+          assert false
+      | '(' ->
+          let group_no = !group_counter in
+          incr group_counter;
+          let (r, j) = regexp0 (i+1) in
+          if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then
+            (Group(group_no, r), j + 2)
+          else
+            failwith "\\( group not closed by \\)"
+      | '1' .. '9' as c ->
+          (Refgroup(Char.code c - 48), i + 1)
+      | 'b' ->
+          (Wordboundary, i + 1)
+      | c ->
+          (Char c, i + 1)
+  and regexpclass0 i =
+    if i < len && s.[i] = '^'
+    then let (c, j) = regexpclass1 (i+1) in (c, true, j)
+    else let (c, j) = regexpclass1 i in (c, false, j)
+  and regexpclass1 i =
+    let c = Charset.make_empty() in
+    let j = regexpclass2 c i i in
+    (c, j)
+  and regexpclass2 c start i =
+    if i >= len then failwith "[ class not closed by ]";
+    if s.[i] = ']' && i > start then i+1 else begin
+      let c1 = s.[i] in
+      if i+2 < len && s.[i+1] = '-' && s.[i+2] <> ']' then begin
+        let c2 = s.[i+2] in
+        Charset.add_range c c1 c2;
+        regexpclass2 c start (i+3)
+      end else begin
+        Charset.add c c1;
+        regexpclass2 c start (i+1)
+      end
+    end in
+
+  let (r, j) = regexp0 0 in
+  if j = len then r else failwith "spurious \\) in regular expression"
+
+(** Parsing and compilation *)
+
+let regexp e = compile false (parse e)
+
+let regexp_case_fold e = compile true (parse e)
+
+let quote s =
+  let len = String.length s in
+  let buf = Bytes.create (2 * len) in
+  let pos = ref 0 in
+  for i = 0 to len - 1 do
+    match s.[i] with
+      '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c ->
+        Bytes.set buf !pos '\\';
+        Bytes.set buf (!pos + 1) c;
+        pos := !pos + 2
+    | c ->
+        Bytes.set buf !pos c;
+        pos := !pos + 1
+  done;
+  Bytes.sub_string buf 0 !pos
+
+let regexp_string s = compile false (String s)
+
+let regexp_string_case_fold s = compile true (String s)
+
+(** Matching functions **)
+
+external re_string_match: regexp -> string -> int -> int array
+     = "re_string_match"
+external re_partial_match: regexp -> string -> int -> int array
+     = "re_partial_match"
+external re_search_forward: regexp -> string -> int -> int array
+     = "re_search_forward"
+external re_search_backward: regexp -> string -> int -> int array
+     = "re_search_backward"
+
+let last_search_result = ref [||]
+
+let string_match re s pos =
+  let res = re_string_match re s pos in
+  last_search_result := res;
+  Array.length res > 0
+
+let string_partial_match re s pos =
+  let res = re_partial_match re s pos in
+  last_search_result := res;
+  Array.length res > 0
+
+let search_forward re s pos =
+  let res = re_search_forward re s pos in
+  last_search_result := res;
+  if Array.length res = 0 then raise Not_found else res.(0)
+
+let search_backward re s pos =
+  let res = re_search_backward re s pos in
+  last_search_result := res;
+  if Array.length res = 0 then raise Not_found else res.(0)
+
+let group_beginning n =
+  let n2 = n + n in
+  if n < 0 || n2 >= Array.length !last_search_result then
+    invalid_arg "Str.group_beginning"
+  else
+    let pos = !last_search_result.(n2) in
+    if pos = -1 then raise Not_found else pos
+
+let group_end n =
+  let n2 = n + n in
+  if n < 0 || n2 >= Array.length !last_search_result then
+    invalid_arg "Str.group_end"
+  else
+    let pos = !last_search_result.(n2 + 1) in
+    if pos = -1 then raise Not_found else pos
+
+let matched_group n txt =
+  let n2 = n + n in
+  if n < 0 || n2 >= Array.length !last_search_result then
+    invalid_arg "Str.matched_group"
+  else
+    let b = !last_search_result.(n2)
+    and e = !last_search_result.(n2 + 1) in
+    if b = -1 then raise Not_found else String.sub txt b (e - b)
+
+let match_beginning () = group_beginning 0
+and match_end () = group_end 0
+and matched_string txt = matched_group 0 txt
+
+(** Replacement **)
+
+external re_replacement_text: string -> int array -> string -> string
+    = "re_replacement_text"
+
+let replace_matched repl matched =
+  re_replacement_text repl !last_search_result matched
+
+let substitute_first expr repl_fun text =
+  try
+    let pos = search_forward expr text 0 in
+    String.concat "" [string_before text pos;
+                      repl_fun text;
+                      string_after text (match_end())]
+  with Not_found ->
+    text
+
+let opt_search_forward re s pos =
+  try Some(search_forward re s pos) with Not_found -> None
+
+let global_substitute expr repl_fun text =
+  let rec replace accu start last_was_empty =
+    let startpos = if last_was_empty then start + 1 else start in
+    if startpos > String.length text then
+      string_after text start :: accu
+    else
+      match opt_search_forward expr text startpos with
+      | None ->
+          string_after text start :: accu
+      | Some pos ->
+          let end_pos = match_end() in
+          let repl_text = repl_fun text in
+          replace (repl_text :: String.sub text start (pos-start) :: accu)
+                  end_pos (end_pos = pos)
+  in
+    String.concat "" (List.rev (replace [] 0 false))
+
+let global_replace expr repl text =
+  global_substitute expr (replace_matched repl) text
+and replace_first expr repl text =
+  substitute_first expr (replace_matched repl) text
+
+(** Splitting *)
+
+let opt_search_forward_progress expr text start =
+  match opt_search_forward expr text start with
+  | None -> None
+  | Some pos ->
+      if match_end() > start then
+        Some pos
+      else if start < String.length text then
+        opt_search_forward expr text (start + 1)
+      else None
+
+let bounded_split expr text num =
+  let start =
+    if string_match expr text 0 then match_end() else 0 in
+  let rec split accu start n =
+    if start >= String.length text then accu else
+    if n = 1 then string_after text start :: accu else
+      match opt_search_forward_progress expr text start with
+      | None ->
+          string_after text start :: accu
+      | Some pos ->
+          split (String.sub text start (pos-start) :: accu)
+                (match_end()) (n-1)
+  in
+    List.rev (split [] start num)
+
+let split expr text = bounded_split expr text 0
+
+let bounded_split_delim expr text num =
+  let rec split accu start n =
+    if start > String.length text then accu else
+    if n = 1 then string_after text start :: accu else
+      match opt_search_forward_progress expr text start with
+      | None ->
+          string_after text start :: accu
+      | Some pos ->
+          split (String.sub text start (pos-start) :: accu)
+                (match_end()) (n-1)
+  in
+    if text = "" then [] else List.rev (split [] 0 num)
+
+let split_delim expr text = bounded_split_delim expr text 0
+
+type split_result = Text of string | Delim of string
+
+let bounded_full_split expr text num =
+  let rec split accu start n =
+    if start >= String.length text then accu else
+    if n = 1 then Text(string_after text start) :: accu else
+      match opt_search_forward_progress expr text start with
+      | None ->
+          Text(string_after text start) :: accu
+      | Some pos ->
+          let s = matched_string text in
+          if pos > start then
+            split (Delim(s) :: Text(String.sub text start (pos-start)) :: accu)
+                  (match_end()) (n-1)
+          else
+            split (Delim(s) :: accu)
+                  (match_end()) (n-1)
+  in
+    List.rev (split [] 0 num)
+
+let full_split expr text = bounded_full_split expr text 0
diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli
new file mode 100644
index 00000000..256289c8
--- /dev/null
+++ b/otherlibs/str/str.mli
@@ -0,0 +1,291 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Regular expressions and high-level string processing *)
+
+
+(** {6 Regular expressions} *)
+
+
+type regexp
+(** The type of compiled regular expressions. *)
+
+
+val regexp : string -> regexp
+(** 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 preceding expression one or
+              several times
+   - [?     ] (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.
+              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 '\n' character.
+   - [$     ] Matches at end of line: either at the end of the matched
+              string, or just before a '\n' 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 [$^\.*+?[]].
+
+   Note: the argument to [regexp] is usually a string literal. In this
+   case, any backslash character in the regular expression must be
+   doubled to make it past the OCaml string parser. For example, the
+   following expression:
+   {[ let r = Str.regexp "hello \\([A-Za-z]+\\)" in
+      Str.replace_first r "\\1" "hello world" ]}
+   returns the string ["world"].
+
+   In particular, if you want a regular expression that matches a single
+   backslash character, you need to quote it in the argument to [regexp]
+   (according to the last item of the list above) by adding a second
+   backslash. Then you need to quote both backslashes (according to the
+   syntax of string constants in OCaml) by doubling them again, so you
+   need to write four backslash characters: [Str.regexp "\\\\"].
+*)
+
+val regexp_case_fold : string -> regexp
+(** Same as [regexp], but the compiled expression will match text
+    in a case-insensitive way: uppercase and lowercase letters will
+    be considered equivalent. *)
+
+val quote : string -> string
+(** [Str.quote s] returns a regexp string that matches exactly
+   [s] and nothing else. *)
+
+val regexp_string : string -> regexp
+(** [Str.regexp_string s] returns a regular expression
+   that matches exactly [s] and nothing else.*)
+
+val regexp_string_case_fold : string -> regexp
+(** [Str.regexp_string_case_fold] is similar to {!Str.regexp_string},
+   but the regexp matches in a case-insensitive way. *)
+
+
+(** {6 String matching and searching} *)
+
+
+val string_match : regexp -> string -> int -> bool
+(** [string_match r s start] tests whether a substring of [s] that
+   starts at position [start] matches the regular expression [r].
+   The first character of a string has position [0], as usual. *)
+
+val search_forward : regexp -> string -> int -> int
+(** [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.
+   @raise Not_found if no substring matches. *)
+
+val search_backward : regexp -> string -> int -> int
+(** [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 also returns true if
+   the argument string is a prefix of a string that matches.
+   This includes the case of a true complete match. *)
+
+val matched_string : string -> string
+(** [matched_string s] returns the substring of [s] that was matched
+   by the last call to one of the following matching or searching
+   functions:
+   - {!Str.string_match}
+   - {!Str.search_forward}
+   - {!Str.search_backward}
+   - {!Str.string_partial_match}
+   - {!Str.global_substitute}
+   - {!Str.substitute_first}
+
+   provided that none of the following functions was called inbetween:
+   - {!Str.global_replace}
+   - {!Str.replace_first}
+   - {!Str.split}
+   - {!Str.bounded_split}
+   - {!Str.split_delim}
+   - {!Str.bounded_split_delim}
+   - {!Str.full_split}
+   - {!Str.bounded_full_split}
+
+   Note: in the case of [global_substitute] and [substitute_first],
+   a call to [matched_string] is only valid within the [subst] argument,
+   not after [global_substitute] or [substitute_first] returns.
+
+   The user must make sure that the parameter [s] is the same string
+   that was passed to the matching or searching function. *)
+
+val match_beginning : unit -> int
+(** [match_beginning()] returns the position of the first character
+   of the substring that was matched by the last call to a matching
+   or searching function (see {!Str.matched_string} for details). *)
+
+val match_end : unit -> int
+(** [match_end()] returns the position of the character following the
+   last character of the substring that was matched by the last call
+   to a matching or searching function (see {!Str.matched_string} for
+   details). *)
+
+val matched_group : int -> string -> string
+(** [matched_group n s] returns the substring of [s] that was matched
+   by the [n]th group [\(...\)] of the regular expression that was
+   matched by the last call to a matching or searching function (see
+   {!Str.matched_string} for details).
+   The user must make sure that the parameter [s] is the same string
+   that was passed to the matching or searching function.
+   @raise Not_found if the [n]th group
+   of the regular expression was not matched.  This can happen
+   with groups inside alternatives [\|], options [?]
+   or repetitions [*].  For instance, the empty string will match
+   [\(a\)*], but [matched_group 1 ""] will raise [Not_found]
+   because the first group itself was not matched. *)
+
+val group_beginning : int -> int
+(** [group_beginning n] returns the position of the first character
+   of the substring that was matched by the [n]th group of
+   the regular expression that was matched by the last call to a
+   matching or searching function (see {!Str.matched_string} for details).
+   @raise Not_found if the [n]th group of the regular expression
+   was not matched.
+   @raise Invalid_argument if there are fewer than [n] groups in
+   the regular expression. *)
+
+val group_end : int -> int
+(** [group_end n] returns
+   the position of the character following the last character of
+   substring that was matched by the [n]th group of the regular
+   expression that was matched by the last call to a matching or
+   searching function (see {!Str.matched_string} for details).
+   @raise Not_found if the [n]th group of the regular expression
+   was not matched.
+   @raise Invalid_argument if there are fewer than [n] groups in
+   the regular expression. *)
+
+
+(** {6 Replacement} *)
+
+
+val global_replace : regexp -> string -> string -> string
+(** [global_replace regexp templ s] returns a string identical to [s],
+   except that all substrings of [s] that match [regexp] have been
+   replaced by [templ]. The replacement template [templ] can contain
+   [\1], [\2], etc; these sequences will be replaced by the text
+   matched by the corresponding group in the regular expression.
+   [\0] stands for the text matched by the whole regular expression. *)
+
+val replace_first : regexp -> string -> string -> string
+(** Same as {!Str.global_replace}, except that only the first substring
+   matching the regular expression is replaced. *)
+
+val global_substitute : regexp -> (string -> string) -> string -> string
+(** [global_substitute regexp subst s] returns a string identical
+   to [s], except that all substrings of [s] that match [regexp]
+   have been replaced by the result of function [subst]. The
+   function [subst] is called once for each matching substring,
+   and receives [s] (the whole text) as argument. *)
+
+val substitute_first : regexp -> (string -> string) -> string -> string
+(** Same as {!Str.global_substitute}, except that only the first substring
+   matching the regular expression is replaced. *)
+
+val replace_matched : string -> string -> string
+(** [replace_matched repl s] returns the replacement text [repl]
+   in which [\1], [\2], etc. have been replaced by the text
+   matched by the corresponding groups in the regular expression
+   that was matched by the last call to a matching or searching
+   function (see {!Str.matched_string} for details).
+   [s] must be the same string that was passed to the matching or
+   searching function. *)
+
+
+(** {6 Splitting} *)
+
+
+val split : regexp -> string -> string list
+(** [split r s] splits [s] into substrings, taking as delimiters
+   the substrings that match [r], and returns the list of substrings.
+   For instance, [split (regexp "[ \t]+") s] splits [s] into
+   blank-separated words.  An occurrence of the delimiter at the
+   beginning or at the end of the string is ignored. *)
+
+val bounded_split : regexp -> string -> int -> string list
+(** Same as {!Str.split}, but splits into at most [n] substrings,
+   where [n] is the extra integer parameter. *)
+
+val split_delim : regexp -> string -> string list
+(** Same as {!Str.split} but occurrences of the
+   delimiter at the beginning and at the end of the string are
+   recognized and returned as empty strings in the result.
+   For instance, [split_delim (regexp " ") " abc "]
+   returns [[""; "abc"; ""]], while [split] with the same
+   arguments returns [["abc"]]. *)
+
+val bounded_split_delim : regexp -> string -> int -> string list
+(** Same as {!Str.bounded_split}, but occurrences of the
+   delimiter at the beginning and at the end of the string are
+   recognized and returned as empty strings in the result. *)
+
+type split_result =
+    Text of string
+  | Delim of string
+
+val full_split : regexp -> string -> split_result list
+(** Same as {!Str.split_delim}, but returns
+   the delimiters as well as the substrings contained between
+   delimiters.  The former are tagged [Delim] in the result list;
+   the latter are tagged [Text].  For instance,
+   [full_split (regexp "[{}]") "{ab}"] returns
+   [[Delim "{"; Text "ab"; Delim "}"]]. *)
+
+val bounded_full_split : regexp -> string -> int -> split_result list
+(** Same as {!Str.bounded_split_delim}, but returns
+   the delimiters as well as the substrings contained between
+   delimiters.  The former are tagged [Delim] in the result list;
+   the latter are tagged [Text]. *)
+
+
+(** {6 Extracting substrings} *)
+
+
+val string_before : string -> int -> string
+(** [string_before s n] returns the substring of all characters of [s]
+   that precede position [n] (excluding the character at
+   position [n]). *)
+
+val string_after : string -> int -> string
+(** [string_after s n] returns the substring of all characters of [s]
+   that follow position [n] (including the character at
+   position [n]). *)
+
+val first_chars : string -> int -> string
+(** [first_chars s n] returns the first [n] characters of [s].
+   This is the same function as {!Str.string_before}. *)
+
+val last_chars : string -> int -> string
+(** [last_chars s n] returns the last [n] characters of [s]. *)
diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c
new file mode 100644
index 00000000..505b927e
--- /dev/null
+++ b/otherlibs/str/strstubs.c
@@ -0,0 +1,546 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <ctype.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+
+/* The backtracking NFA interpreter */
+
+union backtrack_point {
+  struct {
+    value * pc;                 /* with low bit set */
+    unsigned char * txt;
+  } pos;
+  struct {
+    unsigned char ** loc;       /* with low bit clear */
+    unsigned char * val;
+  } undo;
+};
+
+#define Set_tag(p) ((value *) ((intnat)(p) | 1))
+#define Clear_tag(p) ((value *) ((intnat)(p) & ~1))
+#define Tag_is_set(p) ((intnat)(p) & 1)
+
+#define BACKTRACK_STACK_BLOCK_SIZE 500
+
+struct backtrack_stack {
+  struct backtrack_stack * previous;
+  union backtrack_point point[BACKTRACK_STACK_BLOCK_SIZE];
+};
+
+#define Opcode(x) ((x) & 0xFF)
+#define Arg(x) ((uintnat)(x) >> 8)
+#define SignedArg(x) ((intnat)(x) >> 8)
+
+enum {
+  CHAR,       /* match a single character */
+  CHARNORM,   /* match a single character, after normalization */
+  STRING,     /* match a character string */
+  STRINGNORM, /* match a character string, after normalization */
+  CHARCLASS,  /* match a character class */
+  BOL,        /* match at beginning of line */
+  EOL,        /* match at end of line */
+  WORDBOUNDARY, /* match on a word boundary */
+  BEGGROUP,   /* record the beginning of a group */
+  ENDGROUP,   /* record the end of a group */
+  REFGROUP,   /* match a previously matched group */
+  ACCEPT,     /* report success */
+  SIMPLEOPT,  /* match a character class 0 or 1 times */
+  SIMPLESTAR, /* match a character class 0, 1 or several times */
+  SIMPLEPLUS, /* match a character class 1 or several times */
+  GOTO,       /* unconditional branch */
+  PUSHBACK,   /* record a backtrack point --
+                 where to jump in case of failure */
+  SETMARK,    /* remember current position in given register # */
+  CHECKPROGRESS /* backtrack if no progress was made w.r.t. reg # */
+};
+
+/* Accessors in a compiled regexp */
+#define Prog(re) Field(re, 0)
+#define Cpool(re) Field(re, 1)
+#define Normtable(re) Field(re, 2)
+#define Numgroups(re) Int_val(Field(re, 3))
+#define Numregisters(re) Int_val(Field(re, 4))
+#define Startchars(re) Int_val(Field(re, 5))
+
+/* Record positions of matched groups */
+#define DEFAULT_NUM_GROUPS 10
+struct re_group {
+  unsigned char * start;
+  unsigned char * end;
+};
+
+/* Record positions reached during matching; used to check progress
+   in repeated matching of a regexp. */
+#define NUM_REGISTERS 64
+static unsigned char * re_register[NUM_REGISTERS];
+
+/* The initial backtracking stack */
+static struct backtrack_stack initial_stack = { NULL, };
+
+/* Free a chained list of backtracking stacks */
+static void free_backtrack_stack(struct backtrack_stack * stack)
+{
+  struct backtrack_stack * prevstack;
+  while ((prevstack = stack->previous) != NULL) {
+    caml_stat_free(stack);
+    stack = prevstack;
+  }
+}
+
+/* Membership in a bit vector representing a set of booleans */
+#define In_bitset(s,i,tmp) (tmp = (i), ((s)[tmp >> 3] >> (tmp & 7)) & 1)
+
+/* Determine if a character is a word constituent */
+/* PR#4874: word constituent = letter, digit, underscore. */
+
+static unsigned char re_word_letters[32] = {
+  0x00, 0x00, 0x00, 0x00,       /* 0x00-0x1F: none */
+  0x00, 0x00, 0xFF, 0x03,       /* 0x20-0x3F: digits 0-9 */
+  0xFE, 0xFF, 0xFF, 0x87,       /* 0x40-0x5F: A to Z, _ */
+  0xFE, 0xFF, 0xFF, 0x07,       /* 0x60-0x7F: a to z */
+  0x00, 0x00, 0x00, 0x00,       /* 0x80-0x9F: none */
+  0x00, 0x00, 0x00, 0x00,       /* 0xA0-0xBF: none */
+  0xFF, 0xFF, 0x7F, 0xFF,       /* 0xC0-0xDF: Latin-1 accented uppercase */
+  0xFF, 0xFF, 0x7F, 0xFF        /* 0xE0-0xFF: Latin-1 accented lowercase */
+};
+
+#define Is_word_letter(c) ((re_word_letters[(c) >> 3] >> ((c) & 7)) & 1)
+
+/* Allocate an integer array containing the positions of the matched groups.
+   Beginning of group #N is at 2N, end is at 2N+1.
+   Take position = -1 when group wasn't matched. */
+
+static value re_alloc_groups(value re, unsigned char * starttxt,
+                             struct re_group * groups)
+{
+  value res;
+  int n = Numgroups(re);
+  int i;
+  struct re_group * group;
+
+  res = caml_alloc(n * 2, 0);
+  for (i = 0; i < n; i++) {
+    group = &(groups[i]);
+    if (group->start == NULL || group->end == NULL) {
+      Field(res, i * 2) = Val_int(-1);
+      Field(res, i * 2 + 1) = Val_int(-1);
+    } else {
+      Field(res, i * 2) = Val_long(group->start - starttxt);
+      Field(res, i * 2 + 1) = Val_long(group->end - starttxt);
+    }
+  }
+  return res;
+}
+
+/* The bytecode interpreter for the NFA.
+   Return Caml array of matched groups on success, 0 on failure. */
+
+static value re_match(value re,
+                      unsigned char * starttxt,
+                      register unsigned char * txt,
+                      register unsigned char * endtxt,
+                      int accept_partial_match)
+{
+  register value * pc;
+  intnat instr;
+  struct backtrack_stack * stack;
+  union backtrack_point * sp;
+  value cpool;
+  value normtable;
+  unsigned char c;
+  union backtrack_point back;
+  struct re_group default_groups[DEFAULT_NUM_GROUPS];
+  struct re_group * groups;
+  int numgroups = Numgroups(re);
+  value result;
+
+  if (numgroups <= DEFAULT_NUM_GROUPS)
+    groups = default_groups;
+  else
+    groups = caml_stat_alloc(sizeof(struct re_group) * numgroups);
+
+  { int i;
+    struct re_group * p;
+    unsigned char ** q;
+    for (p = &groups[1], i = numgroups; i > 1; i--, p++)
+      p->start = p->end = NULL;
+    for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++)
+      *q = NULL;
+  }
+
+  pc = &Field(Prog(re), 0);
+  stack = &initial_stack;
+  sp = stack->point;
+  cpool = Cpool(re);
+  normtable = Normtable(re);
+  groups[0].start = txt;
+
+  while (1) {
+    instr = Long_val(*pc++);
+    switch (Opcode(instr)) {
+    case CHAR:
+      if (txt == endtxt) goto prefix_match;
+      if (*txt != Arg(instr)) goto backtrack;
+      txt++;
+      break;
+    case CHARNORM:
+      if (txt == endtxt) goto prefix_match;
+      if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack;
+      txt++;
+      break;
+    case STRING: {
+      unsigned char * s =
+        (unsigned char *) String_val(Field(cpool, Arg(instr)));
+      while ((c = *s++) != 0) {
+        if (txt == endtxt) goto prefix_match;
+        if (c != *txt) goto backtrack;
+        txt++;
+      }
+      break;
+    }
+    case STRINGNORM: {
+      unsigned char * s =
+        (unsigned char *) String_val(Field(cpool, Arg(instr)));
+      while ((c = *s++) != 0) {
+        if (txt == endtxt) goto prefix_match;
+        if (c != Byte_u(normtable, *txt)) goto backtrack;
+        txt++;
+      }
+      break;
+    }
+    case CHARCLASS:
+      if (txt == endtxt) goto prefix_match;
+      if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c))
+        goto backtrack;
+      txt++;
+      break;
+    case BOL:
+      if (txt > starttxt && txt[-1] != '\n') goto backtrack;
+      break;
+    case EOL:
+      if (txt < endtxt && *txt != '\n') goto backtrack;
+      break;
+    case WORDBOUNDARY:
+      /* At beginning and end of text: no
+         At beginning of text: OK if current char is a letter
+         At end of text: OK if previous char is a letter
+         Otherwise:
+           OK if previous char is a letter and current char not a letter
+           or previous char is not a letter and current char is a letter */
+      if (txt == starttxt) {
+        if (txt == endtxt) goto prefix_match;
+        if (Is_word_letter(txt[0])) break;
+        goto backtrack;
+      } else if (txt == endtxt) {
+        if (Is_word_letter(txt[-1])) break;
+        goto backtrack;
+      } else {
+        if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break;
+        goto backtrack;
+      }
+    case BEGGROUP: {
+      int group_no = Arg(instr);
+      struct re_group * group = &(groups[group_no]);
+      back.undo.loc = &(group->start);
+      back.undo.val = group->start;
+      group->start = txt;
+      goto push;
+    }
+    case ENDGROUP: {
+      int group_no = Arg(instr);
+      struct re_group * group = &(groups[group_no]);
+      back.undo.loc = &(group->end);
+      back.undo.val = group->end;
+      group->end = txt;
+      goto push;
+    }
+    case REFGROUP: {
+      int group_no = Arg(instr);
+      struct re_group * group = &(groups[group_no]);
+      unsigned char * s;
+      if (group->start == NULL || group->end == NULL) goto backtrack;
+      for (s = group->start; s < group->end; s++) {
+        if (txt == endtxt) goto prefix_match;
+        if (*s != *txt) goto backtrack;
+        txt++;
+      }
+      break;
+    }
+    case ACCEPT:
+      goto accept;
+    case SIMPLEOPT: {
+      char * set = String_val(Field(cpool, Arg(instr)));
+      if (txt < endtxt && In_bitset(set, *txt, c)) txt++;
+      break;
+    }
+    case SIMPLESTAR: {
+      char * set = String_val(Field(cpool, Arg(instr)));
+      while (txt < endtxt && In_bitset(set, *txt, c))
+        txt++;
+      break;
+    }
+    case SIMPLEPLUS: {
+      char * set = String_val(Field(cpool, Arg(instr)));
+      if (txt == endtxt) goto prefix_match;
+      if (! In_bitset(set, *txt, c)) goto backtrack;
+      txt++;
+      while (txt < endtxt && In_bitset(set, *txt, c))
+        txt++;
+      break;
+    }
+    case GOTO:
+      pc = pc + SignedArg(instr);
+      break;
+    case PUSHBACK:
+      back.pos.pc = Set_tag(pc + SignedArg(instr));
+      back.pos.txt = txt;
+      goto push;
+    case SETMARK: {
+      int reg_no = Arg(instr);
+      unsigned char ** reg = &(re_register[reg_no]);
+      back.undo.loc = reg;
+      back.undo.val = *reg;
+      *reg = txt;
+      goto push;
+    }
+    case CHECKPROGRESS: {
+      int reg_no = Arg(instr);
+      if (re_register[reg_no] == txt)
+        goto backtrack;
+      break;
+    }
+    default:
+      caml_fatal_error ("impossible case in re_match");
+    }
+    /* Continue with next instruction */
+    continue;
+
+  push:
+    /* Push an item on the backtrack stack and continue with next instr */
+    if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) {
+      struct backtrack_stack * newstack =
+        caml_stat_alloc(sizeof(struct backtrack_stack));
+      newstack->previous = stack;
+      stack = newstack;
+      sp = stack->point;
+    }
+    *sp = back;
+    sp++;
+    continue;
+
+  prefix_match:
+    /* We get here when matching failed because the end of text
+       was encountered. */
+    if (accept_partial_match) goto accept;
+
+  backtrack:
+    /* We get here when matching fails.  Backtrack to most recent saved
+       program point, undoing variable assignments on the way. */
+    while (1) {
+      if (sp == stack->point) {
+        struct backtrack_stack * prevstack = stack->previous;
+        if (prevstack == NULL) goto reject;
+        caml_stat_free(stack);
+        stack = prevstack;
+        sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE;
+      }
+      sp--;
+      if (Tag_is_set(sp->pos.pc)) {
+        pc = Clear_tag(sp->pos.pc);
+        txt = sp->pos.txt;
+        break;
+      } else {
+        *(sp->undo.loc) = sp->undo.val;
+      }
+    }
+    continue;
+  }
+
+ accept:
+  /* We get here when the regexp was successfully matched */
+  free_backtrack_stack(stack);
+  groups[0].end = txt;
+  result = re_alloc_groups(re, starttxt, groups);
+  if (groups != default_groups) caml_stat_free(groups);
+  return result;
+
+ reject:
+  /* We get here when the regexp was not matched */
+  if (groups != default_groups) caml_stat_free(groups);
+  return 0;
+}
+
+/* String matching and searching.  All functions return the empty array
+   on failure, and an array of positions on success. */
+
+CAMLprim value re_string_match(value re, value str, value pos)
+{
+  unsigned char * starttxt = &Byte_u(str, 0);
+  unsigned char * txt = &Byte_u(str, Long_val(pos));
+  unsigned char * endtxt = &Byte_u(str, caml_string_length(str));
+  value res;
+
+  if (txt < starttxt || txt > endtxt)
+    caml_invalid_argument("Str.string_match");
+  res = re_match(re, starttxt, txt, endtxt, 0);
+  return res == 0 ? Atom(0) : res;
+}
+
+CAMLprim value re_partial_match(value re, value str, value pos)
+{
+  unsigned char * starttxt = &Byte_u(str, 0);
+  unsigned char * txt = &Byte_u(str, Long_val(pos));
+  unsigned char * endtxt = &Byte_u(str, caml_string_length(str));
+  value res;
+
+  if (txt < starttxt || txt > endtxt)
+    caml_invalid_argument("Str.string_partial_match");
+  res = re_match(re, starttxt, txt, endtxt, 1);
+  return res == 0 ? Atom(0) : res;
+}
+
+CAMLprim value re_search_forward(value re, value str, value startpos)
+{
+  unsigned char * starttxt = &Byte_u(str, 0);
+  unsigned char * txt = &Byte_u(str, Long_val(startpos));
+  unsigned char * endtxt = &Byte_u(str, caml_string_length(str));
+  unsigned char * startchars;
+  value res;
+
+  if (txt < starttxt || txt > endtxt)
+    caml_invalid_argument("Str.search_forward");
+  if (Startchars(re) == -1) {
+    do {
+      res = re_match(re, starttxt, txt, endtxt, 0);
+      if (res != 0) return res;
+      txt++;
+    } while (txt <= endtxt);
+    return Atom(0);
+  } else {
+    startchars =
+      (unsigned char *) String_val(Field(Cpool(re), Startchars(re)));
+    do {
+      while (txt < endtxt && startchars[*txt] == 0) txt++;
+      res = re_match(re, starttxt, txt, endtxt, 0);
+      if (res != 0) return res;
+      txt++;
+    } while (txt <= endtxt);
+    return Atom(0);
+  }
+}
+
+CAMLprim value re_search_backward(value re, value str, value startpos)
+{
+  unsigned char * starttxt = &Byte_u(str, 0);
+  unsigned char * txt = &Byte_u(str, Long_val(startpos));
+  unsigned char * endtxt = &Byte_u(str, caml_string_length(str));
+  unsigned char * startchars;
+  value res;
+
+  if (txt < starttxt || txt > endtxt)
+    caml_invalid_argument("Str.search_backward");
+  if (Startchars(re) == -1) {
+    do {
+      res = re_match(re, starttxt, txt, endtxt, 0);
+      if (res != 0) return res;
+      txt--;
+    } while (txt >= starttxt);
+    return Atom(0);
+  } else {
+    startchars =
+      (unsigned char *) String_val(Field(Cpool(re), Startchars(re)));
+    do {
+      while (txt > starttxt && startchars[*txt] == 0) txt--;
+      res = re_match(re, starttxt, txt, endtxt, 0);
+      if (res != 0) return res;
+      txt--;
+    } while (txt >= starttxt);
+    return Atom(0);
+  }
+}
+
+/* Replacement */
+
+CAMLprim value re_replacement_text(value repl, value groups, value orig)
+{
+  CAMLparam3(repl, groups, orig);
+  CAMLlocal1(res);
+  mlsize_t start, end, len, n;
+  char * p, * q;
+  int c;
+
+  len = 0;
+  p = String_val(repl);
+  n = caml_string_length(repl);
+  while (n > 0) {
+    c = *p++; n--;
+    if(c != '\\')
+      len++;
+    else {
+      if (n == 0) caml_failwith("Str.replace: illegal backslash sequence");
+      c = *p++; n--;
+      switch (c) {
+      case '\\':
+        len++; break;
+      case '0': case '1': case '2': case '3': case '4':
+      case '5': case '6': case '7': case '8': case '9':
+        c -= '0';
+        if (c*2 >= Wosize_val(groups))
+          caml_failwith("Str.replace: reference to unmatched group");
+        start = Long_val(Field(groups, c*2));
+        end = Long_val(Field(groups, c*2 + 1));
+        if (start == (mlsize_t) -1)
+          caml_failwith("Str.replace: reference to unmatched group");
+        len += end - start;
+        break;
+      default:
+        len += 2; break;
+      }
+    }
+  }
+  res = caml_alloc_string(len);
+  p = String_val(repl);
+  q = String_val(res);
+  n = caml_string_length(repl);
+  while (n > 0) {
+    c = *p++; n--;
+    if(c != '\\')
+      *q++ = c;
+    else {
+      c = *p++; n--;
+      switch (c) {
+      case '\\':
+        *q++ = '\\'; break;
+      case '0': case '1': case '2': case '3': case '4':
+      case '5': case '6': case '7': case '8': case '9':
+        c -= '0';
+        start = Long_val(Field(groups, c*2));
+        end = Long_val(Field(groups, c*2 + 1));
+        len = end - start;
+        memmove (q, &Byte(orig, start), len);
+        q += len;
+        break;
+      default:
+        *q++ = '\\'; *q++ = c; break;
+      }
+    }
+  }
+  CAMLreturn(res);
+}
diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
new file mode 100644
index 00000000..5181e939
--- /dev/null
+++ b/otherlibs/systhreads/.depend
@@ -0,0 +1,28 @@
+st_stubs.o: st_stubs.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/backtrace.h ../../byterun/caml/exec.h \
+  ../../byterun/caml/callback.h ../../byterun/caml/custom.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/io.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
+  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
+  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
+  ../../byterun/caml/printexc.h ../../byterun/caml/roots.h \
+  ../../byterun/caml/signals.h ../../byterun/caml/stacks.h \
+  ../../byterun/caml/sys.h threads.h st_posix.h
+condition.cmo : mutex.cmi condition.cmi
+condition.cmx : mutex.cmx condition.cmi
+condition.cmi : mutex.cmi
+event.cmo : mutex.cmi condition.cmi event.cmi
+event.cmx : mutex.cmx condition.cmx event.cmi
+event.cmi :
+mutex.cmo : mutex.cmi
+mutex.cmx : mutex.cmi
+mutex.cmi :
+thread.cmo : thread.cmi
+thread.cmx : thread.cmi
+thread.cmi :
+threadUnix.cmo : thread.cmi threadUnix.cmi
+threadUnix.cmx : thread.cmx threadUnix.cmi
+threadUnix.cmi :
diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
new file mode 100644
index 00000000..49130bd2
--- /dev/null
+++ b/otherlibs/systhreads/Makefile
@@ -0,0 +1,159 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+ROOTDIR=../..
+
+include $(ROOTDIR)/config/Makefile
+
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
+
+LIBS = -nostdlib -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/$(UNIXLIB)
+
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc $(LIBS)
+CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt $(LIBS)
+MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
+COMPFLAGS=-w +33..39 -warn-error A -g -bin-annot -safe-string
+ifeq "$(FLAMBDA)" "true"
+OPTCOMPFLAGS=-O3
+else
+OPTCOMPFLAGS=
+endif
+
+LIBNAME=threads
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+HEADER = st_posix.h
+else # Windows
+HEADER = st_win32.h
+endif
+
+BYTECODE_C_OBJS=st_stubs_b.$(O)
+NATIVECODE_C_OBJS=st_stubs_n.$(O)
+
+THREADS_SOURCES = thread.ml mutex.ml condition.ml event.ml threadUnix.ml
+
+THREADS_BCOBJS = $(THREADS_SOURCES:.ml=.cmo)
+THREADS_NCOBJS = $(THREADS_SOURCES:.ml=.cmx)
+
+MLIFILES=thread.mli mutex.mli condition.mli event.mli threadUnix.mli
+CMIFILES=$(MLIFILES:.mli=.cmi)
+
+all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
+
+allopt: lib$(LIBNAME)nat.$(A) $(LIBNAME).cmxa $(CMIFILES)
+
+lib$(LIBNAME).$(A): $(BYTECODE_C_OBJS)
+	$(MKLIB) -o $(LIBNAME) $(BYTECODE_C_OBJS) $(PTHREAD_LINK)
+
+lib$(LIBNAME)nat.$(A): $(NATIVECODE_C_OBJS)
+	$(MKLIB) -o $(LIBNAME)nat $^
+
+$(LIBNAME).cma: $(THREADS_BCOBJS)
+ifeq "$(UNIX_OR_WIN32)" "unix"
+	$(MKLIB) -o $(LIBNAME) -ocamlc '$(CAMLC)' -cclib -lunix -linkall $(PTHREAD_CAML_LINK) $^
+# TODO: Figure out why -cclib -lunix is used here.
+# It may be because of the threadsUnix module which is deprecated.
+# It may hence be good to figure out whether this module shouldn't be
+# removed, and then -cclib -lunix arguments.
+else # Windows
+	$(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLC)" -linkall $(PTHREAD_CAML_LINK) $^
+endif
+
+# See remark above: force static linking of libthreadsnat.a
+$(LIBNAME).cmxa: $(THREADS_NCOBJS)
+	$(CAMLOPT) -linkall -a -cclib -lthreadsnat $(PTHREAD_CAML_LINK) -o $@ $^
+
+# Note: I removed "-cclib -lunix" from the line above.
+# Indeed, if we link threads.cmxa, then we must also link unix.cmxa,
+# which itself will pass -lunix to the C linker.  It seems more
+# modular to me this way. -- Alain
+
+# The following lines produce two object files st_stubs_b.$(O) and
+# st_stubs_n.$(O) from the same source file st_stubs.c (it is compiled
+# twice, each time with different of options).
+# Since the source and object file have a different basename, the name of
+# the object file to produce must be given to the C compiler.
+# For gcc this is done with the -ofoo.$(O) option.
+# For msvc it's the /Fofoo.$(O) option.
+
+ifeq "$(TOOLCHAIN)" "msvc"
+  CCOUTPUT=/Fo
+else
+  CCOUTPUT=-o 
+endif
+
+st_stubs_b.$(O): st_stubs.c $(HEADER)
+	$(BYTECC) -I$(ROOTDIR)/byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
+	  $(CCOUTPUT)$@ -c $<
+
+st_stubs_n.$(O): st_stubs.c $(HEADER)
+	$(NATIVECC) -I$(ROOTDIR)/asmrun -I$(ROOTDIR)/byterun \
+	  $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE \
+	  -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) \
+	  $(CCOUTPUT)$@ -c $<
+
+partialclean:
+	rm -f *.cm*
+
+clean: partialclean
+	rm -f dllthreads*$(EXT_DLL) *.$(A) *.$(O)
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+THREADS_LIBDIR=$(INSTALL_LIBDIR)/$(LIBNAME)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+
+install:
+	if test -f dllthreads$(EXT_DLL); then \
+	  cp dllthreads$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/dllthreads$(EXT_DLL)"; fi
+	cp libthreads.$(A) "$(INSTALL_LIBDIR)"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreads.$(A)
+	mkdir -p "$(THREADS_LIBDIR)"
+	cp $(CMIFILES) $(CMIFILES:.cmi=.cmti) threads.cma "$(THREADS_LIBDIR)"
+	cp $(MLIFILES) "$(INSTALL_LIBDIR)"
+	cp threads.h "$(INSTALL_LIBDIR)/caml"
+
+installopt:
+	cp libthreadsnat.$(A) "$(INSTALL_LIBDIR)"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreadsnat.$(A)
+	cp $(THREADS_NCOBJS) threads.cmxa threads.$(A) "$(THREADS_LIBDIR)"
+	cd "$(THREADS_LIBDIR)" && $(RANLIB) threads.$(A)
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+depend: $(GENFILES)
+	-$(CC) -MM -I../../byterun *.c > .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+else # Windows
+depend:
+endif
+
+include .depend
diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/otherlibs/systhreads/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/systhreads/condition.ml b/otherlibs/systhreads/condition.ml
new file mode 100644
index 00000000..9a014528
--- /dev/null
+++ b/otherlibs/systhreads/condition.ml
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                        *)
+(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t
+external create: unit -> t = "caml_condition_new"
+external wait: t -> Mutex.t -> unit = "caml_condition_wait"
+external signal: t -> unit = "caml_condition_signal"
+external broadcast: t -> unit = "caml_condition_broadcast"
diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli
new file mode 100644
index 00000000..36c71fc8
--- /dev/null
+++ b/otherlibs/systhreads/condition.mli
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Condition variables to synchronize between threads.
+
+   Condition variables are used when one thread wants to wait until another
+   thread has finished doing something: the former thread 'waits' on the
+   condition variable, the latter thread 'signals' the condition when it
+   is done. Condition variables should always be protected by a mutex.
+   The typical use is (if [D] is a shared data structure, [m] its mutex,
+   and [c] is a condition variable):
+   {[
+     Mutex.lock m;
+     while (* some predicate P over D is not satisfied *) do
+       Condition.wait c m
+     done;
+     (* Modify D *)
+     if (* the predicate P over D is now satisfied *) then Condition.signal c;
+     Mutex.unlock m
+   ]}
+*)
+
+type t
+(** The type of condition variables. *)
+
+val create : unit -> t
+(** Return a new condition variable. *)
+
+val wait : t -> Mutex.t -> unit
+(** [wait c m] atomically unlocks the mutex [m] and suspends the
+   calling process on the condition variable [c]. The process will
+   restart after the condition variable [c] has been signalled.
+   The mutex [m] is locked again before [wait] returns. *)
+
+val signal : t -> unit
+(** [signal c] restarts one of the processes waiting on the
+   condition variable [c]. *)
+
+val broadcast : t -> unit
+(** [broadcast c] restarts all processes waiting on the
+   condition variable [c]. *)
diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml
new file mode 100644
index 00000000..f5fc9785
--- /dev/null
+++ b/otherlibs/systhreads/event.ml
@@ -0,0 +1,276 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   David Nowak and Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Events *)
+type 'a basic_event =
+  { poll: unit -> bool;
+      (* If communication can take place immediately, return true. *)
+    suspend: unit -> unit;
+      (* Offer the communication on the channel and get ready
+         to suspend current process. *)
+    result: unit -> 'a }
+      (* Return the result of the communication *)
+
+type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event
+
+type 'a event =
+    Communication of 'a behavior
+  | Choose of 'a event list
+  | WrapAbort of 'a event * (unit -> unit)
+  | Guard of (unit -> 'a event)
+
+(* Communication channels *)
+type 'a channel =
+  { mutable writes_pending: 'a communication Queue.t;
+                        (* All offers to write on it *)
+    mutable reads_pending:  'a communication Queue.t }
+                        (* All offers to read from it *)
+
+(* Communication offered *)
+and 'a communication =
+  { performed: int ref;  (* -1 if not performed yet, set to the number *)
+                         (* of the matching communication after rendez-vous. *)
+    condition: Condition.t;             (* To restart the blocked thread. *)
+    mutable data: 'a option;            (* The data sent or received. *)
+    event_number: int }                 (* Event number in select *)
+
+(* Create a channel *)
+
+let new_channel () =
+  { writes_pending = Queue.create();
+    reads_pending = Queue.create() }
+
+(* Basic synchronization function *)
+
+let masterlock = Mutex.create()
+
+let do_aborts abort_env genev performed =
+  if abort_env <> [] then begin
+    if performed >= 0 then begin
+      let ids_done = snd genev.(performed) in
+      List.iter
+        (fun (id,f) -> if not (List.mem id ids_done) then f ())
+        abort_env
+    end else begin
+      List.iter (fun (_,f) -> f ()) abort_env
+    end
+  end
+
+let basic_sync abort_env genev =
+  let performed = ref (-1) in
+  let condition = Condition.create() in
+  let bev = Array.make (Array.length genev)
+                         (fst (genev.(0)) performed condition 0) in
+  for i = 1 to Array.length genev - 1 do
+    bev.(i) <- (fst genev.(i)) performed condition i
+  done;
+  (* See if any of the events is already activable *)
+  let rec poll_events i =
+    if i >= Array.length bev
+    then false
+    else bev.(i).poll() || poll_events (i+1) in
+  Mutex.lock masterlock;
+  if not (poll_events 0) then begin
+    (* Suspend on all events *)
+    for i = 0 to Array.length bev - 1 do bev.(i).suspend() done;
+    (* Wait until the condition is signalled *)
+    Condition.wait condition masterlock;
+    (* PR#7013: protect against spurious wake-up *)
+    while !performed < 0 do Condition.wait condition masterlock done
+  end;
+  Mutex.unlock masterlock;
+  (* Extract the result *)
+  if abort_env = [] then
+    (* Preserve tail recursion *)
+    bev.(!performed).result()
+  else begin
+    let num = !performed in
+    let result = bev.(num).result() in
+    (* Handle the aborts and return the result *)
+    do_aborts abort_env genev num;
+    result
+  end
+
+(* Apply a random permutation on an array *)
+
+let scramble_array a =
+  let len = Array.length a in
+  if len = 0 then invalid_arg "Event.choose";
+  for i = len - 1 downto 1 do
+    let j = Random.int (i + 1) in
+    let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp
+  done;
+  a
+
+(* Main synchronization function *)
+
+let gensym = let count = ref 0 in fun () -> incr count; !count
+
+let rec flatten_event
+      (abort_list : int list)
+      (accu : ('a behavior * int list) list)
+      (accu_abort : (int * (unit -> unit)) list)
+      ev =
+  match ev with
+     Communication bev -> ((bev,abort_list) :: accu) , accu_abort
+  | WrapAbort (ev,fn) ->
+      let id = gensym () in
+      flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev
+  | Choose evl ->
+      let rec flatten_list accu' accu_abort'= function
+         ev :: l ->
+           let (accu'',accu_abort'') =
+             flatten_event abort_list accu' accu_abort' ev in
+           flatten_list accu'' accu_abort'' l
+       | [] -> (accu',accu_abort') in
+      flatten_list accu accu_abort evl
+  | Guard fn -> flatten_event abort_list accu accu_abort (fn ())
+
+let sync ev =
+  let (evl,abort_env) = flatten_event [] [] [] ev in
+  basic_sync abort_env (scramble_array(Array.of_list evl))
+
+(* Event polling -- like sync, but non-blocking *)
+
+let basic_poll abort_env genev =
+  let performed = ref (-1) in
+  let condition = Condition.create() in
+  let bev = Array.make(Array.length genev)
+                        (fst genev.(0) performed condition 0) in
+  for i = 1 to Array.length genev - 1 do
+    bev.(i) <- fst genev.(i) performed condition i
+  done;
+  (* See if any of the events is already activable *)
+  let rec poll_events i =
+    if i >= Array.length bev
+    then false
+    else bev.(i).poll() || poll_events (i+1) in
+  Mutex.lock masterlock;
+  let ready = poll_events 0 in
+  if ready then begin
+    (* Extract the result *)
+    Mutex.unlock masterlock;
+    let result = Some(bev.(!performed).result()) in
+    do_aborts abort_env genev !performed; result
+  end else begin
+    (* Cancel the communication offers *)
+    performed := 0;
+    Mutex.unlock masterlock;
+    do_aborts abort_env genev (-1);
+    None
+  end
+
+let poll ev =
+  let (evl,abort_env) = flatten_event [] [] [] ev in
+  basic_poll abort_env (scramble_array(Array.of_list evl))
+
+(* Remove all communication opportunities already synchronized *)
+
+let cleanup_queue q =
+  let q' = Queue.create() in
+  Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q;
+  q'
+
+(* Event construction *)
+
+let always data =
+  Communication(fun performed condition evnum ->
+    { poll = (fun () -> performed := evnum; true);
+      suspend = (fun () -> ());
+      result = (fun () -> data) })
+
+let send channel data =
+  Communication(fun performed condition evnum ->
+    let wcomm =
+      { performed = performed;
+        condition = condition;
+        data = Some data;
+        event_number = evnum } in
+    { poll = (fun () ->
+        let rec poll () =
+          let rcomm = Queue.take channel.reads_pending in
+          if !(rcomm.performed) >= 0 then
+            poll ()
+          else begin
+            rcomm.data <- wcomm.data;
+            performed := evnum;
+            rcomm.performed := rcomm.event_number;
+            Condition.signal rcomm.condition
+          end in
+        try
+          poll();
+          true
+        with Queue.Empty ->
+          false);
+      suspend = (fun () ->
+        channel.writes_pending <- cleanup_queue channel.writes_pending;
+        Queue.add wcomm channel.writes_pending);
+      result = (fun () -> ()) })
+
+let receive channel =
+  Communication(fun performed condition evnum ->
+    let rcomm =
+      { performed = performed;
+        condition = condition;
+        data = None;
+        event_number = evnum } in
+    { poll = (fun () ->
+        let rec poll () =
+          let wcomm = Queue.take channel.writes_pending in
+          if !(wcomm.performed) >= 0 then
+            poll ()
+          else begin
+            rcomm.data <- wcomm.data;
+            performed := evnum;
+            wcomm.performed := wcomm.event_number;
+            Condition.signal wcomm.condition
+          end in
+        try
+          poll();
+          true
+        with Queue.Empty ->
+          false);
+    suspend = (fun () ->
+      channel.reads_pending <- cleanup_queue channel.reads_pending;
+      Queue.add rcomm channel.reads_pending);
+    result = (fun () ->
+      match rcomm.data with
+        None -> invalid_arg "Event.receive"
+      | Some res -> res) })
+
+let choose evl = Choose evl
+
+let wrap_abort ev fn = WrapAbort(ev,fn)
+
+let guard fn = Guard fn
+
+let rec wrap ev fn =
+  match ev with
+    Communication genev ->
+      Communication(fun performed condition evnum ->
+        let bev = genev performed condition evnum in
+        { poll = bev.poll;
+          suspend = bev.suspend;
+          result = (fun () -> fn(bev.result())) })
+  | Choose evl ->
+      Choose(List.map (fun ev -> wrap ev fn) evl)
+  | WrapAbort (ev, f') ->
+      WrapAbort (wrap ev fn, f')
+  | Guard gu ->
+      Guard(fun () -> wrap (gu()) fn)
+
+(* Convenience functions *)
+
+let select evl = sync(Choose evl)
diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli
new file mode 100644
index 00000000..83dbe9a1
--- /dev/null
+++ b/otherlibs/systhreads/event.mli
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   David Nowak and Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** First-class synchronous communication.
+
+   This module implements synchronous inter-thread communications over
+   channels. As in John Reppy's Concurrent ML system, the communication
+   events are first-class values: they can be built and combined
+   independently before being offered for communication.
+*)
+
+type 'a channel
+(** The type of communication channels carrying values of type ['a]. *)
+
+val new_channel : unit -> 'a channel
+(** Return a new channel. *)
+
+type +'a event
+(** The type of communication events returning a result of type ['a]. *)
+
+(** [send ch v] returns the event consisting in sending the value [v]
+   over the channel [ch]. The result value of this event is [()]. *)
+val send : 'a channel -> 'a -> unit event
+
+(** [receive ch] returns the event consisting in receiving a value
+   from the channel [ch]. The result value of this event is the
+   value received. *)
+val receive : 'a channel -> 'a event
+
+val always : 'a -> 'a event
+(** [always v] returns an event that is always ready for
+   synchronization.  The result value of this event is [v]. *)
+
+val choose : 'a event list -> 'a event
+(** [choose evl] returns the event that is the alternative of
+   all the events in the list [evl]. *)
+
+val wrap : 'a event -> ('a -> 'b) -> 'b event
+(** [wrap ev fn] returns the event that performs the same communications
+   as [ev], then applies the post-processing function [fn]
+   on the return value. *)
+
+val wrap_abort : 'a event -> (unit -> unit) -> 'a event
+(** [wrap_abort ev fn] returns the event that performs
+   the same communications as [ev], but if it is not selected
+   the function [fn] is called after the synchronization. *)
+
+val guard : (unit -> 'a event) -> 'a event
+(** [guard fn] returns the event that, when synchronized, computes
+   [fn()] and behaves as the resulting event. This allows to
+   compute events with side-effects at the time of the synchronization
+   operation. *)
+
+val sync : 'a event -> 'a
+(** 'Synchronize' on an event: offer all the communication
+   possibilities specified in the event to the outside world,
+   and block until one of the communications succeed. The result
+   value of that communication is returned. *)
+
+val select : 'a event list -> 'a
+(** 'Synchronize' on an alternative of events.
+   [select evl] is shorthand for [sync(choose evl)]. *)
+
+val poll : 'a event -> 'a option
+(** Non-blocking version of {!Event.sync}: offer all the communication
+   possibilities specified in the event to the outside world,
+   and if one can take place immediately, perform it and return
+   [Some r] where [r] is the result value of that communication.
+   Otherwise, return [None] without blocking. *)
diff --git a/otherlibs/systhreads/mutex.ml b/otherlibs/systhreads/mutex.ml
new file mode 100644
index 00000000..836109e7
--- /dev/null
+++ b/otherlibs/systhreads/mutex.ml
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt             *)
+(*                                                                        *)
+(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t
+external create: unit -> t = "caml_mutex_new"
+external lock: t -> unit = "caml_mutex_lock"
+external try_lock: t -> bool = "caml_mutex_try_lock"
+external unlock: t -> unit = "caml_mutex_unlock"
diff --git a/otherlibs/systhreads/mutex.mli b/otherlibs/systhreads/mutex.mli
new file mode 100644
index 00000000..8953a159
--- /dev/null
+++ b/otherlibs/systhreads/mutex.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Locks for mutual exclusion.
+
+   Mutexes (mutual-exclusion locks) are used to implement critical sections
+   and protect shared mutable data structures against concurrent accesses.
+   The typical use is (if [m] is the mutex associated with the data structure
+   [D]):
+   {[
+     Mutex.lock m;
+     (* Critical section that operates over D *);
+     Mutex.unlock m
+   ]}
+*)
+
+type t
+(** The type of mutexes. *)
+
+val create : unit -> t
+(** Return a new mutex. *)
+
+val lock : t -> unit
+(** Lock the given mutex. Only one thread can have the mutex locked
+   at any time. A thread that attempts to lock a mutex already locked
+   by another thread will suspend until the other thread unlocks
+   the mutex. *)
+
+val try_lock : t -> bool
+(** Same as {!Mutex.lock}, but does not suspend the calling thread if
+   the mutex is already locked: just return [false] immediately
+   in that case. If the mutex is unlocked, lock it and
+   return [true]. *)
+
+val unlock : t -> unit
+(** Unlock the given mutex. Other threads suspended trying to lock
+   the mutex will restart. *)
diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
new file mode 100644
index 00000000..a751ff32
--- /dev/null
+++ b/otherlibs/systhreads/st_posix.h
@@ -0,0 +1,428 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2009 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* POSIX thread implementation of the "st" interface */
+
+#include <errno.h>
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <pthread.h>
+#ifdef __sun
+#define _POSIX_PTHREAD_SEMANTICS
+#endif
+#include <signal.h>
+#include <sys/time.h>
+#ifdef __linux__
+#include <unistd.h>
+#endif
+
+#ifdef __GNUC__
+#define INLINE inline
+#else
+#define INLINE
+#endif
+
+typedef int st_retcode;
+
+#define SIGPREEMPTION SIGVTALRM
+
+/* OS-specific initialization */
+
+static int st_initialize(void)
+{
+  return 0;
+}
+
+/* Thread creation.  Created in detached mode if [res] is NULL. */
+
+typedef pthread_t st_thread_id;
+
+static int st_thread_create(st_thread_id * res,
+                            void * (*fn)(void *), void * arg)
+{
+  pthread_t thr;
+  pthread_attr_t attr;
+  int rc;
+
+  pthread_attr_init(&attr);
+  if (res == NULL) pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
+  rc = pthread_create(&thr, &attr, fn, arg);
+  if (res != NULL) *res = thr;
+  return rc;
+}
+
+#define ST_THREAD_FUNCTION void *
+
+/* Cleanup at thread exit */
+
+static INLINE void st_thread_cleanup(void)
+{
+  return;
+}
+
+/* Thread termination */
+
+static void st_thread_exit(void)
+{
+  pthread_exit(NULL);
+}
+
+static void st_thread_join(st_thread_id thr)
+{
+  pthread_join(thr, NULL);
+  /* best effort: ignore errors */
+}
+
+/* Scheduling hints */
+
+static void INLINE st_thread_yield(void)
+{
+#ifndef __linux__
+  /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */
+  sched_yield();
+#endif
+}
+
+/* Thread-specific state */
+
+typedef pthread_key_t st_tlskey;
+
+static int st_tls_newkey(st_tlskey * res)
+{
+  return pthread_key_create(res, NULL);
+}
+
+static INLINE void * st_tls_get(st_tlskey k)
+{
+  return pthread_getspecific(k);
+}
+
+static INLINE void st_tls_set(st_tlskey k, void * v)
+{
+  pthread_setspecific(k, v);
+}
+
+/* The master lock.  This is a mutex that is held most of the time,
+   so we implement it in a slightly consoluted way to avoid
+   all risks of busy-waiting.  Also, we count the number of waiting
+   threads. */
+
+typedef struct {
+  pthread_mutex_t lock;         /* to protect contents  */
+  int busy;                     /* 0 = free, 1 = taken */
+  volatile int waiters;         /* number of threads waiting on master lock */
+  pthread_cond_t is_free;       /* signaled when free */
+} st_masterlock;
+
+static void st_masterlock_init(st_masterlock * m)
+{
+  pthread_mutex_init(&m->lock, NULL);
+  pthread_cond_init(&m->is_free, NULL);
+  m->busy = 1;
+  m->waiters = 0;
+}
+
+static void st_masterlock_acquire(st_masterlock * m)
+{
+  pthread_mutex_lock(&m->lock);
+  while (m->busy) {
+    m->waiters ++;
+    pthread_cond_wait(&m->is_free, &m->lock);
+    m->waiters --;
+  }
+  m->busy = 1;
+  pthread_mutex_unlock(&m->lock);
+}
+
+static void st_masterlock_release(st_masterlock * m)
+{
+  pthread_mutex_lock(&m->lock);
+  m->busy = 0;
+  pthread_mutex_unlock(&m->lock);
+  pthread_cond_signal(&m->is_free);
+}
+
+static INLINE int st_masterlock_waiters(st_masterlock * m)
+{
+  return m->waiters;
+}
+
+/* Mutexes */
+
+typedef pthread_mutex_t * st_mutex;
+
+static int st_mutex_create(st_mutex * res)
+{
+  int rc;
+  st_mutex m = malloc(sizeof(pthread_mutex_t));
+  if (m == NULL) return ENOMEM;
+  rc = pthread_mutex_init(m, NULL);
+  if (rc != 0) { free(m); return rc; }
+  *res = m;
+  return 0;
+}
+
+static int st_mutex_destroy(st_mutex m)
+{
+  int rc;
+  rc = pthread_mutex_destroy(m);
+  free(m);
+  return rc;
+}
+
+static INLINE int st_mutex_lock(st_mutex m)
+{
+  return pthread_mutex_lock(m);
+}
+
+#define PREVIOUSLY_UNLOCKED 0
+#define ALREADY_LOCKED EBUSY
+
+static INLINE int st_mutex_trylock(st_mutex m)
+{
+  return pthread_mutex_trylock(m);
+}
+
+static INLINE int st_mutex_unlock(st_mutex m)
+{
+  return pthread_mutex_unlock(m);
+}
+
+/* Condition variables */
+
+typedef pthread_cond_t * st_condvar;
+
+static int st_condvar_create(st_condvar * res)
+{
+  int rc;
+  st_condvar c = malloc(sizeof(pthread_cond_t));
+  if (c == NULL) return ENOMEM;
+  rc = pthread_cond_init(c, NULL);
+  if (rc != 0) { free(c); return rc; }
+  *res = c;
+  return 0;
+}
+
+static int st_condvar_destroy(st_condvar c)
+{
+  int rc;
+  rc = pthread_cond_destroy(c);
+  free(c);
+  return rc;
+}
+
+static INLINE int st_condvar_signal(st_condvar c)
+{
+  return pthread_cond_signal(c);
+}
+
+static INLINE int st_condvar_broadcast(st_condvar c)
+{
+  return pthread_cond_broadcast(c);
+}
+
+static INLINE int st_condvar_wait(st_condvar c, st_mutex m)
+{
+  return pthread_cond_wait(c, m);
+}
+
+/* Triggered events */
+
+typedef struct st_event_struct {
+  pthread_mutex_t lock;         /* to protect contents */
+  int status;                   /* 0 = not triggered, 1 = triggered */
+  pthread_cond_t triggered;     /* signaled when triggered */
+} * st_event;
+
+static int st_event_create(st_event * res)
+{
+  int rc;
+  st_event e = malloc(sizeof(struct st_event_struct));
+  if (e == NULL) return ENOMEM;
+  rc = pthread_mutex_init(&e->lock, NULL);
+  if (rc != 0) { free(e); return rc; }
+  rc = pthread_cond_init(&e->triggered, NULL);
+  if (rc != 0) { pthread_mutex_destroy(&e->lock); free(e); return rc; }
+  e->status = 0;
+  *res = e;
+  return 0;
+}
+
+static int st_event_destroy(st_event e)
+{
+  int rc1, rc2;
+  rc1 = pthread_mutex_destroy(&e->lock);
+  rc2 = pthread_cond_destroy(&e->triggered);
+  free(e);
+  return rc1 != 0 ? rc1 : rc2;
+}
+
+static int st_event_trigger(st_event e)
+{
+  int rc;
+  rc = pthread_mutex_lock(&e->lock);
+  if (rc != 0) return rc;
+  e->status = 1;
+  rc = pthread_mutex_unlock(&e->lock);
+  if (rc != 0) return rc;
+  rc = pthread_cond_broadcast(&e->triggered);
+  return rc;
+}
+
+static int st_event_wait(st_event e)
+{
+  int rc;
+  rc = pthread_mutex_lock(&e->lock);
+  if (rc != 0) return rc;
+  while(e->status == 0) {
+    rc = pthread_cond_wait(&e->triggered, &e->lock);
+    if (rc != 0) return rc;
+  }
+  rc = pthread_mutex_unlock(&e->lock);
+  return rc;
+}
+
+/* Reporting errors */
+
+static void st_check_error(int retcode, char * msg)
+{
+  char * err;
+  int errlen, msglen;
+  value str;
+
+  if (retcode == 0) return;
+  if (retcode == ENOMEM) caml_raise_out_of_memory();
+  err = strerror(retcode);
+  msglen = strlen(msg);
+  errlen = strlen(err);
+  str = caml_alloc_string(msglen + 2 + errlen);
+  memmove (&Byte(str, 0), msg, msglen);
+  memmove (&Byte(str, msglen), ": ", 2);
+  memmove (&Byte(str, msglen + 2), err, errlen);
+  caml_raise_sys_error(str);
+}
+
+/* Variable used to stop the "tick" thread */
+static volatile int caml_tick_thread_stop = 0;
+
+/* The tick thread: posts a SIGPREEMPTION signal periodically */
+
+static void * caml_thread_tick(void * arg)
+{
+  struct timeval timeout;
+  sigset_t mask;
+
+  /* Block all signals so that we don't try to execute an OCaml signal handler*/
+  sigfillset(&mask);
+  pthread_sigmask(SIG_BLOCK, &mask, NULL);
+  while(! caml_tick_thread_stop) {
+    /* select() seems to be the most efficient way to suspend the
+       thread for sub-second intervals */
+    timeout.tv_sec = 0;
+    timeout.tv_usec = Thread_timeout * 1000;
+    select(0, NULL, NULL, NULL, &timeout);
+    /* The preemption signal should never cause a callback, so don't
+     go through caml_handle_signal(), just record signal delivery via
+     caml_record_signal(). */
+    caml_record_signal(SIGPREEMPTION);
+  }
+  return NULL;
+}
+
+/* "At fork" processing */
+
+#if defined(__ANDROID__)
+/* Android's libc does not include declaration of pthread_atfork;
+   however, it implements it since API level 10 (Gingerbread).
+   The reason for the omission is that Android (GUI) applications
+   are not supposed to fork at all, however this workaround is still
+   included in case OCaml is used for an Android CLI utility. */
+int pthread_atfork(void (*prepare)(void), void (*parent)(void),
+                   void (*child)(void));
+#endif
+
+static int st_atfork(void (*fn)(void))
+{
+  return pthread_atfork(NULL, NULL, fn);
+}
+
+/* Signal handling */
+
+static void st_decode_sigset(value vset, sigset_t * set)
+{
+  sigemptyset(set);
+  while (vset != Val_int(0)) {
+    int sig = caml_convert_signal_number(Int_val(Field(vset, 0)));
+    sigaddset(set, sig);
+    vset = Field(vset, 1);
+  }
+}
+
+#ifndef NSIG
+#define NSIG 64
+#endif
+
+static value st_encode_sigset(sigset_t * set)
+{
+  value res = Val_int(0);
+  int i;
+
+  Begin_root(res)
+    for (i = 1; i < NSIG; i++)
+      if (sigismember(set, i) > 0) {
+        value newcons = caml_alloc_small(2, 0);
+        Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
+        Field(newcons, 1) = res;
+        res = newcons;
+      }
+  End_roots();
+  return res;
+}
+
+static int sigmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK };
+
+value caml_thread_sigmask(value cmd, value sigs) /* ML */
+{
+  int how;
+  sigset_t set, oldset;
+  int retcode;
+
+  how = sigmask_cmd[Int_val(cmd)];
+  st_decode_sigset(sigs, &set);
+  caml_enter_blocking_section();
+  retcode = pthread_sigmask(how, &set, &oldset);
+  caml_leave_blocking_section();
+  st_check_error(retcode, "Thread.sigmask");
+  return st_encode_sigset(&oldset);
+}
+
+value caml_wait_signal(value sigs) /* ML */
+{
+#ifdef HAS_SIGWAIT
+  sigset_t set;
+  int retcode, signo;
+
+  st_decode_sigset(sigs, &set);
+  caml_enter_blocking_section();
+  retcode = sigwait(&set, &signo);
+  caml_leave_blocking_section();
+  st_check_error(retcode, "Thread.wait_signal");
+  return Val_int(caml_rev_convert_signal_number(signo));
+#else
+  caml_invalid_argument("Thread.wait_signal not implemented");
+  return Val_int(0);            /* not reached */
+#endif
+}
diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
new file mode 100644
index 00000000..cd7daa7c
--- /dev/null
+++ b/otherlibs/systhreads/st_stubs.c
@@ -0,0 +1,951 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1995 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include "caml/alloc.h"
+#include "caml/backtrace.h"
+#include "caml/callback.h"
+#include "caml/custom.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/memory.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/printexc.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#ifdef NATIVE_CODE
+#include "caml/stack.h"
+#else
+#include "caml/stacks.h"
+#endif
+#include "caml/sys.h"
+#include "threads.h"
+
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "caml/spacetime.h"
+#endif
+
+/* Initial size of bytecode stack when a thread is created (4 Ko) */
+#define Thread_stack_size (Stack_size / 4)
+
+/* Max computation time before rescheduling, in milliseconds */
+#define Thread_timeout 50
+
+/* OS-specific code */
+#ifdef _WIN32
+#include "st_win32.h"
+#else
+#include "st_posix.h"
+#endif
+
+/* The ML value describing a thread (heap-allocated) */
+
+struct caml_thread_descr {
+  value ident;                  /* Unique integer ID */
+  value start_closure;          /* The closure to start this thread */
+  value terminated;             /* Triggered event for thread termination */
+};
+
+#define Ident(v) (((struct caml_thread_descr *)(v))->ident)
+#define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure)
+#define Terminated(v) (((struct caml_thread_descr *)(v))->terminated)
+
+/* The infos on threads (allocated via malloc()) */
+
+struct caml_thread_struct {
+  value descr;                  /* The heap-allocated descriptor (root) */
+  struct caml_thread_struct * next;  /* Double linking of running threads */
+  struct caml_thread_struct * prev;
+#ifdef NATIVE_CODE
+  char * top_of_stack;          /* Top of stack for this thread (approx.) */
+  char * bottom_of_stack;       /* Saved value of caml_bottom_of_stack */
+  uintnat last_retaddr;         /* Saved value of caml_last_return_address */
+  value * gc_regs;              /* Saved value of caml_gc_regs */
+  char * exception_pointer;     /* Saved value of caml_exception_pointer */
+  struct caml__roots_block * local_roots; /* Saved value of local_roots */
+  struct longjmp_buffer * exit_buf; /* For thread exit */
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  value internal_spacetime_trie_root;
+  value internal_spacetime_finaliser_trie_root;
+  value* spacetime_trie_node_ptr;
+  value* spacetime_finaliser_trie_root;
+#endif
+#else
+  value * stack_low;            /* The execution stack for this thread */
+  value * stack_high;
+  value * stack_threshold;
+  value * sp;                   /* Saved value of caml_extern_sp for this thread */
+  value * trapsp;               /* Saved value of caml_trapsp for this thread */
+  struct caml__roots_block * local_roots; /* Saved value of caml_local_roots */
+  struct longjmp_buffer * external_raise; /* Saved caml_external_raise */
+#endif
+  int backtrace_pos;            /* Saved caml_backtrace_pos */
+  backtrace_slot * backtrace_buffer;    /* Saved caml_backtrace_buffer */
+  value backtrace_last_exn;     /* Saved caml_backtrace_last_exn (root) */
+};
+
+typedef struct caml_thread_struct * caml_thread_t;
+
+/* The "head" of the circular list of thread descriptors */
+static caml_thread_t all_threads = NULL;
+
+/* The descriptor for the currently executing thread */
+static caml_thread_t curr_thread = NULL;
+
+/* The master lock protecting the OCaml runtime system */
+static st_masterlock caml_master_lock;
+
+/* Whether the "tick" thread is already running */
+static int caml_tick_thread_running = 0;
+
+/* The thread identifier of the "tick" thread */
+static st_thread_id caml_tick_thread_id;
+
+/* The key used for storing the thread descriptor in the specific data
+   of the corresponding system thread. */
+static st_tlskey thread_descriptor_key;
+
+/* The key used for unlocking I/O channels on exceptions */
+static st_tlskey last_channel_locked_key;
+
+/* Identifier for next thread creation */
+static intnat thread_next_ident = 0;
+
+/* Forward declarations */
+static value caml_threadstatus_new (void);
+static void caml_threadstatus_terminate (value);
+static st_retcode caml_threadstatus_wait (value);
+
+/* Imports from the native-code runtime system */
+#ifdef NATIVE_CODE
+extern struct longjmp_buffer caml_termination_jmpbuf;
+extern void (*caml_termination_hook)(void);
+#endif
+
+/* Hook for scanning the stacks of the other threads */
+
+static void (*prev_scan_roots_hook) (scanning_action);
+
+static void caml_thread_scan_roots(scanning_action action)
+{
+  caml_thread_t th;
+
+  th = curr_thread;
+  do {
+    (*action)(th->descr, &th->descr);
+    (*action)(th->backtrace_last_exn, &th->backtrace_last_exn);
+    /* Don't rescan the stack of the current thread, it was done already */
+    if (th != curr_thread) {
+#ifdef NATIVE_CODE
+      if (th->bottom_of_stack != NULL)
+        caml_do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
+                       th->gc_regs, th->local_roots);
+#else
+      caml_do_local_roots(action, th->sp, th->stack_high, th->local_roots);
+#endif
+    }
+    th = th->next;
+  } while (th != curr_thread);
+  /* Hook */
+  if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
+}
+
+/* Saving and restoring runtime state in curr_thread */
+
+static inline void caml_thread_save_runtime_state(void)
+{
+#ifdef NATIVE_CODE
+  curr_thread->top_of_stack = caml_top_of_stack;
+  curr_thread->bottom_of_stack = caml_bottom_of_stack;
+  curr_thread->last_retaddr = caml_last_return_address;
+  curr_thread->gc_regs = caml_gc_regs;
+  curr_thread->exception_pointer = caml_exception_pointer;
+  curr_thread->local_roots = caml_local_roots;
+#ifdef WITH_SPACETIME
+  curr_thread->spacetime_trie_node_ptr
+    = caml_spacetime_trie_node_ptr;
+  curr_thread->spacetime_finaliser_trie_root
+    = caml_spacetime_finaliser_trie_root;
+#endif
+#else
+  curr_thread->stack_low = caml_stack_low;
+  curr_thread->stack_high = caml_stack_high;
+  curr_thread->stack_threshold = caml_stack_threshold;
+  curr_thread->sp = caml_extern_sp;
+  curr_thread->trapsp = caml_trapsp;
+  curr_thread->local_roots = caml_local_roots;
+  curr_thread->external_raise = caml_external_raise;
+#endif
+  curr_thread->backtrace_pos = caml_backtrace_pos;
+  curr_thread->backtrace_buffer = caml_backtrace_buffer;
+  curr_thread->backtrace_last_exn = caml_backtrace_last_exn;
+}
+
+static inline void caml_thread_restore_runtime_state(void)
+{
+#ifdef NATIVE_CODE
+  caml_top_of_stack = curr_thread->top_of_stack;
+  caml_bottom_of_stack= curr_thread->bottom_of_stack;
+  caml_last_return_address = curr_thread->last_retaddr;
+  caml_gc_regs = curr_thread->gc_regs;
+  caml_exception_pointer = curr_thread->exception_pointer;
+  caml_local_roots = curr_thread->local_roots;
+#ifdef WITH_SPACETIME
+  caml_spacetime_trie_node_ptr
+    = curr_thread->spacetime_trie_node_ptr;
+  caml_spacetime_finaliser_trie_root
+    = curr_thread->spacetime_finaliser_trie_root;
+#endif
+#else
+  caml_stack_low = curr_thread->stack_low;
+  caml_stack_high = curr_thread->stack_high;
+  caml_stack_threshold = curr_thread->stack_threshold;
+  caml_extern_sp = curr_thread->sp;
+  caml_trapsp = curr_thread->trapsp;
+  caml_local_roots = curr_thread->local_roots;
+  caml_external_raise = curr_thread->external_raise;
+#endif
+  caml_backtrace_pos = curr_thread->backtrace_pos;
+  caml_backtrace_buffer = curr_thread->backtrace_buffer;
+  caml_backtrace_last_exn = curr_thread->backtrace_last_exn;
+}
+
+/* Hooks for caml_enter_blocking_section and caml_leave_blocking_section */
+
+
+static void caml_thread_enter_blocking_section(void)
+{
+  /* Save the current runtime state in the thread descriptor
+     of the current thread */
+  caml_thread_save_runtime_state();
+  /* Tell other threads that the runtime is free */
+  st_masterlock_release(&caml_master_lock);
+}
+
+static void caml_thread_leave_blocking_section(void)
+{
+  /* Wait until the runtime is free */
+  st_masterlock_acquire(&caml_master_lock);
+  /* Update curr_thread to point to the thread descriptor corresponding
+     to the thread currently executing */
+  curr_thread = st_tls_get(thread_descriptor_key);
+  /* Restore the runtime state from the curr_thread descriptor */
+  caml_thread_restore_runtime_state();
+}
+
+static int caml_thread_try_leave_blocking_section(void)
+{
+  /* Disable immediate processing of signals (PR#3659).
+     try_leave_blocking_section always fails, forcing the signal to be
+     recorded and processed at the next leave_blocking_section or
+     polling. */
+  return 0;
+}
+
+/* Hooks for I/O locking */
+
+static void caml_io_mutex_free(struct channel *chan)
+{
+  st_mutex mutex = chan->mutex;
+  if (mutex != NULL) {
+    st_mutex_destroy(mutex);
+    chan->mutex = NULL;
+  }
+}
+
+static void caml_io_mutex_lock(struct channel *chan)
+{
+  st_mutex mutex = chan->mutex;
+
+  if (mutex == NULL) {
+    st_check_error(st_mutex_create(&mutex), "channel locking"); /*PR#7038*/
+    chan->mutex = mutex;
+  }
+  /* PR#4351: first try to acquire mutex without releasing the master lock */
+  if (st_mutex_trylock(mutex) == PREVIOUSLY_UNLOCKED) {
+    st_tls_set(last_channel_locked_key, (void *) chan);
+    return;
+  }
+  /* If unsuccessful, block on mutex */
+  caml_enter_blocking_section();
+  st_mutex_lock(mutex);
+  /* Problem: if a signal occurs at this point,
+     and the signal handler raises an exception, we will not
+     unlock the mutex.  The alternative (doing the setspecific
+     before locking the mutex is also incorrect, since we could
+     then unlock a mutex that is unlocked or locked by someone else. */
+  st_tls_set(last_channel_locked_key, (void *) chan);
+  caml_leave_blocking_section();
+}
+
+static void caml_io_mutex_unlock(struct channel *chan)
+{
+  st_mutex_unlock(chan->mutex);
+  st_tls_set(last_channel_locked_key, NULL);
+}
+
+static void caml_io_mutex_unlock_exn(void)
+{
+  struct channel * chan = st_tls_get(last_channel_locked_key);
+  if (chan != NULL) caml_io_mutex_unlock(chan);
+}
+
+/* Hook for estimating stack usage */
+
+static uintnat (*prev_stack_usage_hook)(void);
+
+static uintnat caml_thread_stack_usage(void)
+{
+  uintnat sz;
+  caml_thread_t th;
+
+  /* Don't add stack for current thread, this is done elsewhere */
+  for (sz = 0, th = curr_thread->next;
+       th != curr_thread;
+       th = th->next) {
+#ifdef NATIVE_CODE
+  if(th->top_of_stack != NULL && th->bottom_of_stack != NULL &&
+     th->top_of_stack > th->bottom_of_stack)
+       sz += (value *) th->top_of_stack - (value *) th->bottom_of_stack;
+#else
+    sz += th->stack_high - th->sp;
+#endif
+  }
+  if (prev_stack_usage_hook != NULL)
+    sz += prev_stack_usage_hook();
+  return sz;
+}
+
+/* Create and setup a new thread info block.
+   This block has no associated thread descriptor and
+   is not inserted in the list of threads. */
+
+static caml_thread_t caml_thread_new_info(void)
+{
+  caml_thread_t th;
+  th = (caml_thread_t) malloc(sizeof(struct caml_thread_struct));
+  if (th == NULL) return NULL;
+  th->descr = Val_unit;         /* filled later */
+#ifdef NATIVE_CODE
+  th->bottom_of_stack = NULL;
+  th->top_of_stack = NULL;
+  th->last_retaddr = 1;
+  th->exception_pointer = NULL;
+  th->local_roots = NULL;
+  th->exit_buf = NULL;
+#ifdef WITH_SPACETIME
+  /* CR-someday mshinwell: The commented-out changes here are for multicore,
+     where we think we should have one trie per domain. */
+  th->internal_spacetime_trie_root = Val_unit;
+  th->spacetime_trie_node_ptr =
+    &caml_spacetime_trie_root; /* &th->internal_spacetime_trie_root; */
+  th->internal_spacetime_finaliser_trie_root = Val_unit;
+  th->spacetime_finaliser_trie_root
+    = caml_spacetime_finaliser_trie_root;
+    /* &th->internal_spacetime_finaliser_trie_root; */
+  caml_spacetime_register_thread(
+    th->spacetime_trie_node_ptr,
+    th->spacetime_finaliser_trie_root);
+#endif
+#else
+  /* Allocate the stacks */
+  th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
+  th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
+  th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
+  th->sp = th->stack_high;
+  th->trapsp = th->stack_high;
+  th->local_roots = NULL;
+  th->external_raise = NULL;
+#endif
+  th->backtrace_pos = 0;
+  th->backtrace_buffer = NULL;
+  th->backtrace_last_exn = Val_unit;
+  return th;
+}
+
+/* Allocate a thread descriptor block. */
+
+static value caml_thread_new_descriptor(value clos)
+{
+  value mu = Val_unit;
+  value descr;
+  Begin_roots2 (clos, mu)
+    /* Create and initialize the termination semaphore */
+    mu = caml_threadstatus_new();
+    /* Create a descriptor for the new thread */
+    descr = caml_alloc_small(3, 0);
+    Ident(descr) = Val_long(thread_next_ident);
+    Start_closure(descr) = clos;
+    Terminated(descr) = mu;
+    thread_next_ident++;
+  End_roots();
+  return descr;
+}
+
+/* Remove a thread info block from the list of threads.
+   Free it and its stack resources. */
+
+static void caml_thread_remove_info(caml_thread_t th)
+{
+  if (th->next == th)
+    all_threads = NULL; /* last OCaml thread exiting */
+  else if (all_threads == th)
+    all_threads = th->next;     /* PR#5295 */
+  th->next->prev = th->prev;
+  th->prev->next = th->next;
+#ifndef NATIVE_CODE
+  caml_stat_free(th->stack_low);
+#endif
+  if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
+#ifndef WITH_SPACETIME
+  caml_stat_free(th);
+  /* CR-soon mshinwell: consider what to do about the Spacetime trace.  Could
+     perhaps have a hook to save a snapshot on thread termination.
+     For the moment we can't even free [th], since it contains the trie
+     roots. */
+#endif
+}
+
+/* Reinitialize the thread machinery after a fork() (PR#4577) */
+
+static void caml_thread_reinitialize(void)
+{
+  caml_thread_t thr, next;
+  struct channel * chan;
+
+  /* Remove all other threads (now nonexistent)
+     from the doubly-linked list of threads */
+  thr = curr_thread->next;
+  while (thr != curr_thread) {
+    next = thr->next;
+    caml_stat_free(thr);
+    thr = next;
+  }
+  curr_thread->next = curr_thread;
+  curr_thread->prev = curr_thread;
+  all_threads = curr_thread;
+  /* Reinitialize the master lock machinery,
+     just in case the fork happened while other threads were doing
+     caml_leave_blocking_section */
+  st_masterlock_init(&caml_master_lock);
+  /* Tick thread is not currently running in child process, will be
+     re-created at next Thread.create */
+  caml_tick_thread_running = 0;
+  /* Destroy all IO mutexes; will be reinitialized on demand */
+  for (chan = caml_all_opened_channels;
+       chan != NULL;
+       chan = chan->next) {
+    if (chan->mutex != NULL) {
+      st_mutex_destroy(chan->mutex);
+      chan->mutex = NULL;
+    }
+  }
+}
+
+/* Initialize the thread machinery */
+
+CAMLprim value caml_thread_initialize(value unit)   /* ML */
+{
+  /* Protect against repeated initialization (PR#1325) */
+  if (curr_thread != NULL) return Val_unit;
+  /* OS-specific initialization */
+  st_initialize();
+  /* Initialize and acquire the master lock */
+  st_masterlock_init(&caml_master_lock);
+  /* Initialize the keys */
+  st_tls_newkey(&thread_descriptor_key);
+  st_tls_newkey(&last_channel_locked_key);
+  /* Set up a thread info block for the current thread */
+  curr_thread =
+    (caml_thread_t) caml_stat_alloc(sizeof(struct caml_thread_struct));
+  curr_thread->descr = caml_thread_new_descriptor(Val_unit);
+  curr_thread->next = curr_thread;
+  curr_thread->prev = curr_thread;
+  all_threads = curr_thread;
+  curr_thread->backtrace_last_exn = Val_unit;
+#ifdef NATIVE_CODE
+  curr_thread->exit_buf = &caml_termination_jmpbuf;
+#endif
+  /* The stack-related fields will be filled in at the next
+     caml_enter_blocking_section */
+  /* Associate the thread descriptor with the thread */
+  st_tls_set(thread_descriptor_key, (void *) curr_thread);
+  /* Set up the hooks */
+  prev_scan_roots_hook = caml_scan_roots_hook;
+  caml_scan_roots_hook = caml_thread_scan_roots;
+  caml_enter_blocking_section_hook = caml_thread_enter_blocking_section;
+  caml_leave_blocking_section_hook = caml_thread_leave_blocking_section;
+  caml_try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
+#ifdef NATIVE_CODE
+  caml_termination_hook = st_thread_exit;
+#endif
+  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;
+  prev_stack_usage_hook = caml_stack_usage_hook;
+  caml_stack_usage_hook = caml_thread_stack_usage;
+  /* Set up fork() to reinitialize the thread machinery in the child
+     (PR#4577) */
+  st_atfork(caml_thread_reinitialize);
+  return Val_unit;
+}
+
+/* Cleanup the thread machinery on program exit or DLL unload. */
+
+CAMLprim value caml_thread_cleanup(value unit)   /* ML */
+{
+  if (caml_tick_thread_running){
+    caml_tick_thread_stop = 1;
+    st_thread_join(caml_tick_thread_id);
+    caml_tick_thread_stop = 0;
+    caml_tick_thread_running = 0;
+  }
+  return Val_unit;
+}
+
+/* Thread cleanup at termination */
+
+static void caml_thread_stop(void)
+{
+  /* PR#5188, PR#7220: some of the global runtime state may have
+     changed as the thread was running, so we save it in the
+     curr_thread data to make sure that the cleanup logic
+     below uses accurate information. */
+  caml_thread_save_runtime_state();
+  /* Signal that the thread has terminated */
+  caml_threadstatus_terminate(Terminated(curr_thread->descr));
+  /* Remove th from the doubly-linked list of threads and free its info block */
+  caml_thread_remove_info(curr_thread);
+  /* OS-specific cleanups */
+  st_thread_cleanup();
+  /* Release the runtime system */
+  st_masterlock_release(&caml_master_lock);
+}
+
+/* Create a thread */
+
+static ST_THREAD_FUNCTION caml_thread_start(void * arg)
+{
+  caml_thread_t th = (caml_thread_t) arg;
+  value clos;
+#ifdef NATIVE_CODE
+  struct longjmp_buffer termination_buf;
+  char tos;
+#endif
+
+  /* Associate the thread descriptor with the thread */
+  st_tls_set(thread_descriptor_key, (void *) th);
+  /* Acquire the global mutex */
+  caml_leave_blocking_section();
+#ifdef NATIVE_CODE
+  /* Record top of stack (approximative) */
+  th->top_of_stack = &tos;
+  /* Setup termination handler (for caml_thread_exit) */
+  if (sigsetjmp(termination_buf.buf, 0) == 0) {
+    th->exit_buf = &termination_buf;
+#endif
+    /* Callback the closure */
+    clos = Start_closure(th->descr);
+    caml_modify(&(Start_closure(th->descr)), Val_unit);
+    caml_callback_exn(clos, Val_unit);
+    caml_thread_stop();
+#ifdef NATIVE_CODE
+  }
+#endif
+  /* The thread now stops running */
+  return 0;
+}
+
+CAMLprim value caml_thread_new(value clos)          /* ML */
+{
+  caml_thread_t th;
+  st_retcode err;
+
+  /* Create a thread info block */
+  th = caml_thread_new_info();
+  if (th == NULL) caml_raise_out_of_memory();
+  /* Equip it with a thread descriptor */
+  th->descr = caml_thread_new_descriptor(clos);
+  /* Add thread info block to the list of threads */
+  th->next = curr_thread->next;
+  th->prev = curr_thread;
+  curr_thread->next->prev = th;
+  curr_thread->next = th;
+  /* Create the new thread */
+  err = st_thread_create(NULL, caml_thread_start, (void *) th);
+  if (err != 0) {
+    /* Creation failed, remove thread info block from list of threads */
+    caml_thread_remove_info(th);
+    st_check_error(err, "Thread.create");
+  }
+  /* Create the tick thread if not already done.
+     Because of PR#4666, we start the tick thread late, only when we create
+     the first additional thread in the current process*/
+  if (! caml_tick_thread_running) {
+    err = st_thread_create(&caml_tick_thread_id, caml_thread_tick, NULL);
+    st_check_error(err, "Thread.create");
+    caml_tick_thread_running = 1;
+  }
+  return th->descr;
+}
+
+/* Register a thread already created from C */
+
+CAMLexport int caml_c_thread_register(void)
+{
+  caml_thread_t th;
+  st_retcode err;
+
+  /* Already registered? */
+  if (st_tls_get(thread_descriptor_key) != NULL) return 0;
+  /* Create a thread info block */
+  th = caml_thread_new_info();
+  if (th == NULL) return 0;
+#ifdef NATIVE_CODE
+  th->top_of_stack = (char *) &err;
+#endif
+  /* Take master lock to protect access to the chaining of threads */
+  st_masterlock_acquire(&caml_master_lock);
+  /* Add thread info block to the list of threads */
+  if (all_threads == NULL) {
+    th->next = th;
+    th->prev = th;
+    all_threads = th;
+  } else {
+    th->next = all_threads->next;
+    th->prev = all_threads;
+    all_threads->next->prev = th;
+    all_threads->next = th;
+  }
+  /* Associate the thread descriptor with the thread */
+  st_tls_set(thread_descriptor_key, (void *) th);
+  /* Release the master lock */
+  st_masterlock_release(&caml_master_lock);
+  /* Now we can re-enter the run-time system and heap-allocate the descriptor */
+  caml_leave_blocking_section();
+  th->descr = caml_thread_new_descriptor(Val_unit);  /* no closure */
+  /* Create the tick thread if not already done.  */
+  if (! caml_tick_thread_running) {
+    err = st_thread_create(&caml_tick_thread_id, caml_thread_tick, NULL);
+    if (err == 0) caml_tick_thread_running = 1;
+  }
+  /* Exit the run-time system */
+  caml_enter_blocking_section();
+  return 1;
+}
+
+/* Unregister a thread that was created from C and registered with
+   the function above */
+
+CAMLexport int caml_c_thread_unregister(void)
+{
+  caml_thread_t th = st_tls_get(thread_descriptor_key);
+  /* Not registered? */
+  if (th == NULL) return 0;
+  /* Wait until the runtime is available */
+  st_masterlock_acquire(&caml_master_lock);
+  /* Forget the thread descriptor */
+  st_tls_set(thread_descriptor_key, NULL);
+  /* Remove thread info block from list of threads, and free it */
+  caml_thread_remove_info(th);
+  /* Release the runtime */
+  st_masterlock_release(&caml_master_lock);
+  return 1;
+}
+
+/* Return the current thread */
+
+CAMLprim value caml_thread_self(value unit)         /* ML */
+{
+  if (curr_thread == NULL) caml_invalid_argument("Thread.self: not initialized");
+  return curr_thread->descr;
+}
+
+/* Return the identifier of a thread */
+
+CAMLprim value caml_thread_id(value th)          /* ML */
+{
+  return Ident(th);
+}
+
+/* Print uncaught exception and backtrace */
+
+CAMLprim value caml_thread_uncaught_exception(value exn)  /* ML */
+{
+  char * msg = caml_format_exception(exn);
+  fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
+          Int_val(Ident(curr_thread->descr)), msg);
+  free(msg);
+  if (caml_backtrace_active) caml_print_exception_backtrace();
+  fflush(stderr);
+  return Val_unit;
+}
+
+/* Terminate current thread */
+
+CAMLprim value caml_thread_exit(value unit)   /* ML */
+{
+  struct longjmp_buffer * exit_buf = NULL;
+
+  if (curr_thread == NULL) caml_invalid_argument("Thread.exit: not initialized");
+
+  /* In native code, we cannot call pthread_exit here because on some
+     systems this raises a C++ exception, and ocamlopt-generated stack
+     frames cannot be unwound.  Instead, we longjmp to the thread
+     creation point (in caml_thread_start) or to the point in
+     caml_main where caml_termination_hook will be called.
+     Note that threads created in C then registered do not have
+     a creation point (exit_buf == NULL).
+ */
+#ifdef NATIVE_CODE
+  exit_buf = curr_thread->exit_buf;
+#endif
+  caml_thread_stop();
+  if (exit_buf != NULL) {
+    /* Native-code and (main thread or thread created by OCaml) */
+    siglongjmp(exit_buf->buf, 1);
+  } else {
+    /* Bytecode, or thread created from C */
+    st_thread_exit();
+  }
+  return Val_unit;  /* not reached */
+}
+
+/* Allow re-scheduling */
+
+CAMLprim value caml_thread_yield(value unit)        /* ML */
+{
+  if (st_masterlock_waiters(&caml_master_lock) == 0) return Val_unit;
+  caml_enter_blocking_section();
+  st_thread_yield();
+  caml_leave_blocking_section();
+  return Val_unit;
+}
+
+/* Suspend the current thread until another thread terminates */
+
+CAMLprim value caml_thread_join(value th)          /* ML */
+{
+  st_retcode rc = caml_threadstatus_wait(Terminated(th));
+  st_check_error(rc, "Thread.join");
+  return Val_unit;
+}
+
+/* Mutex operations */
+
+#define Mutex_val(v) (* ((st_mutex *) Data_custom_val(v)))
+
+static void caml_mutex_finalize(value wrapper)
+{
+  st_mutex_destroy(Mutex_val(wrapper));
+}
+
+static int caml_mutex_compare(value wrapper1, value wrapper2)
+{
+  st_mutex mut1 = Mutex_val(wrapper1);
+  st_mutex mut2 = Mutex_val(wrapper2);
+  return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1;
+}
+
+static intnat caml_mutex_hash(value wrapper)
+{
+  return (intnat) (Mutex_val(wrapper));
+}
+
+static struct custom_operations caml_mutex_ops = {
+  "_mutex",
+  caml_mutex_finalize,
+  caml_mutex_compare,
+  caml_mutex_hash,
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+CAMLprim value caml_mutex_new(value unit)        /* ML */
+{
+  st_mutex mut = NULL;          /* suppress warning */
+  value wrapper;
+  st_check_error(st_mutex_create(&mut), "Mutex.create");
+  wrapper = caml_alloc_custom(&caml_mutex_ops, sizeof(st_mutex *),
+                              0, 1);
+  Mutex_val(wrapper) = mut;
+  return wrapper;
+}
+
+CAMLprim value caml_mutex_lock(value wrapper)     /* ML */
+{
+  st_mutex mut = Mutex_val(wrapper);
+  st_retcode retcode;
+
+  /* PR#4351: first try to acquire mutex without releasing the master lock */
+  if (st_mutex_trylock(mut) == PREVIOUSLY_UNLOCKED) return Val_unit;
+  /* If unsuccessful, block on mutex */
+  Begin_root(wrapper)           /* prevent the deallocation of mutex */
+    caml_enter_blocking_section();
+    retcode = st_mutex_lock(mut);
+    caml_leave_blocking_section();
+  End_roots();
+  st_check_error(retcode, "Mutex.lock");
+  return Val_unit;
+}
+
+CAMLprim value caml_mutex_unlock(value wrapper)           /* ML */
+{
+  st_mutex mut = Mutex_val(wrapper);
+  st_retcode retcode;
+  /* PR#4351: no need to release and reacquire master lock */
+  retcode = st_mutex_unlock(mut);
+  st_check_error(retcode, "Mutex.unlock");
+  return Val_unit;
+}
+
+CAMLprim value caml_mutex_try_lock(value wrapper)           /* ML */
+{
+  st_mutex mut = Mutex_val(wrapper);
+  st_retcode retcode;
+  retcode = st_mutex_trylock(mut);
+  if (retcode == ALREADY_LOCKED) return Val_false;
+  st_check_error(retcode, "Mutex.try_lock");
+  return Val_true;
+}
+
+/* Conditions operations */
+
+#define Condition_val(v) (* (st_condvar *) Data_custom_val(v))
+
+static void caml_condition_finalize(value wrapper)
+{
+  st_condvar_destroy(Condition_val(wrapper));
+}
+
+static int caml_condition_compare(value wrapper1, value wrapper2)
+{
+  st_condvar cond1 = Condition_val(wrapper1);
+  st_condvar cond2 = Condition_val(wrapper2);
+  return cond1 == cond2 ? 0 : cond1 < cond2 ? -1 : 1;
+}
+
+static intnat caml_condition_hash(value wrapper)
+{
+  return (intnat) (Condition_val(wrapper));
+}
+
+static struct custom_operations caml_condition_ops = {
+  "_condition",
+  caml_condition_finalize,
+  caml_condition_compare,
+  caml_condition_hash,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+CAMLprim value caml_condition_new(value unit)        /* ML */
+{
+  st_condvar cond = NULL;       /* suppress warning */
+  value wrapper;
+  st_check_error(st_condvar_create(&cond), "Condition.create");
+  wrapper = caml_alloc_custom(&caml_condition_ops, sizeof(st_condvar *),
+                              0, 1);
+  Condition_val(wrapper) = cond;
+  return wrapper;
+}
+
+CAMLprim value caml_condition_wait(value wcond, value wmut)           /* ML */
+{
+  st_condvar cond = Condition_val(wcond);
+  st_mutex mut = Mutex_val(wmut);
+  st_retcode retcode;
+
+  Begin_roots2(wcond, wmut)     /* prevent deallocation of cond and mutex */
+    caml_enter_blocking_section();
+    retcode = st_condvar_wait(cond, mut);
+    caml_leave_blocking_section();
+  End_roots();
+  st_check_error(retcode, "Condition.wait");
+  return Val_unit;
+}
+
+CAMLprim value caml_condition_signal(value wrapper)           /* ML */
+{
+  st_check_error(st_condvar_signal(Condition_val(wrapper)),
+                 "Condition.signal");
+  return Val_unit;
+}
+
+CAMLprim value caml_condition_broadcast(value wrapper)           /* ML */
+{
+  st_check_error(st_condvar_broadcast(Condition_val(wrapper)),
+                 "Condition.broadcast");
+  return Val_unit;
+}
+
+/* Thread status blocks */
+
+#define Threadstatus_val(v) (* ((st_event *) Data_custom_val(v)))
+
+static void caml_threadstatus_finalize(value wrapper)
+{
+  st_event_destroy(Threadstatus_val(wrapper));
+}
+
+static int caml_threadstatus_compare(value wrapper1, value wrapper2)
+{
+  st_event ts1 = Threadstatus_val(wrapper1);
+  st_event ts2 = Threadstatus_val(wrapper2);
+  return ts1 == ts2 ? 0 : ts1 < ts2 ? -1 : 1;
+}
+
+static struct custom_operations caml_threadstatus_ops = {
+  "_threadstatus",
+  caml_threadstatus_finalize,
+  caml_threadstatus_compare,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+static value caml_threadstatus_new (void)
+{
+  st_event ts = NULL;           /* suppress warning */
+  value wrapper;
+  st_check_error(st_event_create(&ts), "Thread.create");
+  wrapper = caml_alloc_custom(&caml_threadstatus_ops, sizeof(st_event *),
+                              0, 1);
+  Threadstatus_val(wrapper) = ts;
+  return wrapper;
+}
+
+static void caml_threadstatus_terminate (value wrapper)
+{
+  st_event_trigger(Threadstatus_val(wrapper));
+}
+
+static st_retcode caml_threadstatus_wait (value wrapper)
+{
+  st_event ts = Threadstatus_val(wrapper);
+  st_retcode retcode;
+
+  Begin_roots1(wrapper)         /* prevent deallocation of ts */
+    caml_enter_blocking_section();
+    retcode = st_event_wait(ts);
+    caml_leave_blocking_section();
+  End_roots();
+  return retcode;
+}
diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h
new file mode 100644
index 00000000..fa447a9c
--- /dev/null
+++ b/otherlibs/systhreads/st_win32.h
@@ -0,0 +1,424 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2009 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Win32 implementation of the "st" interface */
+
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0400
+#include <windows.h>
+#include <winerror.h>
+#include <stdio.h>
+#include <signal.h>
+
+#define INLINE __inline
+
+#if 1
+#define TRACE(x)
+#define TRACE1(x,y)
+#else
+#include <stdio.h>
+#define TRACE(x) printf("%d: %s\n", GetCurrentThreadId(), x); fflush(stdout)
+#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); \
+                    fflush(stdout)
+#endif
+
+typedef DWORD st_retcode;
+
+#define SIGPREEMPTION SIGTERM
+
+/* Thread-local storage assocaiting a Win32 event to every thread. */
+static DWORD st_thread_sem_key;
+
+/* OS-specific initialization */
+
+static DWORD st_initialize(void)
+{
+  st_thread_sem_key = TlsAlloc();
+  if (st_thread_sem_key == TLS_OUT_OF_INDEXES)
+    return GetLastError();
+  else
+    return 0;
+}
+
+/* Thread creation.  Created in detached mode if [res] is NULL. */
+
+typedef HANDLE st_thread_id;
+
+static DWORD st_thread_create(st_thread_id * res,
+                              LPTHREAD_START_ROUTINE fn, void * arg)
+{
+  HANDLE h = CreateThread(NULL, 0, fn, arg, 0, NULL);
+  TRACE1("st_thread_create", h);
+  if (h == NULL) return GetLastError();
+  if (res == NULL)
+    CloseHandle(h);
+  else
+    *res = h;
+  return 0;
+}
+
+#define ST_THREAD_FUNCTION DWORD WINAPI
+
+/* Cleanup at thread exit */
+
+static void st_thread_cleanup(void)
+{
+  HANDLE ev = (HANDLE) TlsGetValue(st_thread_sem_key);
+  if (ev != NULL) CloseHandle(ev);
+}
+
+/* Thread termination */
+
+static void st_thread_exit(void)
+{
+  TRACE("st_thread_exit");
+  ExitThread(0);
+}
+
+static void st_thread_join(st_thread_id thr)
+{
+  TRACE1("st_thread_join", h);
+  WaitForSingleObject(thr, INFINITE);
+}
+
+/* Scheduling hints */
+
+static INLINE void st_thread_yield(void)
+{
+  Sleep(0);
+}
+
+/* Thread-specific state */
+
+typedef DWORD st_tlskey;
+
+static DWORD st_tls_newkey(st_tlskey * res)
+{
+  *res = TlsAlloc();
+  if (*res == TLS_OUT_OF_INDEXES)
+    return GetLastError();
+  else
+    return 0;
+}
+
+static INLINE void * st_tls_get(st_tlskey k)
+{
+  return TlsGetValue(k);
+}
+
+static INLINE void st_tls_set(st_tlskey k, void * v)
+{
+  TlsSetValue(k, v);
+}
+
+/* The master lock.  */
+
+typedef CRITICAL_SECTION st_masterlock;
+
+static void st_masterlock_init(st_masterlock * m)
+{
+  TRACE("st_masterlock_init");
+  InitializeCriticalSection(m);
+  EnterCriticalSection(m);
+}
+
+static INLINE void st_masterlock_acquire(st_masterlock * m)
+{
+  TRACE("st_masterlock_acquire");
+  EnterCriticalSection(m);
+  TRACE("st_masterlock_acquire (done)");
+}
+
+static INLINE void st_masterlock_release(st_masterlock * m)
+{
+  LeaveCriticalSection(m);
+  TRACE("st_masterlock_released");
+}
+
+static INLINE int st_masterlock_waiters(st_masterlock * m)
+{
+  return 1;                     /* info not maintained */
+}
+
+/* Mutexes */
+
+typedef CRITICAL_SECTION * st_mutex;
+
+static DWORD st_mutex_create(st_mutex * res)
+{
+  st_mutex m = malloc(sizeof(CRITICAL_SECTION));
+  if (m == NULL) return ERROR_NOT_ENOUGH_MEMORY;
+  InitializeCriticalSection(m);
+  *res = m;
+  return 0;
+}
+
+static DWORD st_mutex_destroy(st_mutex m)
+{
+  DeleteCriticalSection(m);
+  free(m);
+  return 0;
+}
+
+static INLINE DWORD st_mutex_lock(st_mutex m)
+{
+  TRACE1("st_mutex_lock", m);
+  EnterCriticalSection(m);
+  TRACE1("st_mutex_lock (done)", m);
+  return 0;
+}
+
+/* Error codes with the 29th bit set are reserved for the application */
+
+#define PREVIOUSLY_UNLOCKED 0
+#define ALREADY_LOCKED (1<<29)
+
+static INLINE DWORD st_mutex_trylock(st_mutex m)
+{
+  TRACE1("st_mutex_trylock", m);
+  if (TryEnterCriticalSection(m)) {
+    TRACE1("st_mutex_trylock (success)", m);
+    return PREVIOUSLY_UNLOCKED;
+  } else {
+    TRACE1("st_mutex_trylock (failure)", m);
+    return ALREADY_LOCKED;
+  }
+}
+
+static INLINE DWORD st_mutex_unlock(st_mutex m)
+{
+  TRACE1("st_mutex_unlock", m);
+  LeaveCriticalSection(m);
+  return 0;
+}
+
+/* Condition variables */
+
+/* A condition variable is just a list of threads currently
+   waiting on this c.v.  Each thread is represented by its
+   associated event. */
+
+struct st_wait_list {
+  HANDLE event;                  /* event of the first waiting thread */
+  struct st_wait_list * next;
+};
+
+typedef struct st_condvar_struct {
+  CRITICAL_SECTION lock;         /* protect the data structure */
+  struct st_wait_list * waiters; /* list of threads waiting */
+} * st_condvar;
+
+static DWORD st_condvar_create(st_condvar * res)
+{
+  st_condvar c = malloc(sizeof(struct st_condvar_struct));
+  if (c == NULL) return ERROR_NOT_ENOUGH_MEMORY;
+  InitializeCriticalSection(&c->lock);
+  c->waiters = NULL;
+  *res = c;
+  return 0;
+}
+
+static DWORD st_condvar_destroy(st_condvar c)
+{
+  TRACE1("st_condvar_destroy", c);
+  DeleteCriticalSection(&c->lock);
+  free(c);
+  return 0;
+}
+
+static DWORD st_condvar_signal(st_condvar c)
+{
+  DWORD rc = 0;
+  struct st_wait_list * curr, * next;
+
+  TRACE1("st_condvar_signal", c);
+  EnterCriticalSection(&c->lock);
+  curr = c->waiters;
+  if (curr != NULL) {
+    next = curr->next;
+    /* Wake up the first waiting thread */
+    TRACE1("st_condvar_signal: waking up", curr->event);
+    if (! SetEvent(curr->event)) rc = GetLastError();
+    /* Remove it from the waiting list */
+    c->waiters = next;
+  }
+  LeaveCriticalSection(&c->lock);
+  return rc;
+}
+
+static DWORD st_condvar_broadcast(st_condvar c)
+{
+  DWORD rc = 0;
+  struct st_wait_list * curr, * next;
+
+  TRACE1("st_condvar_broadcast", c);
+  EnterCriticalSection(&c->lock);
+  /* Wake up all waiting threads */
+  curr = c->waiters;
+  while (curr != NULL) {
+    next = curr->next;
+    TRACE1("st_condvar_signal: waking up", curr->event);
+    if (! SetEvent(curr->event)) rc = GetLastError();
+    curr = next;
+  }
+  /* Remove them all from the waiting list */
+  c->waiters = NULL;
+  LeaveCriticalSection(&c->lock);
+  return rc;
+}
+
+static DWORD st_condvar_wait(st_condvar c, st_mutex m)
+{
+  HANDLE ev;
+  struct st_wait_list wait;
+
+  TRACE1("st_condvar_wait", c);
+  /* Recover (or create) the event associated with the calling thread */
+  ev = (HANDLE) TlsGetValue(st_thread_sem_key);
+  if (ev == 0) {
+    ev = CreateEvent(NULL,
+                     FALSE /*auto reset*/,
+                     FALSE /*initially unset*/,
+                     NULL);
+    if (ev == NULL) return GetLastError();
+    TlsSetValue(st_thread_sem_key, (void *) ev);
+  }
+  EnterCriticalSection(&c->lock);
+  /* Insert the current thread in the waiting list (atomically) */
+  wait.event = ev;
+  wait.next = c->waiters;
+  c->waiters = &wait;
+  LeaveCriticalSection(&c->lock);
+  /* Release the mutex m */
+  LeaveCriticalSection(m);
+  /* Wait for our event to be signaled.  There is no risk of lost
+     wakeup, since we inserted ourselves on the waiting list of c
+     before releasing m */
+  TRACE1("st_condvar_wait: blocking on event", ev);
+  if (WaitForSingleObject(ev, INFINITE) == WAIT_FAILED)
+    return GetLastError();
+  /* Reacquire the mutex m */
+  TRACE1("st_condvar_wait: restarted, acquiring mutex", m);
+  EnterCriticalSection(m);
+  TRACE1("st_condvar_wait: acquired mutex", m);
+  return 0;
+}
+
+/* Triggered events */
+
+typedef HANDLE st_event;
+
+static DWORD st_event_create(st_event * res)
+{
+  st_event m =
+    CreateEvent(NULL, TRUE/*manual reset*/, FALSE/*initially unset*/, NULL);
+  TRACE1("st_event_create", m);
+  if (m == NULL) return GetLastError();
+  *res = m;
+  return 0;
+}
+
+static DWORD st_event_destroy(st_event e)
+{
+  TRACE1("st_event_destroy", e);
+  if (CloseHandle(e))
+    return 0;
+  else
+    return GetLastError();
+}
+
+static DWORD st_event_trigger(st_event e)
+{
+  TRACE1("st_event_trigger", e);
+  if (SetEvent(e))
+    return 0;
+  else
+    return GetLastError();
+}
+
+static DWORD st_event_wait(st_event e)
+{
+  TRACE1("st_event_wait", e);
+  if (WaitForSingleObject(e, INFINITE) == WAIT_FAILED)
+    return GetLastError();
+  else
+    return 0;
+}
+
+/* Reporting errors */
+
+static void st_check_error(DWORD retcode, char * msg)
+{
+  char err[1024];
+  int errlen, msglen;
+  value str;
+
+  if (retcode == 0) return;
+  if (retcode == ERROR_NOT_ENOUGH_MEMORY) caml_raise_out_of_memory();
+  if (! FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
+                      NULL,
+                      retcode,
+                      0,
+                      err,
+                      sizeof(err),
+                      NULL)) {
+    sprintf(err, "error code %lx", retcode);
+  }
+  msglen = strlen(msg);
+  errlen = strlen(err);
+  str = caml_alloc_string(msglen + 2 + errlen);
+  memmove (&Byte(str, 0), msg, msglen);
+  memmove (&Byte(str, msglen), ": ", 2);
+  memmove (&Byte(str, msglen + 2), err, errlen);
+  caml_raise_sys_error(str);
+}
+
+/* Variable used to stop the "tick" thread */
+static volatile int caml_tick_thread_stop = 0;
+
+/* The tick thread: posts a SIGPREEMPTION signal periodically */
+
+static DWORD WINAPI caml_thread_tick(void * arg)
+{
+  while(! caml_tick_thread_stop) {
+    Sleep(Thread_timeout);
+    /* The preemption signal should never cause a callback, so don't
+     go through caml_handle_signal(), just record signal delivery via
+     caml_record_signal(). */
+    caml_record_signal(SIGPREEMPTION);
+  }
+  return 0;
+}
+
+/* "At fork" processing -- none under Win32 */
+
+static DWORD st_atfork(void (*fn)(void))
+{
+  return 0;
+}
+
+/* Signal handling -- none under Win32 */
+
+value caml_thread_sigmask(value cmd, value sigs) /* ML */
+{
+  caml_invalid_argument("Thread.sigmask not implemented");
+  return Val_int(0);            /* not reached */
+}
+
+value caml_wait_signal(value sigs) /* ML */
+{
+  caml_invalid_argument("Thread.wait_signal not implemented");
+  return Val_int(0);            /* not reached */
+}
diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml
new file mode 100644
index 00000000..c55ff3fe
--- /dev/null
+++ b/otherlibs/systhreads/thread.ml
@@ -0,0 +1,90 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* User-level threads *)
+
+type t
+
+external thread_initialize : unit -> unit = "caml_thread_initialize"
+external thread_cleanup : unit -> unit = "caml_thread_cleanup"
+external thread_new : (unit -> unit) -> t = "caml_thread_new"
+external thread_uncaught_exception : exn -> unit =
+            "caml_thread_uncaught_exception"
+
+external yield : unit -> unit = "caml_thread_yield"
+external self : unit -> t = "caml_thread_self" [@@noalloc]
+external id : t -> int = "caml_thread_id" [@@noalloc]
+external join : t -> unit = "caml_thread_join"
+external exit : unit -> unit = "caml_thread_exit"
+
+(* For new, make sure the function passed to thread_new never
+   raises an exception. *)
+
+let create fn arg =
+  thread_new
+    (fun () ->
+      try
+        fn arg; ()
+      with exn ->
+             flush stdout; flush stderr;
+             thread_uncaught_exception exn)
+
+(* Thread.kill is currently not implemented due to problems with
+   cleanup handlers on several platforms *)
+
+let kill th = invalid_arg "Thread.kill: not implemented"
+
+(* Preemption *)
+
+let preempt signal = yield()
+
+(* Initialization of the scheduler *)
+
+let preempt_signal =
+  match Sys.os_type with
+  | "Win32" -> Sys.sigterm
+  | _       -> Sys.sigvtalrm
+
+let _ =
+  Sys.set_signal preempt_signal (Sys.Signal_handle preempt);
+  thread_initialize();
+  at_exit
+    (fun () ->
+        thread_cleanup();
+        (* In case of DLL-embedded OCaml the preempt_signal handler
+           will point to nowhere after DLL unloading and an accidental
+           preempt_signal will crash the main program. So restore the
+           default handler. *)
+        Sys.set_signal preempt_signal Sys.Signal_default
+    )
+
+(* Wait functions *)
+
+let delay time = ignore(Unix.select [] [] [] time)
+
+let wait_read fd = ()
+let wait_write fd = ()
+
+let wait_timed_read fd d =
+  match Unix.select [fd] [] [] d with ([], _, _) -> false | (_, _, _) -> true
+let wait_timed_write fd d =
+  match Unix.select [] [fd] [] d with (_, [], _) -> false | (_, _, _) -> true
+let select = Unix.select
+
+let wait_pid p = Unix.waitpid [] p
+
+external sigmask : Unix.sigprocmask_command -> int list -> int list
+   = "caml_thread_sigmask"
+external wait_signal : int list -> int = "caml_wait_signal"
diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli
new file mode 100644
index 00000000..9b8a1267
--- /dev/null
+++ b/otherlibs/systhreads/thread.mli
@@ -0,0 +1,133 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                        *)
+(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Lightweight threads for Posix [1003.1c] and Win32. *)
+
+type t
+(** The type of thread handles. *)
+
+(** {6 Thread creation and termination} *)
+
+val create : ('a -> 'b) -> 'a -> t
+(** [Thread.create funct arg] creates a new thread of control,
+   in which the function application [funct arg]
+   is executed concurrently with the other threads of the program.
+   The application of [Thread.create]
+   returns the handle of the newly created thread.
+   The new thread terminates when the application [funct arg]
+   returns, either normally or by raising an uncaught exception.
+   In the latter case, the exception is printed on standard error,
+   but not propagated back to the parent thread. Similarly, the
+   result of the application [funct arg] is discarded and not
+   directly accessible to the parent thread. *)
+
+val self : unit -> t
+(** Return the thread currently executing. *)
+
+val id : t -> int
+(** Return the identifier of the given thread. A thread identifier
+   is an integer that identifies uniquely the thread.
+   It can be used to build data structures indexed by threads. *)
+
+val exit : unit -> unit
+(** Terminate prematurely the currently executing thread. *)
+
+val kill : t -> unit
+(** Terminate prematurely the thread whose handle is given. *)
+
+(** {6 Suspending threads} *)
+
+val delay: float -> unit
+(** [delay d] suspends the execution of the calling thread for
+   [d] seconds. The other program threads continue to run during
+   this time. *)
+
+val join : t -> unit
+(** [join th] suspends the execution of the calling thread
+   until the thread [th] has terminated. *)
+
+val wait_read : Unix.file_descr -> unit
+(** See {!Thread.wait_write}.*)
+
+val wait_write : Unix.file_descr -> unit
+(** This function does nothing in this implementation. *)
+
+val wait_timed_read : Unix.file_descr -> float -> bool
+(** See {!Thread.wait_timed_read}.*)
+
+val wait_timed_write : Unix.file_descr -> float -> bool
+(** Suspend the execution of the calling thread until at least
+   one character is available for reading ([wait_read]) or
+   one character can be written without blocking ([wait_write])
+   on the given Unix file descriptor. Wait for at most
+   the amount of time given as second argument (in seconds).
+   Return [true] if the file descriptor is ready for input/output
+   and [false] if the timeout expired.
+
+   These functions return immediately [true] in the Win32
+   implementation. *)
+
+val select :
+  Unix.file_descr list -> Unix.file_descr list ->
+  Unix.file_descr list -> float ->
+    Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
+(** Suspend the execution of the calling thread until input/output
+   becomes possible on the given Unix file descriptors.
+   The arguments and results have the same meaning as for
+   [Unix.select].
+   This function is not implemented yet under Win32. *)
+
+val wait_pid : int -> int * Unix.process_status
+(** [wait_pid p] suspends the execution of the calling thread
+   until the process specified by the process identifier [p]
+   terminates. Returns the pid of the child caught and
+   its termination status, as per [Unix.wait].
+   This function is not implemented under MacOS. *)
+
+val yield : unit -> unit
+(** Re-schedule the calling thread without suspending it.
+   This function can be used to give scheduling hints,
+   telling the scheduler that now is a good time to
+   switch to other threads. *)
+
+(** {6 Management of signals} *)
+
+(** Signal handling follows the POSIX thread model: signals generated
+  by a thread are delivered to that thread; signals generated externally
+  are delivered to one of the threads that does not block it.
+  Each thread possesses a set of blocked signals, which can be modified
+  using {!Thread.sigmask}.  This set is inherited at thread creation time.
+  Per-thread signal masks are supported only by the system thread library
+  under Unix, but not under Win32, nor by the VM thread library. *)
+
+val sigmask : Unix.sigprocmask_command -> int list -> int list
+(** [sigmask cmd sigs] changes the set of blocked signals for the
+   calling thread.
+   If [cmd] is [SIG_SETMASK], blocked signals are set to those in
+   the list [sigs].
+   If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to
+   the set of blocked signals.
+   If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed
+   from the set of blocked signals.
+   [sigmask] returns the set of previously blocked signals for the thread. *)
+
+
+val wait_signal : int list -> int
+(** [wait_signal sigs] suspends the execution of the calling thread
+   until the process receives one of the signals specified in the
+   list [sigs].  It then returns the number of the signal received.
+   Signal handlers attached to the signals in [sigs] will not
+   be invoked.  The signals [sigs] are expected to be blocked before
+   calling [wait_signal]. *)
diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml
new file mode 100644
index 00000000..acaafb01
--- /dev/null
+++ b/otherlibs/systhreads/threadUnix.ml
@@ -0,0 +1,65 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [ThreadUnix]: thread-compatible system calls *)
+
+open Unix
+
+(*** Process handling *)
+
+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"
+let wait = Unix.wait
+let waitpid = Unix.waitpid
+let system = Unix.system
+let read = Unix.read
+let write = Unix.write
+let write_substring = Unix.write_substring
+let select = Unix.select
+
+let timed_read fd buff ofs len timeout =
+  if Thread.wait_timed_read fd timeout
+  then Unix.read fd buff ofs len
+  else raise (Unix_error(ETIMEDOUT, "timed_read", ""))
+
+let timed_write fd buff ofs len timeout =
+  if Thread.wait_timed_write fd timeout
+  then Unix.write fd buff ofs len
+  else raise (Unix_error(ETIMEDOUT, "timed_write", ""))
+
+let timed_write_substring fd buff ofs len timeout =
+  timed_write fd (Bytes.unsafe_of_string buff) ofs len timeout
+
+let pipe = Unix.pipe
+
+let open_process_in = Unix.open_process_in
+let open_process_out = Unix.open_process_out
+let open_process = Unix.open_process
+
+external sleep : int -> unit = "unix_sleep"
+
+let socket = Unix.socket
+let accept = Unix.accept
+external connect : file_descr -> sockaddr -> unit = "unix_connect"
+let recv = Unix.recv
+let recvfrom = Unix.recvfrom
+let send = Unix.send
+let send_substring = Unix.send_substring
+let sendto = Unix.sendto
+let sendto_substring = Unix.sendto_substring
+
+let open_connection = Unix.open_connection
diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli
new file mode 100644
index 00000000..9e8d927e
--- /dev/null
+++ b/otherlibs/systhreads/threadUnix.mli
@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Thread-compatible system calls.
+
+   @deprecated The functionality of this module has been merged back into
+   the {!Unix} module.  Threaded programs can now call the functions
+   from module {!Unix} directly, and still get the correct behavior
+   (block the calling thread, if required, but do not block all threads
+   in the process).  *)
+
+(** {6 Process handling} *)
+
+val execv : string -> string array -> unit
+val execve : string -> string array -> string array -> unit
+val execvp : string -> string array -> unit
+val wait : unit -> int * Unix.process_status
+val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
+val system : string -> Unix.process_status
+
+(** {6 Basic input/output} *)
+
+val read : Unix.file_descr -> bytes -> int -> int -> int
+val write : Unix.file_descr -> bytes -> int -> int -> int
+val write_substring : Unix.file_descr -> string -> int -> int -> int
+
+(** {6 Input/output with timeout} *)
+
+val timed_read :
+      Unix.file_descr ->
+      bytes -> int -> int -> float -> int
+(** See {!ThreadUnix.timed_write}. *)
+
+val timed_write :
+      Unix.file_descr ->
+      bytes -> int -> int -> float -> int
+(** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that
+   [Unix_error(ETIMEDOUT,_,_)] is raised if no data is
+   available for reading or ready for writing after [d] seconds.
+   The delay [d] is given in the fifth argument, in seconds. *)
+
+val timed_write_substring :
+      Unix.file_descr -> string -> int -> int -> float -> int
+(** See {!ThreadUnix.timed_write}. *)
+
+(** {6 Polling} *)
+
+val select :
+  Unix.file_descr list -> Unix.file_descr list ->
+  Unix.file_descr list -> float ->
+        Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
+
+(** {6 Pipes and redirections} *)
+
+val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
+val open_process_in: string -> in_channel
+val open_process_out: string -> out_channel
+val open_process: string -> in_channel * out_channel
+
+(** {6 Time} *)
+
+val sleep : int -> unit
+
+(** {6 Sockets} *)
+
+val socket :
+  ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
+    Unix.file_descr
+val accept :
+  ?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
+val connect : Unix.file_descr -> Unix.sockaddr -> unit
+val recv : Unix.file_descr -> bytes ->
+           int -> int -> Unix.msg_flag list -> int
+val recvfrom : Unix.file_descr -> bytes -> int -> int ->
+               Unix.msg_flag list -> int * Unix.sockaddr
+val send : Unix.file_descr -> bytes -> int -> int ->
+           Unix.msg_flag list -> int
+val send_substring : Unix.file_descr -> string -> int -> int ->
+           Unix.msg_flag list -> int
+val sendto : Unix.file_descr -> bytes -> int -> int ->
+             Unix.msg_flag list -> Unix.sockaddr -> int
+val sendto_substring : Unix.file_descr -> string -> int -> int ->
+             Unix.msg_flag list -> Unix.sockaddr -> int
+val open_connection : Unix.sockaddr -> in_channel * out_channel
diff --git a/otherlibs/systhreads/threads.h b/otherlibs/systhreads/threads.h
new file mode 100644
index 00000000..97fd1b27
--- /dev/null
+++ b/otherlibs/systhreads/threads.h
@@ -0,0 +1,68 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1995 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_THREADS_H
+#define CAML_THREADS_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+CAMLextern void caml_enter_blocking_section (void);
+CAMLextern void caml_leave_blocking_section (void);
+#define caml_acquire_runtime_system caml_leave_blocking_section
+#define caml_release_runtime_system caml_enter_blocking_section
+
+/* Manage the master lock around the OCaml run-time system.
+   Only one thread at a time can execute OCaml compiled code or
+   OCaml run-time system functions.
+
+   When OCaml calls a C function, the current thread holds the master
+   lock.  The C function can release it by calling
+   [caml_release_runtime_system].  Then, another thread can execute OCaml
+   code.  However, the calling thread must not access any OCaml data,
+   nor call any runtime system function, nor call back into OCaml.
+
+   Before returning to its OCaml caller, or accessing OCaml data,
+   or call runtime system functions, the current thread must
+   re-acquire the master lock by calling [caml_acquire_runtime_system].
+
+   Symmetrically, if a C function (not called from OCaml) wishes to
+   call back into OCaml code, it should invoke [caml_acquire_runtime_system]
+   first, then do the callback, then invoke [caml_release_runtime_system].
+
+   For historical reasons, alternate names can be used:
+     [caml_enter_blocking_section]  instead of  [caml_release_runtime_system]
+     [caml_leave_blocking_section]  instead of  [caml_acquire_runtime_system]
+   Intuition: a ``blocking section'' is a piece of C code that does not
+   use the runtime system (typically, a blocking I/O operation).
+*/
+
+CAMLextern int caml_c_thread_register(void);
+CAMLextern int caml_c_thread_unregister(void);
+
+/* If a thread is created by C code (instead of by OCaml itself),
+   it must be registered with the OCaml runtime system before
+   being able to call back into OCaml code or use other runtime system
+   functions.  Just call [caml_c_thread_register] once.
+   Before the thread finishes, it must call [caml_c_thread_unregister].
+   Both functions return 1 on success, 0 on error.
+*/
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_THREADS_H */
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
new file mode 100644
index 00000000..f25df2a0
--- /dev/null
+++ b/otherlibs/threads/.depend
@@ -0,0 +1,33 @@
+scheduler.o: scheduler.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/backtrace.h ../../byterun/caml/exec.h \
+  ../../byterun/caml/callback.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/io.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
+  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
+  ../../byterun/caml/address_class.h ../../byterun/caml/printexc.h \
+  ../../byterun/caml/roots.h ../../byterun/caml/signals.h \
+  ../../byterun/caml/stacks.h ../../byterun/caml/sys.h
+condition.cmo : thread.cmi mutex.cmi condition.cmi
+condition.cmx : thread.cmx mutex.cmx condition.cmi
+condition.cmi : mutex.cmi
+event.cmo : mutex.cmi condition.cmi event.cmi
+event.cmx : mutex.cmx condition.cmx event.cmi
+event.cmi :
+marshal.cmo :
+marshal.cmx :
+mutex.cmo : thread.cmi mutex.cmi
+mutex.cmx : thread.cmx mutex.cmi
+mutex.cmi :
+pervasives.cmo : unix.cmo
+pervasives.cmx : unix.cmx
+thread.cmo : unix.cmo thread.cmi
+thread.cmx : unix.cmx thread.cmi
+thread.cmi : unix.cmo
+threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi
+threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
+threadUnix.cmi : unix.cmo
+unix.cmo :
+unix.cmx :
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
new file mode 100644
index 00000000..a2a20e61
--- /dev/null
+++ b/otherlibs/threads/Makefile
@@ -0,0 +1,136 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# FIXME reduce redundancy by including ../Makefile
+
+include ../../config/Makefile
+CAMLRUN ?= ../../boot/ocamlrun
+CAMLYACC ?= ../../boot/ocamlyacc
+
+CC=$(BYTECC)
+CFLAGS=-I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g
+ROOTDIR=../..
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib \
+      -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix
+MKLIB=$(CAMLRUN) ../../tools/ocamlmklib
+COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string
+
+C_OBJS=scheduler.o
+
+CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
+
+LIB=../../stdlib
+
+LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo		\
+  $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo	\
+  $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo		\
+  $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo			\
+  $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo		\
+  $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo	\
+  $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo $(LIB)/stream.cmo		\
+  $(LIB)/buffer.cmo $(LIB)/camlinternalFormat.cmo $(LIB)/printf.cmo	\
+  $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo	\
+  $(LIB)/random.cmo $(LIB)/hashtbl.cmo $(LIB)/format.cmo		\
+  $(LIB)/scanf.cmo $(LIB)/callback.cmo $(LIB)/camlinternalOO.cmo	\
+  $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo		\
+  $(LIB)/weak.cmo $(LIB)/ephemeron.cmo $(LIB)/filename.cmo		\
+  $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo	\
+  $(LIB)/bytesLabels.cmo $(LIB)/stringLabels.cmo			\
+  $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo
+
+UNIXLIB=../unix
+
+UNIXLIB_OBJS=unix.cmo $(UNIXLIB)/unixLabels.cmo
+
+all: libvmthreads.a threads.cma stdlib.cma unix.cma
+
+allopt:
+
+libvmthreads.a: $(C_OBJS)
+	$(MKLIB) -o threads -oc vmthreads $(C_OBJS)
+
+threads.cma: $(CAML_OBJS)
+	$(MKLIB) -ocamlc '$(CAMLC)' -o threads -oc vmthreads $(CAML_OBJS)
+
+stdlib.cma: $(LIB_OBJS)
+	$(CAMLC) -a -o stdlib.cma $(LIB_OBJS)
+
+unix.cma: $(UNIXLIB_OBJS)
+	$(MKLIB) -ocamlc '$(CAMLC)' -o unix -linkall $(UNIXLIB_OBJS)
+
+pervasives.cmo: pervasives.mli pervasives.cmi pervasives.ml
+	$(CAMLC) ${COMPFLAGS} -nopervasives -c pervasives.ml
+
+pervasives.mli: $(LIB)/pervasives.mli
+	ln -s $(LIB)/pervasives.mli pervasives.mli
+
+pervasives.cmi: $(LIB)/pervasives.cmi
+	ln -s $(LIB)/pervasives.cmi pervasives.cmi
+
+marshal.cmo: marshal.mli marshal.cmi marshal.ml
+	$(CAMLC) ${COMPFLAGS} -c marshal.ml
+
+marshal.mli: $(LIB)/marshal.mli
+	ln -s $(LIB)/marshal.mli marshal.mli
+
+marshal.cmi: $(LIB)/marshal.cmi
+	ln -s $(LIB)/marshal.cmi marshal.cmi
+
+unix.mli: $(UNIXLIB)/unix.mli
+	ln -s -f $(UNIXLIB)/unix.mli unix.mli
+
+unix.cmi: $(UNIXLIB)/unix.cmi
+	ln -s -f $(UNIXLIB)/unix.cmi unix.cmi
+
+unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo
+	$(CAMLC) ${COMPFLAGS} -c unix.ml
+
+partialclean:
+	rm -f *.cm*
+
+clean: partialclean
+	rm -f libvmthreads.a dllvmthreads.so *.o
+	rm -f pervasives.mli marshal.mli unix.mli
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+
+CMIFILES=thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi
+
+install:
+	if test -f dllvmthreads.so; then \
+	  cp dllvmthreads.so $(INSTALL_STUBLIBDIR)/.; \
+	fi
+	mkdir -p $(INSTALL_LIBDIR)/vmthreads
+	cp libvmthreads.a $(INSTALL_LIBDIR)/vmthreads/libvmthreads.a
+	cd $(INSTALL_LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a
+	cp $(CMIFILES) $(CMIFILES:.cmi=.mli) $(CMIFILES:.cmi=.cmti) \
+	   threads.cma stdlib.cma unix.cma $(INSTALL_LIBDIR)/vmthreads
+
+installopt:
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml
new file mode 100644
index 00000000..c685d813
--- /dev/null
+++ b/otherlibs/threads/condition.ml
@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = { mutable waiting: Thread.t list }
+
+let create () = { waiting = [] }
+
+let wait cond mut =
+  Thread.critical_section := true;
+  Mutex.unlock mut;
+  cond.waiting <- Thread.self() :: cond.waiting;
+  Thread.sleep();
+  Mutex.lock mut
+
+let signal cond =
+  match cond.waiting with               (* atomic *)
+    [] -> ()
+  | th :: rem -> cond.waiting <- rem (* atomic *); Thread.wakeup th
+
+let broadcast cond =
+  let w = cond.waiting in                  (* atomic *)
+  cond.waiting <- [];                      (* atomic *)
+  List.iter Thread.wakeup w
diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli
new file mode 100644
index 00000000..2557fe78
--- /dev/null
+++ b/otherlibs/threads/condition.mli
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Condition variables to synchronize between threads.
+
+   Condition variables are used when one thread wants to wait until another
+   thread has finished doing something: the former thread ``waits'' on the
+   condition variable, the latter thread ``signals'' the condition when it
+   is done. Condition variables should always be protected by a mutex.
+   The typical use is (if [D] is a shared data structure, [m] its mutex,
+   and [c] is a condition variable):
+   {[
+     Mutex.lock m;
+     while (* some predicate P over D is not satisfied *) do
+       Condition.wait c m
+     done;
+     (* Modify D *)
+     if (* the predicate P over D is now satisfied *) then Condition.signal c;
+     Mutex.unlock m
+   ]}
+*)
+
+type t
+(** The type of condition variables. *)
+
+val create : unit -> t
+(** Return a new condition variable. *)
+
+val wait : t -> Mutex.t -> unit
+(** [wait c m] atomically unlocks the mutex [m] and suspends the
+   calling process on the condition variable [c]. The process will
+   restart after the condition variable [c] has been signalled.
+   The mutex [m] is locked again before [wait] returns. *)
+
+val signal : t -> unit
+(** [signal c] restarts one of the processes waiting on the
+   condition variable [c]. *)
+
+val broadcast : t -> unit
+(** [broadcast c] restarts all processes waiting on the
+   condition variable [c]. *)
diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml
new file mode 100644
index 00000000..b00a6fc3
--- /dev/null
+++ b/otherlibs/threads/event.ml
@@ -0,0 +1,274 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   David Nowak and Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Events *)
+type 'a basic_event =
+  { poll: unit -> bool;
+      (* If communication can take place immediately, return true. *)
+    suspend: unit -> unit;
+      (* Offer the communication on the channel and get ready
+         to suspend current process. *)
+    result: unit -> 'a }
+      (* Return the result of the communication *)
+
+type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event
+
+type 'a event =
+    Communication of 'a behavior
+  | Choose of 'a event list
+  | WrapAbort of 'a event * (unit -> unit)
+  | Guard of (unit -> 'a event)
+
+(* Communication channels *)
+type 'a channel =
+  { mutable writes_pending: 'a communication Queue.t;
+                        (* All offers to write on it *)
+    mutable reads_pending:  'a communication Queue.t }
+                        (* All offers to read from it *)
+
+(* Communication offered *)
+and 'a communication =
+  { performed: int ref;  (* -1 if not performed yet, set to the number *)
+                         (* of the matching communication after rendez-vous. *)
+    condition: Condition.t;             (* To restart the blocked thread. *)
+    mutable data: 'a option;            (* The data sent or received. *)
+    event_number: int }                 (* Event number in select *)
+
+(* Create a channel *)
+
+let new_channel () =
+  { writes_pending = Queue.create();
+    reads_pending = Queue.create() }
+
+(* Basic synchronization function *)
+
+let masterlock = Mutex.create()
+
+let do_aborts abort_env genev performed =
+  if abort_env <> [] then begin
+    if performed >= 0 then begin
+      let ids_done = snd genev.(performed) in
+      List.iter
+        (fun (id,f) -> if not (List.mem id ids_done) then f ())
+        abort_env
+    end else begin
+      List.iter (fun (_,f) -> f ()) abort_env
+    end
+  end
+
+let basic_sync abort_env genev =
+  let performed = ref (-1) in
+  let condition = Condition.create() in
+  let bev = Array.make (Array.length genev)
+                         (fst (genev.(0)) performed condition 0) in
+  for i = 1 to Array.length genev - 1 do
+    bev.(i) <- (fst genev.(i)) performed condition i
+  done;
+  (* See if any of the events is already activable *)
+  let rec poll_events i =
+    if i >= Array.length bev
+    then false
+    else bev.(i).poll() || poll_events (i+1) in
+  Mutex.lock masterlock;
+  if not (poll_events 0) then begin
+    (* Suspend on all events *)
+    for i = 0 to Array.length bev - 1 do bev.(i).suspend() done;
+    (* Wait until the condition is signalled *)
+    Condition.wait condition masterlock
+  end;
+  Mutex.unlock masterlock;
+  (* Extract the result *)
+  if abort_env = [] then
+    (* Preserve tail recursion *)
+    bev.(!performed).result()
+  else begin
+    let num = !performed in
+    let result = bev.(num).result() in
+    (* Handle the aborts and return the result *)
+    do_aborts abort_env genev num;
+    result
+  end
+
+(* Apply a random permutation on an array *)
+
+let scramble_array a =
+  let len = Array.length a in
+  if len = 0 then invalid_arg "Event.choose";
+  for i = len - 1 downto 1 do
+    let j = Random.int (i + 1) in
+    let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp
+  done;
+  a
+
+(* Main synchronization function *)
+
+let gensym = let count = ref 0 in fun () -> incr count; !count
+
+let rec flatten_event
+      (abort_list : int list)
+      (accu : ('a behavior * int list) list)
+      (accu_abort : (int * (unit -> unit)) list)
+      ev =
+  match ev with
+     Communication bev -> ((bev,abort_list) :: accu) , accu_abort
+  | WrapAbort (ev,fn) ->
+      let id = gensym () in
+      flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev
+  | Choose evl ->
+      let rec flatten_list accu' accu_abort'= function
+         ev :: l ->
+           let (accu'',accu_abort'') =
+             flatten_event abort_list accu' accu_abort' ev in
+           flatten_list accu'' accu_abort'' l
+       | [] -> (accu',accu_abort') in
+      flatten_list accu accu_abort evl
+  | Guard fn -> flatten_event abort_list accu accu_abort (fn ())
+
+let sync ev =
+  let (evl,abort_env) = flatten_event [] [] [] ev in
+  basic_sync abort_env (scramble_array(Array.of_list evl))
+
+(* Event polling -- like sync, but non-blocking *)
+
+let basic_poll abort_env genev =
+  let performed = ref (-1) in
+  let condition = Condition.create() in
+  let bev = Array.make(Array.length genev)
+                        (fst genev.(0) performed condition 0) in
+  for i = 1 to Array.length genev - 1 do
+    bev.(i) <- fst genev.(i) performed condition i
+  done;
+  (* See if any of the events is already activable *)
+  let rec poll_events i =
+    if i >= Array.length bev
+    then false
+    else bev.(i).poll() || poll_events (i+1) in
+  Mutex.lock masterlock;
+  let ready = poll_events 0 in
+  if ready then begin
+    (* Extract the result *)
+    Mutex.unlock masterlock;
+    let result = Some(bev.(!performed).result()) in
+    do_aborts abort_env genev !performed; result
+  end else begin
+    (* Cancel the communication offers *)
+    performed := 0;
+    Mutex.unlock masterlock;
+    do_aborts abort_env genev (-1);
+    None
+  end
+
+let poll ev =
+  let (evl,abort_env) = flatten_event [] [] [] ev in
+  basic_poll abort_env (scramble_array(Array.of_list evl))
+
+(* Remove all communication opportunities already synchronized *)
+
+let cleanup_queue q =
+  let q' = Queue.create() in
+  Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q;
+  q'
+
+(* Event construction *)
+
+let always data =
+  Communication(fun performed condition evnum ->
+    { poll = (fun () -> performed := evnum; true);
+      suspend = (fun () -> ());
+      result = (fun () -> data) })
+
+let send channel data =
+  Communication(fun performed condition evnum ->
+    let wcomm =
+      { performed = performed;
+        condition = condition;
+        data = Some data;
+        event_number = evnum } in
+    { poll = (fun () ->
+        let rec poll () =
+          let rcomm = Queue.take channel.reads_pending in
+          if !(rcomm.performed) >= 0 then
+            poll ()
+          else begin
+            rcomm.data <- wcomm.data;
+            performed := evnum;
+            rcomm.performed := rcomm.event_number;
+            Condition.signal rcomm.condition
+          end in
+        try
+          poll();
+          true
+        with Queue.Empty ->
+          false);
+      suspend = (fun () ->
+        channel.writes_pending <- cleanup_queue channel.writes_pending;
+        Queue.add wcomm channel.writes_pending);
+      result = (fun () -> ()) })
+
+let receive channel =
+  Communication(fun performed condition evnum ->
+    let rcomm =
+      { performed = performed;
+        condition = condition;
+        data = None;
+        event_number = evnum } in
+    { poll = (fun () ->
+        let rec poll () =
+          let wcomm = Queue.take channel.writes_pending in
+          if !(wcomm.performed) >= 0 then
+            poll ()
+          else begin
+            rcomm.data <- wcomm.data;
+            performed := evnum;
+            wcomm.performed := wcomm.event_number;
+            Condition.signal wcomm.condition
+          end in
+        try
+          poll();
+          true
+        with Queue.Empty ->
+          false);
+    suspend = (fun () ->
+      channel.reads_pending <- cleanup_queue channel.reads_pending;
+      Queue.add rcomm channel.reads_pending);
+    result = (fun () ->
+      match rcomm.data with
+        None -> invalid_arg "Event.receive"
+      | Some res -> res) })
+
+let choose evl = Choose evl
+
+let wrap_abort ev fn = WrapAbort(ev,fn)
+
+let guard fn = Guard fn
+
+let rec wrap ev fn =
+  match ev with
+    Communication genev ->
+      Communication(fun performed condition evnum ->
+        let bev = genev performed condition evnum in
+        { poll = bev.poll;
+          suspend = bev.suspend;
+          result = (fun () -> fn(bev.result())) })
+  | Choose evl ->
+      Choose(List.map (fun ev -> wrap ev fn) evl)
+  | WrapAbort (ev, f') ->
+      WrapAbort (wrap ev fn, f')
+  | Guard gu ->
+      Guard(fun () -> wrap (gu()) fn)
+
+(* Convenience functions *)
+
+let select evl = sync(Choose evl)
diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli
new file mode 100644
index 00000000..a1921234
--- /dev/null
+++ b/otherlibs/threads/event.mli
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   David Nowak and Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** First-class synchronous communication.
+
+   This module implements synchronous inter-thread communications over
+   channels. As in John Reppy's Concurrent ML system, the communication
+   events are first-class values: they can be built and combined
+   independently before being offered for communication.
+*)
+
+type 'a channel
+(** The type of communication channels carrying values of type ['a]. *)
+
+val new_channel : unit -> 'a channel
+(** Return a new channel. *)
+
+type +'a event
+(** The type of communication events returning a result of type ['a]. *)
+
+(** [send ch v] returns the event consisting in sending the value [v]
+   over the channel [ch]. The result value of this event is [()]. *)
+val send : 'a channel -> 'a -> unit event
+
+(** [receive ch] returns the event consisting in receiving a value
+   from the channel [ch]. The result value of this event is the
+   value received. *)
+val receive : 'a channel -> 'a event
+
+val always : 'a -> 'a event
+(** [always v] returns an event that is always ready for
+   synchronization.  The result value of this event is [v]. *)
+
+val choose : 'a event list -> 'a event
+(** [choose evl] returns the event that is the alternative of
+   all the events in the list [evl]. *)
+
+val wrap : 'a event -> ('a -> 'b) -> 'b event
+(** [wrap ev fn] returns the event that performs the same communications
+   as [ev], then applies the post-processing function [fn]
+   on the return value. *)
+
+val wrap_abort : 'a event -> (unit -> unit) -> 'a event
+(** [wrap_abort ev fn] returns the event that performs
+   the same communications as [ev], but if it is not selected
+   the function [fn] is called after the synchronization. *)
+
+val guard : (unit -> 'a event) -> 'a event
+(** [guard fn] returns the event that, when synchronized, computes
+   [fn()] and behaves as the resulting event. This allows events with
+   side-effects to be computed at the time of the synchronization
+   operation. *)
+
+val sync : 'a event -> 'a
+(** ``Synchronize'' on an event: offer all the communication
+   possibilities specified in the event to the outside world,
+   and block until one of the communications succeed. The result
+   value of that communication is returned. *)
+
+val select : 'a event list -> 'a
+(** ``Synchronize'' on an alternative of events.
+   [select evl] is shorthand for [sync(choose evl)]. *)
+
+val poll : 'a event -> 'a option
+(** Non-blocking version of {!Event.sync}: offer all the communication
+   possibilities specified in the event to the outside world,
+   and if one can take place immediately, perform it and return
+   [Some r] where [r] is the result value of that communication.
+   Otherwise, return [None] without blocking. *)
diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml
new file mode 100644
index 00000000..88660680
--- /dev/null
+++ b/otherlibs/threads/marshal.ml
@@ -0,0 +1,61 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type extern_flags =
+    No_sharing
+  | Closures
+  | Compat_32
+
+external to_bytes: 'a -> extern_flags list -> bytes
+    = "caml_output_value_to_string"
+
+external to_string: 'a -> extern_flags list -> string
+    = "caml_output_value_to_string"
+
+let to_channel chan v flags =
+  output_string chan (to_string v flags)
+
+external to_buffer_unsafe:
+      bytes -> int -> int -> 'a -> extern_flags list -> int
+    = "caml_output_value_to_buffer"
+
+let to_buffer buff ofs len v flags =
+  if ofs < 0 || len < 0 || ofs + len > Bytes.length buff
+  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 = "caml_input_value"
+external from_bytes_unsafe: bytes -> int -> 'a
+         = "caml_input_value_from_string"
+external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size"
+
+let header_size = 20
+let data_size buff ofs =
+  if ofs < 0 || ofs > Bytes.length buff - header_size
+  then invalid_arg "Marshal.data_size"
+  else data_size_unsafe buff ofs
+let total_size buff ofs = header_size + data_size buff ofs
+
+let from_bytes buff ofs =
+  if ofs < 0 || ofs > Bytes.length buff - header_size
+  then invalid_arg "Marshal.from_bytes"
+  else begin
+    let len = data_size_unsafe buff ofs in
+    if ofs > Bytes.length buff - (header_size + len)
+    then invalid_arg "Marshal.from_bytes"
+    else from_bytes_unsafe buff ofs
+  end
+
+let from_string buff ofs = from_bytes (Bytes.unsafe_of_string buff) ofs
diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml
new file mode 100644
index 00000000..8209d7d2
--- /dev/null
+++ b/otherlibs/threads/mutex.ml
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = { mutable locked: bool; mutable waiting: Thread.t list }
+
+let create () = { locked = false; waiting = [] }
+
+let rec lock m =
+  if m.locked then begin                (* test and set atomic *)
+    Thread.critical_section := true;
+    m.waiting <- Thread.self() :: m.waiting;
+    Thread.sleep();
+    lock m
+  end else begin
+    m.locked <- true                    (* test and set atomic *)
+  end
+
+let try_lock m =                        (* test and set atomic *)
+  if m.locked then false else begin m.locked <- true; true end
+
+let unlock m =
+  (* Don't play with Thread.critical_section here because of Condition.wait *)
+  let w = m.waiting in                  (* atomic *)
+  m.waiting <- [];                      (* atomic *)
+  m.locked <- false;                    (* atomic *)
+  List.iter Thread.wakeup w
diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli
new file mode 100644
index 00000000..8953a159
--- /dev/null
+++ b/otherlibs/threads/mutex.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Locks for mutual exclusion.
+
+   Mutexes (mutual-exclusion locks) are used to implement critical sections
+   and protect shared mutable data structures against concurrent accesses.
+   The typical use is (if [m] is the mutex associated with the data structure
+   [D]):
+   {[
+     Mutex.lock m;
+     (* Critical section that operates over D *);
+     Mutex.unlock m
+   ]}
+*)
+
+type t
+(** The type of mutexes. *)
+
+val create : unit -> t
+(** Return a new mutex. *)
+
+val lock : t -> unit
+(** Lock the given mutex. Only one thread can have the mutex locked
+   at any time. A thread that attempts to lock a mutex already locked
+   by another thread will suspend until the other thread unlocks
+   the mutex. *)
+
+val try_lock : t -> bool
+(** Same as {!Mutex.lock}, but does not suspend the calling thread if
+   the mutex is already locked: just return [false] immediately
+   in that case. If the mutex is unlocked, lock it and
+   return [true]. *)
+
+val unlock : t -> unit
+(** Unlock the given mutex. Other threads suspended trying to lock
+   the mutex will restart. *)
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
new file mode 100644
index 00000000..97cb52bc
--- /dev/null
+++ b/otherlibs/threads/pervasives.ml
@@ -0,0 +1,636 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Same as ../../stdlib/pervasives.ml, except that I/O functions have
+   been redefined to not block the whole process, but only the calling
+   thread. *)
+
+(* type 'a option = None | Some of 'a *)
+
+(* Exceptions *)
+
+external register_named_value : string -> 'a -> unit
+                              = "caml_register_named_value"
+
+let () =
+  (* for asmrun/fail.c *)
+  register_named_value "Pervasives.array_bound_error"
+    (Invalid_argument "index out of bounds")
+
+
+external raise : exn -> 'a = "%raise"
+external raise_notrace : exn -> 'a = "%raise_notrace"
+
+let failwith s = raise(Failure s)
+let invalid_arg s = raise(Invalid_argument s)
+
+exception Exit
+
+(* Composition operators *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
+(* Debugging *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+
+(* Comparisons *)
+
+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 compare : 'a -> 'a -> int = "%compare"
+
+let min x y = if x <= y then x else y
+let max x y = if x >= y then x else y
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+
+(* Boolean operations *)
+
+external not : bool -> bool = "%boolnot"
+external ( & ) : bool -> bool -> bool = "%sequand"
+external ( && ) : bool -> bool -> bool = "%sequand"
+external ( or ) : bool -> bool -> bool = "%sequor"
+external ( || ) : bool -> bool -> bool = "%sequor"
+
+(* Integer operations *)
+
+external ( ~- ) : int -> int = "%negint"
+external ( ~+ ) : int -> int = "%identity"
+external succ : int -> int = "%succint"
+external pred : int -> int = "%predint"
+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"
+
+let abs x = if x >= 0 then x else -x
+
+external ( land ) : int -> int -> int = "%andint"
+external ( lor ) : int -> int -> int = "%orint"
+external ( lxor ) : int -> int -> int = "%xorint"
+
+let lnot x = x lxor (-1)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+external ( lsr ) : int -> int -> int = "%lsrint"
+external ( asr ) : int -> int -> int = "%asrint"
+
+let max_int = (-1) lsr 1
+let min_int = max_int + 1
+
+(* Floating-point operations *)
+
+external ( ~-. ) : float -> float = "%negfloat"
+external ( ~+. ) : float -> float = "%identity"
+external ( +. ) : float -> float -> float = "%addfloat"
+external ( -. ) : float -> float -> float = "%subfloat"
+external ( *. ) : float -> float -> float = "%mulfloat"
+external ( /. ) : float -> float -> float = "%divfloat"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow"
+  [@@unboxed] [@@noalloc]
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+  [@@unboxed] [@@noalloc]
+external acos : float -> float = "caml_acos_float" "acos"
+  [@@unboxed] [@@noalloc]
+external asin : float -> float = "caml_asin_float" "asin"
+  [@@unboxed] [@@noalloc]
+external atan : float -> float = "caml_atan_float" "atan"
+  [@@unboxed] [@@noalloc]
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+  [@@unboxed] [@@noalloc]
+external hypot : float -> float -> float
+               = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+external cosh : float -> float = "caml_cosh_float" "cosh"
+  [@@unboxed] [@@noalloc]
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+external log10 : float -> float = "caml_log10_float" "log10"
+  [@@unboxed] [@@noalloc]
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+  [@@unboxed] [@@noalloc]
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+external sinh : float -> float = "caml_sinh_float" "sinh"
+  [@@unboxed] [@@noalloc]
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+  [@@unboxed] [@@noalloc]
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+external tanh : float -> float = "caml_tanh_float" "tanh"
+  [@@unboxed] [@@noalloc]
+external ceil : float -> float = "caml_ceil_float" "ceil"
+  [@@unboxed] [@@noalloc]
+external floor : float -> float = "caml_floor_float" "floor"
+  [@@unboxed] [@@noalloc]
+external abs_float : float -> float = "%absfloat"
+external copysign : float -> float -> float
+                  = "caml_copysign_float" "caml_copysign"
+                  [@@unboxed] [@@noalloc]
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
+  [@@unboxed] [@@noalloc]
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+  "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+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_bits : int64 -> float = "caml_int64_float_of_bits"
+let infinity =
+  float_of_bits 0x7F_F0_00_00_00_00_00_00L
+let neg_infinity =
+  float_of_bits 0xFF_F0_00_00_00_00_00_00L
+let nan =
+  float_of_bits 0x7F_F0_00_00_00_00_00_01L
+let max_float =
+  float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
+let min_float =
+  float_of_bits 0x00_10_00_00_00_00_00_00L
+let epsilon_float =
+  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 [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+
+(* String and byte sequence operations -- more in modules String and Bytes *)
+
+external string_length : string -> int = "%string_length"
+external bytes_length : bytes -> int = "%bytes_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
+external string_blit : string -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
+                        = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+external bytes_unsafe_of_string : string -> bytes = "%bytes_of_string"
+
+let ( ^ ) s1 s2 =
+  let l1 = string_length s1 and l2 = string_length s2 in
+  let s = bytes_create (l1 + l2) in
+  string_blit s1 0 s 0 l1;
+  string_blit s2 0 s l1 l2;
+  bytes_unsafe_to_string s
+
+(* Character operations -- more in module Char *)
+
+external int_of_char : char -> int = "%identity"
+external unsafe_char_of_int : int -> char = "%identity"
+let char_of_int n =
+  if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
+
+(* Unit operations *)
+
+external ignore : 'a -> unit = "%ignore"
+
+(* Pair operations *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+external snd : 'a * 'b -> 'b = "%field1"
+
+(* References *)
+
+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"
+
+(* Result type *)
+
+type ('a,'b) result = Ok of 'a | Error of 'b
+
+(* String conversion functions *)
+
+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"
+let bool_of_string = function
+  | "true" -> true
+  | "false" -> false
+  | _ -> invalid_arg "bool_of_string"
+
+let bool_of_string_opt = function
+  | "true" -> Some true
+  | "false" -> Some false
+  | _ -> None
+
+let string_of_int n =
+  format_int "%d" n
+
+external int_of_string : string -> int = "caml_int_of_string"
+
+let int_of_string_opt s =
+  (* TODO: provide this directly as a non-raising primitive. *)
+  try Some (int_of_string s)
+  with Failure _ -> None
+
+external string_get : string -> int -> char = "%string_safe_get"
+
+let valid_float_lexem s =
+  let l = string_length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match string_get s i with
+    | '0' .. '9' | '-' -> loop (i + 1)
+    | _ -> s
+  in
+  loop 0
+;;
+
+let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
+
+external float_of_string : string -> float = "caml_float_of_string"
+
+let float_of_string_opt s =
+  (* TODO: provide this directly as a non-raising primitive. *)
+  try Some (float_of_string s)
+  with Failure _ -> None
+
+(* List operations -- more in module List *)
+
+let rec ( @ ) l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd :: tl -> hd :: (tl @ l2)
+
+(* I/O operations *)
+
+type in_channel
+type out_channel
+
+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
+let stderr = open_descriptor_out 2
+
+(* Non-blocking stuff *)
+
+external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read"
+external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write"
+
+let thread_wait_read fd = thread_wait_read_prim fd
+let thread_wait_write fd = thread_wait_write_prim fd
+
+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 = thread_wait_read (descr_inchan ic)
+
+let wait_outchan oc len = thread_wait_write (descr_outchan oc)
+
+(* General output functions *)
+
+type open_flag =
+    Open_rdonly | Open_wronly | Open_append
+  | Open_creat | Open_trunc | Open_excl
+  | Open_binary | Open_text | Open_nonblock
+
+external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
+
+external set_out_channel_name: out_channel -> string -> unit =
+  "caml_ml_set_channel_name"
+
+let open_out_gen mode perm name =
+  let c = open_descriptor_out(open_desc name mode perm) in
+  set_out_channel_name c name;
+  c
+
+let open_out name =
+  open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 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_ml_flush_partial"
+
+let rec flush oc =
+  let success =
+    try
+      flush_partial oc
+    with Sys_blocked_io ->
+      wait_outchan oc (-1); false in
+  if success then () else flush oc
+
+external out_channels_list : unit -> out_channel list
+                           = "caml_ml_out_channels_list"
+
+let flush_all () =
+  let rec iter = function
+      [] -> ()
+    | a::l ->
+        begin try
+            flush a
+        with Sys_error _ ->
+          () (* ignore channels closed during a preceding flush. *)
+        end;
+        iter l
+  in iter (out_channels_list ())
+
+external unsafe_output_partial : out_channel -> bytes -> int -> int -> int
+                        = "caml_ml_output_partial"
+
+let rec unsafe_output oc buf pos len =
+  if len > 0 then begin
+    let written =
+      try
+        unsafe_output_partial oc buf pos len
+      with Sys_blocked_io ->
+        wait_outchan oc len; 0 in
+    unsafe_output oc buf (pos + written) (len - written)
+  end
+
+external output_char_blocking : out_channel -> char -> unit
+                              = "caml_ml_output_char"
+external output_byte_blocking : out_channel -> int -> unit
+                              = "caml_ml_output_char"
+
+let rec output_char oc c =
+  try
+    output_char_blocking oc c
+  with Sys_blocked_io ->
+    wait_outchan oc 1; output_char oc c
+
+let output_bytes oc s =
+  unsafe_output oc s 0 (bytes_length s)
+
+let output_string oc s =
+  unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s)
+
+let output oc s ofs len =
+  if ofs < 0 || len < 0 || ofs > bytes_length s - len
+  then invalid_arg "output"
+  else unsafe_output oc s ofs len
+
+let output_substring oc s ofs len =
+  output oc (bytes_unsafe_of_string s) ofs len
+
+let rec output_byte oc b =
+  try
+    output_byte_blocking oc b
+  with Sys_blocked_io ->
+    wait_outchan oc 1; output_byte oc b
+
+let output_binary_int oc n =
+  output_byte oc (n asr 24);
+  output_byte oc (n asr 16);
+  output_byte oc (n asr 8);
+  output_byte oc n
+
+external marshal_to_string : 'a -> unit list -> 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_ml_seek_out"
+
+let seek_out oc pos = flush oc; seek_out_blocking oc pos
+
+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_ml_set_binary_mode"
+
+(* General input functions *)
+
+external set_in_channel_name: in_channel -> string -> unit =
+  "caml_ml_set_channel_name"
+
+let open_in_gen mode perm name =
+  let c = open_descriptor_in(open_desc name mode perm) in
+  set_in_channel_name c name;
+  c
+
+let open_in name =
+  open_in_gen [Open_rdonly; Open_text] 0 name
+
+let open_in_bin name =
+  open_in_gen [Open_rdonly; Open_binary] 0 name
+
+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
+    input_char_blocking ic
+  with Sys_blocked_io ->
+    wait_inchan ic; input_char ic
+
+external unsafe_input_blocking : in_channel -> bytes -> int -> int -> int
+                               = "caml_ml_input"
+
+let rec unsafe_input ic s ofs len =
+  try
+    unsafe_input_blocking ic s ofs len
+  with Sys_blocked_io ->
+    wait_inchan ic; unsafe_input ic s ofs len
+
+let input ic s ofs len =
+  if ofs < 0 || len < 0 || ofs > bytes_length s - len
+  then invalid_arg "input"
+  else unsafe_input ic s ofs len
+
+let rec unsafe_really_input ic s ofs len =
+  if len <= 0 then () else begin
+    let r = unsafe_input ic s ofs len in
+    if r = 0
+    then raise End_of_file
+    else unsafe_really_input ic s (ofs + r) (len - r)
+  end
+
+let really_input ic s ofs len =
+  if ofs < 0 || len < 0 || ofs > bytes_length s - len
+  then invalid_arg "really_input"
+  else unsafe_really_input ic s ofs len
+
+let really_input_string ic len =
+  let s = bytes_create len in
+  really_input ic s 0 len;
+  bytes_unsafe_to_string s
+
+external bytes_set : bytes -> int -> char -> unit = "%bytes_safe_set"
+
+let input_line ic =
+  let buf = ref (bytes_create 128) in
+  let pos = ref 0 in
+  begin try
+    while true do
+      if !pos = bytes_length !buf then begin
+        let newbuf = bytes_create (2 * !pos) in
+        bytes_blit !buf 0 newbuf 0 !pos;
+        buf := newbuf
+      end;
+      let c = input_char ic in
+      if c = '\n' then raise Exit;
+      bytes_set !buf !pos c;
+      incr pos
+    done
+  with Exit -> ()
+     | End_of_file -> if !pos = 0 then raise End_of_file
+  end;
+  let res = bytes_create !pos in
+  bytes_blit !buf 0 res 0 !pos;
+  bytes_unsafe_to_string res
+
+let rec input_byte ic =
+  try
+    input_byte_blocking ic
+  with Sys_blocked_io ->
+    wait_inchan ic; input_byte ic
+
+let input_binary_int ic =
+  let b1 = input_byte ic in
+  let n1 = if b1 >= 128 then b1 - 256 else b1 in
+  let b2 = input_byte ic in
+  let b3 = input_byte ic in
+  let b4 = input_byte ic in
+  (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4
+
+external unmarshal : bytes -> int -> 'a = "caml_input_value_from_string"
+external marshal_data_size : bytes -> int -> int = "caml_marshal_data_size"
+
+let input_value ic =
+  let header = bytes_create 20 in
+  really_input ic header 0 20;
+  let bsize = marshal_data_size header 0 in
+  let buffer = bytes_create (20 + bsize) in
+  bytes_blit header 0 buffer 0 20;
+  really_input ic buffer 20 bsize;
+  unmarshal buffer 0
+
+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_ml_set_binary_mode"
+
+(* Output functions on standard output *)
+
+let print_char c = output_char stdout c
+let print_string s = output_string stdout s
+let print_bytes s = output_bytes stdout s
+let print_int i = output_string stdout (string_of_int i)
+let print_float f = output_string stdout (string_of_float f)
+let print_endline s =
+  output_string stdout s; output_char stdout '\n'; flush stdout
+let print_newline () = output_char stdout '\n'; flush stdout
+
+(* Output functions on standard error *)
+
+let prerr_char c = output_char stderr c
+let prerr_string s = output_string stderr s
+let prerr_bytes s = output_bytes stderr s
+let prerr_int i = output_string stderr (string_of_int i)
+let prerr_float f = output_string stderr (string_of_float f)
+let prerr_endline s =
+  output_string stderr s; output_char stderr '\n'; flush stderr
+let prerr_newline () = output_char stderr '\n'; flush stderr
+
+(* Input functions on standard input *)
+
+let read_line () = flush stdout; input_line stdin
+let read_int () = int_of_string(read_line())
+let read_int_opt () = int_of_string_opt(read_line())
+let read_float () = float_of_string(read_line())
+let read_float_opt () = float_of_string_opt(read_line())
+
+(* Operations on large files *)
+
+module LargeFile =
+  struct
+    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, 'd, 'e, 'f) format6
+   = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+   = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+               * string
+
+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+let string_of_format (Format (fmt, str)) = str
+
+external format_of_string :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+
+let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+  Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
+          str1 ^ "%," ^ str2)
+
+(* Miscellaneous *)
+
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let exit_function = ref flush_all
+
+let at_exit f =
+  let g = !exit_function in
+  exit_function := (fun () -> f(); g())
+
+let do_at_exit () = (!exit_function) ()
+
+let exit retcode =
+  do_at_exit ();
+  sys_exit retcode
+
+let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
new file mode 100644
index 00000000..fff4b177
--- /dev/null
+++ b/otherlibs/threads/scheduler.c
@@ -0,0 +1,878 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* The thread scheduler */
+
+#include <string.h>
+#include <stdlib.h>
+#include <stdio.h>
+
+#include "caml/alloc.h"
+#include "caml/backtrace.h"
+#include "caml/callback.h"
+#include "caml/config.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/memory.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/printexc.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stacks.h"
+#include "caml/sys.h"
+
+#if ! (defined(HAS_SELECT) && \
+       defined(HAS_SETITIMER) && \
+       defined(HAS_GETTIMEOFDAY) && \
+       (defined(HAS_WAITPID) || defined(HAS_WAIT4)))
+#include "Cannot compile libthreads, system calls missing"
+#endif
+
+#include <errno.h>
+#include <sys/time.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+
+#ifndef HAS_WAITPID
+#define waitpid(pid,status,opts) wait4(pid,status,opts,NULL)
+#endif
+
+#ifndef O_NONBLOCK
+#define O_NONBLOCK O_NDELAY
+#endif
+
+/* Configuration */
+
+/* Initial size of stack when a thread is created (4kB) */
+#define Thread_stack_size (Stack_size / 4)
+
+/* Max computation time before rescheduling, in microseconds (50ms) */
+#define Thread_timeout 50000
+
+/* The thread descriptors */
+
+struct caml_thread_struct {
+  value ident;                  /* Unique id (for equality comparisons) */
+  struct caml_thread_struct * next;  /* Double linking of threads */
+  struct caml_thread_struct * prev;
+  value * stack_low;            /* The execution stack for this thread */
+  value * stack_high;
+  value * stack_threshold;
+  value * sp;
+  value * trapsp;
+  value backtrace_pos;          /* The backtrace info for this thread */
+  backtrace_slot * backtrace_buffer;
+  value backtrace_last_exn;
+  value status;                 /* RUNNABLE, KILLED. etc (see below) */
+  value fd;     /* File descriptor on which we're doing read or write */
+  value readfds, writefds, exceptfds;
+                /* Lists of file descriptors on which we're doing select() */
+  value delay;                  /* Time until which this thread is blocked */
+  value joining;                /* Thread we're trying to join */
+  value waitpid;                /* PID of process we're waiting for */
+  value retval;                 /* Value to return when thread resumes */
+};
+
+typedef struct caml_thread_struct * caml_thread_t;
+
+#define RUNNABLE Val_int(0)
+#define KILLED Val_int(1)
+#define SUSPENDED Val_int(2)
+#define BLOCKED_READ Val_int(4)
+#define BLOCKED_WRITE Val_int(8)
+#define BLOCKED_SELECT Val_int(16)
+#define BLOCKED_DELAY Val_int(32)
+#define BLOCKED_JOIN Val_int(64)
+#define BLOCKED_WAIT Val_int(128)
+
+#define RESUMED_WAKEUP Val_int(0)
+#define RESUMED_DELAY Val_int(1)
+#define RESUMED_JOIN Val_int(2)
+#define RESUMED_IO Val_int(3)
+
+#define TAG_RESUMED_SELECT 0
+#define TAG_RESUMED_WAIT 1
+
+#define NO_FDS Val_unit
+#define NO_DELAY Val_unit
+#define NO_JOINING Val_unit
+#define NO_WAITPID Val_int(0)
+
+#define DELAY_INFTY 1E30        /* +infty, for this purpose */
+
+/* The thread currently active */
+static caml_thread_t curr_thread = NULL;
+/* Identifier for next thread creation */
+static value next_ident = Val_int(0);
+
+#define Assign(dst,src) caml_modify((value *)&(dst), (value)(src))
+
+/* Scan the stacks of the other threads */
+
+static void (*prev_scan_roots_hook) (scanning_action);
+
+static void thread_scan_roots(scanning_action action)
+{
+  caml_thread_t th, start;
+
+  /* Scan all active descriptors */
+  start = curr_thread;
+  (*action)((value) curr_thread, (value *) &curr_thread);
+  /* Don't scan curr_thread->sp, this has already been done.
+     Don't scan local roots either, for the same reason. */
+  for (th = start->next; th != start; th = th->next) {
+    caml_do_local_roots(action, th->sp, th->stack_high, NULL);
+  }
+  /* Hook */
+  if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
+}
+
+/* Forward declarations for async I/O handling */
+
+static int stdin_initial_status, stdout_initial_status, stderr_initial_status;
+static void thread_restore_std_descr(void);
+
+/* Initialize the thread machinery */
+
+value thread_initialize(value unit)       /* ML */
+{
+  /* Protect against repeated initialization (PR#1325) */
+  if (curr_thread != NULL) return Val_unit;
+  /* Create a descriptor for the current thread */
+  curr_thread =
+    (caml_thread_t) caml_alloc_shr(sizeof(struct caml_thread_struct)
+                              / sizeof(value), 0);
+  curr_thread->ident = next_ident;
+  next_ident = Val_int(Int_val(next_ident) + 1);
+  curr_thread->next = curr_thread;
+  curr_thread->prev = curr_thread;
+  curr_thread->stack_low = caml_stack_low;
+  curr_thread->stack_high = caml_stack_high;
+  curr_thread->stack_threshold = caml_stack_threshold;
+  curr_thread->sp = caml_extern_sp;
+  curr_thread->trapsp = caml_trapsp;
+  curr_thread->backtrace_pos = Val_int(caml_backtrace_pos);
+  curr_thread->backtrace_buffer = caml_backtrace_buffer;
+  caml_initialize (&curr_thread->backtrace_last_exn, caml_backtrace_last_exn);
+  curr_thread->status = RUNNABLE;
+  curr_thread->fd = Val_int(0);
+  curr_thread->readfds = NO_FDS;
+  curr_thread->writefds = NO_FDS;
+  curr_thread->exceptfds = NO_FDS;
+  curr_thread->delay = NO_DELAY;
+  curr_thread->joining = NO_JOINING;
+  curr_thread->waitpid = NO_WAITPID;
+  curr_thread->retval = Val_unit;
+  /* Initialize GC */
+  prev_scan_roots_hook = caml_scan_roots_hook;
+  caml_scan_roots_hook = thread_scan_roots;
+  /* Set standard file descriptors to non-blocking mode */
+  stdin_initial_status = fcntl(0, F_GETFL);
+  stdout_initial_status = fcntl(1, F_GETFL);
+  stderr_initial_status = fcntl(2, F_GETFL);
+  if (stdin_initial_status != -1)
+    fcntl(0, F_SETFL, stdin_initial_status | O_NONBLOCK);
+  if (stdout_initial_status != -1)
+    fcntl(1, F_SETFL, stdout_initial_status | O_NONBLOCK);
+  if (stderr_initial_status != -1)
+    fcntl(2, F_SETFL, stderr_initial_status | O_NONBLOCK);
+  /* Register an at-exit function to restore the standard file descriptors */
+  atexit(thread_restore_std_descr);
+  return Val_unit;
+}
+
+/* Initialize the interval timer used for preemption */
+
+value thread_initialize_preemption(value unit)     /* ML */
+{
+  struct itimerval timer;
+
+  timer.it_interval.tv_sec = 0;
+  timer.it_interval.tv_usec = Thread_timeout;
+  timer.it_value = timer.it_interval;
+  setitimer(ITIMER_VIRTUAL, &timer, NULL);
+  return Val_unit;
+}
+
+/* Create a thread */
+
+value thread_new(value clos)          /* ML */
+{
+  caml_thread_t th;
+  /* Allocate the thread and its stack */
+  Begin_root(clos);
+    th = (caml_thread_t) caml_alloc_shr(sizeof(struct caml_thread_struct)
+                                   / sizeof(value), 0);
+  End_roots();
+  th->ident = next_ident;
+  next_ident = Val_int(Int_val(next_ident) + 1);
+  th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
+  th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
+  th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
+  th->sp = th->stack_high;
+  th->trapsp = th->stack_high;
+  /* Set up a return frame that pretends we're applying the function to ().
+     This way, the next RETURN instruction will run the function. */
+  th->sp -= 5;
+  th->sp[0] = Val_unit;         /* dummy local to be popped by RETURN 1 */
+  th->sp[1] = (value) Code_val(clos);
+  th->sp[2] = clos;
+  th->sp[3] = Val_long(0);      /* no extra args */
+  th->sp[4] = Val_unit;         /* the () argument */
+  /* Fake a C call frame */
+  th->sp--;
+  th->sp[0] = Val_unit;         /* a dummy environment */
+  /* Finish initialization of th */
+  th->backtrace_pos = Val_int(0);
+  th->backtrace_buffer = NULL;
+  th->backtrace_last_exn = Val_unit;
+  /* The thread is initially runnable */
+  th->status = RUNNABLE;
+  th->fd = Val_int(0);
+  th->readfds = NO_FDS;
+  th->writefds = NO_FDS;
+  th->exceptfds = NO_FDS;
+  th->delay = NO_DELAY;
+  th->joining = NO_JOINING;
+  th->waitpid = NO_WAITPID;
+  th->retval = Val_unit;
+  /* Insert thread in doubly linked list of threads */
+  th->prev = curr_thread->prev;
+  th->next = curr_thread;
+  Assign(curr_thread->prev->next, th);
+  Assign(curr_thread->prev, th);
+  /* Return thread */
+  return (value) th;
+}
+
+/* Return the thread identifier */
+
+value thread_id(value th)             /* ML */
+{
+  return ((caml_thread_t)th)->ident;
+}
+
+/* Return the current time as a floating-point number */
+
+static double timeofday(void)
+{
+  struct timeval tv;
+  gettimeofday(&tv, NULL);
+  return (double) tv.tv_sec + (double) tv.tv_usec * 1e-6;
+}
+
+/* Find a runnable thread and activate it */
+
+#define FOREACH_THREAD(x) x = curr_thread; do { x = x->next;
+#define END_FOREACH(x) } while (x != curr_thread)
+
+static value alloc_process_status(int pid, int status);
+static void add_fdlist_to_set(value fdl, fd_set *set);
+static value inter_fdlist_set(value fdl, fd_set *set, int *count);
+static void find_bad_fd(int fd, fd_set *set);
+static void find_bad_fds(value fdl, fd_set *set);
+
+static value schedule_thread(void)
+{
+  caml_thread_t run_thread, th;
+  fd_set readfds, writefds, exceptfds;
+  double delay, now;
+  int need_select, need_wait;
+
+  /* Don't allow preemption during a callback */
+  if (caml_callback_depth > 1) return curr_thread->retval;
+
+  /* Save the status of the current thread */
+  curr_thread->stack_low = caml_stack_low;
+  curr_thread->stack_high = caml_stack_high;
+  curr_thread->stack_threshold = caml_stack_threshold;
+  curr_thread->sp = caml_extern_sp;
+  curr_thread->trapsp = caml_trapsp;
+  curr_thread->backtrace_pos = Val_int(caml_backtrace_pos);
+  curr_thread->backtrace_buffer = caml_backtrace_buffer;
+  caml_modify (&curr_thread->backtrace_last_exn, caml_backtrace_last_exn);
+
+try_again:
+  /* Find if a thread is runnable.
+     Build fdsets and delay for select.
+     See if some join or wait operations succeeded. */
+  run_thread = NULL;
+  FD_ZERO(&readfds);
+  FD_ZERO(&writefds);
+  FD_ZERO(&exceptfds);
+  delay = DELAY_INFTY;
+  now = -1.0;
+  need_select = 0;
+  need_wait = 0;
+
+  FOREACH_THREAD(th)
+    if (th->status <= SUSPENDED) continue;
+
+    if (th->status & (BLOCKED_READ - 1)) {
+      FD_SET(Int_val(th->fd), &readfds);
+      need_select = 1;
+    }
+    if (th->status & (BLOCKED_WRITE - 1)) {
+      FD_SET(Int_val(th->fd), &writefds);
+      need_select = 1;
+    }
+    if (th->status & (BLOCKED_SELECT - 1)) {
+      add_fdlist_to_set(th->readfds, &readfds);
+      add_fdlist_to_set(th->writefds, &writefds);
+      add_fdlist_to_set(th->exceptfds, &exceptfds);
+      need_select = 1;
+    }
+    if (th->status & (BLOCKED_DELAY - 1)) {
+      double th_delay;
+      if (now < 0.0) now = timeofday();
+      th_delay = Double_val(th->delay) - now;
+      if (th_delay <= 0) {
+        th->status = RUNNABLE;
+        Assign(th->retval,RESUMED_DELAY);
+      } else {
+        if (th_delay < delay) delay = th_delay;
+      }
+    }
+    if (th->status & (BLOCKED_JOIN - 1)) {
+      if (((caml_thread_t)(th->joining))->status == KILLED) {
+        th->status = RUNNABLE;
+        Assign(th->retval, RESUMED_JOIN);
+      }
+    }
+    if (th->status & (BLOCKED_WAIT - 1)) {
+      int status, pid;
+      pid = waitpid(Int_val(th->waitpid), &status, WNOHANG);
+      if (pid > 0) {
+        th->status = RUNNABLE;
+        Assign(th->retval, alloc_process_status(pid, status));
+      } else {
+        need_wait = 1;
+      }
+    }
+  END_FOREACH(th);
+
+  /* Find if a thread is runnable. */
+  run_thread = NULL;
+  FOREACH_THREAD(th)
+    if (th->status == RUNNABLE) { run_thread = th; break; }
+  END_FOREACH(th);
+
+  /* Do the select if needed */
+  if (need_select || run_thread == NULL) {
+    struct timeval delay_tv, * delay_ptr;
+    int retcode;
+    /* If a thread is blocked on wait, don't block forever */
+    if (need_wait && delay > Thread_timeout * 1e-6) {
+      delay = Thread_timeout * 1e-6;
+    }
+    /* Convert delay to a timeval */
+    /* If a thread is runnable, just poll */
+    if (run_thread != NULL) {
+      delay_tv.tv_sec = 0;
+      delay_tv.tv_usec = 0;
+      delay_ptr = &delay_tv;
+    }
+    else if (delay != DELAY_INFTY) {
+      delay_tv.tv_sec = (unsigned int) delay;
+      delay_tv.tv_usec = (delay - (double) delay_tv.tv_sec) * 1E6;
+      delay_ptr = &delay_tv;
+    }
+    else {
+      delay_ptr = NULL;
+    }
+    caml_enter_blocking_section();
+    retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr);
+    caml_leave_blocking_section();
+    if (retcode == -1)
+      switch (errno) {
+      case EINTR:
+        break;
+      case EBADF:
+        /* One of the descriptors in the sets was closed or is bad.
+           Find it using fstat() and wake up the threads waiting on it
+           so that they'll get an error when operating on it. */
+        FOREACH_THREAD(th)
+          if (th->status & (BLOCKED_READ - 1)) {
+            find_bad_fd(Int_val(th->fd), &readfds);
+          }
+          if (th->status & (BLOCKED_WRITE - 1)) {
+            find_bad_fd(Int_val(th->fd), &writefds);
+          }
+          if (th->status & (BLOCKED_SELECT - 1)) {
+            find_bad_fds(th->readfds, &readfds);
+            find_bad_fds(th->writefds, &writefds);
+            find_bad_fds(th->exceptfds, &exceptfds);
+          }
+        END_FOREACH(th);
+        retcode = FD_SETSIZE;
+        break;
+      default:
+        caml_sys_error(NO_ARG);
+      }
+    if (retcode > 0) {
+      /* Some descriptors are ready.
+         Mark the corresponding threads runnable. */
+      FOREACH_THREAD(th)
+        if (retcode <= 0) break;
+        if ((th->status & (BLOCKED_READ - 1)) &&
+            FD_ISSET(Int_val(th->fd), &readfds)) {
+          Assign(th->retval, RESUMED_IO);
+          th->status = RUNNABLE;
+          if (run_thread == NULL) run_thread = th; /* Found one. */
+          /* Wake up only one thread per fd */
+          FD_CLR(Int_val(th->fd), &readfds);
+          retcode--;
+        }
+        if ((th->status & (BLOCKED_WRITE - 1)) &&
+            FD_ISSET(Int_val(th->fd), &writefds)) {
+          Assign(th->retval, RESUMED_IO);
+          th->status = RUNNABLE;
+          if (run_thread == NULL) run_thread = th; /* Found one. */
+          /* Wake up only one thread per fd */
+          FD_CLR(Int_val(th->fd), &readfds);
+          retcode--;
+        }
+        if (th->status & (BLOCKED_SELECT - 1)) {
+          value r = Val_unit, w = Val_unit, e = Val_unit;
+          Begin_roots3(r,w,e)
+            r = inter_fdlist_set(th->readfds, &readfds, &retcode);
+            w = inter_fdlist_set(th->writefds, &writefds, &retcode);
+            e = inter_fdlist_set(th->exceptfds, &exceptfds, &retcode);
+            if (r != NO_FDS || w != NO_FDS || e != NO_FDS) {
+              value retval = caml_alloc_small(3, TAG_RESUMED_SELECT);
+              Field(retval, 0) = r;
+              Field(retval, 1) = w;
+              Field(retval, 2) = e;
+              Assign(th->retval, retval);
+              th->status = RUNNABLE;
+              if (run_thread == NULL) run_thread = th; /* Found one. */
+            }
+          End_roots();
+        }
+      END_FOREACH(th);
+    }
+    /* If we get here with run_thread still NULL, one of the following
+       may have happened:
+       - a delay has expired
+       - a wait() needs to be polled again
+       - the select() failed (e.g. was interrupted)
+       In these cases, we go through the loop once more to make the
+       corresponding threads runnable. */
+    if (run_thread == NULL &&
+        (delay != DELAY_INFTY || need_wait || retcode == -1))
+      goto try_again;
+  }
+
+  /* If we haven't something to run at that point, we're in big trouble. */
+  if (run_thread == NULL) caml_invalid_argument("Thread: deadlock");
+
+  /* Free everything the thread was waiting on */
+  Assign(run_thread->readfds, NO_FDS);
+  Assign(run_thread->writefds, NO_FDS);
+  Assign(run_thread->exceptfds, NO_FDS);
+  Assign(run_thread->delay, NO_DELAY);
+  Assign(run_thread->joining, NO_JOINING);
+  run_thread->waitpid = NO_WAITPID;
+
+  /* Activate the thread */
+  curr_thread = run_thread;
+  caml_stack_low = curr_thread->stack_low;
+  caml_stack_high = curr_thread->stack_high;
+  caml_stack_threshold = curr_thread->stack_threshold;
+  caml_extern_sp = curr_thread->sp;
+  caml_trapsp = curr_thread->trapsp;
+  caml_backtrace_pos = Int_val(curr_thread->backtrace_pos);
+  caml_backtrace_buffer = curr_thread->backtrace_buffer;
+  caml_backtrace_last_exn = curr_thread->backtrace_last_exn;
+  return curr_thread->retval;
+}
+
+/* Since context switching is not allowed in callbacks, a thread that
+   blocks during a callback is a deadlock. */
+
+static void check_callback(void)
+{
+  if (caml_callback_depth > 1)
+    caml_fatal_error("Thread: deadlock during callback");
+}
+
+/* Reschedule without suspending the current thread */
+
+value thread_yield(value unit)        /* ML */
+{
+  Assert(curr_thread != NULL);
+  Assign(curr_thread->retval, Val_unit);
+  return schedule_thread();
+}
+
+/* Honor an asynchronous request for re-scheduling */
+
+static void thread_reschedule(void)
+{
+  value accu;
+
+  Assert(curr_thread != NULL);
+  /* Pop accu from event frame, making it look like a C_CALL frame
+     followed by a RETURN frame */
+  accu = *caml_extern_sp++;
+  /* Reschedule */
+  Assign(curr_thread->retval, accu);
+  accu = schedule_thread();
+  /* Push accu below C_CALL frame so that it looks like an event frame */
+  *--caml_extern_sp = accu;
+}
+
+/* Request a re-scheduling as soon as possible */
+
+value thread_request_reschedule(value unit)    /* ML */
+{
+  caml_async_action_hook = thread_reschedule;
+  caml_something_to_do = 1;
+  return Val_unit;
+}
+
+/* Suspend the current thread */
+
+value thread_sleep(value unit)        /* ML */
+{
+  Assert(curr_thread != NULL);
+  check_callback();
+  curr_thread->status = SUSPENDED;
+  return schedule_thread();
+}
+
+/* Suspend the current thread on a read() or write() request */
+
+static value thread_wait_rw(int kind, value fd)
+{
+  /* Don't do an error if we're not initialized yet
+     (we can be called from thread-safe Pervasives before initialization),
+     just return immediately. */
+  if (curr_thread == NULL) return RESUMED_WAKEUP;
+  /* As a special case, if we're in a callback, don't fail but block
+     the whole process till I/O is possible */
+  if (caml_callback_depth > 1) {
+    fd_set fds;
+    FD_ZERO(&fds);
+    FD_SET(Int_val(fd), &fds);
+    switch(kind) {
+      case BLOCKED_READ: select(FD_SETSIZE, &fds, NULL, NULL, NULL); break;
+      case BLOCKED_WRITE: select(FD_SETSIZE, NULL, &fds, NULL, NULL); break;
+    }
+    return RESUMED_IO;
+  } else {
+    curr_thread->fd = fd;
+    curr_thread->status = kind;
+    return schedule_thread();
+  }
+}
+
+value thread_wait_read(value fd)
+{
+  return thread_wait_rw(BLOCKED_READ, fd);
+}
+
+value thread_wait_write(value fd)
+{
+  return thread_wait_rw(BLOCKED_WRITE, fd);
+}
+
+/* Suspend the current thread on a read() or write() request with timeout */
+
+static value thread_wait_timed_rw(int kind, value arg)
+{
+  double date;
+
+  check_callback();
+  curr_thread->fd = Field(arg, 0);
+  date = timeofday() + Double_val(Field(arg, 1));
+  Assign(curr_thread->delay, caml_copy_double(date));
+  curr_thread->status = kind | BLOCKED_DELAY;
+  return schedule_thread();
+}
+
+value thread_wait_timed_read(value arg)
+{
+  return thread_wait_timed_rw(BLOCKED_READ, arg);
+}
+
+value thread_wait_timed_write(value arg)
+{
+  return thread_wait_timed_rw(BLOCKED_WRITE, arg);
+}
+
+/* Suspend the current thread on a select() request */
+
+value thread_select(value arg)        /* ML */
+{
+  double date;
+  check_callback();
+  Assign(curr_thread->readfds, Field(arg, 0));
+  Assign(curr_thread->writefds, Field(arg, 1));
+  Assign(curr_thread->exceptfds, Field(arg, 2));
+  date = Double_val(Field(arg, 3));
+  if (date >= 0.0) {
+    date += timeofday();
+    Assign(curr_thread->delay, caml_copy_double(date));
+    curr_thread->status = BLOCKED_SELECT | BLOCKED_DELAY;
+  } else {
+    curr_thread->status = BLOCKED_SELECT;
+  }
+  return schedule_thread();
+}
+
+/* Primitives to implement suspension on buffered channels */
+
+value thread_inchan_ready(value vchan) /* ML */
+{
+  struct channel * chan = Channel(vchan);
+  return Val_bool(chan->curr < chan->max);
+}
+
+value thread_outchan_ready(value vchan, value vsize) /* ML */
+{
+  struct channel * chan = Channel(vchan);
+  intnat size = Long_val(vsize);
+  /* Negative size means we want to flush the buffer entirely */
+  if (size < 0) {
+    return Val_bool(chan->curr == chan->buff);
+  } else {
+    int free = chan->end - chan->curr;
+    if (chan->curr == chan->buff)
+      return Val_bool(size < free);
+    else
+      return Val_bool(size <= free);
+  }
+}
+
+/* Suspend the current thread for some time */
+
+value thread_delay(value time)          /* ML */
+{
+  double date = timeofday() + Double_val(time);
+  Assert(curr_thread != NULL);
+  check_callback();
+  curr_thread->status = BLOCKED_DELAY;
+  Assign(curr_thread->delay, caml_copy_double(date));
+  return schedule_thread();
+}
+
+/* Suspend the current thread until another thread terminates */
+
+value thread_join(value th)          /* ML */
+{
+  check_callback();
+  Assert(curr_thread != NULL);
+  if (((caml_thread_t)th)->status == KILLED) return Val_unit;
+  curr_thread->status = BLOCKED_JOIN;
+  Assign(curr_thread->joining, th);
+  return schedule_thread();
+}
+
+/* Suspend the current thread until a Unix process exits */
+
+value thread_wait_pid(value pid)          /* ML */
+{
+  Assert(curr_thread != NULL);
+  check_callback();
+  curr_thread->status = BLOCKED_WAIT;
+  curr_thread->waitpid = pid;
+  return schedule_thread();
+}
+
+/* Reactivate another thread */
+
+value thread_wakeup(value thread)     /* ML */
+{
+  caml_thread_t th = (caml_thread_t) thread;
+  switch (th->status) {
+  case SUSPENDED:
+    th->status = RUNNABLE;
+    Assign(th->retval, RESUMED_WAKEUP);
+    break;
+  case KILLED:
+    caml_failwith("Thread.wakeup: killed thread");
+  default:
+    caml_failwith("Thread.wakeup: thread not suspended");
+  }
+  return Val_unit;
+}
+
+/* Return the current thread */
+
+value thread_self(value unit)         /* ML */
+{
+  Assert(curr_thread != NULL);
+  return (value) curr_thread;
+}
+
+/* Kill a thread */
+
+value thread_kill(value thread)       /* ML */
+{
+  value retval = Val_unit;
+  caml_thread_t th = (caml_thread_t) thread;
+  if (th->status == KILLED) caml_failwith("Thread.kill: killed thread");
+  /* Don't paint ourselves in a corner */
+  if (th == th->next) caml_failwith("Thread.kill: cannot kill the last thread");
+  /* This thread is no longer waiting on anything */
+  th->status = KILLED;
+  /* If this is the current thread, activate another one */
+  if (th == curr_thread) {
+    Begin_root(thread);
+    retval = schedule_thread();
+    th = (caml_thread_t) thread;
+    End_roots();
+  }
+  /* Remove thread from the doubly-linked list */
+  Assign(th->prev->next, th->next);
+  Assign(th->next->prev, th->prev);
+  /* Free its resources */
+  caml_stat_free((char *) th->stack_low);
+  th->stack_low = NULL;
+  th->stack_high = NULL;
+  th->stack_threshold = NULL;
+  th->sp = NULL;
+  th->trapsp = NULL;
+  if (th->backtrace_buffer != NULL) {
+    free(th->backtrace_buffer);
+    th->backtrace_buffer = NULL;
+  }
+  return retval;
+}
+
+/* Print uncaught exception and backtrace */
+
+value thread_uncaught_exception(value exn)  /* ML */
+{
+  char * msg = caml_format_exception(exn);
+  fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
+          Int_val(curr_thread->ident), msg);
+  free(msg);
+  if (caml_backtrace_active) caml_print_exception_backtrace();
+  fflush(stderr);
+  return Val_unit;
+}
+
+/* Set a list of file descriptors in a fdset */
+
+static void add_fdlist_to_set(value fdl, fd_set *set)
+{
+  for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) {
+    int fd = Int_val(Field(fdl, 0));
+    /* Ignore funky file descriptors, which can cause crashes */
+    if (fd >= 0 && fd < FD_SETSIZE) FD_SET(fd, set);
+  }
+}
+
+/* Build the intersection of a list and a fdset (the list of file descriptors
+   which are both in the list and in the fdset). */
+
+static value inter_fdlist_set(value fdl, fd_set *set, int *count)
+{
+  value res = Val_unit;
+  value cons;
+
+  Begin_roots2(fdl, res);
+    for (res = NO_FDS; fdl != NO_FDS; fdl = Field(fdl, 1)) {
+      int fd = Int_val(Field(fdl, 0));
+      if (FD_ISSET(fd, set)) {
+        cons = caml_alloc_small(2, 0);
+        Field(cons, 0) = Val_int(fd);
+        Field(cons, 1) = res;
+        res = cons;
+        FD_CLR(fd, set); /* wake up only one thread per fd ready */
+        (*count)--;
+      }
+    }
+  End_roots();
+  return res;
+}
+
+/* Find closed file descriptors in a waiting list and set them to 1 in
+   the given fdset */
+
+static void find_bad_fd(int fd, fd_set *set)
+{
+  struct stat s;
+  if (fd >= 0 && fd < FD_SETSIZE && fstat(fd, &s) == -1 && errno == EBADF)
+    FD_SET(fd, set);
+}
+
+static void find_bad_fds(value fdl, fd_set *set)
+{
+  for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1))
+    find_bad_fd(Int_val(Field(fdl, 0)), set);
+}
+
+/* Auxiliary function for allocating the result of a waitpid() call */
+
+#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \
+      defined(WSTOPSIG) && defined(WTERMSIG))
+/* Assume old-style V7 status word */
+#define WIFEXITED(status) (((status) & 0xFF) == 0)
+#define WEXITSTATUS(status) (((status) >> 8) & 0xFF)
+#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF)
+#define WSTOPSIG(status) (((status) >> 8) & 0xFF)
+#define WTERMSIG(status) ((status) & 0x3F)
+#endif
+
+#define TAG_WEXITED 0
+#define TAG_WSIGNALED 1
+#define TAG_WSTOPPED 2
+
+static value alloc_process_status(int pid, int status)
+{
+  value st, res;
+
+  if (WIFEXITED(status)) {
+    st = caml_alloc_small(1, TAG_WEXITED);
+    Field(st, 0) = Val_int(WEXITSTATUS(status));
+  }
+  else if (WIFSTOPPED(status)) {
+    st = caml_alloc_small(1, TAG_WSTOPPED);
+    Field(st, 0) = Val_int(WSTOPSIG(status));
+  }
+  else {
+    st = caml_alloc_small(1, TAG_WSIGNALED);
+    Field(st, 0) = Val_int(WTERMSIG(status));
+  }
+  Begin_root(st);
+    res = caml_alloc_small(2, TAG_RESUMED_WAIT);
+    Field(res, 0) = Val_int(pid);
+    Field(res, 1) = st;
+  End_roots();
+  return res;
+}
+
+/* Restore the standard file descriptors to their initial state */
+
+static void thread_restore_std_descr(void)
+{
+  if (stdin_initial_status != -1) fcntl(0, F_SETFL, stdin_initial_status);
+  if (stdout_initial_status != -1) fcntl(1, F_SETFL, stdout_initial_status);
+  if (stderr_initial_status != -1) fcntl(2, F_SETFL, stderr_initial_status);
+}
diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml
new file mode 100644
index 00000000..c4561e18
--- /dev/null
+++ b/otherlibs/threads/thread.ml
@@ -0,0 +1,147 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* User-level threads *)
+
+type t
+
+let critical_section = ref false
+
+type resumption_status =
+    Resumed_wakeup
+  | Resumed_delay
+  | Resumed_join
+  | Resumed_io
+  | Resumed_select of
+      Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
+  | Resumed_wait of int * Unix.process_status
+
+(* to avoid warning *)
+let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
+         Resumed_io; Resumed_select ([], [], []);
+         Resumed_wait (0, Unix.WEXITED 0)]
+
+(* It is mucho important that the primitives that reschedule are called
+   through an ML function call, not directly. That's because when such a
+   primitive returns, the bytecode interpreter is only semi-obedient:
+   it takes sp from the new thread, but keeps pc from the old thread.
+   But that's OK if all calls to rescheduling primitives are immediately
+   followed by a RETURN operation, which will restore the correct pc
+   from the stack. Furthermore, the RETURNs must all have the same
+   frame size, which means that both the primitives and their ML wrappers
+   must take exactly one argument. *)
+
+external thread_initialize : unit -> unit = "thread_initialize"
+external thread_initialize_preemption : unit -> unit
+   = "thread_initialize_preemption"
+external thread_new : (unit -> unit) -> t = "thread_new"
+external thread_yield : unit -> unit = "thread_yield"
+external thread_request_reschedule : unit -> unit = "thread_request_reschedule"
+external thread_sleep : unit -> unit = "thread_sleep"
+external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read"
+external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write"
+external thread_wait_timed_read :
+  Unix.file_descr * float -> resumption_status     (* remember: 1 arg *)
+  = "thread_wait_timed_read"
+external thread_wait_timed_write :
+  Unix.file_descr * float -> resumption_status     (* remember: 1 arg *)
+  = "thread_wait_timed_write"
+external thread_select :
+  Unix.file_descr list * Unix.file_descr list *          (* remember: 1 arg *)
+  Unix.file_descr list * float -> resumption_status
+  = "thread_select"
+external thread_join : t -> unit = "thread_join"
+external thread_delay : float -> unit = "thread_delay"
+external thread_wait_pid : int -> resumption_status = "thread_wait_pid"
+external thread_wakeup : t -> unit = "thread_wakeup"
+external thread_self : unit -> t = "thread_self" [@@noalloc]
+external thread_kill : t -> unit = "thread_kill"
+external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception"
+external thread_id : t -> int = "thread_id" [@@noalloc]
+
+(* In sleep() below, we rely on the fact that signals are detected
+   only at function applications and beginning of loops,
+   making all other operations atomic. *)
+
+let yield () = thread_yield()
+let sleep () = critical_section := false; thread_sleep()
+let delay duration = thread_delay duration
+let join th = thread_join th
+let wakeup pid = thread_wakeup pid
+let self () = thread_self()
+let kill pid = thread_kill pid
+let exit () = thread_kill(thread_self())
+let id t = thread_id t
+
+let select_aux arg = thread_select arg
+
+let select readfds writefds exceptfds delay =
+  match select_aux (readfds, writefds, exceptfds, delay) with
+    Resumed_select(r, w, e) -> (r, w, e)
+  | _ -> ([], [], [])
+
+let wait_read fd = thread_wait_read fd
+let wait_write fd = thread_wait_write fd
+
+let wait_timed_read_aux arg = thread_wait_timed_read arg
+let wait_timed_write_aux arg = thread_wait_timed_write arg
+
+let wait_timed_read fd delay =
+  match wait_timed_read_aux (fd, delay) with Resumed_io -> true | _ -> false
+
+let wait_timed_write fd delay =
+  match wait_timed_write_aux (fd, delay) with Resumed_io -> true | _ -> false
+
+let wait_pid_aux pid = thread_wait_pid pid
+
+let wait_pid pid =
+  match wait_pid_aux pid with
+    Resumed_wait(pid, status) -> (pid, status)
+  | _ -> invalid_arg "Thread.wait_pid"
+
+let wait_signal sigs =
+  let gotsig = ref 0 in
+  let self = thread_self() in
+  let sighandler s = gotsig := s; wakeup self in
+  let oldhdlrs =
+    List.map (fun s -> Sys.signal s (Sys.Signal_handle sighandler)) sigs in
+  if !gotsig = 0 then sleep();
+  List.iter2 Sys.set_signal sigs oldhdlrs;
+  !gotsig
+
+(* For Thread.create, make sure the function passed to thread_new
+   always terminates by calling Thread.exit. *)
+
+let create fn arg =
+  thread_new
+    (fun () ->
+      try
+        fn arg; exit()
+      with x ->
+        flush stdout; flush stderr;
+        thread_uncaught_exception x;
+        exit())
+
+(* Preemption *)
+
+let preempt signal =
+  if !critical_section then () else thread_request_reschedule()
+
+(* Initialization of the scheduler *)
+
+let _ =
+  thread_initialize();
+  Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle preempt);
+  thread_initialize_preemption()
diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
new file mode 100644
index 00000000..bf0c3804
--- /dev/null
+++ b/otherlibs/threads/thread.mli
@@ -0,0 +1,140 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Lightweight threads. *)
+
+type t
+(** The type of thread handles. *)
+
+
+(** {6 Thread creation and termination} *)
+
+val create : ('a -> 'b) -> 'a -> t
+(** [Thread.create funct arg] creates a new thread of control,
+   in which the function application [funct arg]
+   is executed concurrently with the other threads of the program.
+   The application of [Thread.create]
+   returns the handle of the newly created thread.
+   The new thread terminates when the application [funct arg]
+   returns, either normally or by raising an uncaught exception.
+   In the latter case, the exception is printed on standard error,
+   but not propagated back to the parent thread. Similarly, the
+   result of the application [funct arg] is discarded and not
+   directly accessible to the parent thread. *)
+
+val self : unit -> t
+(** Return the thread currently executing. *)
+
+val id : t -> int
+(** Return the identifier of the given thread. A thread identifier
+   is an integer that identifies uniquely the thread.
+   It can be used to build data structures indexed by threads. *)
+
+val exit : unit -> unit
+(** Terminate prematurely the currently executing thread. *)
+
+val kill : t -> unit
+(** Terminate prematurely the thread whose handle is given.
+   This functionality is available only with bytecode-level threads. *)
+
+(** {6 Suspending threads} *)
+
+val delay : float -> unit
+(** [delay d] suspends the execution of the calling thread for
+   [d] seconds. The other program threads continue to run during
+   this time. *)
+
+val join : t -> unit
+(** [join th] suspends the execution of the calling thread
+   until the thread [th] has terminated. *)
+
+val wait_read : Unix.file_descr -> unit
+(** See {!Thread.wait_write}.*)
+
+val wait_write : Unix.file_descr -> unit
+(** Suspend the execution of the calling thread until at least
+   one character is available for reading ({!Thread.wait_read}) or
+   one character can be written without blocking ([wait_write])
+   on the given Unix file descriptor. *)
+
+val wait_timed_read : Unix.file_descr -> float -> bool
+(** 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
+   the amount of time given as second argument (in seconds).
+   Return [true] if the file descriptor is ready for input/output
+   and [false] if the timeout expired. *)
+
+val select :
+  Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list ->
+    float ->
+    Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
+(** Suspend the execution of the calling thread until input/output
+   becomes possible on the given Unix file descriptors.
+   The arguments and results have the same meaning as for
+   {!Unix.select}. *)
+
+val wait_pid : int -> int * Unix.process_status
+(** [wait_pid p] suspends the execution of the calling thread
+   until the Unix process specified by the process identifier [p]
+   terminates. A pid [p] 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. Negative pid arguments represent
+   process groups. Returns the pid of the child caught and
+   its termination status, as per {!Unix.wait}. *)
+
+val wait_signal : int list -> int
+(** [wait_signal sigs] suspends the execution of the calling thread
+   until the process receives one of the signals specified in the
+   list [sigs].  It then returns the number of the signal received.
+   Signal handlers attached to the signals in [sigs] will not
+   be invoked.  Do not call [wait_signal] concurrently
+   from several threads on the same signals. *)
+
+val yield : unit -> unit
+(** Re-schedule the calling thread without suspending it.
+   This function can be used to give scheduling hints,
+   telling the scheduler that now is a good time to
+   switch to other threads. *)
+
+(**/**)
+
+(** {6 Synchronization primitives}
+
+   The following primitives provide the basis for implementing
+   synchronization functions between threads. Their direct use is
+   discouraged, as they are very low-level and prone to race conditions
+   and deadlocks. The modules {!Mutex}, {!Condition} and {!Event}
+   provide higher-level synchronization primitives. *)
+
+val critical_section : bool ref
+(** Setting this reference to [true] deactivate thread preemption
+   (the timer interrupt that transfers control from thread to thread),
+   causing the current thread to run uninterrupted until
+   [critical_section] is reset to [false] or the current thread
+   explicitly relinquishes control using [sleep], [delay],
+   [wait_inchan] or [wait_descr]. *)
+
+val sleep : unit -> unit
+(** Suspend the calling thread until another thread reactivates it
+   using {!Thread.wakeup}. Just before suspending the thread,
+   {!Thread.critical_section} is reset to [false]. Resetting
+   {!Thread.critical_section} and suspending the calling thread is an
+   atomic operation. *)
+
+val wakeup : t -> unit
+(** Reactivate the given thread. After the call to [wakeup],
+   the suspended thread will resume execution at some future time. *)
diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml
new file mode 100644
index 00000000..95b5857a
--- /dev/null
+++ b/otherlibs/threads/threadUnix.ml
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [ThreadUnix]: thread-compatible system calls *)
+
+let execv = Unix.execv
+let execve = Unix.execve
+let execvp = Unix.execvp
+let wait = Unix.wait
+let waitpid = Unix.waitpid
+let system = Unix.system
+let read = Unix.read
+let write = Unix.write
+let single_write = Unix.single_write
+let write_substring = Unix.write_substring
+let single_write_substring = Unix.single_write_substring
+let select = Unix.select
+let pipe = Unix.pipe
+let open_process_in = Unix.open_process_in
+let open_process_out = Unix.open_process_out
+let open_process = Unix.open_process
+let open_process_full = Unix.open_process_full
+let sleep = Unix.sleep
+let socket = Unix.socket
+let socketpair = Unix.socketpair
+let accept = Unix.accept
+let connect = Unix.connect
+let recv = Unix.recv
+let recvfrom = Unix.recvfrom
+let send = Unix.send
+let send_substring = Unix.send_substring
+let sendto = Unix.sendto
+let sendto_substring = Unix.sendto_substring
+let open_connection = Unix.open_connection
+let establish_server = Unix.establish_server
+
+open Unix
+
+let rec timed_read fd buff ofs len timeout =
+  if Thread.wait_timed_read fd timeout
+  then begin try Unix.read fd buff ofs len
+             with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+                    timed_read fd buff ofs len timeout
+       end
+  else raise (Unix_error(ETIMEDOUT, "timed_read", ""))
+
+let rec timed_write fd buff ofs len timeout =
+  if Thread.wait_timed_write fd timeout
+  then begin try Unix.write fd buff ofs len
+             with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+                    timed_write fd buff ofs len timeout
+       end
+  else raise (Unix_error(ETIMEDOUT, "timed_write", ""))
+
+let timed_write_substring fd buff ofs len timeout =
+  timed_write fd (Bytes.unsafe_of_string buff) ofs len timeout
diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
new file mode 100644
index 00000000..2b03ac9b
--- /dev/null
+++ b/otherlibs/threads/threadUnix.mli
@@ -0,0 +1,104 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Thread-compatible system calls.
+
+   @deprecated The functionality of this module has been merged back into
+   the {!Unix} module.  Threaded programs can now call the functions
+   from module {!Unix} directly, and still get the correct behavior
+   (block the calling thread, if required, but do not block all threads
+   in the process).  *)
+
+(** {6 Process handling} *)
+
+val execv : string -> string array -> unit
+val execve : string -> string array -> string array -> unit
+val execvp : string -> string array -> unit
+val wait : unit -> int * Unix.process_status
+val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
+val system : string -> Unix.process_status
+
+(** {6 Basic input/output} *)
+
+val read : Unix.file_descr -> bytes -> int -> int -> int
+val write : Unix.file_descr -> bytes -> int -> int -> int
+val single_write : Unix.file_descr -> bytes -> int -> int -> int
+val write_substring : Unix.file_descr -> string -> int -> int -> int
+val single_write_substring : Unix.file_descr -> string -> int -> int -> int
+
+(** {6 Input/output with timeout} *)
+
+val timed_read : Unix.file_descr -> bytes -> int -> int -> float -> int
+(** See {!ThreadUnix.timed_write}. *)
+
+val timed_write : Unix.file_descr -> bytes -> int -> int -> float -> int
+(** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that
+   [Unix_error(ETIMEDOUT,_,_)] is raised if no data is
+   available for reading or ready for writing after [d] seconds.
+   The delay [d] is given in the fifth argument, in seconds. *)
+
+val timed_write_substring :
+      Unix.file_descr -> string -> int -> int -> float -> int
+(** See {!ThreadUnix.timed_write}. *)
+
+(** {6 Polling} *)
+
+val select :
+  Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list ->
+    float ->
+    Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
+
+(** {6 Pipes and redirections} *)
+
+val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
+val open_process_in : string -> in_channel
+val open_process_out : string -> out_channel
+val open_process : string -> in_channel * out_channel
+val open_process_full :
+  string -> string array -> in_channel * out_channel * in_channel
+
+(** {6 Time} *)
+
+val sleep : int -> unit
+
+(** {6 Sockets} *)
+
+val socket :
+  ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
+    Unix.file_descr
+val socketpair :
+  ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
+    Unix.file_descr * Unix.file_descr
+val accept :
+  ?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
+val connect : Unix.file_descr -> Unix.sockaddr -> unit
+val recv :
+  Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int
+val recvfrom :
+  Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list ->
+    int * Unix.sockaddr
+val send :
+  Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int
+val send_substring :
+  Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int
+val sendto :
+  Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list ->
+    Unix.sockaddr -> int
+val sendto_substring :
+  Unix.file_descr -> string -> int -> int -> Unix.msg_flag list ->
+    Unix.sockaddr -> int
+val open_connection : Unix.sockaddr -> in_channel * out_channel
+val establish_server :
+  (in_channel -> out_channel -> unit) -> Unix.sockaddr -> unit
diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
new file mode 100644
index 00000000..9701cbd0
--- /dev/null
+++ b/otherlibs/threads/unix.ml
@@ -0,0 +1,1205 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* An alternate implementation of the Unix module from ../unix
+   which is safe in conjunction with bytecode threads. *)
+
+(* Type definitions that matter for thread operations *)
+
+type file_descr = int
+
+type process_status =
+    WEXITED of int
+  | WSIGNALED of int
+  | WSTOPPED of int
+
+(* We can't call functions from Thread because of type circularities,
+   so we redefine here the functions that we need *)
+
+type resumption_status =
+    Resumed_wakeup
+  | Resumed_delay
+  | Resumed_join
+  | Resumed_io
+  | Resumed_select of file_descr list * file_descr list * file_descr list
+  | Resumed_wait of int * process_status
+
+(* to avoid warning *)
+let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
+         Resumed_io; Resumed_select ([], [], []);
+         Resumed_wait (0, WEXITED 0)]
+
+external thread_initialize : unit -> unit = "thread_initialize"
+external thread_wait_read : file_descr -> unit = "thread_wait_read"
+external thread_wait_write : file_descr -> unit = "thread_wait_write"
+external thread_select :
+  file_descr list * file_descr list * file_descr list * float
+       -> resumption_status
+  = "thread_select"
+external thread_wait_pid : int -> resumption_status = "thread_wait_pid"
+external thread_delay : float -> unit = "thread_delay"
+
+let wait_read fd = thread_wait_read fd
+let wait_write fd = thread_wait_write fd
+let select_aux arg = thread_select arg
+let wait_pid_aux pid = thread_wait_pid pid
+let delay duration = thread_delay duration
+
+(* Make sure that threads are initialized (PR#1516). *)
+
+let _ = thread_initialize()
+
+(* Back to the Unix module *)
+
+type error =
+    E2BIG
+  | EACCES
+  | EAGAIN
+  | EBADF
+  | EBUSY
+  | ECHILD
+  | EDEADLK
+  | EDOM
+  | EEXIST
+  | EFAULT
+  | EFBIG
+  | EINTR
+  | EINVAL
+  | EIO
+  | EISDIR
+  | EMFILE
+  | EMLINK
+  | ENAMETOOLONG
+  | ENFILE
+  | ENODEV
+  | ENOENT
+  | ENOEXEC
+  | ENOLCK
+  | ENOMEM
+  | ENOSPC
+  | ENOSYS
+  | ENOTDIR
+  | ENOTEMPTY
+  | ENOTTY
+  | ENXIO
+  | EPERM
+  | EPIPE
+  | ERANGE
+  | EROFS
+  | ESPIPE
+  | ESRCH
+  | EXDEV
+  | EWOULDBLOCK
+  | EINPROGRESS
+  | EALREADY
+  | ENOTSOCK
+  | EDESTADDRREQ
+  | EMSGSIZE
+  | EPROTOTYPE
+  | ENOPROTOOPT
+  | EPROTONOSUPPORT
+  | ESOCKTNOSUPPORT
+  | EOPNOTSUPP
+  | EPFNOSUPPORT
+  | EAFNOSUPPORT
+  | EADDRINUSE
+  | EADDRNOTAVAIL
+  | ENETDOWN
+  | ENETUNREACH
+  | ENETRESET
+  | ECONNABORTED
+  | ECONNRESET
+  | ENOBUFS
+  | EISCONN
+  | ENOTCONN
+  | ESHUTDOWN
+  | ETOOMANYREFS
+  | ETIMEDOUT
+  | ECONNREFUSED
+  | EHOSTDOWN
+  | EHOSTUNREACH
+  | ELOOP
+  | EOVERFLOW
+  | EUNKNOWNERR of int
+
+exception Unix_error of error * string * string
+
+let _ = Callback.register_exception "Unix.Unix_error"
+                                    (Unix_error(E2BIG, "", ""))
+
+external error_message : error -> string = "unix_error_message"
+
+let handle_unix_error f arg =
+  try
+    f arg
+  with Unix_error(err, fun_name, arg) ->
+    prerr_string Sys.argv.(0);
+    prerr_string ": \"";
+    prerr_string fun_name;
+    prerr_string "\" failed";
+    if String.length arg > 0 then begin
+      prerr_string " on \"";
+      prerr_string arg;
+      prerr_string "\""
+    end;
+    prerr_string ": ";
+    prerr_endline (error_message err);
+    exit 2
+
+external environment : unit -> string array = "unix_environment"
+external getenv: string -> string = "caml_sys_getenv"
+external putenv: string -> string -> unit = "unix_putenv"
+
+type interval_timer =
+    ITIMER_REAL
+  | ITIMER_VIRTUAL
+  | ITIMER_PROF
+
+type interval_timer_status =
+  { it_interval: float;                 (* Period *)
+    it_value: float }                   (* Current value of the timer *)
+
+external getitimer: interval_timer -> interval_timer_status = "unix_getitimer"
+external setitimer:
+  interval_timer -> interval_timer_status -> interval_timer_status
+  = "unix_setitimer"
+
+type wait_flag =
+    WNOHANG
+  | WUNTRACED
+
+let stdin = 0
+let stdout = 1
+let stderr = 2
+
+type open_flag =
+    O_RDONLY
+  | O_WRONLY
+  | O_RDWR
+  | O_NONBLOCK
+  | O_APPEND
+  | O_CREAT
+  | O_TRUNC
+  | O_EXCL
+  | O_NOCTTY
+  | O_DSYNC
+  | O_SYNC
+  | O_RSYNC
+  | O_SHARE_DELETE
+  | O_CLOEXEC
+  | O_KEEPEXEC
+
+type file_perm = int
+
+
+external openfile : string -> open_flag list -> file_perm -> file_descr
+           = "unix_open"
+
+external close : file_descr -> unit = "unix_close"
+external unsafe_read : file_descr -> bytes -> int -> int -> int = "unix_read"
+external unsafe_write : file_descr -> bytes -> int -> int -> int
+    = "unix_write"
+external unsafe_single_write : file_descr -> bytes -> int -> int -> int
+    = "unix_single_write"
+
+let rec read fd buf ofs len =
+  try
+    if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+    then invalid_arg "Unix.read"
+    else unsafe_read fd buf ofs len
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_read fd; read fd buf ofs len
+
+let rec write fd buf ofs len =
+  try
+    if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+    then invalid_arg "Unix.write"
+    else unsafe_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 > Bytes.length buf - len
+    then invalid_arg "Unix.single_write"
+    else unsafe_single_write fd buf ofs len
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_write fd; single_write fd buf ofs len
+
+let write_substring fd buf ofs len =
+  write fd (Bytes.unsafe_of_string buf) ofs len
+
+let single_write_substring fd buf ofs len =
+  single_write fd (Bytes.unsafe_of_string buf) ofs len
+
+external in_channel_of_descr : file_descr -> in_channel
+                             = "caml_ml_open_descriptor_in"
+external out_channel_of_descr : file_descr -> out_channel
+                              = "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
+                              = "caml_channel_descriptor"
+
+type seek_command =
+    SEEK_SET
+  | SEEK_CUR
+  | SEEK_END
+
+external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
+external truncate : string -> int -> unit = "unix_truncate"
+external ftruncate : file_descr -> int -> unit = "unix_ftruncate"
+
+type file_kind =
+    S_REG
+  | S_DIR
+  | S_CHR
+  | S_BLK
+  | S_LNK
+  | S_FIFO
+  | S_SOCK
+
+type stats =
+  { st_dev : int;
+    st_ino : int;
+    st_kind : file_kind;
+    st_perm : file_perm;
+    st_nlink : int;
+    st_uid : int;
+    st_gid : int;
+    st_rdev : int;
+    st_size : int;
+    st_atime : float;
+    st_mtime : float;
+    st_ctime : float }
+
+external stat : string -> stats = "unix_stat"
+external lstat : string -> stats = "unix_lstat"
+external fstat : file_descr -> stats = "unix_fstat"
+external isatty : file_descr -> bool = "unix_isatty"
+external unlink : string -> unit = "unix_unlink"
+external rename : string -> string -> unit = "unix_rename"
+external link : string -> string -> unit = "unix_link"
+
+module LargeFile =
+  struct
+    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 =
+      { st_dev : int;
+        st_ino : int;
+        st_kind : file_kind;
+        st_perm : file_perm;
+        st_nlink : int;
+        st_uid : int;
+        st_gid : int;
+        st_rdev : int;
+        st_size : int64;
+        st_atime : float;
+        st_mtime : float;
+        st_ctime : float;
+      }
+    external stat : string -> stats = "unix_stat_64"
+    external lstat : string -> stats = "unix_lstat_64"
+    external fstat : file_descr -> stats = "unix_fstat_64"
+  end
+
+type access_permission =
+    R_OK
+  | W_OK
+  | X_OK
+  | F_OK
+
+external chmod : string -> file_perm -> unit = "unix_chmod"
+external fchmod : file_descr -> file_perm -> unit = "unix_fchmod"
+external chown : string -> int -> int -> unit = "unix_chown"
+external fchown : file_descr -> int -> int -> unit = "unix_fchown"
+external umask : int -> int = "unix_umask"
+external access : string -> access_permission list -> unit = "unix_access"
+
+external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
+external dup2 :
+   ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2"
+external set_nonblock : file_descr -> unit = "unix_set_nonblock"
+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"
+
+external mkdir : string -> file_perm -> unit = "unix_mkdir"
+external rmdir : string -> unit = "unix_rmdir"
+external chdir : string -> unit = "unix_chdir"
+external getcwd : unit -> string = "unix_getcwd"
+external chroot : string -> unit = "unix_chroot"
+
+type dir_handle
+
+external opendir : string -> dir_handle = "unix_opendir"
+external readdir : dir_handle -> string = "unix_readdir"
+external rewinddir : dir_handle -> unit = "unix_rewinddir"
+external closedir : dir_handle -> unit = "unix_closedir"
+
+external _pipe :
+  ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
+
+let pipe ?cloexec () =
+  let (out_fd, in_fd as fd_pair) = _pipe ?cloexec () in
+  set_nonblock in_fd;
+  set_nonblock out_fd;
+  fd_pair
+
+external symlink : ?to_dir:bool -> string -> string -> unit = "unix_symlink"
+external has_symlink : unit -> bool = "unix_has_symlink"
+external readlink : string -> string = "unix_readlink"
+external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
+
+let select readfds writefds exceptfds delay =
+  match select_aux (readfds, writefds, exceptfds, delay) with
+    Resumed_select(r, w, e) -> (r, w, e)
+  | _ -> ([], [], [])
+
+type lock_command =
+    F_ULOCK
+  | F_LOCK
+  | F_TLOCK
+  | F_TEST
+  | F_RLOCK
+  | F_TRLOCK
+
+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"
+
+(* Disable the timer interrupt before doing exec, because some OS
+   keep sending timer interrupts to the exec'ed code.
+   Also restore blocking mode on stdin, stdout and stderr,
+   since this is what most programs expect! *)
+
+let safe_clear_nonblock fd =
+  try clear_nonblock fd with Unix_error(_,_,_) -> ()
+let safe_set_nonblock fd =
+  try set_nonblock fd with Unix_error(_,_,_) -> ()
+
+let do_exec fn =
+  let oldtimer =
+    setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in
+  safe_clear_nonblock stdin;
+  safe_clear_nonblock stdout;
+  safe_clear_nonblock stderr;
+  try
+    fn ()
+  with Unix_error(_,_,_) as exn ->
+    ignore(setitimer ITIMER_VIRTUAL oldtimer);
+    safe_set_nonblock stdin;
+    safe_set_nonblock stdout;
+    safe_set_nonblock stderr;
+    raise exn
+
+let execv proc args =
+  do_exec (fun () -> _execv proc args)
+
+let execve proc args env =
+  do_exec (fun () -> _execve proc args env)
+
+let execvp proc args =
+  do_exec (fun () -> _execvp proc args)
+
+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"
+
+let wait_pid pid =
+  match wait_pid_aux pid with
+    Resumed_wait(pid, status) -> (pid, status)
+  | _ -> invalid_arg "Thread.wait_pid"
+
+let wait () = wait_pid (-1)
+
+let waitpid flags pid =
+  if List.mem WNOHANG flags
+  then _waitpid flags pid
+  else wait_pid pid
+
+external getpid : unit -> int = "unix_getpid"
+external getppid : unit -> int = "unix_getppid"
+external nice : int -> int = "unix_nice"
+
+external kill : int -> int -> unit = "unix_kill"
+type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
+external sigprocmask: sigprocmask_command -> int list -> int list
+        = "unix_sigprocmask"
+external sigpending: unit -> int list = "unix_sigpending"
+external sigsuspend: int list -> unit = "unix_sigsuspend"
+
+let pause() =
+  let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs
+
+type process_times =
+  { tms_utime : float;
+    tms_stime : float;
+    tms_cutime : float;
+    tms_cstime : float }
+
+type tm =
+  { tm_sec : int;
+    tm_min : int;
+    tm_hour : int;
+    tm_mday : int;
+    tm_mon : int;
+    tm_year : int;
+    tm_wday : int;
+    tm_yday : int;
+    tm_isdst : bool }
+
+external time : unit -> float = "unix_time"
+external gettimeofday : unit -> float = "unix_gettimeofday"
+external gmtime : float -> tm = "unix_gmtime"
+external localtime : float -> tm = "unix_localtime"
+external mktime : tm -> float * tm = "unix_mktime"
+external alarm : int -> int = "unix_alarm"
+
+let sleepf = delay
+let sleep secs = delay (float secs)
+
+external times : unit -> process_times = "unix_times"
+external utimes : string -> float -> float -> unit = "unix_utimes"
+
+external getuid : unit -> int = "unix_getuid"
+external geteuid : unit -> int = "unix_geteuid"
+external setuid : int -> unit = "unix_setuid"
+external getgid : unit -> int = "unix_getgid"
+external getegid : unit -> int = "unix_getegid"
+external setgid : int -> unit = "unix_setgid"
+external getgroups : unit -> int array = "unix_getgroups"
+external setgroups : int array -> unit = "unix_setgroups"
+external initgroups : string -> int -> unit = "unix_initgroups"
+
+type passwd_entry =
+  { pw_name : string;
+    pw_passwd : string;
+    pw_uid : int;
+    pw_gid : int;
+    pw_gecos : string;
+    pw_dir : string;
+    pw_shell : string }
+
+type group_entry =
+  { gr_name : string;
+    gr_passwd : string;
+    gr_gid : int;
+    gr_mem : string array }
+
+
+external getlogin : unit -> string = "unix_getlogin"
+external getpwnam : string -> passwd_entry = "unix_getpwnam"
+external getgrnam : string -> group_entry = "unix_getgrnam"
+external getpwuid : int -> passwd_entry = "unix_getpwuid"
+external getgrgid : int -> group_entry = "unix_getgrgid"
+
+type inet_addr = string
+
+external inet_addr_of_string : string -> inet_addr
+                                    = "unix_inet_addr_of_string"
+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
+  | SOCK_DGRAM
+  | SOCK_RAW
+  | SOCK_SEQPACKET
+
+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
+  | SHUTDOWN_ALL
+
+type msg_flag =
+    MSG_OOB
+  | MSG_DONTROUTE
+  | MSG_PEEK
+
+external _socket : 
+  ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
+  = "unix_socket"
+external _socketpair :
+  ?cloexec: bool -> socket_domain -> socket_type -> int ->
+                                           file_descr * file_descr
+  = "unix_socketpair"
+
+let socket ?cloexec dom typ proto =
+  let s = _socket ?cloexec dom typ proto in
+  set_nonblock s;
+  s
+
+let socketpair ?cloexec dom typ proto =
+  let (s1, s2 as spair) = _socketpair ?cloexec dom typ proto in
+  set_nonblock s1; set_nonblock s2;
+  spair
+
+external _accept :
+  ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
+
+let rec accept ?cloexec req =
+  wait_read req;
+  try
+    let (s, caller as result) = _accept ?cloexec req in
+    set_nonblock s;
+    result
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req
+
+external bind : file_descr -> sockaddr -> unit = "unix_bind"
+external listen : file_descr -> int -> unit = "unix_listen"
+external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown"
+external getsockname : file_descr -> sockaddr = "unix_getsockname"
+external getpeername : file_descr -> sockaddr = "unix_getpeername"
+
+external _connect : file_descr -> sockaddr -> unit = "unix_connect"
+
+let connect s addr =
+  try
+    _connect s addr
+  with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) ->
+    wait_write s;
+    (* Check if it really worked *)
+    ignore(getpeername s)
+
+external unsafe_recv :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int
+                                  = "unix_recv"
+external unsafe_recvfrom :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr
+                                  = "unix_recvfrom"
+external unsafe_send :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int
+                                  = "unix_send"
+external unsafe_sendto :
+  file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int
+                                  = "unix_sendto" "unix_sendto_native"
+
+let rec recv fd buf ofs len flags =
+  try
+    if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+    then invalid_arg "Unix.recv"
+    else unsafe_recv fd buf ofs len flags
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_read fd; recv fd buf ofs len flags
+
+let rec recvfrom fd buf ofs len flags =
+  try
+    if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+    then invalid_arg "Unix.recvfrom"
+    else unsafe_recvfrom fd buf ofs len flags
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_read fd;
+    recvfrom fd buf ofs len flags
+
+let rec send fd buf ofs len flags =
+  try
+    if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+    then invalid_arg "Unix.send"
+    else unsafe_send fd buf ofs len flags
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_write fd;
+    send fd buf ofs len flags
+
+let rec sendto fd buf ofs len flags addr =
+  try
+    if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+    then invalid_arg "Unix.sendto"
+    else unsafe_sendto fd buf ofs len flags addr
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_write fd;
+    sendto fd buf ofs len flags addr
+
+let send_substring fd buf ofs len flags =
+  send fd (Bytes.unsafe_of_string buf) ofs len flags
+
+let sendto_substring fd buf ofs len flags addr =
+  sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr
+
+type socket_bool_option =
+    SO_DEBUG
+  | SO_BROADCAST
+  | SO_REUSEADDR
+  | SO_KEEPALIVE
+  | SO_DONTROUTE
+  | SO_OOBINLINE
+  | SO_ACCEPTCONN
+  | TCP_NODELAY
+  | IPV6_ONLY
+
+
+type socket_int_option =
+    SO_SNDBUF
+  | SO_RCVBUF
+  | SO_ERROR
+  | SO_TYPE
+  | SO_RCVLOWAT
+  | SO_SNDLOWAT
+
+type socket_optint_option = SO_LINGER
+
+type socket_float_option =
+    SO_RCVTIMEO
+  | SO_SNDTIMEO
+
+type socket_error_option = SO_ERROR
+
+module SO: sig
+  type ('opt, 'v) t
+  val bool: (socket_bool_option, bool) t
+  val int: (socket_int_option, int) t
+  val optint: (socket_optint_option, int option) t
+  val float: (socket_float_option, float) t
+  val error: (socket_error_option, error option) t
+  val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
+  val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
+end = struct
+  type ('opt, 'v) t = int
+  let bool = 0
+  let int = 1
+  let optint = 2
+  let float = 3
+  let error = 4
+  external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
+              = "unix_getsockopt"
+  external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
+              = "unix_setsockopt"
+end
+
+let getsockopt fd opt = SO.get SO.bool fd opt
+let setsockopt fd opt v = SO.set SO.bool fd opt v
+
+let getsockopt_int fd opt = SO.get SO.int fd opt
+let setsockopt_int fd opt v = SO.set SO.int fd opt v
+
+let getsockopt_optint fd opt = SO.get SO.optint fd opt
+let setsockopt_optint fd opt v = SO.set SO.optint fd opt v
+
+let getsockopt_float fd opt = SO.get SO.float fd opt
+let setsockopt_float fd opt v = SO.set SO.float fd opt v
+
+let getsockopt_error fd = SO.get SO.error fd SO_ERROR
+
+type host_entry =
+  { h_name : string;
+    h_aliases : string array;
+    h_addrtype : socket_domain;
+    h_addr_list : inet_addr array }
+
+type protocol_entry =
+  { p_name : string;
+    p_aliases : string array;
+    p_proto : int }
+
+type service_entry =
+  { s_name : string;
+    s_aliases : string array;
+    s_port : int;
+    s_proto : string }
+
+external gethostname : unit -> string = "unix_gethostname"
+external gethostbyname : string -> host_entry = "unix_gethostbyname"
+external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr"
+external getprotobyname : string -> protocol_entry
+                                         = "unix_getprotobyname"
+external getprotobynumber : int -> protocol_entry
+                                         = "unix_getprotobynumber"
+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;
+    mutable c_ignpar: bool;
+    mutable c_parmrk: bool;
+    mutable c_inpck: bool;
+    mutable c_istrip: bool;
+    mutable c_inlcr: bool;
+    mutable c_igncr: bool;
+    mutable c_icrnl: bool;
+    mutable c_ixon: bool;
+    mutable c_ixoff: bool;
+    mutable c_opost: bool;
+    mutable c_obaud: int;
+    mutable c_ibaud: int;
+    mutable c_csize: int;
+    mutable c_cstopb: int;
+    mutable c_cread: bool;
+    mutable c_parenb: bool;
+    mutable c_parodd: bool;
+    mutable c_hupcl: bool;
+    mutable c_clocal: bool;
+    mutable c_isig: bool;
+    mutable c_icanon: bool;
+    mutable c_noflsh: bool;
+    mutable c_echo: bool;
+    mutable c_echoe: bool;
+    mutable c_echok: bool;
+    mutable c_echonl: bool;
+    mutable c_vintr: char;
+    mutable c_vquit: char;
+    mutable c_verase: char;
+    mutable c_vkill: char;
+    mutable c_veof: char;
+    mutable c_veol: char;
+    mutable c_vmin: int;
+    mutable c_vtime: int;
+    mutable c_vstart: char;
+    mutable c_vstop: char
+  }
+
+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"
+external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak"
+external tcdrain: file_descr -> unit = "unix_tcdrain"
+
+type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
+
+external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush"
+
+type flow_action = TCOOFF | TCOON | TCIOFF | TCION
+
+external tcflow: file_descr -> flow_action -> unit = "unix_tcflow"
+
+external setsid : unit -> int = "unix_setsid"
+
+(* High-level process management (system, popen) *)
+
+let rec waitpid_non_intr pid =
+  try waitpid [] pid
+  with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
+let system cmd =
+  match fork() with
+     0 -> begin try
+            execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
+          with _ ->
+            exit 127
+          end
+  | id -> snd(waitpid_non_intr id)
+
+(* Make sure [fd] is not one of the standard descriptors 0, 1, 2,
+   by duplicating it if needed. *)
+
+let rec file_descr_not_standard fd =
+  if fd >= 3 then fd else begin
+    let res = file_descr_not_standard (dup fd) in
+    close fd;
+    res
+  end
+
+let perform_redirections new_stdin new_stdout new_stderr =
+  let new_stdin = file_descr_not_standard new_stdin in
+  let new_stdout = file_descr_not_standard new_stdout in
+  let new_stderr = file_descr_not_standard new_stderr in
+  dup2 ~cloexec:false new_stdin stdin; close new_stdin;
+  dup2 ~cloexec:false new_stdout stdout; close new_stdout;
+  dup2 ~cloexec:false new_stderr stderr; close new_stderr
+
+let create_process cmd args new_stdin new_stdout new_stderr =
+  match fork() with
+    0 ->
+      begin try
+        perform_redirections new_stdin new_stdout new_stderr;
+        execvp cmd args
+      with _ ->
+        exit 127
+      end
+  | id -> id
+
+let create_process_env cmd args env new_stdin new_stdout new_stderr =
+  match fork() with
+    0 ->
+      begin try
+        perform_redirections new_stdin new_stdout new_stderr;
+        execvpe cmd args env
+      with _ ->
+        exit 127
+      end
+  | id -> id
+
+type popen_process =
+    Process of in_channel * out_channel
+  | Process_in of in_channel
+  | Process_out of out_channel
+  | Process_full of in_channel * out_channel * in_channel
+
+let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
+
+let open_proc cmd envopt proc input output error =
+  match fork() with
+     0 -> begin try
+            perform_redirections input output error;
+            let shell = "/bin/sh" in
+            let argv = [| shell; "-c"; cmd |] in
+            match envopt with
+            | Some env -> execve shell argv env
+            | None     -> execv shell argv
+          with _ ->
+            exit 127
+          end
+  | id -> Hashtbl.add popen_processes proc id
+
+let open_process_in cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let inchan = in_channel_of_descr in_read in
+  try
+    open_proc cmd None (Process_in inchan) stdin in_write stderr;
+    close in_write;
+    inchan
+  with e ->
+    close_in inchan;
+    close in_write;
+    raise e
+
+let open_process_out cmd =
+  let (out_read, out_write) = pipe ~cloexec:true () in
+  let outchan = out_channel_of_descr out_write in
+  try
+    open_proc cmd None (Process_out outchan) out_read stdout stderr;
+    close out_read;
+    outchan
+  with e ->
+    close_out outchan;
+    close out_read;
+    raise e
+
+let open_process cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let inchan = in_channel_of_descr in_read in
+  try
+    let (out_read, out_write) = pipe ~cloexec:true () in
+    let outchan = out_channel_of_descr out_write in
+    try
+      open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr;
+      close out_read;
+      close in_write;
+      (inchan, outchan)
+    with e ->
+      close_out outchan;
+      close out_read;
+      raise e
+  with e ->
+    close_in inchan;
+    close in_write;
+    raise e    
+
+let open_process_full cmd env =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let inchan = in_channel_of_descr in_read in
+  try
+    let (out_read, out_write) = pipe ~cloexec:true () in
+    let outchan = out_channel_of_descr out_write in
+    try
+      let (err_read, err_write) = pipe ~cloexec:true () in
+      let errchan = in_channel_of_descr err_read in
+      try
+        open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
+                  out_read in_write err_write;
+        close out_read;
+        close in_write;
+        close err_write;
+        (inchan, outchan, errchan)
+      with e ->
+        close_in errchan;
+        close err_write;
+        raise e
+    with e ->
+      close_out outchan;
+      close out_read;
+      raise e
+  with e ->
+    close_in inchan;
+    close in_write;
+    raise e    
+
+let find_proc_id fun_name proc =
+  try
+    let pid = Hashtbl.find popen_processes proc in
+    Hashtbl.remove popen_processes proc;
+    pid
+  with Not_found ->
+    raise(Unix_error(EBADF, fun_name, ""))
+
+let close_process_in inchan =
+  let pid = find_proc_id "close_process_in" (Process_in inchan) in
+  close_in inchan;
+  snd(waitpid_non_intr pid)
+
+let close_process_out outchan =
+  let pid = find_proc_id "close_process_out" (Process_out outchan) in
+  (* The application may have closed [outchan] already to signal
+     end-of-input to the process.  *)
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr pid)
+
+let close_process (inchan, outchan) =
+  let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr pid)
+
+let close_process_full (inchan, outchan, errchan) =
+  let pid =
+    find_proc_id "close_process_full"
+                 (Process_full(inchan, outchan, errchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  close_in errchan;
+  snd(waitpid_non_intr pid)
+
+let find_proc_id fun_name proc =
+  try
+    let pid = Hashtbl.find popen_processes proc in
+    Hashtbl.remove popen_processes proc;
+    pid
+  with Not_found ->
+    raise(Unix_error(EBADF, fun_name, ""))
+
+let rec waitpid_non_intr pid =
+  try waitpid [] pid
+  with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
+let close_process_in inchan =
+  let pid = find_proc_id "close_process_in" (Process_in inchan) in
+  close_in inchan;
+  snd(waitpid_non_intr pid)
+
+let close_process_out outchan =
+  let pid = find_proc_id "close_process_out" (Process_out outchan) in
+  close_out outchan;
+  snd(waitpid_non_intr pid)
+
+let close_process (inchan, outchan) =
+  let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr pid)
+
+let close_process_full (inchan, outchan, errchan) =
+  let pid =
+    find_proc_id "close_process_full"
+                 (Process_full(inchan, outchan, errchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  close_in errchan;
+  snd(waitpid_non_intr pid)
+
+(* High-level network functions *)
+
+let open_connection sockaddr =
+  let sock =
+    socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+  try
+    connect sock sockaddr;
+    (in_channel_of_descr sock, out_channel_of_descr sock)
+  with exn ->
+    close sock; raise exn
+
+let shutdown_connection inchan =
+  shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
+
+let rec accept_non_intr s =
+  try accept ~cloexec:true s
+  with Unix_error (EINTR, _, _) -> accept_non_intr s
+
+let establish_server server_fun sockaddr =
+  let sock =
+    socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+  setsockopt sock SO_REUSEADDR true;
+  bind sock sockaddr;
+  listen sock 5;
+  while true do
+    let (s, caller) = accept_non_intr sock in
+    (* The "double fork" trick, the process which calls server_fun will not
+       leave a zombie process *)
+    match fork() with
+       0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *)
+            close sock;
+            let inchan = in_channel_of_descr s in
+            let outchan = out_channel_of_descr s in
+            server_fun inchan outchan;
+            (* Do not close inchan nor outchan, as the server_fun could
+               have done it already, and we are about to exit anyway
+               (PR#3794) *)
+            exit 0
+    | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *)
+  done
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
new file mode 100644
index 00000000..2d9d23d3
--- /dev/null
+++ b/otherlibs/unix/.depend
@@ -0,0 +1,527 @@
+accept.o: accept.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
+access.o: access.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/signals.h unixsupport.h
+addrofstr.o: addrofstr.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
+  socketaddr.h
+alarm.o: alarm.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+bind.o: bind.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h socketaddr.h
+chdir.o: chdir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+chmod.o: chmod.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+chown.o: chown.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+chroot.o: chroot.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+close.o: close.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/signals.h unixsupport.h
+closedir.o: closedir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+connect.o: connect.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+cst2constr.o: cst2constr.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/fail.h cst2constr.h
+cstringv.o: cstringv.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h unixsupport.h
+dup.o: dup.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+dup2.o: dup2.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+envir.o: envir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h
+errmsg.o: errmsg.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h
+execv.o: execv.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h unixsupport.h
+execve.o: execve.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h unixsupport.h
+execvp.o: execvp.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/osdeps.h unixsupport.h
+exit.o: exit.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+fchmod.o: fchmod.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/signals.h unixsupport.h
+fchown.o: fchown.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/signals.h unixsupport.h
+fcntl.o: fcntl.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h
+fork.o: fork.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/debugger.h unixsupport.h
+ftruncate.o: ftruncate.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/io.h ../../byterun/caml/signals.h unixsupport.h
+getaddrinfo.o: getaddrinfo.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  cst2constr.h socketaddr.h
+getcwd.o: getcwd.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+getegid.o: getegid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+geteuid.o: geteuid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+getgid.o: getgid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+getgr.o: getgr.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/memory.h unixsupport.h
+getgroups.o: getgroups.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+gethost.o: gethost.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
+gethostname.o: gethostname.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+getlogin.o: getlogin.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h unixsupport.h
+getnameinfo.o: getnameinfo.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
+getpeername.o: getpeername.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h socketaddr.h
+getpid.o: getpid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+getppid.o: getppid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+getproto.o: getproto.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h unixsupport.h
+getpw.o: getpw.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/fail.h unixsupport.h
+getserv.o: getserv.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h unixsupport.h
+getsockname.o: getsockname.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h socketaddr.h
+gettimeofday.o: gettimeofday.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+getuid.o: getuid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+gmtime.o: gmtime.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h unixsupport.h
+initgroups.o: initgroups.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+isatty.o: isatty.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+itimer.o: itimer.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h unixsupport.h
+kill.o: kill.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/fail.h unixsupport.h ../../byterun/caml/signals.h
+link.o: link.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+listen.o: listen.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h
+lockf.o: lockf.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/signals.h unixsupport.h
+lseek.o: lseek.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/io.h \
+  ../../byterun/caml/signals.h unixsupport.h
+mkdir.o: mkdir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+mkfifo.o: mkfifo.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+nice.o: nice.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+open.o: open.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/signals.h unixsupport.h
+opendir.o: opendir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/signals.h unixsupport.h
+pipe.o: pipe.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h unixsupport.h
+putenv.o: putenv.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/memory.h unixsupport.h
+read.o: read.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+readdir.o: readdir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/signals.h unixsupport.h
+readlink.o: readlink.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/signals.h unixsupport.h
+rename.o: rename.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+rewinddir.o: rewinddir.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h
+rmdir.o: rmdir.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+select.o: select.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+sendrecv.o: sendrecv.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
+setgid.o: setgid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+setgroups.o: setgroups.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h unixsupport.h
+setsid.o: setsid.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h
+setuid.o: setuid.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+shutdown.o: shutdown.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h
+signals.o: signals.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
+  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
+  ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \
+  unixsupport.h
+sleep.o: sleep.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/signals.h unixsupport.h
+socket.o: socket.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  unixsupport.h
+socketaddr.o: socketaddr.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h \
+  socketaddr.h
+socketpair.o: socketpair.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+sockopt.o: sockopt.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/fail.h unixsupport.h socketaddr.h
+stat.o: stat.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
+  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
+  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/signals.h \
+  ../../byterun/caml/io.h unixsupport.h cst2constr.h nanosecond_stat.h
+strofaddr.o: strofaddr.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h \
+  socketaddr.h
+symlink.o: symlink.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+termios.o: termios.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h
+time.o: time.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h unixsupport.h
+times.o: times.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h
+truncate.o: truncate.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
+  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
+  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/signals.h \
+  ../../byterun/caml/io.h unixsupport.h
+umask.o: umask.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  unixsupport.h
+unixsupport.o: unixsupport.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
+  cst2constr.h
+unlink.o: unlink.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+utimes.o: utimes.c ../../byterun/caml/fail.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+wait.o: wait.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
+  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
+  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
+  ../../byterun/caml/signals.h unixsupport.h
+write.o: write.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
+  ../../byterun/caml/../../config/m.h \
+  ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+unix.cmo : unix.cmi
+unix.cmx : unix.cmi
+unix.cmi :
+unixLabels.cmo : unix.cmi unixLabels.cmi
+unixLabels.cmx : unix.cmx unixLabels.cmi
+unixLabels.cmi : unix.cmi
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
new file mode 100644
index 00000000..39ef5917
--- /dev/null
+++ b/otherlibs/unix/Makefile
@@ -0,0 +1,52 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the Unix interface library
+
+LIBNAME=unix
+
+EXTRACAMLFLAGS=-nolabels
+
+# dllunix.so particularly requires libm for modf symbols
+LDOPTS=$(NATIVECCLIBS)
+
+COBJS=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 \
+  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 \
+  initgroups.o isatty.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 \
+  readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \
+  setgid.o setgroups.o setsid.o setuid.o shutdown.o signals.o \
+  sleep.o socket.o socketaddr.o \
+  socketpair.o sockopt.o stat.o strofaddr.o symlink.o termios.o \
+  time.o times.o truncate.o umask.o unixsupport.o unlink.o \
+  utimes.o wait.o write.o
+
+CAMLOBJS=unix.cmo unixLabels.cmo
+
+HEADERS=unixsupport.h socketaddr.h
+
+include ../Makefile
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c
new file mode 100644
index 00000000..d02cc09a
--- /dev/null
+++ b/otherlibs/unix/accept.c
@@ -0,0 +1,64 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define _GNU_SOURCE
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_accept(value cloexec, value sock)
+{
+  int retcode;
+  value res;
+  value a;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+  int clo = unix_cloexec_p(cloexec);
+
+  addr_len = sizeof(addr);
+  caml_enter_blocking_section();
+#if defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC)
+  retcode = accept4(Int_val(sock), &addr.s_gen, &addr_len,
+                    clo ? SOCK_CLOEXEC : 0);
+#else
+  retcode = accept(Int_val(sock), &addr.s_gen, &addr_len);
+#endif
+  caml_leave_blocking_section();
+  if (retcode == -1) uerror("accept", Nothing);
+#if !(defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC))
+  if (clo) unix_set_cloexec(retcode, "accept", Nothing);
+#endif
+  a = alloc_sockaddr(&addr, addr_len, retcode);
+  Begin_root (a);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = Val_int(retcode);
+    Field(res, 1) = a;
+  End_roots();
+  return res;
+}
+
+#else
+
+CAMLprim value unix_accept(value cloexec, value sock)
+{ caml_invalid_argument("accept not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
new file mode 100644
index 00000000..0df09ed2
--- /dev/null
+++ b/otherlibs/unix/access.c
@@ -0,0 +1,65 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_UNISTD
+# include <unistd.h>
+#else
+# ifndef _WIN32
+#  include <sys/file.h>
+# endif
+# ifndef R_OK
+#   define R_OK    4/* test for read permission */
+#   define W_OK    2/* test for write permission */
+#   define X_OK    1/* test for execute (search) permission */
+#   define F_OK    0/* test for presence of file */
+# endif
+#endif
+
+static int access_permission_table[] = {
+  R_OK,
+  W_OK, 
+#ifdef _WIN32
+  /* Since there is no concept of execute permission on Windows,
+     we fall b+ack to the read permission */
+  R_OK,
+#else
+  X_OK,
+#endif
+  F_OK
+};
+
+CAMLprim value unix_access(value path, value perms)
+{
+  CAMLparam2(path, perms);
+  char * p;
+  int ret, cv_flags;
+
+  caml_unix_check_path(path, "access");
+  cv_flags = caml_convert_flag_list(perms, access_permission_table);
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = access(p, cv_flags);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("access", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c
new file mode 100644
index 00000000..2325cb9e
--- /dev/null
+++ b/otherlibs/unix/addrofstr.c
@@ -0,0 +1,97 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_inet_addr_of_string(value s)
+{
+  if (! caml_string_is_c_safe(s)) caml_failwith("inet_addr_of_string");
+#if defined(HAS_IPV6)
+#ifdef _WIN32
+ {
+  CAMLparam1(s);
+  CAMLlocal1(vres);
+  struct addrinfo hints;
+  struct addrinfo * res;
+  int retcode;
+  memset(&hints, 0, sizeof(hints));
+  hints.ai_family = AF_UNSPEC;
+  hints.ai_flags = AI_NUMERICHOST;
+  retcode = getaddrinfo(String_val(s), NULL, &hints, &res);
+  if (retcode != 0) caml_failwith("inet_addr_of_string");
+  switch (res->ai_addr->sa_family) {
+  case AF_INET:
+    {
+      vres =
+        alloc_inet_addr(&((struct sockaddr_in *) res->ai_addr)->sin_addr);
+      break;
+    }
+  case AF_INET6:
+    {
+      vres =
+        alloc_inet6_addr(&((struct sockaddr_in6 *) res->ai_addr)->sin6_addr);
+      break;
+    }
+  default:
+    {
+      freeaddrinfo(res);
+      caml_failwith("inet_addr_of_string");
+    }
+  }
+  freeaddrinfo(res);
+  CAMLreturn (vres);
+ }
+#else
+ {
+  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
+    caml_failwith("inet_addr_of_string");
+ }
+#endif
+#elif defined(HAS_INET_ATON)
+ {
+  struct in_addr address;
+  if (inet_aton(String_val(s), &address) == 0)
+    caml_failwith("inet_addr_of_string");
+  return alloc_inet_addr(&address);
+ }
+#else
+ {
+  struct in_addr address;
+  address.s_addr = inet_addr(String_val(s));
+  if (address.s_addr == (uint32_t) -1) caml_failwith("inet_addr_of_string");
+  return alloc_inet_addr(&address);
+ }
+#endif
+}
+
+#else
+
+CAMLprim value unix_inet_addr_of_string(value s)
+{ caml_invalid_argument("inet_addr_of_string not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c
new file mode 100644
index 00000000..05542524
--- /dev/null
+++ b/otherlibs/unix/alarm.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_alarm(value t)
+{
+  return Val_int(alarm((unsigned int) Long_val(t)));
+}
diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c
new file mode 100644
index 00000000..73b24b06
--- /dev/null
+++ b/otherlibs/unix/bind.c
@@ -0,0 +1,41 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_bind(value socket, value address)
+{
+  int ret;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  get_sockaddr(address, &addr, &addr_len);
+  ret = bind(Int_val(socket), &addr.s_gen, addr_len);
+  if (ret == -1) uerror("bind", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_bind(value socket, value address)
+{ caml_invalid_argument("bind not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c
new file mode 100644
index 00000000..244ad5d3
--- /dev/null
+++ b/otherlibs/unix/chdir.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_chdir(value path)
+{
+  CAMLparam1(path);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "chdir");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = chdir(p);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("chdir", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c
new file mode 100644
index 00000000..cfdc1a33
--- /dev/null
+++ b/otherlibs/unix/chmod.c
@@ -0,0 +1,36 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_chmod(value path, value perm)
+{
+  CAMLparam2(path, perm);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "chmod");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = chmod(p, Int_val(perm));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("chmod", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c
new file mode 100644
index 00000000..f018e9e0
--- /dev/null
+++ b/otherlibs/unix/chown.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_chown(value path, value uid, value gid)
+{
+  CAMLparam1(path);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "chown");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = chown(p, Int_val(uid), Int_val(gid));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("chown", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c
new file mode 100644
index 00000000..7b87de72
--- /dev/null
+++ b/otherlibs/unix/chroot.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_chroot(value path)
+{
+  CAMLparam1(path);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "chroot");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = chroot(p);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("chroot", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c
new file mode 100644
index 00000000..961b8cbf
--- /dev/null
+++ b/otherlibs/unix/close.c
@@ -0,0 +1,28 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_close(value fd)
+{
+  int ret;
+  caml_enter_blocking_section();
+  ret = close(Int_val(fd));
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("close", Nothing);
+  return Val_unit;
+}
diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c
new file mode 100644
index 00000000..97bebb49
--- /dev/null
+++ b/otherlibs/unix/closedir.c
@@ -0,0 +1,38 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <errno.h>
+#include <sys/types.h>
+#ifdef HAS_DIRENT
+#include <dirent.h>
+#else
+#include <sys/dir.h>
+#endif
+
+CAMLprim value unix_closedir(value vd)
+{
+  CAMLparam1(vd);
+  DIR * d = DIR_Val(vd);
+  if (d == (DIR *) NULL) unix_error(EBADF, "closedir", Nothing);
+  caml_enter_blocking_section();
+  closedir(d);
+  caml_leave_blocking_section();
+  DIR_Val(vd) = (DIR *) NULL;
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c
new file mode 100644
index 00000000..8569ab41
--- /dev/null
+++ b/otherlibs/unix/connect.c
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_connect(value socket, value address)
+{
+  int retcode;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  get_sockaddr(address, &addr, &addr_len);
+  caml_enter_blocking_section();
+  retcode = connect(Int_val(socket), &addr.s_gen, addr_len);
+  caml_leave_blocking_section();
+  if (retcode == -1) uerror("connect", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_connect(value socket, value address)
+{ caml_invalid_argument("connect not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c
new file mode 100644
index 00000000..aab492b9
--- /dev/null
+++ b/otherlibs/unix/cst2constr.c
@@ -0,0 +1,26 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include "cst2constr.h"
+
+value cst_to_constr(int n, int *tbl, int size, int deflt)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    if (n == tbl[i]) return Val_int(i);
+  return Val_int(deflt);
+}
diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h
new file mode 100644
index 00000000..44c9299e
--- /dev/null
+++ b/otherlibs/unix/cst2constr.h
@@ -0,0 +1,16 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+extern value cst_to_constr(int n, int * tbl, int size, int deflt);
diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c
new file mode 100644
index 00000000..68441cfa
--- /dev/null
+++ b/otherlibs/unix/cstringv.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+
+char ** cstringvect(value arg, char * cmdname)
+{
+  char ** res;
+  mlsize_t size, i;
+
+  size = Wosize_val(arg);
+  for (i = 0; i < size; i++)
+    if (! caml_string_is_c_safe(Field(arg, i)))
+      unix_error(EINVAL, cmdname, Field(arg, i));
+  res = (char **) caml_stat_alloc((size + 1) * sizeof(char *));
+  for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i));
+  res[size] = NULL;
+  return res;
+}
diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c
new file mode 100644
index 00000000..c9294e6e
--- /dev/null
+++ b/otherlibs/unix/dup.c
@@ -0,0 +1,36 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define _GNU_SOURCE
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include <fcntl.h>
+
+CAMLprim value unix_dup(value cloexec, value fd)
+{
+  int ret;
+#ifdef F_DUPFD_CLOEXEC
+  ret = fcntl(Int_val(fd),
+              (unix_cloexec_p(cloexec) ? F_DUPFD_CLOEXEC : F_DUPFD),
+              0);
+#else
+  ret = dup(Int_val(fd));
+#endif
+  if (ret == -1) uerror("dup", Nothing);
+#ifndef F_DUPFD_CLOEXEC
+  if (unix_cloexec_p(cloexec)) unix_set_cloexec(ret, "dup", Nothing);
+#endif
+  return Val_int(ret);
+}
diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c
new file mode 100644
index 00000000..78539765
--- /dev/null
+++ b/otherlibs/unix/dup2.c
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define _GNU_SOURCE
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include <fcntl.h>
+
+CAMLprim value unix_dup2(value cloexec, value fd1, value fd2)
+{
+  if (Int_val(fd2) == Int_val(fd1)) {
+    /* In this case, dup3 fails and dup2 does nothing. */
+    /* Just apply the cloexec flag to fd2, if it is given. */
+    if (Is_block(cloexec)) {
+      if (Bool_val(Field(cloexec, 0)))
+        unix_set_cloexec(Int_val(fd2), "dup2", Nothing);
+      else
+        unix_clear_cloexec(Int_val(fd2), "dup2", Nothing);
+    }
+  } else {
+#ifdef HAS_DUP3
+    if (dup3(Int_val(fd1), Int_val(fd2),
+             unix_cloexec_p(cloexec) ? O_CLOEXEC : 0) == -1)
+      uerror("dup2", Nothing);
+#else
+    if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
+    if (unix_cloexec_p(cloexec))
+      unix_set_cloexec(Int_val(fd2), "dup2", Nothing);
+#endif
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c
new file mode 100644
index 00000000..3c6b54dc
--- /dev/null
+++ b/otherlibs/unix/envir.c
@@ -0,0 +1,30 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+
+#ifndef _WIN32
+extern char ** environ;
+#endif
+
+CAMLprim value unix_environment(value unit)
+{
+  if (environ != NULL) {
+    return caml_copy_string_array((const char**)environ);
+  } else {
+    return Atom(0);
+  }
+}
diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c
new file mode 100644
index 00000000..fef473ea
--- /dev/null
+++ b/otherlibs/unix/errmsg.c
@@ -0,0 +1,28 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+
+extern int error_table[];
+
+CAMLprim value unix_error_message(value err)
+{
+  int errnum;
+  errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
+  return caml_copy_string(strerror(errnum));
+}
diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c
new file mode 100644
index 00000000..58f2e45e
--- /dev/null
+++ b/otherlibs/unix/execv.c
@@ -0,0 +1,30 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_execv(value path, value args)
+{
+  char ** argv;
+  caml_unix_check_path(path, "execv");
+  argv = cstringvect(args, "execv");
+  (void) execv(String_val(path), argv);
+  caml_stat_free((char *) argv);
+  uerror("execv", path);
+  return Val_unit;                  /* never reached, but suppress warnings */
+                                /* from smart compilers */
+}
diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c
new file mode 100644
index 00000000..dfdef299
--- /dev/null
+++ b/otherlibs/unix/execve.c
@@ -0,0 +1,33 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_execve(value path, value args, value env)
+{
+  char ** argv;
+  char ** envp;
+  caml_unix_check_path(path, "execve");
+  argv = cstringvect(args, "execve");
+  envp = cstringvect(env, "execve");
+  (void) execve(String_val(path), argv, envp);
+  caml_stat_free((char *) argv);
+  caml_stat_free((char *) envp);
+  uerror("execve", path);
+  return Val_unit;                  /* never reached, but suppress warnings */
+                                /* from smart compilers */
+}
diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c
new file mode 100644
index 00000000..d521adcf
--- /dev/null
+++ b/otherlibs/unix/execvp.c
@@ -0,0 +1,54 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#define CAML_INTERNALS
+#include <caml/osdeps.h>
+#include "unixsupport.h"
+
+#ifndef _WIN32
+extern char ** environ;
+#endif
+
+CAMLprim value unix_execvp(value path, value args)
+{
+  char ** argv;
+  caml_unix_check_path(path, "execvp");
+  argv = cstringvect(args, "execvp");
+  (void) execvp(String_val(path), argv);
+  caml_stat_free((char *) argv);
+  uerror("execvp", path);
+  return Val_unit;                  /* never reached, but suppress warnings */
+                                    /* from smart compilers */
+}
+
+CAMLprim value unix_execvpe(value path, value args, value env)
+{
+  char * exefile;
+  char ** argv;
+  char ** envp;
+  caml_unix_check_path(path, "execvpe");
+  exefile = caml_search_exe_in_path(String_val(path));
+  argv = cstringvect(args, "execvpe");
+  envp = cstringvect(env, "execvpe");
+  (void) execve(exefile, argv, envp);
+  caml_stat_free(exefile);
+  caml_stat_free((char *) argv);
+  caml_stat_free((char *) envp);
+  uerror("execvpe", path);
+  return Val_unit;                  /* never reached, but suppress warnings */
+                                    /* from smart compilers */
+}
diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c
new file mode 100644
index 00000000..8da00dac
--- /dev/null
+++ b/otherlibs/unix/exit.c
@@ -0,0 +1,24 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_exit(value n)
+{
+  _exit(Int_val(n));
+  return Val_unit;                  /* never reached, but suppress warnings */
+                                    /* from smart compilers */
+}
diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c
new file mode 100644
index 00000000..49c7e8b0
--- /dev/null
+++ b/otherlibs/unix/fchmod.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_FCHMOD
+
+CAMLprim value unix_fchmod(value fd, value perm)
+{
+  int result;
+  caml_enter_blocking_section();
+  result = fchmod(Int_val(fd), Int_val(perm));
+  caml_leave_blocking_section();
+  if (result == -1) uerror("fchmod", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_fchmod(value fd, value perm)
+{ caml_invalid_argument("fchmod not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c
new file mode 100644
index 00000000..8e441967
--- /dev/null
+++ b/otherlibs/unix/fchown.c
@@ -0,0 +1,38 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_FCHMOD
+
+CAMLprim value unix_fchown(value fd, value uid, value gid)
+{
+  int result;
+  caml_enter_blocking_section();
+  result = fchown(Int_val(fd), Int_val(uid), Int_val(gid));
+  caml_leave_blocking_section();
+  if (result == -1) uerror("fchown", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_fchown(value fd, value uid, value gid)
+{ caml_invalid_argument("fchown not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c
new file mode 100644
index 00000000..e10a98e3
--- /dev/null
+++ b/otherlibs/unix/fcntl.c
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
+
+#ifndef O_NONBLOCK
+#define O_NONBLOCK O_NDELAY
+#endif
+
+CAMLprim value unix_set_nonblock(value fd)
+{
+  int retcode;
+  retcode = fcntl(Int_val(fd), F_GETFL, 0);
+  if (retcode == -1 ||
+      fcntl(Int_val(fd), F_SETFL, retcode | O_NONBLOCK) == -1)
+    uerror("set_nonblock", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value unix_clear_nonblock(value fd)
+{
+  int retcode;
+  retcode = fcntl(Int_val(fd), F_GETFL, 0);
+  if (retcode == -1 ||
+      fcntl(Int_val(fd), F_SETFL, retcode & ~O_NONBLOCK) == -1)
+    uerror("clear_nonblock", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value unix_set_close_on_exec(value fd)
+{
+  unix_set_cloexec(Int_val(fd), "set_close_on_exec", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value unix_clear_close_on_exec(value fd)
+{
+  unix_clear_cloexec(Int_val(fd), "set_close_on_exec", Nothing);
+  return Val_unit;
+}
diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
new file mode 100644
index 00000000..c8fef37c
--- /dev/null
+++ b/otherlibs/unix/fork.c
@@ -0,0 +1,32 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/debugger.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_fork(value unit)
+{
+  int ret;
+  ret = fork();
+  if (ret == -1) uerror("fork", Nothing);
+  if (caml_debugger_in_use)
+    if ((caml_debugger_fork_mode && ret == 0) ||
+        (!caml_debugger_fork_mode && ret != 0))
+      caml_debugger_cleanup_fork();
+  return Val_int(ret);
+}
diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
new file mode 100644
index 00000000..335ffe08
--- /dev/null
+++ b/otherlibs/unix/ftruncate.c
@@ -0,0 +1,59 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <sys/types.h>
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/io.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+#ifdef HAS_TRUNCATE
+
+CAMLprim value unix_ftruncate(value fd, value len)
+{
+  int result;
+  caml_enter_blocking_section();
+  result = ftruncate(Int_val(fd), Long_val(len));
+  caml_leave_blocking_section();
+  if (result == -1) uerror("ftruncate", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value unix_ftruncate_64(value fd, value len)
+{
+  int result;
+  file_offset ofs = File_offset_val(len);
+  caml_enter_blocking_section();
+  result = ftruncate(Int_val(fd), ofs);
+  caml_leave_blocking_section();
+  if (result == -1) uerror("ftruncate", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_ftruncate(value fd, value len)
+{ caml_invalid_argument("ftruncate not implemented"); }
+
+CAMLprim value unix_ftruncate_64(value fd, value len)
+{ caml_invalid_argument("ftruncate not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c
new file mode 100644
index 00000000..90c27dae
--- /dev/null
+++ b/otherlibs/unix/getaddrinfo.c
@@ -0,0 +1,135 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+#include <caml/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;
+  socklen_param_type len;
+
+  len = a->ai_addrlen;
+  if (len > sizeof(sa)) len = sizeof(sa);
+  memcpy(&sa.s_gen, a->ai_addr, len);
+  vaddr = alloc_sockaddr(&sa, len, -1);
+  vcanonname = caml_copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname);
+  vres = caml_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);
+  char * node, * serv;
+  struct addrinfo hints;
+  struct addrinfo * res, * r;
+  int retcode;
+
+  if (! (caml_string_is_c_safe(vnode) && caml_string_is_c_safe(vserv)))
+    return Val_int(0);
+
+  /* Extract "node" parameter */
+  if (caml_string_length(vnode) == 0) {
+    node = NULL;
+  } else {
+    node = caml_strdup(String_val(vnode));
+  }
+  /* Extract "service" parameter */
+  if (caml_string_length(vserv) == 0) {
+    serv = NULL;
+  } else {
+    serv = caml_strdup(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 */
+  caml_enter_blocking_section();
+  retcode = getaddrinfo(node, serv, &hints, &res);
+  caml_leave_blocking_section();
+  if (node != NULL) caml_stat_free(node);
+  if (serv != NULL) caml_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 = caml_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)
+{ caml_invalid_argument("getaddrinfo not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c
new file mode 100644
index 00000000..74c8a07f
--- /dev/null
+++ b/otherlibs/unix/getcwd.c
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#if !defined (_WIN32) && !macintosh
+#include <sys/param.h>
+#endif
+
+#ifndef PATH_MAX
+#ifdef MAXPATHLEN
+#define PATH_MAX MAXPATHLEN
+#else
+#define PATH_MAX 512
+#endif
+#endif
+
+#ifdef HAS_GETCWD
+
+CAMLprim value unix_getcwd(value unit)
+{
+  char buff[PATH_MAX];
+  if (getcwd(buff, sizeof(buff)) == 0) uerror("getcwd", Nothing);
+  return caml_copy_string(buff);
+}
+
+#else
+#ifdef HAS_GETWD
+
+CAMLprim value unix_getcwd(value unit)
+{
+  char buff[PATH_MAX];
+  if (getwd(buff) == 0) uerror("getcwd", copy_string(buff));
+  return copy_string(buff);
+}
+
+#else
+
+CAMLprim value unix_getcwd(value unit)
+{ caml_invalid_argument("getcwd not implemented"); }
+
+#endif
+#endif
diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c
new file mode 100644
index 00000000..ddda2f63
--- /dev/null
+++ b/otherlibs/unix/getegid.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_getegid(value unit)
+{
+  return Val_int(getegid());
+}
diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c
new file mode 100644
index 00000000..3243ba76
--- /dev/null
+++ b/otherlibs/unix/geteuid.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_geteuid(value unit)
+{
+  return Val_int(geteuid());
+}
diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c
new file mode 100644
index 00000000..f18b4c09
--- /dev/null
+++ b/otherlibs/unix/getgid.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_getgid(value unit)
+{
+  return Val_int(getgid());
+}
diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c
new file mode 100644
index 00000000..5aa8762b
--- /dev/null
+++ b/otherlibs/unix/getgr.c
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+#include <stdio.h>
+#include <grp.h>
+
+static value alloc_group_entry(struct group *entry)
+{
+  value res;
+  value name = Val_unit, pass = Val_unit, mem = Val_unit;
+
+  Begin_roots3 (name, pass, mem);
+    name = caml_copy_string(entry->gr_name);
+    /* on some platforms, namely Android, gr_passwd can be NULL - hence this workaround */
+    pass = caml_copy_string(entry->gr_passwd ? entry->gr_passwd : "");
+    mem = caml_copy_string_array((const char**)entry->gr_mem);
+    res = caml_alloc_small(4, 0);
+    Field(res,0) = name;
+    Field(res,1) = pass;
+    Field(res,2) = Val_int(entry->gr_gid);
+    Field(res,3) = mem;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_getgrnam(value name)
+{
+  struct group * entry;
+  if (! caml_string_is_c_safe(name)) caml_raise_not_found();
+  entry = getgrnam(String_val(name));
+  if (entry == NULL) caml_raise_not_found();
+  return alloc_group_entry(entry);
+}
+
+CAMLprim value unix_getgrgid(value gid)
+{
+  struct group * entry;
+  entry = getgrgid(Int_val(gid));
+  if (entry == NULL) caml_raise_not_found();
+  return alloc_group_entry(entry);
+}
diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c
new file mode 100644
index 00000000..4bccd69d
--- /dev/null
+++ b/otherlibs/unix/getgroups.c
@@ -0,0 +1,49 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+#ifdef HAS_GETGROUPS
+
+#include <sys/types.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <limits.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_getgroups(value unit)
+{
+  gid_t gidset[NGROUPS_MAX];
+  int n;
+  value res;
+  int i;
+
+  n = getgroups(NGROUPS_MAX, gidset);
+  if (n == -1) uerror("getgroups", Nothing);
+  res = caml_alloc_tuple(n);
+  for (i = 0; i < n; i++)
+    Field(res, i) = Val_int(gidset[i]);
+  return res;
+}
+
+#else
+
+CAMLprim value unix_getgroups(value unit)
+{ caml_invalid_argument("getgroups not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
new file mode 100644
index 00000000..1c1f5efa
--- /dev/null
+++ b/otherlibs/unix/gethost.c
@@ -0,0 +1,184 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+#ifndef _WIN32
+#include <sys/types.h>
+#include <netdb.h>
+#endif
+
+#define NETDB_BUFFER_SIZE 10000
+
+#ifdef _WIN32
+#define GETHOSTBYADDR_IS_REENTRANT 1
+#define GETHOSTBYNAME_IS_REENTRANT 1
+#endif
+
+static int entry_h_length;
+
+extern int socket_domain_table[];
+
+static value alloc_one_addr(char const *a)
+{
+  struct in_addr 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)
+{
+  value res;
+  value name = Val_unit, aliases = Val_unit;
+  value addr_list = Val_unit, adr = Val_unit;
+
+  Begin_roots4 (name, aliases, addr_list, adr);
+    name = caml_copy_string((char *)(entry->h_name));
+    /* PR#4043: protect against buggy implementations of gethostbyname()
+       that return a NULL pointer in h_aliases */
+    if (entry->h_aliases)
+      aliases = caml_copy_string_array((const char**)entry->h_aliases);
+    else
+      aliases = Atom(0);
+    entry_h_length = entry->h_length;
+#ifdef h_addr
+    addr_list = caml_alloc_array(alloc_one_addr, (const char**)entry->h_addr_list);
+#else
+    adr = alloc_one_addr(entry->h_addr);
+    addr_list = caml_alloc_small(1, 0);
+    Field(addr_list, 0) = adr;
+#endif
+    res = caml_alloc_small(4, 0);
+    Field(res, 0) = name;
+    Field(res, 1) = aliases;
+    switch (entry->h_addrtype) {
+    case PF_UNIX:          Field(res, 2) = Val_int(0); break;
+    case PF_INET:          Field(res, 2) = Val_int(1); break;
+    default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break;
+    }
+    Field(res, 3) = addr_list;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_gethostbyaddr(value a)
+{
+  struct in_addr adr = GET_INET_ADDR(a);
+  struct hostent * hp;
+#if HAS_GETHOSTBYADDR_R == 7
+  struct hostent h;
+  char buffer[NETDB_BUFFER_SIZE];
+  int h_errnop;
+  caml_enter_blocking_section();
+  hp = gethostbyaddr_r((char *) &adr, 4, AF_INET,
+                       &h, buffer, sizeof(buffer), &h_errnop);
+  caml_leave_blocking_section();
+#elif HAS_GETHOSTBYADDR_R == 8
+  struct hostent h;
+  char buffer[NETDB_BUFFER_SIZE];
+  int h_errnop, rc;
+  caml_enter_blocking_section();
+  rc = gethostbyaddr_r((char *) &adr, 4, AF_INET,
+                       &h, buffer, sizeof(buffer), &hp, &h_errnop);
+  caml_leave_blocking_section();
+  if (rc != 0) hp = NULL;
+#else
+#ifdef GETHOSTBYADDR_IS_REENTRANT
+  caml_enter_blocking_section();
+#endif
+  hp = gethostbyaddr((char *) &adr, 4, AF_INET);
+#ifdef GETHOSTBYADDR_IS_REENTRANT
+  caml_leave_blocking_section();
+#endif
+#endif
+  if (hp == (struct hostent *) NULL) caml_raise_not_found();
+  return alloc_host_entry(hp);
+}
+
+CAMLprim value unix_gethostbyname(value name)
+{
+  struct hostent * hp;
+  char * hostname;
+#if HAS_GETHOSTBYNAME_R
+  struct hostent h;
+  char buffer[NETDB_BUFFER_SIZE];
+  int err;
+#endif
+
+  if (! caml_string_is_c_safe(name)) caml_raise_not_found();
+
+#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
+  hostname = caml_strdup(String_val(name));
+#else
+  hostname = String_val(name);
+#endif
+
+#if HAS_GETHOSTBYNAME_R == 5
+  {
+    caml_enter_blocking_section();
+    hp = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &err);
+    caml_leave_blocking_section();
+  }
+#elif HAS_GETHOSTBYNAME_R == 6
+  {
+    int rc;
+    caml_enter_blocking_section();
+    rc = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &hp, &err);
+    caml_leave_blocking_section();
+    if (rc != 0) hp = NULL;
+  }
+#else
+#ifdef GETHOSTBYNAME_IS_REENTRANT
+  caml_enter_blocking_section();
+#endif
+  hp = gethostbyname(hostname);
+#ifdef GETHOSTBYNAME_IS_REENTRANT
+  caml_leave_blocking_section();
+#endif
+#endif
+
+#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
+  caml_stat_free(hostname);
+#endif
+
+  if (hp == (struct hostent *) NULL) caml_raise_not_found();
+  return alloc_host_entry(hp);
+}
+
+#else
+
+CAMLprim value unix_gethostbyaddr(value name)
+{ caml_invalid_argument("gethostbyaddr not implemented"); }
+
+CAMLprim value unix_gethostbyname(value name)
+{ caml_invalid_argument("gethostbyname not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c
new file mode 100644
index 00000000..0552a448
--- /dev/null
+++ b/otherlibs/unix/gethostname.c
@@ -0,0 +1,56 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#ifndef _WIN32
+#include <sys/param.h>
+#endif
+#include "unixsupport.h"
+
+#ifdef HAS_GETHOSTNAME
+
+#ifndef MAXHOSTNAMELEN
+#define MAXHOSTNAMELEN 256
+#endif
+
+CAMLprim value unix_gethostname(value unit)
+{
+  char name[MAXHOSTNAMELEN];
+  gethostname(name, MAXHOSTNAMELEN);
+  name[MAXHOSTNAMELEN-1] = 0;
+  return caml_copy_string(name);
+}
+
+#else
+#ifdef HAS_UNAME
+
+#include <sys/utsname.h>
+
+CAMLprim value unix_gethostname(value unit)
+{
+  struct utsname un;
+  uname(&un);
+  return copy_string(un.nodename);
+}
+
+#else
+
+CAMLprim value unix_gethostname(value unit)
+{ caml_invalid_argument("gethostname not implemented"); }
+
+#endif
+#endif
diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c
new file mode 100644
index 00000000..9cbb9518
--- /dev/null
+++ b/otherlibs/unix/getlogin.c
@@ -0,0 +1,29 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+#include <errno.h>
+
+extern char * getlogin(void);
+
+CAMLprim value unix_getlogin(value unit)
+{
+  char * name;
+  name = getlogin();
+  if (name == NULL) unix_error(ENOENT, "getlogin", Nothing);
+  return caml_copy_string(name);
+}
diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c
new file mode 100644
index 00000000..cd2ec336
--- /dev/null
+++ b/otherlibs/unix/getnameinfo.c
@@ -0,0 +1,67 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/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 = caml_convert_flag_list(vopts, getnameinfo_flag_table);
+  caml_enter_blocking_section();
+  retcode =
+    getnameinfo((const struct sockaddr *) &addr.s_gen, addr_len,
+                host, sizeof(host), serv, sizeof(serv), opts);
+  caml_leave_blocking_section();
+  if (retcode != 0) caml_raise_not_found(); /* TODO: detailed error reporting? */
+  vhost = caml_copy_string(host);
+  vserv = caml_copy_string(serv);
+  vres = caml_alloc_small(2, 0);
+  Field(vres, 0) = vhost;
+  Field(vres, 1) = vserv;
+  CAMLreturn(vres);
+}
+
+#else
+
+CAMLprim value unix_getnameinfo(value vaddr, value vopts)
+{ caml_invalid_argument("getnameinfo not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c
new file mode 100644
index 00000000..9390b55b
--- /dev/null
+++ b/otherlibs/unix/getpeername.c
@@ -0,0 +1,41 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_getpeername(value sock)
+{
+  int retcode;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  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, -1);
+}
+
+#else
+
+CAMLprim value unix_getpeername(value sock)
+{ caml_invalid_argument("getpeername not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c
new file mode 100644
index 00000000..1c7600d6
--- /dev/null
+++ b/otherlibs/unix/getpid.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_getpid(value unit)
+{
+  return Val_int(getpid());
+}
diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c
new file mode 100644
index 00000000..ba961f32
--- /dev/null
+++ b/otherlibs/unix/getppid.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_getppid(value unit)
+{
+  return Val_int(getppid());
+}
diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c
new file mode 100644
index 00000000..d50c2d4a
--- /dev/null
+++ b/otherlibs/unix/getproto.c
@@ -0,0 +1,69 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#ifndef _WIN32
+#include <netdb.h>
+#endif
+
+static value alloc_proto_entry(struct protoent *entry)
+{
+  value res;
+  value name = Val_unit, aliases = Val_unit;
+
+  Begin_roots2 (name, aliases);
+    name = caml_copy_string(entry->p_name);
+    aliases = caml_copy_string_array((const char**)entry->p_aliases);
+    res = caml_alloc_small(3, 0);
+    Field(res,0) = name;
+    Field(res,1) = aliases;
+    Field(res,2) = Val_int(entry->p_proto);
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_getprotobyname(value name)
+{
+  struct protoent * entry;
+  if (! caml_string_is_c_safe(name)) caml_raise_not_found();
+  entry = getprotobyname(String_val(name));
+  if (entry == (struct protoent *) NULL) caml_raise_not_found();
+  return alloc_proto_entry(entry);
+}
+
+CAMLprim value unix_getprotobynumber(value proto)
+{
+  struct protoent * entry;
+  entry = getprotobynumber(Int_val(proto));
+  if (entry == (struct protoent *) NULL) caml_raise_not_found();
+  return alloc_proto_entry(entry);
+}
+
+#else
+
+CAMLprim value unix_getprotobynumber(value proto)
+{ caml_invalid_argument("getprotobynumber not implemented"); }
+
+CAMLprim value unix_getprotobyname(value name)
+{ caml_invalid_argument("getprotobyname not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c
new file mode 100644
index 00000000..b49c23f3
--- /dev/null
+++ b/otherlibs/unix/getpw.c
@@ -0,0 +1,66 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+#include <pwd.h>
+
+static value alloc_passwd_entry(struct passwd *entry)
+{
+  value res;
+  value name = Val_unit, passwd = Val_unit, gecos = Val_unit;
+  value dir = Val_unit, shell = Val_unit;
+
+  Begin_roots5 (name, passwd, gecos, dir, shell);
+    name = caml_copy_string(entry->pw_name);
+    passwd = caml_copy_string(entry->pw_passwd);
+#if !defined(__BEOS__) && !defined(__ANDROID__)
+    gecos = caml_copy_string(entry->pw_gecos);
+#else
+    gecos = caml_copy_string("");
+#endif
+    dir = caml_copy_string(entry->pw_dir);
+    shell = caml_copy_string(entry->pw_shell);
+    res = caml_alloc_small(7, 0);
+    Field(res,0) = name;
+    Field(res,1) = passwd;
+    Field(res,2) = Val_int(entry->pw_uid);
+    Field(res,3) = Val_int(entry->pw_gid);
+    Field(res,4) = gecos;
+    Field(res,5) = dir;
+    Field(res,6) = shell;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_getpwnam(value name)
+{
+  struct passwd * entry;
+  if (! caml_string_is_c_safe(name)) caml_raise_not_found();
+  entry = getpwnam(String_val(name));
+  if (entry == (struct passwd *) NULL) caml_raise_not_found();
+  return alloc_passwd_entry(entry);
+}
+
+CAMLprim value unix_getpwuid(value uid)
+{
+  struct passwd * entry;
+  entry = getpwuid(Int_val(uid));
+  if (entry == (struct passwd *) NULL) caml_raise_not_found();
+  return alloc_passwd_entry(entry);
+}
diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c
new file mode 100644
index 00000000..9edfa879
--- /dev/null
+++ b/otherlibs/unix/getserv.c
@@ -0,0 +1,77 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include <sys/types.h>
+
+#ifndef _WIN32
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <netdb.h>
+#endif
+
+static value alloc_service_entry(struct servent *entry)
+{
+  value res;
+  value name = Val_unit, aliases = Val_unit, proto = Val_unit;
+
+  Begin_roots3 (name, aliases, proto);
+    name = caml_copy_string(entry->s_name);
+    aliases = caml_copy_string_array((const char**)entry->s_aliases);
+    proto = caml_copy_string(entry->s_proto);
+    res = caml_alloc_small(4, 0);
+    Field(res,0) = name;
+    Field(res,1) = aliases;
+    Field(res,2) = Val_int(ntohs(entry->s_port));
+    Field(res,3) = proto;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_getservbyname(value name, value proto)
+{
+  struct servent * entry;
+  if (! (caml_string_is_c_safe(name) && caml_string_is_c_safe(proto)))
+    caml_raise_not_found();
+  entry = getservbyname(String_val(name), String_val(proto));
+  if (entry == (struct servent *) NULL) caml_raise_not_found();
+  return alloc_service_entry(entry);
+}
+
+CAMLprim value unix_getservbyport(value port, value proto)
+{
+  struct servent * entry;
+  if (! caml_string_is_c_safe(proto)) caml_raise_not_found();
+  entry = getservbyport(htons(Int_val(port)), String_val(proto));
+  if (entry == (struct servent *) NULL) caml_raise_not_found();
+  return alloc_service_entry(entry);
+}
+
+#else
+
+CAMLprim value unix_getservbyport(value port, value proto)
+{ caml_invalid_argument("getservbyport not implemented"); }
+
+CAMLprim value unix_getservbyname(value name, value proto)
+{ caml_invalid_argument("getservbyname not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c
new file mode 100644
index 00000000..3544b25f
--- /dev/null
+++ b/otherlibs/unix/getsockname.c
@@ -0,0 +1,41 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_getsockname(value sock)
+{
+  int retcode;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  addr_len = sizeof(addr);
+  retcode = getsockname(Int_val(sock), &addr.s_gen, &addr_len);
+  if (retcode == -1) uerror("getsockname", Nothing);
+  return alloc_sockaddr(&addr, addr_len, -1);
+}
+
+#else
+
+CAMLprim value unix_getsockname(value sock)
+{ caml_invalid_argument("getsockname not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c
new file mode 100644
index 00000000..609a9a82
--- /dev/null
+++ b/otherlibs/unix/gettimeofday.c
@@ -0,0 +1,38 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#ifdef HAS_GETTIMEOFDAY
+
+#include <sys/types.h>
+#include <sys/time.h>
+
+CAMLprim value unix_gettimeofday(value unit)
+{
+  struct timeval tp;
+  if (gettimeofday(&tp, NULL) == -1) uerror("gettimeofday", Nothing);
+  return caml_copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6);
+}
+
+#else
+
+CAMLprim value unix_gettimeofday(value unit)
+{ caml_invalid_argument("gettimeofday not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c
new file mode 100644
index 00000000..781c4b8d
--- /dev/null
+++ b/otherlibs/unix/getuid.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_getuid(value unit)
+{
+  return Val_int(getuid());
+}
diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c
new file mode 100644
index 00000000..b0c2711a
--- /dev/null
+++ b/otherlibs/unix/gmtime.c
@@ -0,0 +1,95 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+#include <time.h>
+#include <errno.h>
+
+static value alloc_tm(struct tm *tm)
+{
+  value res;
+  res = caml_alloc_small(9, 0);
+  Field(res,0) = Val_int(tm->tm_sec);
+  Field(res,1) = Val_int(tm->tm_min);
+  Field(res,2) = Val_int(tm->tm_hour);
+  Field(res,3) = Val_int(tm->tm_mday);
+  Field(res,4) = Val_int(tm->tm_mon);
+  Field(res,5) = Val_int(tm->tm_year);
+  Field(res,6) = Val_int(tm->tm_wday);
+  Field(res,7) = Val_int(tm->tm_yday);
+  Field(res,8) = tm->tm_isdst ? Val_true : Val_false;
+  return res;
+}
+
+CAMLprim value unix_gmtime(value t)
+{
+  time_t clock;
+  struct tm * tm;
+  clock = (time_t) Double_val(t);
+  tm = gmtime(&clock);
+  if (tm == NULL) unix_error(EINVAL, "gmtime", Nothing);
+  return alloc_tm(tm);
+}
+
+CAMLprim value unix_localtime(value t)
+{
+  time_t clock;
+  struct tm * tm;
+  clock = (time_t) Double_val(t);
+  tm = localtime(&clock);
+  if (tm == NULL) unix_error(EINVAL, "localtime", Nothing);
+  return alloc_tm(tm);
+}
+
+#ifdef HAS_MKTIME
+
+CAMLprim value unix_mktime(value t)
+{
+  struct tm tm;
+  time_t clock;
+  value res;
+  value tmval = Val_unit, clkval = Val_unit;
+
+  Begin_roots2(tmval, clkval);
+    tm.tm_sec = Int_val(Field(t, 0));
+    tm.tm_min = Int_val(Field(t, 1));
+    tm.tm_hour = Int_val(Field(t, 2));
+    tm.tm_mday = Int_val(Field(t, 3));
+    tm.tm_mon = Int_val(Field(t, 4));
+    tm.tm_year = Int_val(Field(t, 5));
+    tm.tm_wday = Int_val(Field(t, 6));
+    tm.tm_yday = Int_val(Field(t, 7));
+    tm.tm_isdst = -1; /* tm.tm_isdst = Bool_val(Field(t, 8)); */
+    clock = mktime(&tm);
+    if (clock == (time_t) -1) unix_error(ERANGE, "mktime", Nothing);
+    tmval = alloc_tm(&tm);
+    clkval = caml_copy_double((double) clock);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = clkval;
+    Field(res, 1) = tmval;
+  End_roots ();
+  return res;
+}
+
+#else
+
+CAMLprim value unix_mktime(value t)
+{ caml_invalid_argument("mktime not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/initgroups.c b/otherlibs/unix/initgroups.c
new file mode 100644
index 00000000..77be82f0
--- /dev/null
+++ b/otherlibs/unix/initgroups.c
@@ -0,0 +1,46 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Stephane Glondu <steph@glondu.net>                    */
+/*                                                                        */
+/*   Copyright 2009 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+#ifdef HAS_INITGROUPS
+
+#include <sys/types.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <errno.h>
+#include <limits.h>
+#include <grp.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_initgroups(value user, value group)
+{
+  if (! caml_string_is_c_safe(user))
+    unix_error(EINVAL, "initgroups", user);
+  if (initgroups(String_val(user), Int_val(group)) == -1) {
+    uerror("initgroups", Nothing);
+  }
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_initgroups(value user, value group)
+{ caml_invalid_argument("initgroups not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/isatty.c b/otherlibs/unix/isatty.c
new file mode 100644
index 00000000..fb537dd1
--- /dev/null
+++ b/otherlibs/unix/isatty.c
@@ -0,0 +1,22 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2006 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_isatty(value fd)
+{
+  return (Val_bool(isatty(Int_val(fd))));
+}
diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c
new file mode 100644
index 00000000..09993706
--- /dev/null
+++ b/otherlibs/unix/itimer.c
@@ -0,0 +1,75 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SETITIMER
+
+#include <math.h>
+#include <sys/time.h>
+
+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 = caml_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 };
+
+CAMLprim value unix_setitimer(value which, value newval)
+{
+  struct itimerval new, old;
+  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);
+}
+
+CAMLprim value unix_getitimer(value which)
+{
+  struct itimerval val;
+  if (getitimer(itimers[Int_val(which)], &val) == -1)
+    uerror("getitimer", Nothing);
+  return unix_convert_itimer(&val);
+}
+
+#else
+
+CAMLprim value unix_setitimer(value which, value newval)
+{ caml_invalid_argument("setitimer not implemented"); }
+CAMLprim value unix_getitimer(value which)
+{ caml_invalid_argument("getitimer not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
new file mode 100644
index 00000000..d229d3e9
--- /dev/null
+++ b/otherlibs/unix/kill.c
@@ -0,0 +1,31 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+#include <signal.h>
+#include <caml/signals.h>
+
+CAMLprim value unix_kill(value pid, value signal)
+{
+  int sig;
+  sig = caml_convert_signal_number(Int_val(signal));
+  if (kill(Int_val(pid), sig) == -1)
+    uerror("kill", Nothing);
+  return Val_unit;
+}
diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c
new file mode 100644
index 00000000..3179c060
--- /dev/null
+++ b/otherlibs/unix/link.c
@@ -0,0 +1,38 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_link(value path1, value path2)
+{
+  CAMLparam2(path1, path2);
+  char * p1;
+  char * p2;
+  int ret;
+  caml_unix_check_path(path1, "link");
+  caml_unix_check_path(path2, "link");
+  p1 = caml_strdup(String_val(path1));
+  p2 = caml_strdup(String_val(path2));
+  caml_enter_blocking_section();
+  ret = link(p1, p2);
+  caml_leave_blocking_section();
+  caml_stat_free(p1);
+  caml_stat_free(p2);
+  if (ret == -1) uerror("link", path2);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c
new file mode 100644
index 00000000..f5ac130d
--- /dev/null
+++ b/otherlibs/unix/listen.c
@@ -0,0 +1,35 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include <sys/socket.h>
+
+CAMLprim value unix_listen(value sock, value backlog)
+{
+  if (listen(Int_val(sock), Int_val(backlog)) == -1) uerror("listen", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_listen(value sock, value backlog)
+{ caml_invalid_argument("listen not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c
new file mode 100644
index 00000000..cdcc4afe
--- /dev/null
+++ b/otherlibs/unix/lockf.c
@@ -0,0 +1,116 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <fcntl.h>
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW)
+
+CAMLprim value unix_lockf(value fd, value cmd, value span)
+{
+  struct flock l;
+  int ret;
+  int fildes;
+  long size;
+
+  fildes = Int_val(fd);
+  size = Long_val(span);
+  l.l_whence = 1;
+  if (size < 0) {
+    l.l_start = size;
+    l.l_len = -size;
+  } else {
+    l.l_start = 0L;
+    l.l_len = size;
+  }
+  switch (Int_val(cmd)) {
+  case 0: /* F_ULOCK */
+    l.l_type = F_UNLCK;
+    ret = fcntl(fildes, F_SETLK, &l);
+    break;
+  case 1: /* F_LOCK */
+    l.l_type = F_WRLCK;
+    caml_enter_blocking_section();
+    ret = fcntl(fildes, F_SETLKW, &l);
+    caml_leave_blocking_section();
+    break;
+  case 2: /* F_TLOCK */
+    l.l_type = F_WRLCK;
+    ret = fcntl(fildes, F_SETLK, &l);
+    break;
+  case 3: /* F_TEST */
+    l.l_type = F_WRLCK;
+    ret = fcntl(fildes, F_GETLK, &l);
+    if (ret != -1) {
+      if (l.l_type == F_UNLCK)
+        ret = 0;
+      else {
+        errno = EACCES;
+        ret = -1;
+      }
+    }
+    break;
+  case 4: /* F_RLOCK */
+    l.l_type = F_RDLCK;
+    caml_enter_blocking_section();
+    ret = fcntl(fildes, F_SETLKW, &l);
+    caml_leave_blocking_section();
+    break;
+  case 5: /* F_TRLOCK */
+    l.l_type = F_RDLCK;
+    ret = fcntl(fildes, F_SETLK, &l);
+    break;
+  default:
+    errno = EINVAL;
+    ret = -1;
+  }
+  if (ret == -1) uerror("lockf", Nothing);
+  return Val_unit;
+}
+
+#else
+
+#ifdef HAS_LOCKF
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#else
+#define F_ULOCK 0
+#define F_LOCK 1
+#define F_TLOCK 2
+#define F_TEST 3
+#endif
+
+static int lock_command_table[] = {
+  F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK
+};
+
+CAMLprim value unix_lockf(value fd, value cmd, value span)
+{
+  if (lockf(Int_val(fd), lock_command_table[Int_val(cmd)], Long_val(span))
+      == -1) uerror("lockf", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_lockf(value fd, value cmd, value span)
+{ caml_invalid_argument("lockf not implemented"); }
+
+#endif
+#endif
diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
new file mode 100644
index 00000000..4b3cad41
--- /dev/null
+++ b/otherlibs/unix/lseek.c
@@ -0,0 +1,66 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <errno.h>
+#include <sys/types.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/io.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#else
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+
+#ifndef EOVERFLOW
+#define EOVERFLOW ERANGE
+#endif
+
+static int seek_command_table[] = {
+  SEEK_SET, SEEK_CUR, SEEK_END
+};
+
+CAMLprim value unix_lseek(value fd, value ofs, value cmd)
+{
+  file_offset ret;
+  caml_enter_blocking_section();
+  ret = lseek(Int_val(fd), Long_val(ofs),
+                       seek_command_table[Int_val(cmd)]);
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("lseek", Nothing);
+  if (ret > Max_long) unix_error(EOVERFLOW, "lseek", Nothing);
+  return Val_long(ret);
+}
+
+CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
+{
+  file_offset ret;
+  /* [ofs] is an Int64, which is stored as a custom block; we must therefore
+     extract its contents before dropping the runtime lock, or it might be
+     moved. */
+  file_offset ofs_c = File_offset_val(ofs);
+  caml_enter_blocking_section();
+  ret = lseek(Int_val(fd), ofs_c, seek_command_table[Int_val(cmd)]);
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("lseek", Nothing);
+  return Val_file_offset(ret);
+}
diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c
new file mode 100644
index 00000000..93cb61cc
--- /dev/null
+++ b/otherlibs/unix/mkdir.c
@@ -0,0 +1,36 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_mkdir(value path, value perm)
+{
+  CAMLparam2(path, perm);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "mkdir");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = mkdir(p, Int_val(perm));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("mkdir", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c
new file mode 100644
index 00000000..4b97c1c4
--- /dev/null
+++ b/otherlibs/unix/mkfifo.c
@@ -0,0 +1,73 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_MKFIFO
+
+CAMLprim value unix_mkfifo(value path, value mode)
+{
+  CAMLparam2(path, mode);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "mkfifo");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = mkfifo(p, Int_val(mode));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("mkfifo", path);
+  CAMLreturn(Val_unit);
+}
+
+#else
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#ifdef S_IFIFO
+
+CAMLprim value unix_mkfifo(value path, value mode)
+{
+  CAMLparam2(path, mode);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "mkfifo");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = mknod(p, (Int_val(mode) & 07777) | S_IFIFO, 0);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("mkfifo", path);
+  CAMLreturn(Val_unit);
+}
+
+#else
+
+CAMLprim value unix_mkfifo(value path, value mode)
+{
+  caml_invalid_argument("mkfifo not implemented");
+}
+
+#endif
+#endif
diff --git a/otherlibs/unix/nanosecond_stat.h b/otherlibs/unix/nanosecond_stat.h
new file mode 100644
index 00000000..6abeb57e
--- /dev/null
+++ b/otherlibs/unix/nanosecond_stat.h
@@ -0,0 +1,27 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                  Jeremie Dimino, Jane Street Group, LLC                */
+/*                                                                        */
+/*   Copyright 2015 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* This file is used by the configure test program nanosecond_stat.c
+   and stat.c in this directory */
+
+#if HAS_NANOSECOND_STAT == 1
+#  define NSEC(buf, field) buf->st_##field##tim.tv_nsec
+#elif HAS_NANOSECOND_STAT == 2
+#  define NSEC(buf, field) buf->st_##field##timespec.tv_nsec
+#elif HAS_NANOSECOND_STAT == 3
+#  define NSEC(buf, field) buf->st_##field##timensec
+#else
+#  define NSEC(buf, field) 0
+#endif
diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c
new file mode 100644
index 00000000..50d46413
--- /dev/null
+++ b/otherlibs/unix/nice.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include <errno.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+CAMLprim value unix_nice(value incr)
+{
+  int ret;
+  errno = 0;
+#ifdef HAS_NICE
+  ret = nice(Int_val(incr));
+#else
+  ret = 0;
+#endif
+  if (ret == -1 && errno != 0) uerror("nice", Nothing);
+  return Val_int(ret);
+}
diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c
new file mode 100644
index 00000000..1892d44c
--- /dev/null
+++ b/otherlibs/unix/open.c
@@ -0,0 +1,87 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <string.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
+
+#ifndef O_NONBLOCK
+#define O_NONBLOCK O_NDELAY
+#endif
+#ifndef O_DSYNC
+#define O_DSYNC 0
+#endif
+#ifndef O_SYNC
+#define O_SYNC 0
+#endif
+#ifndef O_RSYNC
+#define O_RSYNC 0
+#endif
+
+static int open_flag_table[15] = {
+  O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
+  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC,
+  0, /* O_SHARE_DELETE, Windows-only */
+  0, /* O_CLOEXEC, treated specially */
+  0  /* O_KEEPEXEC, treated specially */
+};
+
+enum { CLOEXEC = 1, KEEPEXEC = 2 };
+
+static int open_cloexec_table[15] = {
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0,
+  0,
+  CLOEXEC, KEEPEXEC
+};
+
+CAMLprim value unix_open(value path, value flags, value perm)
+{
+  CAMLparam3(path, flags, perm);
+  int fd, cv_flags, clo_flags, cloexec;
+  char * p;
+
+  caml_unix_check_path(path, "open");
+  cv_flags = caml_convert_flag_list(flags, open_flag_table);
+  clo_flags = caml_convert_flag_list(flags, open_cloexec_table);
+  if (clo_flags & CLOEXEC)
+    cloexec = 1;
+  else if (clo_flags & KEEPEXEC)
+    cloexec = 0;
+  else
+    cloexec = unix_cloexec_default;
+#if defined(O_CLOEXEC)
+  if (cloexec) cv_flags |= O_CLOEXEC;
+#endif
+  p = caml_strdup(String_val(path));
+  /* open on a named FIFO can block (PR#1533) */
+  caml_enter_blocking_section();
+  fd = open(p, cv_flags, Int_val(perm));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (fd == -1) uerror("open", path);
+#if !defined(O_CLOEXEC)
+  if (cloexec) unix_set_cloexec(fd, "open", path);
+#endif
+  CAMLreturn (Val_int(fd));
+}
diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
new file mode 100644
index 00000000..067cacc5
--- /dev/null
+++ b/otherlibs/unix/opendir.c
@@ -0,0 +1,45 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <sys/types.h>
+#ifdef HAS_DIRENT
+#include <dirent.h>
+#else
+#include <sys/dir.h>
+#endif
+
+CAMLprim value unix_opendir(value path)
+{
+  CAMLparam1(path);
+  DIR * d;
+  value res;
+  char * p;
+
+  caml_unix_check_path(path, "opendir");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  d = opendir(p);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (d == (DIR *) NULL) uerror("opendir", path);
+  res = caml_alloc_small(1, Abstract_tag);
+  DIR_Val(res) = d;
+  CAMLreturn(res);
+}
diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c
new file mode 100644
index 00000000..103f826c
--- /dev/null
+++ b/otherlibs/unix/pipe.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define _GNU_SOURCE
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+#include <fcntl.h>
+
+CAMLprim value unix_pipe(value cloexec, value vunit)
+{
+  int fd[2];
+  value res;
+#ifdef HAS_PIPE2
+  if (pipe2(fd, unix_cloexec_p(cloexec) ? O_CLOEXEC : 0) == -1)
+    uerror("pipe", Nothing);
+#else
+  if (pipe(fd) == -1) uerror("pipe", Nothing);
+  if (unix_cloexec_p(cloexec)) {
+    unix_set_cloexec(fd[0], "pipe", Nothing);
+    unix_set_cloexec(fd[1], "pipe", Nothing);
+  }
+#endif
+  res = caml_alloc_small(2, 0);
+  Field(res, 0) = Val_int(fd[0]);
+  Field(res, 1) = Val_int(fd[1]);
+  return res;
+}
diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c
new file mode 100644
index 00000000..f5709b69
--- /dev/null
+++ b/otherlibs/unix/putenv.c
@@ -0,0 +1,53 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1998 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#include "unixsupport.h"
+
+#ifdef HAS_PUTENV
+
+CAMLprim value unix_putenv(value name, value val)
+{
+  mlsize_t namelen = caml_string_length(name);
+  mlsize_t vallen = caml_string_length(val);
+  char * s;
+
+  if (! (caml_string_is_c_safe(name) && caml_string_is_c_safe(val)))
+    unix_error(EINVAL, "putenv", name);
+  s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1);
+  memmove (s, String_val(name), namelen);
+  s[namelen] = '=';
+  memmove (s + namelen + 1, String_val(val), vallen);
+  s[namelen + 1 + vallen] = 0;
+  if (putenv(s) == -1) {
+    caml_stat_free(s);
+    uerror("putenv", name);
+  }
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_putenv(value name, value val)
+{ caml_invalid_argument("putenv not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c
new file mode 100644
index 00000000..428e49fc
--- /dev/null
+++ b/otherlibs/unix/read.c
@@ -0,0 +1,38 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_read(value fd, value buf, value ofs, value len)
+{
+  long numbytes;
+  int ret;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  Begin_root (buf);
+    numbytes = Long_val(len);
+    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+    caml_enter_blocking_section();
+    ret = read(Int_val(fd), iobuf, (int) numbytes);
+    caml_leave_blocking_section();
+    if (ret == -1) uerror("read", Nothing);
+    memmove (&Byte(buf, Long_val(ofs)), iobuf, ret);
+  End_roots();
+  return Val_int(ret);
+}
diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c
new file mode 100644
index 00000000..d741fc4f
--- /dev/null
+++ b/otherlibs/unix/readdir.c
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <errno.h>
+#include <sys/types.h>
+#ifdef HAS_DIRENT
+#include <dirent.h>
+typedef struct dirent directory_entry;
+#else
+#include <sys/dir.h>
+typedef struct direct directory_entry;
+#endif
+
+CAMLprim value unix_readdir(value vd)
+{
+  DIR * d;
+  directory_entry * e;
+  d = DIR_Val(vd);
+  if (d == (DIR *) NULL) unix_error(EBADF, "readdir", Nothing);
+  caml_enter_blocking_section();
+  e = readdir((DIR *) d);
+  caml_leave_blocking_section();
+  if (e == (directory_entry *) NULL) caml_raise_end_of_file();
+  return caml_copy_string(e->d_name);
+}
diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c
new file mode 100644
index 00000000..4e9f0453
--- /dev/null
+++ b/otherlibs/unix/readlink.c
@@ -0,0 +1,57 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+
+#ifdef HAS_SYMLINK
+
+#include <sys/param.h>
+#include "unixsupport.h"
+
+#ifndef PATH_MAX
+#ifdef MAXPATHLEN
+#define PATH_MAX MAXPATHLEN
+#else
+#define PATH_MAX 512
+#endif
+#endif
+
+CAMLprim value unix_readlink(value path)
+{
+  CAMLparam1(path);
+  char buffer[PATH_MAX];
+  int len;
+  char * p;
+  caml_unix_check_path(path, "readlink");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  len = readlink(p, buffer, sizeof(buffer) - 1);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (len == -1) uerror("readlink", path);
+  buffer[len] = '\0';
+  CAMLreturn(caml_copy_string(buffer));
+}
+
+#else
+
+CAMLprim value unix_readlink(value path)
+{ caml_invalid_argument("readlink not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c
new file mode 100644
index 00000000..bf13eab6
--- /dev/null
+++ b/otherlibs/unix/rename.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_rename(value path1, value path2)
+{
+  CAMLparam2(path1, path2);
+  char * p1;
+  char * p2;
+  int ret;
+  caml_unix_check_path(path1, "rename");
+  caml_unix_check_path(path2, "rename");
+  p1 = caml_strdup(String_val(path1));
+  p2 = caml_strdup(String_val(path2));
+  caml_enter_blocking_section();
+  ret = rename(p1, p2);
+  caml_leave_blocking_section();
+  caml_stat_free(p2);
+  caml_stat_free(p1);
+  if (ret == -1)
+    uerror("rename", path1);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c
new file mode 100644
index 00000000..e3f889f2
--- /dev/null
+++ b/otherlibs/unix/rewinddir.c
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include <errno.h>
+#include <sys/types.h>
+#ifdef HAS_DIRENT
+#include <dirent.h>
+#else
+#include <sys/dir.h>
+#endif
+
+#ifdef HAS_REWINDDIR
+
+CAMLprim value unix_rewinddir(value vd)
+{
+  DIR * d = DIR_Val(vd);
+  if (d == (DIR *) NULL) unix_error(EBADF, "rewinddir", Nothing);
+  rewinddir(d);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_rewinddir(value d)
+{ caml_invalid_argument("rewinddir not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c
new file mode 100644
index 00000000..9f9b4589
--- /dev/null
+++ b/otherlibs/unix/rmdir.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_rmdir(value path)
+{
+  CAMLparam1(path);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "rmdir");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = rmdir(p);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("rmdir", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c
new file mode 100644
index 00000000..aaf3ddc7
--- /dev/null
+++ b/otherlibs/unix/select.c
@@ -0,0 +1,114 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SELECT
+
+#include <sys/types.h>
+#include <sys/time.h>
+#ifdef HAS_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+#include <string.h>
+#include <unistd.h>
+#include <errno.h>
+
+static int fdlist_to_fdset(value fdlist, fd_set *fdset, int *maxfd)
+{
+  value l;
+  FD_ZERO(fdset);
+  for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    long fd = Long_val(Field(l, 0));
+    /* PR#5563: harden against bad fds */
+    if (fd < 0 || fd >= FD_SETSIZE) return -1;
+    FD_SET((int) fd, fdset);
+    if (fd > *maxfd) *maxfd = fd;
+  }
+  return 0;
+}
+
+static value fdset_to_fdlist(value fdlist, fd_set *fdset)
+{
+  value l;
+  value res = Val_int(0);
+
+  Begin_roots2(l, res);
+    for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+      int fd = Int_val(Field(l, 0));
+      if (FD_ISSET(fd, fdset)) {
+        value newres = caml_alloc_small(2, 0);
+        Field(newres, 0) = Val_int(fd);
+        Field(newres, 1) = res;
+        res = newres;
+      }
+    }
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_select(value readfds, value writefds, value exceptfds,
+                           value timeout)
+{
+  fd_set read, write, except;
+  int maxfd;
+  double tm;
+  struct timeval tv;
+  struct timeval * tvp;
+  int retcode;
+  value res;
+
+  Begin_roots3 (readfds, writefds, exceptfds);
+    maxfd = -1;
+    retcode  = fdlist_to_fdset(readfds, &read, &maxfd);
+    retcode += fdlist_to_fdset(writefds, &write, &maxfd);
+    retcode += fdlist_to_fdset(exceptfds, &except, &maxfd);
+    /* PR#5563: if a bad fd was encountered, report EINVAL error */
+    if (retcode != 0) unix_error(EINVAL, "select", Nothing);
+    tm = Double_val(timeout);
+    if (tm < 0.0)
+      tvp = (struct timeval *) NULL;
+    else {
+      tv.tv_sec = (int) tm;
+      tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
+      tvp = &tv;
+    }
+    caml_enter_blocking_section();
+    retcode = select(maxfd + 1, &read, &write, &except, tvp);
+    caml_leave_blocking_section();
+    if (retcode == -1) uerror("select", Nothing);
+    readfds = fdset_to_fdlist(readfds, &read);
+    writefds = fdset_to_fdlist(writefds, &write);
+    exceptfds = fdset_to_fdlist(exceptfds, &except);
+    res = caml_alloc_small(3, 0);
+    Field(res, 0) = readfds;
+    Field(res, 1) = writefds;
+    Field(res, 2) = exceptfds;
+  End_roots();
+  return res;
+}
+
+#else
+
+CAMLprim value unix_select(value readfds, value writefds, value exceptfds,
+                           value timeout)
+{ caml_invalid_argument("select not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c
new file mode 100644
index 00000000..4b8e7554
--- /dev/null
+++ b/otherlibs/unix/sendrecv.c
@@ -0,0 +1,148 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+#include "socketaddr.h"
+
+static int msg_flag_table[] = {
+  MSG_OOB, MSG_DONTROUTE, MSG_PEEK
+};
+
+CAMLprim value unix_recv(value sock, value buff, value ofs, value len,
+                         value flags)
+{
+  int ret, cv_flags;
+  long numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  cv_flags = caml_convert_flag_list(flags, msg_flag_table);
+  Begin_root (buff);
+    numbytes = Long_val(len);
+    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+    caml_enter_blocking_section();
+    ret = recv(Int_val(sock), iobuf, (int) numbytes, cv_flags);
+    caml_leave_blocking_section();
+    if (ret == -1) uerror("recv", Nothing);
+    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
+  End_roots();
+  return Val_int(ret);
+}
+
+CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len,
+                             value flags)
+{
+  int ret, cv_flags;
+  long numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+  value res;
+  value adr = Val_unit;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  cv_flags = caml_convert_flag_list(flags, msg_flag_table);
+  Begin_roots2 (buff, adr);
+    numbytes = Long_val(len);
+    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+    addr_len = sizeof(addr);
+    caml_enter_blocking_section();
+    ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, cv_flags,
+                   &addr.s_gen, &addr_len);
+    caml_leave_blocking_section();
+    if (ret == -1) uerror("recvfrom", Nothing);
+    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
+    adr = alloc_sockaddr(&addr, addr_len, -1);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = Val_int(ret);
+    Field(res, 1) = adr;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_send(value sock, value buff, value ofs, value len,
+                         value flags)
+{
+  int ret, cv_flags;
+  long numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  cv_flags = caml_convert_flag_list(flags, msg_flag_table);
+  numbytes = Long_val(len);
+  if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+  memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
+  caml_enter_blocking_section();
+  ret = send(Int_val(sock), iobuf, (int) numbytes, cv_flags);
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("send", Nothing);
+  return Val_int(ret);
+}
+
+CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len,
+                                  value flags, value dest)
+{
+  int ret, cv_flags;
+  long numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  cv_flags = caml_convert_flag_list(flags, msg_flag_table);
+  get_sockaddr(dest, &addr, &addr_len);
+  numbytes = Long_val(len);
+  if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+  memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
+  caml_enter_blocking_section();
+  ret = sendto(Int_val(sock), iobuf, (int) numbytes, cv_flags,
+               &addr.s_gen, addr_len);
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("sendto", Nothing);
+  return Val_int(ret);
+}
+
+CAMLprim value unix_sendto(value *argv, int argc)
+{
+  return unix_sendto_native
+           (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+}
+
+#else
+
+CAMLprim value unix_recv(value sock, value buff, value ofs, value len,
+                         value flags)
+{ caml_invalid_argument("recv not implemented"); }
+
+CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len,
+                             value flags)
+{ caml_invalid_argument("recvfrom not implemented"); }
+
+CAMLprim value unix_send(value sock, value buff, value ofs, value len,
+                         value flags)
+{ caml_invalid_argument("send not implemented"); }
+
+CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len,
+                                  value flags, value dest)
+{ caml_invalid_argument("sendto not implemented"); }
+
+CAMLprim value unix_sendto(value *argv, int argc)
+{ caml_invalid_argument("sendto not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c
new file mode 100644
index 00000000..91d22557
--- /dev/null
+++ b/otherlibs/unix/setgid.c
@@ -0,0 +1,23 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_setgid(value gid)
+{
+  if (setgid(Int_val(gid)) == -1) uerror("setgid", Nothing);
+  return Val_unit;
+}
diff --git a/otherlibs/unix/setgroups.c b/otherlibs/unix/setgroups.c
new file mode 100644
index 00000000..6c63cce0
--- /dev/null
+++ b/otherlibs/unix/setgroups.c
@@ -0,0 +1,53 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*  Contributed by Stephane Glondu <steph@glondu.net>                     */
+/*                                                                        */
+/*   Copyright 2009 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+
+#ifdef HAS_SETGROUPS
+
+#include <sys/types.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <limits.h>
+#include <grp.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_setgroups(value groups)
+{
+  gid_t * gidset;
+  mlsize_t size, i;
+  int n;
+
+  size = Wosize_val(groups);
+  gidset = (gid_t *) caml_stat_alloc(size * sizeof(gid_t));
+  for (i = 0; i < size; i++) gidset[i] = Int_val(Field(groups, i));
+
+  n = setgroups(size, gidset);
+
+  caml_stat_free(gidset);
+  if (n == -1) uerror("setgroups", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_setgroups(value groups)
+{ caml_invalid_argument("setgroups not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c
new file mode 100644
index 00000000..b4449e67
--- /dev/null
+++ b/otherlibs/unix/setsid.c
@@ -0,0 +1,31 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1997 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+CAMLprim value unix_setsid(value unit)
+{
+#ifdef HAS_SETSID
+  return Val_int(setsid());
+#else
+  caml_invalid_argument("setsid not implemented");
+  return Val_unit;
+#endif
+}
diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c
new file mode 100644
index 00000000..978dd9eb
--- /dev/null
+++ b/otherlibs/unix/setuid.c
@@ -0,0 +1,23 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_setuid(value uid)
+{
+  if (setuid(Int_val(uid)) == -1) uerror("setuid", Nothing);
+  return Val_unit;
+}
diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c
new file mode 100644
index 00000000..6c0edd37
--- /dev/null
+++ b/otherlibs/unix/shutdown.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include <sys/socket.h>
+
+static int shutdown_command_table[] = {
+  0, 1, 2
+};
+
+CAMLprim value unix_shutdown(value sock, value cmd)
+{
+  if (shutdown(Int_val(sock), shutdown_command_table[Int_val(cmd)]) == -1)
+    uerror("shutdown", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_shutdown(value sock, value cmd)
+{ caml_invalid_argument("shutdown not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
new file mode 100644
index 00000000..945e7d16
--- /dev/null
+++ b/otherlibs/unix/signals.c
@@ -0,0 +1,108 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1998 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <errno.h>
+#include <signal.h>
+
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifndef NSIG
+#define NSIG 64
+#endif
+
+#ifdef POSIX_SIGNALS
+
+static void decode_sigset(value vset, sigset_t * set)
+{
+  sigemptyset(set);
+  while (vset != Val_int(0)) {
+    int sig = caml_convert_signal_number(Int_val(Field(vset, 0)));
+    sigaddset(set, sig);
+    vset = Field(vset, 1);
+  }
+}
+
+static value encode_sigset(sigset_t * set)
+{
+  value res = Val_int(0);
+  int i;
+
+  Begin_root(res)
+    for (i = 1; i < NSIG; i++)
+      if (sigismember(set, i) > 0) {
+        value newcons = caml_alloc_small(2, 0);
+        Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
+        Field(newcons, 1) = res;
+        res = newcons;
+      }
+  End_roots();
+  return res;
+}
+
+static int sigprocmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK };
+
+CAMLprim value unix_sigprocmask(value vaction, value vset)
+{
+  int how;
+  sigset_t set, oldset;
+  int retcode;
+
+  how = sigprocmask_cmd[Int_val(vaction)];
+  decode_sigset(vset, &set);
+  caml_enter_blocking_section();
+  retcode = sigprocmask(how, &set, &oldset);
+  caml_leave_blocking_section();
+  if (retcode == -1) uerror("sigprocmask", Nothing);
+  return encode_sigset(&oldset);
+}
+
+CAMLprim value unix_sigpending(value unit)
+{
+  sigset_t pending;
+  if (sigpending(&pending) == -1) uerror("sigpending", Nothing);
+  return encode_sigset(&pending);
+}
+
+CAMLprim value unix_sigsuspend(value vset)
+{
+  sigset_t set;
+  int retcode;
+  decode_sigset(vset, &set);
+  caml_enter_blocking_section();
+  retcode = sigsuspend(&set);
+  caml_leave_blocking_section();
+  if (retcode == -1 && errno != EINTR) uerror("sigsuspend", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_sigprocmask(value vaction, value vset)
+{ caml_invalid_argument("Unix.sigprocmask not available"); }
+
+CAMLprim value unix_sigpending(value unit)
+{ caml_invalid_argument("Unix.sigpending not available"); }
+
+CAMLprim value unix_sigsuspend(value vset)
+{ caml_invalid_argument("Unix.sigsuspend not available"); }
+
+#endif
diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
new file mode 100644
index 00000000..54724312
--- /dev/null
+++ b/otherlibs/unix/sleep.c
@@ -0,0 +1,71 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#include <errno.h>
+#include <time.h>
+#ifdef HAS_SELECT
+#include <sys/types.h>
+#include <sys/time.h>
+#ifdef HAS_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+#endif
+
+CAMLprim value unix_sleep(value duration)
+{
+  double d = Double_val(duration);
+  if (d < 0.0) return Val_unit;
+#if defined(HAS_NANOSLEEP)
+  {
+    struct timespec t;
+    int ret;
+    caml_enter_blocking_section();
+    t.tv_sec = (time_t) d;
+    t.tv_nsec = (d - t.tv_sec) * 1e9;
+    do {
+      ret = nanosleep(&t, &t);
+    } while (ret == -1 && errno == EINTR);
+    caml_leave_blocking_section();
+    if (ret == -1) uerror("sleep", Nothing);
+  }
+#elif defined(HAS_SELECT)
+  {
+    struct timeval t;
+    int ret;
+    caml_enter_blocking_section();
+    t.tv_sec = (time_t) d;
+    t.tv_usec = (d - t.tv_sec) * 1e6;
+    do {
+      ret = select(0, NULL, NULL, NULL, &t);
+    } while (ret == -1 && errno == EINTR);
+    caml_leave_blocking_section();
+    if (ret == -1) uerror("sleep", Nothing);
+  }
+#else
+  /* Fallback implementation, resolution 1 second only.
+     We cannot reliably iterate until sleep() returns 0, because the
+     remaining time returned by sleep() is generally rounded up. */
+  {
+    caml_enter_blocking_section();
+    sleep ((unsigned int) d);
+    caml_leave_blocking_section();
+  }
+#endif
+  return Val_unit;
+}
diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c
new file mode 100644
index 00000000..5166ed13
--- /dev/null
+++ b/otherlibs/unix/socket.c
@@ -0,0 +1,65 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define _GNU_SOURCE
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include <sys/types.h>
+#include <sys/socket.h>
+
+int socket_domain_table[] = {
+  PF_UNIX, PF_INET,
+#if defined(HAS_IPV6)
+  PF_INET6
+#elif defined(PF_UNDEF)
+  PF_UNDEF
+#else
+  0
+#endif
+};
+
+int socket_type_table[] = {
+  SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
+};
+
+CAMLprim value unix_socket(value cloexec, value domain,
+                           value type, value proto)
+{
+  int retcode;
+  int ty = socket_type_table[Int_val(type)];
+#ifdef SOCK_CLOEXEC
+  if (unix_cloexec_p(cloexec)) ty |= SOCK_CLOEXEC;
+#endif
+  retcode = socket(socket_domain_table[Int_val(domain)],
+                   ty, Int_val(proto));
+  if (retcode == -1) uerror("socket", Nothing);
+#ifndef SOCK_CLOEXEC
+  if (unix_cloexec_p(cloexec))
+    unix_set_cloexec(retcode, "socket", Nothing);
+#endif
+  return Val_int(retcode);
+}
+
+#else
+
+CAMLprim value unix_socket(value cloexec, value domain,
+                           value type,value proto)
+{ caml_invalid_argument("socket not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
new file mode 100644
index 00000000..5f64021f
--- /dev/null
+++ b/otherlibs/unix/socketaddr.c
@@ -0,0 +1,156 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <errno.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+#ifdef _WIN32
+#undef EAFNOSUPPORT
+#define EAFNOSUPPORT WSAEAFNOSUPPORT
+#endif
+
+CAMLexport 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 is marshaled in an endian-independent manner. */
+  res = caml_alloc_string(4);
+  memcpy(String_val(res), a, 4);
+  return res;
+}
+
+#ifdef HAS_IPV6
+
+CAMLexport value alloc_inet6_addr(struct in6_addr * a)
+{
+  value res;
+  res = caml_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*/)
+{
+  switch(Tag_val(mladr)) {
+#ifndef _WIN32
+  case 0:                       /* ADDR_UNIX */
+    { value path;
+      mlsize_t len;
+      path = Field(mladr, 0);
+      len = caml_string_length(path);
+      adr->s_unix.sun_family = AF_UNIX;
+      if (len >= sizeof(adr->s_unix.sun_path)) {
+        unix_error(ENAMETOOLONG, "", path);
+      }
+      /* "Abstract" sockets in Linux have names starting with '\0' */
+      if (Byte(path, 0) != 0 && ! caml_string_is_c_safe(path)) {
+        unix_error(ENOENT, "", path);
+      }
+      memmove (adr->s_unix.sun_path, String_val(path), len + 1);
+      *adr_len =
+        ((char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix))
+        + len;
+      break;
+    }
+#endif
+  case 1:                       /* ADDR_INET */
+#ifdef HAS_IPV6
+    if (caml_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)));
+#ifdef SIN6_LEN
+      adr->s_inet6.sin6_len = sizeof(struct sockaddr_in6);
+#endif
+      *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)));
+#ifdef SIN6_LEN
+    adr->s_inet.sin_len = sizeof(struct sockaddr_in);
+#endif
+    *adr_len = sizeof(struct sockaddr_in);
+    break;
+  }
+}
+
+value alloc_sockaddr(union sock_addr_union * adr /*in*/,
+                     socklen_param_type adr_len, int close_on_error)
+{
+  value res;
+  switch(adr->s_gen.sa_family) {
+#ifndef _WIN32
+  case AF_UNIX:
+    { value n;
+      /* Based on recommendation in section BUGS of Linux unix(7). See
+         http://man7.org/linux/man-pages/man7/unix.7.html */
+      mlsize_t path_length =
+        strnlen(adr->s_unix.sun_path,
+                adr_len - offsetof(struct sockaddr_un, sun_path));
+      n = caml_alloc_string(path_length);
+      memmove(String_val(n), adr->s_unix.sun_path, path_length);
+      Begin_root (n);
+        res = caml_alloc_small(1, 0);
+        Field(res,0) = n;
+      End_roots();
+      break;
+    }
+#endif
+  case AF_INET:
+    { value a = alloc_inet_addr(&adr->s_inet.sin_addr);
+      Begin_root (a);
+        res = caml_alloc_small(2, 1);
+        Field(res,0) = a;
+        Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port));
+      End_roots();
+      break;
+    }
+#ifdef HAS_IPV6
+  case AF_INET6:
+    { value a = alloc_inet6_addr(&adr->s_inet6.sin6_addr);
+      Begin_root (a);
+        res = caml_alloc_small(2, 1);
+        Field(res,0) = a;
+        Field(res,1) = Val_int(ntohs(adr->s_inet6.sin6_port));
+      End_roots();
+      break;
+    }
+#endif
+  default:
+    if (close_on_error != -1) close (close_on_error);
+    unix_error(EAFNOSUPPORT, "", Nothing);
+  }
+  return res;
+}
+
+#endif
diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h
new file mode 100644
index 00000000..4c80d25d
--- /dev/null
+++ b/otherlibs/unix/socketaddr.h
@@ -0,0 +1,62 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_SOCKETADDR_H
+#define CAML_SOCKETADDR_H
+
+#include "caml/misc.h"
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+
+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
+};
+
+#ifdef HAS_SOCKLEN_T
+typedef socklen_t socklen_param_type;
+#else
+typedef int socklen_param_type;
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+extern void get_sockaddr (value mladdr,
+                          union sock_addr_union * addr /*out*/,
+                          socklen_param_type * addr_len /*out*/);
+CAMLexport value alloc_sockaddr (union sock_addr_union * addr /*in*/,
+                      socklen_param_type addr_len, int close_on_error);
+CAMLexport value alloc_inet_addr (struct in_addr * inaddr);
+#define GET_INET_ADDR(v) (*((struct in_addr *) (v)))
+
+#ifdef HAS_IPV6
+CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr);
+#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v)))
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_SOCKETADDR_H */
diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c
new file mode 100644
index 00000000..15cc82b2
--- /dev/null
+++ b/otherlibs/unix/socketpair.c
@@ -0,0 +1,56 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include <sys/socket.h>
+
+extern int socket_domain_table[], socket_type_table[];
+
+CAMLprim value unix_socketpair(value cloexec, value domain,
+                               value type, value proto)
+{
+  int sv[2];
+  value res;
+  int ty = socket_type_table[Int_val(type)];
+#ifdef SOCK_CLOEXEC
+  if (unix_cloexec_p(cloexec)) ty |= SOCK_CLOEXEC;
+#endif
+  if (socketpair(socket_domain_table[Int_val(domain)],
+                 ty, Int_val(proto), sv) == -1)
+    uerror("socketpair", Nothing);
+#ifndef SOCK_CLOEXEC
+  if (unix_cloexec_p(cloexec)) {
+    unix_set_cloexec(sv[0], "socketpair", Nothing);
+    unix_set_cloexec(sv[1], "socketpair", Nothing);
+  }
+#endif
+  res = caml_alloc_small(2, 0);
+  Field(res,0) = Val_int(sv[0]);
+  Field(res,1) = Val_int(sv[1]);
+  return res;
+}
+
+#else
+
+CAMLprim value unix_socketpair(value domain, value type, value proto)
+{ caml_invalid_argument("socketpair not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c
new file mode 100644
index 00000000..d2961d09
--- /dev/null
+++ b/otherlibs/unix/sockopt.c
@@ -0,0 +1,301 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include <errno.h>
+#include <sys/time.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netinet/tcp.h>
+
+#include "socketaddr.h"
+
+#ifndef SO_DEBUG
+#define SO_DEBUG (-1)
+#endif
+#ifndef SO_BROADCAST
+#define SO_BROADCAST (-1)
+#endif
+#ifndef SO_REUSEADDR
+#define SO_REUSEADDR (-1)
+#endif
+#ifndef SO_KEEPALIVE
+#define SO_KEEPALIVE (-1)
+#endif
+#ifndef SO_DONTROUTE
+#define SO_DONTROUTE (-1)
+#endif
+#ifndef SO_OOBINLINE
+#define SO_OOBINLINE (-1)
+#endif
+#ifndef SO_ACCEPTCONN
+#define SO_ACCEPTCONN (-1)
+#endif
+#ifndef SO_SNDBUF
+#define SO_SNDBUF (-1)
+#endif
+#ifndef SO_RCVBUF
+#define SO_RCVBUF (-1)
+#endif
+#ifndef SO_ERROR
+#define SO_ERROR (-1)
+#endif
+#ifndef SO_TYPE
+#define SO_TYPE (-1)
+#endif
+#ifndef SO_RCVLOWAT
+#define SO_RCVLOWAT (-1)
+#endif
+#ifndef SO_SNDLOWAT
+#define SO_SNDLOWAT (-1)
+#endif
+#ifndef SO_LINGER
+#define SO_LINGER (-1)
+#endif
+#ifndef SO_RCVTIMEO
+#define SO_RCVTIMEO (-1)
+#endif
+#ifndef SO_SNDTIMEO
+#define SO_SNDTIMEO (-1)
+#endif
+#ifndef TCP_NODELAY
+#define TCP_NODELAY (-1)
+#endif
+#ifndef SO_ERROR
+#define SO_ERROR (-1)
+#endif
+#ifndef IPPROTO_IPV6
+#define IPPROTO_IPV6 (-1)
+#endif
+#ifndef IPV6_V6ONLY
+#define IPV6_V6ONLY (-1)
+#endif
+
+enum option_type {
+  TYPE_BOOL = 0,
+  TYPE_INT = 1,
+  TYPE_LINGER = 2,
+  TYPE_TIMEVAL = 3,
+  TYPE_UNIX_ERROR = 4
+};
+
+struct socket_option {
+  int level;
+  int option;
+};
+
+/* Table of options, indexed by type */
+
+static struct socket_option sockopt_bool[] = {
+  { SOL_SOCKET, SO_DEBUG },
+  { SOL_SOCKET, SO_BROADCAST },
+  { SOL_SOCKET, SO_REUSEADDR },
+  { SOL_SOCKET, SO_KEEPALIVE },
+  { SOL_SOCKET, SO_DONTROUTE },
+  { SOL_SOCKET, SO_OOBINLINE },
+  { SOL_SOCKET, SO_ACCEPTCONN },
+  { IPPROTO_TCP, TCP_NODELAY },
+  { IPPROTO_IPV6, IPV6_V6ONLY}
+};
+
+static struct socket_option sockopt_int[] = {
+  { SOL_SOCKET, SO_SNDBUF },
+  { SOL_SOCKET, SO_RCVBUF },
+  { SOL_SOCKET, SO_ERROR },
+  { SOL_SOCKET, SO_TYPE },
+  { SOL_SOCKET, SO_RCVLOWAT },
+  { SOL_SOCKET, SO_SNDLOWAT } };
+
+static struct socket_option sockopt_linger[] = {
+  { SOL_SOCKET, SO_LINGER }
+};
+
+static struct socket_option sockopt_timeval[] = {
+  { SOL_SOCKET, SO_RCVTIMEO },
+  { SOL_SOCKET, SO_SNDTIMEO }
+};
+
+static struct socket_option sockopt_unix_error[] = {
+  { SOL_SOCKET, SO_ERROR }
+};
+
+static struct socket_option * sockopt_table[] = {
+  sockopt_bool,
+  sockopt_int,
+  sockopt_linger,
+  sockopt_timeval,
+  sockopt_unix_error
+};
+
+static char * getsockopt_fun_name[] = {
+  "getsockopt",
+  "getsockopt_int",
+  "getsockopt_optint",
+  "getsockopt_float",
+  "getsockopt_error"
+};
+
+static char * setsockopt_fun_name[] = {
+  "setsockopt",
+  "setsockopt_int",
+  "setsockopt_optint",
+  "setsockopt_float",
+  "setsockopt_error"
+};
+
+union option_value {
+  int i;
+  struct linger lg;
+  struct timeval tv;
+};
+
+CAMLexport value
+unix_getsockopt_aux(char * name,
+                    enum option_type ty, int level, int option,
+                    value socket)
+{
+  union option_value optval;
+  socklen_param_type optsize;
+
+
+  switch (ty) {
+  case TYPE_BOOL:
+  case TYPE_INT:
+  case TYPE_UNIX_ERROR:
+    optsize = sizeof(optval.i); break;
+  case TYPE_LINGER:
+    optsize = sizeof(optval.lg); break;
+  case TYPE_TIMEVAL:
+    optsize = sizeof(optval.tv); break;
+  default:
+    unix_error(EINVAL, name, Nothing);
+  }
+
+  if (getsockopt(Int_val(socket), level, option,
+                 (void *) &optval, &optsize) == -1)
+    uerror(name, Nothing);
+
+  switch (ty) {
+  case TYPE_BOOL:
+    return Val_bool(optval.i);
+  case TYPE_INT:
+    return Val_int(optval.i);
+  case TYPE_LINGER:
+    if (optval.lg.l_onoff == 0) {
+      return Val_int(0);        /* None */
+    } else {
+      value res = caml_alloc_small(1, 0); /* Some */
+      Field(res, 0) = Val_int(optval.lg.l_linger);
+      return res;
+    }
+  case TYPE_TIMEVAL:
+    return caml_copy_double((double) optval.tv.tv_sec
+                       + (double) optval.tv.tv_usec / 1e6);
+  case TYPE_UNIX_ERROR:
+    if (optval.i == 0) {
+      return Val_int(0);        /* None */
+    } else {
+      value err, res;
+      err = unix_error_of_code(optval.i);
+      Begin_root(err);
+        res = caml_alloc_small(1, 0); /* Some */
+        Field(res, 0) = err;
+      End_roots();
+      return res;
+    }
+  default:
+    unix_error(EINVAL, name, Nothing);
+  }
+}
+
+CAMLexport value
+unix_setsockopt_aux(char * name,
+                    enum option_type ty, int level, int option,
+                    value socket, value val)
+{
+  union option_value optval;
+  socklen_param_type optsize;
+  double f;
+
+  switch (ty) {
+  case TYPE_BOOL:
+  case TYPE_INT:
+    optsize = sizeof(optval.i);
+    optval.i = Int_val(val);
+    break;
+  case TYPE_LINGER:
+    optsize = sizeof(optval.lg);
+    optval.lg.l_onoff = Is_block (val);
+    if (optval.lg.l_onoff)
+      optval.lg.l_linger = Int_val (Field (val, 0));
+    break;
+  case TYPE_TIMEVAL:
+    f = Double_val(val);
+    optsize = sizeof(optval.tv);
+    optval.tv.tv_sec = (int) f;
+    optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec));
+    break;
+  case TYPE_UNIX_ERROR:
+  default:
+    unix_error(EINVAL, name, Nothing);
+  }
+
+  if (setsockopt(Int_val(socket), level, option,
+                 (void *) &optval, optsize) == -1)
+    uerror(name, Nothing);
+
+  return Val_unit;
+}
+
+CAMLprim value unix_getsockopt(value vty, value vsocket, value voption)
+{
+  enum option_type ty = Int_val(vty);
+  struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]);
+  return unix_getsockopt_aux(getsockopt_fun_name[ty],
+                             ty,
+                             opt->level,
+                             opt->option,
+                             vsocket);
+}
+
+CAMLprim value unix_setsockopt(value vty, value vsocket, value voption,
+                               value val)
+{
+  enum option_type ty = Int_val(vty);
+  struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]);
+  return unix_setsockopt_aux(setsockopt_fun_name[ty],
+                             ty,
+                             opt->level,
+                             opt->option,
+                             vsocket,
+                             val);
+}
+
+#else
+
+CAMLprim value unix_getsockopt(value vty, value socket, value option)
+{ caml_invalid_argument("getsockopt not implemented"); }
+
+CAMLprim value unix_setsockopt(value vty, value socket, value option, value val)
+{ caml_invalid_argument("setsockopt not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
new file mode 100644
index 00000000..cd62dd0b
--- /dev/null
+++ b/otherlibs/unix/stat.c
@@ -0,0 +1,179 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include <caml/io.h>
+#include "unixsupport.h"
+#include "cst2constr.h"
+
+#ifndef S_IFLNK
+#define S_IFLNK 0
+#endif
+#ifndef S_IFIFO
+#define S_IFIFO 0
+#endif
+#ifndef S_IFSOCK
+#define S_IFSOCK 0
+#endif
+#ifndef S_IFBLK
+#define S_IFBLK 0
+#endif
+
+#ifndef EOVERFLOW
+#define EOVERFLOW ERANGE
+#endif
+
+static int file_kind_table[] = {
+  S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK
+};
+
+static value stat_aux(int use_64, struct stat *buf)
+{
+  CAMLparam0();
+  CAMLlocal5(atime, mtime, ctime, offset, v);
+
+  #include "nanosecond_stat.h"
+  atime = caml_copy_double((double) buf->st_atime
+                           + (NSEC(buf, a) / 1000000000.0));
+  mtime = caml_copy_double((double) buf->st_mtime
+                           + (NSEC(buf, m) / 1000000000.0));
+  ctime = caml_copy_double((double) buf->st_ctime
+                           + (NSEC(buf, c) / 1000000000.0));
+  #undef NSEC
+  offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size);
+  v = caml_alloc_small(12, 0);
+  Field (v, 0) = Val_int (buf->st_dev);
+  Field (v, 1) = Val_int (buf->st_ino);
+  Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table,
+                               sizeof(file_kind_table) / sizeof(int), 0);
+  Field (v, 3) = Val_int (buf->st_mode & 07777);
+  Field (v, 4) = Val_int (buf->st_nlink);
+  Field (v, 5) = Val_int (buf->st_uid);
+  Field (v, 6) = Val_int (buf->st_gid);
+  Field (v, 7) = Val_int (buf->st_rdev);
+  Field (v, 8) = offset;
+  Field (v, 9) = atime;
+  Field (v, 10) = mtime;
+  Field (v, 11) = ctime;
+  CAMLreturn(v);
+}
+
+CAMLprim value unix_stat(value path)
+{
+  CAMLparam1(path);
+  int ret;
+  struct stat buf;
+  char * p;
+  caml_unix_check_path(path, "stat");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = stat(p, &buf);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("stat", path);
+  if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
+    unix_error(EOVERFLOW, "stat", path);
+  CAMLreturn(stat_aux(0, &buf));
+}
+
+CAMLprim value unix_lstat(value path)
+{
+  CAMLparam1(path);
+  int ret;
+  struct stat buf;
+  char * p;
+  caml_unix_check_path(path, "lstat");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+#ifdef HAS_SYMLINK
+  ret = lstat(p, &buf);
+#else
+  ret = stat(p, &buf);
+#endif
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("lstat", path);
+  if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
+    unix_error(EOVERFLOW, "lstat", path);
+  CAMLreturn(stat_aux(0, &buf));
+}
+
+CAMLprim value unix_fstat(value fd)
+{
+  int ret;
+  struct stat buf;
+  caml_enter_blocking_section();
+  ret = fstat(Int_val(fd), &buf);
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("fstat", Nothing);
+  if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
+    unix_error(EOVERFLOW, "fstat", Nothing);
+  return stat_aux(0, &buf);
+}
+
+CAMLprim value unix_stat_64(value path)
+{
+  CAMLparam1(path);
+  int ret;
+  struct stat buf;
+  char * p;
+  caml_unix_check_path(path, "stat");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = stat(p, &buf);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("stat", path);
+  CAMLreturn(stat_aux(1, &buf));
+}
+
+CAMLprim value unix_lstat_64(value path)
+{
+  CAMLparam1(path);
+  int ret;
+  struct stat buf;
+  char * p;
+  caml_unix_check_path(path, "lstat");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+#ifdef HAS_SYMLINK
+  ret = lstat(p, &buf);
+#else
+  ret = stat(p, &buf);
+#endif
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("lstat", path);
+  CAMLreturn(stat_aux(1, &buf));
+}
+
+CAMLprim value unix_fstat_64(value fd)
+{
+  int ret;
+  struct stat buf;
+  caml_enter_blocking_section();
+  ret = fstat(Int_val(fd), &buf);
+  caml_leave_blocking_section();
+  if (ret == -1) uerror("fstat", Nothing);
+  return stat_aux(1, &buf);
+}
diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c
new file mode 100644
index 00000000..45675ad0
--- /dev/null
+++ b/otherlibs/unix/strofaddr.c
@@ -0,0 +1,74 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+
+CAMLprim value unix_string_of_inet_addr(value a)
+{
+  char * res;
+#ifdef HAS_IPV6
+#ifdef _WIN32
+  char buffer[64];
+  union sock_addr_union sa;
+  int len;
+  int retcode;
+  if (caml_string_length(a) == 16) {
+    memset(&sa.s_inet6, 0, sizeof(struct sockaddr_in6));
+    sa.s_inet6.sin6_family = AF_INET6;
+    sa.s_inet6.sin6_addr = GET_INET6_ADDR(a);
+    len = sizeof(struct sockaddr_in6);
+  } else {
+    memset(&sa.s_inet, 0, sizeof(struct sockaddr_in));
+    sa.s_inet.sin_family = AF_INET;
+    sa.s_inet.sin_addr = GET_INET_ADDR(a);
+    len = sizeof(struct sockaddr_in);
+  }
+  retcode = getnameinfo
+    (&sa.s_gen, len, buffer, sizeof(buffer), NULL, 0, NI_NUMERICHOST);
+  if (retcode != 0)
+    res = NULL;
+  else
+    res = buffer;
+#else
+  char buffer[64];
+  if (caml_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));
+#endif
+#else
+  res = inet_ntoa(GET_INET_ADDR(a));
+#endif
+  if (res == NULL) uerror("string_of_inet_addr", Nothing);
+  return caml_copy_string(res);
+}
+
+#else
+
+CAMLprim value unix_string_of_inet_addr(value a)
+{ caml_invalid_argument("string_of_inet_addr not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c
new file mode 100644
index 00000000..0bff3f6d
--- /dev/null
+++ b/otherlibs/unix/symlink.c
@@ -0,0 +1,61 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifdef HAS_SYMLINK
+
+CAMLprim value unix_symlink(value to_dir, value path1, value path2)
+{
+  CAMLparam3(to_dir, path1, path2);
+  char * p1;
+  char * p2;
+  int ret;
+  caml_unix_check_path(path1, "symlink");
+  caml_unix_check_path(path2, "symlink");
+  p1 = caml_strdup(String_val(path1));
+  p2 = caml_strdup(String_val(path2));
+  caml_enter_blocking_section();
+  ret = symlink(p1, p2);
+  caml_leave_blocking_section();
+  caml_stat_free(p1);
+  caml_stat_free(p2);
+  if (ret == -1)
+    uerror("symlink", path2);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value unix_has_symlink(value unit)
+{
+  CAMLparam0();
+  CAMLreturn(Val_true);
+}
+
+#else
+
+CAMLprim value unix_symlink(value to_dir, value path1, value path2)
+{ caml_invalid_argument("symlink not implemented"); }
+
+CAMLprim value unix_has_symlink(value unit)
+{
+  CAMLparam0();
+  CAMLreturn(Val_false);
+}
+
+#endif
diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c
new file mode 100644
index 00000000..b6a221ff
--- /dev/null
+++ b/otherlibs/unix/termios.c
@@ -0,0 +1,387 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+#ifdef HAS_TERMIOS
+
+#include <termios.h>
+#include <errno.h>
+
+static struct termios terminal_status;
+
+enum { Bool, Enum, Speed, Char, End };
+
+enum { Input, Output };
+
+#define iflags ((long)(&terminal_status.c_iflag))
+#define oflags ((long)(&terminal_status.c_oflag))
+#define cflags ((long)(&terminal_status.c_cflag))
+#define lflags ((long)(&terminal_status.c_lflag))
+
+/* Number of fields in the terminal_io record field. Cf. unix.mli */
+
+#define NFIELDS 38
+
+/* Structure of the terminal_io record. Cf. unix.mli */
+
+static long terminal_io_descr[] = {
+  /* Input modes */
+  Bool, iflags, IGNBRK,
+  Bool, iflags, BRKINT,
+  Bool, iflags, IGNPAR,
+  Bool, iflags, PARMRK,
+  Bool, iflags, INPCK,
+  Bool, iflags, ISTRIP,
+  Bool, iflags, INLCR,
+  Bool, iflags, IGNCR,
+  Bool, iflags, ICRNL,
+  Bool, iflags, IXON,
+  Bool, iflags, IXOFF,
+  /* Output modes */
+  Bool, oflags, OPOST,
+  /* Control modes */
+  Speed, Output,
+  Speed, Input,
+  Enum, cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8,
+  Enum, cflags, 1, 2, CSTOPB, 0, CSTOPB,
+  Bool, cflags, CREAD,
+  Bool, cflags, PARENB,
+  Bool, cflags, PARODD,
+  Bool, cflags, HUPCL,
+  Bool, cflags, CLOCAL,
+  /* Local modes */
+  Bool, lflags, ISIG,
+  Bool, lflags, ICANON,
+  Bool, lflags, NOFLSH,
+  Bool, lflags, ECHO,
+  Bool, lflags, ECHOE,
+  Bool, lflags, ECHOK,
+  Bool, lflags, ECHONL,
+  /* Control characters */
+  Char, VINTR,
+  Char, VQUIT,
+  Char, VERASE,
+  Char, VKILL,
+  Char, VEOF,
+  Char, VEOL,
+  Char, VMIN,
+  Char, VTIME,
+  Char, VSTART,
+  Char, VSTOP,
+  End
+};
+
+#undef iflags
+#undef oflags
+#undef cflags
+#undef lflags
+
+static struct {
+  speed_t speed;
+  int baud;
+} speedtable[] = {
+
+  /* standard speeds */
+  {B0,       0},
+  {B50,      50},
+  {B75,      75},
+  {B110,     110},
+  {B134,     134},
+  {B150,     150},
+#ifdef B200
+  /* Shouldn't need to be ifdef'd but I'm not sure it's available everywhere. */
+  {B200,     200},
+#endif
+  {B300,     300},
+  {B600,     600},
+  {B1200,    1200},
+  {B1800,    1800},
+  {B2400,    2400},
+  {B4800,    4800},
+  {B9600,    9600},
+  {B19200,   19200},
+  {B38400,   38400},
+
+  /* usual extensions */
+#ifdef B57600
+  {B57600,   57600},
+#endif
+#ifdef B115200
+  {B115200,  115200},
+#endif
+#ifdef B230400
+  {B230400,  230400},
+#endif
+
+  /* Linux extensions */
+#ifdef B460800
+  {B460800,  460800},
+#endif
+#ifdef B500000
+  {B500000,  500000},
+#endif
+#ifdef B576000
+  {B576000,  576000},
+#endif
+#ifdef B921600
+  {B921600,  921600},
+#endif
+#ifdef B1000000
+  {B1000000, 1000000},
+#endif
+#ifdef B1152000
+  {B1152000, 1152000},
+#endif
+#ifdef B1500000
+  {B1500000, 1500000},
+#endif
+#ifdef B2000000
+  {B2000000, 2000000},
+#endif
+#ifdef B2500000
+  {B2500000, 2500000},
+#endif
+#ifdef B3000000
+  {B3000000, 3000000},
+#endif
+#ifdef B3500000
+  {B3500000, 3500000},
+#endif
+#ifdef B4000000
+  {B4000000, 4000000},
+#endif
+
+  /* MacOS extensions */
+#ifdef B7200
+  {B7200,    7200},
+#endif
+#ifdef B14400
+  {B14400,   14400},
+#endif
+#ifdef B28800
+  {B28800,   28800},
+#endif
+#ifdef B76800
+  {B76800,   76800},
+#endif
+
+  /* Cygwin extensions (in addition to the Linux ones) */
+#ifdef B128000
+  {B128000,  128000},
+#endif
+#ifdef B256000
+  {B256000,  256000},
+#endif
+};
+
+#define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0]))
+
+static void encode_terminal_status(value *dst)
+{
+  long * pc;
+  int i;
+
+  for(pc = terminal_io_descr; *pc != End; dst++) {
+    switch(*pc++) {
+    case Bool:
+      { int * src = (int *) (*pc++);
+        int msk = *pc++;
+        *dst = Val_bool(*src & msk);
+        break; }
+    case Enum:
+      { int * src = (int *) (*pc++);
+        int ofs = *pc++;
+        int num = *pc++;
+        int msk = *pc++;
+        for (i = 0; i < num; i++) {
+          if ((*src & msk) == pc[i]) {
+            *dst = Val_int(i + ofs);
+            break;
+          }
+        }
+        pc += num;
+        break; }
+    case Speed:
+      { int which = *pc++;
+        speed_t speed = 0;
+        *dst = Val_int(9600);   /* in case no speed in speedtable matches */
+        switch (which) {
+        case Output:
+          speed = cfgetospeed(&terminal_status); break;
+        case Input:
+          speed = cfgetispeed(&terminal_status); break;
+        }
+        for (i = 0; i < NSPEEDS; i++) {
+          if (speed == speedtable[i].speed) {
+            *dst = Val_int(speedtable[i].baud);
+            break;
+          }
+        }
+        break; }
+    case Char:
+      { int which = *pc++;
+        *dst = Val_int(terminal_status.c_cc[which]);
+        break; }
+    }
+  }
+}
+
+static void decode_terminal_status(value *src)
+{
+  long * pc;
+  int i;
+
+  for (pc = terminal_io_descr; *pc != End; src++) {
+    switch(*pc++) {
+    case Bool:
+      { int * dst = (int *) (*pc++);
+        int msk = *pc++;
+        if (Bool_val(*src))
+          *dst |= msk;
+        else
+          *dst &= ~msk;
+        break; }
+    case Enum:
+      { int * dst = (int *) (*pc++);
+        int ofs = *pc++;
+        int num = *pc++;
+        int msk = *pc++;
+        i = Int_val(*src) - ofs;
+        if (i >= 0 && i < num) {
+          *dst = (*dst & ~msk) | pc[i];
+        } else {
+          unix_error(EINVAL, "tcsetattr", Nothing);
+        }
+        pc += num;
+        break; }
+    case Speed:
+      { int which = *pc++;
+        int baud = Int_val(*src);
+        int res = 0;
+        for (i = 0; i < NSPEEDS; i++) {
+          if (baud == speedtable[i].baud) {
+            switch (which) {
+            case Output:
+              res = cfsetospeed(&terminal_status, speedtable[i].speed); break;
+            case Input:
+              res = cfsetispeed(&terminal_status, speedtable[i].speed); break;
+            }
+            if (res == -1) uerror("tcsetattr", Nothing);
+            goto ok;
+          }
+        }
+        unix_error(EINVAL, "tcsetattr", Nothing);
+      ok:
+        break; }
+    case Char:
+      { int which = *pc++;
+        terminal_status.c_cc[which] = Int_val(*src);
+        break; }
+    }
+  }
+}
+
+CAMLprim value unix_tcgetattr(value fd)
+{
+  value res;
+
+  if (tcgetattr(Int_val(fd), &terminal_status) == -1)
+    uerror("tcgetattr", Nothing);
+  res = caml_alloc_tuple(NFIELDS);
+  encode_terminal_status(&Field(res, 0));
+  return res;
+}
+
+static int when_flag_table[] = {
+  TCSANOW, TCSADRAIN, TCSAFLUSH
+};
+
+CAMLprim value unix_tcsetattr(value fd, value when, value arg)
+{
+  if (tcgetattr(Int_val(fd), &terminal_status) == -1)
+    uerror("tcsetattr", Nothing);
+  decode_terminal_status(&Field(arg, 0));
+  if (tcsetattr(Int_val(fd),
+                when_flag_table[Int_val(when)],
+                &terminal_status) == -1)
+    uerror("tcsetattr", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value unix_tcsendbreak(value fd, value delay)
+{
+  if (tcsendbreak(Int_val(fd), Int_val(delay)) == -1)
+    uerror("tcsendbreak", Nothing);
+  return Val_unit;
+}
+
+#if defined(__ANDROID__)
+CAMLprim value unix_tcdrain(value fd)
+{ caml_invalid_argument("tcdrain not implemented"); }
+#else
+CAMLprim value unix_tcdrain(value fd)
+{
+  if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing);
+  return Val_unit;
+}
+#endif
+
+static int queue_flag_table[] = {
+  TCIFLUSH, TCOFLUSH, TCIOFLUSH
+};
+
+CAMLprim value unix_tcflush(value fd, value queue)
+{
+  if (tcflush(Int_val(fd), queue_flag_table[Int_val(queue)]) == -1)
+    uerror("tcflush", Nothing);
+  return Val_unit;
+}
+
+static int action_flag_table[] = {
+  TCOOFF, TCOON, TCIOFF, TCION
+};
+
+CAMLprim value unix_tcflow(value fd, value action)
+{
+  if (tcflow(Int_val(fd), action_flag_table[Int_val(action)]) == -1)
+    uerror("tcflow", Nothing);
+  return Val_unit;
+}
+
+#else
+
+CAMLprim value unix_tcgetattr(value fd)
+{ caml_invalid_argument("tcgetattr not implemented"); }
+
+CAMLprim value unix_tcsetattr(value fd, value when, value arg)
+{ caml_invalid_argument("tcsetattr not implemented"); }
+
+CAMLprim value unix_tcsendbreak(value fd, value delay)
+{ caml_invalid_argument("tcsendbreak not implemented"); }
+
+CAMLprim value unix_tcdrain(value fd)
+{ caml_invalid_argument("tcdrain not implemented"); }
+
+CAMLprim value unix_tcflush(value fd, value queue)
+{ caml_invalid_argument("tcflush not implemented"); }
+
+CAMLprim value unix_tcflow(value fd, value action)
+{ caml_invalid_argument("tcflow not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c
new file mode 100644
index 00000000..f7916c99
--- /dev/null
+++ b/otherlibs/unix/time.c
@@ -0,0 +1,24 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <time.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_time(value unit)
+{
+  return caml_copy_double((double) time((time_t *) NULL));
+}
diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c
new file mode 100644
index 00000000..7ad3f59a
--- /dev/null
+++ b/otherlibs/unix/times.c
@@ -0,0 +1,67 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+#include <time.h>
+#include <sys/types.h>
+#include <sys/times.h>
+#ifdef HAS_GETRUSAGE
+#include <sys/time.h>
+#include <sys/resource.h>
+#endif
+
+#ifndef CLK_TCK
+#ifdef HZ
+#define CLK_TCK HZ
+#else
+#define CLK_TCK 60
+#endif
+#endif
+
+CAMLprim value unix_times(value unit)
+{
+#ifdef HAS_GETRUSAGE
+
+  value res;
+  struct rusage ru;
+
+  res = caml_alloc_small(4 * Double_wosize, Double_array_tag);
+
+  getrusage (RUSAGE_SELF, &ru);
+  Store_double_field (res, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
+  Store_double_field (res, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
+  getrusage (RUSAGE_CHILDREN, &ru);
+  Store_double_field (res, 2, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
+  Store_double_field (res, 3, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
+  return res;
+
+#else
+
+  value res;
+  struct tms buffer;
+
+  times(&buffer);
+  res = caml_alloc_small(4 * Double_wosize, Double_array_tag);
+  Store_double_field(res, 0, (double) buffer.tms_utime / CLK_TCK);
+  Store_double_field(res, 1, (double) buffer.tms_stime / CLK_TCK);
+  Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK);
+  Store_double_field(res, 3, (double) buffer.tms_cstime / CLK_TCK);
+  return res;
+
+#endif
+}
diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
new file mode 100644
index 00000000..4f333cbd
--- /dev/null
+++ b/otherlibs/unix/truncate.c
@@ -0,0 +1,72 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <sys/types.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include <caml/io.h>
+#include "unixsupport.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+#ifdef HAS_TRUNCATE
+
+CAMLprim value unix_truncate(value path, value len)
+{
+  CAMLparam2(path, len);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "truncate");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = truncate(p, Long_val(len));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("truncate", path);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value unix_truncate_64(value path, value vlen)
+{
+  CAMLparam2(path, vlen);
+  char * p;
+  int ret;
+  file_offset len = File_offset_val(vlen);
+  caml_unix_check_path(path, "truncate");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = truncate(p, len);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("truncate", path);
+  CAMLreturn(Val_unit);
+}
+
+#else
+
+CAMLprim value unix_truncate(value path, value len)
+{ caml_invalid_argument("truncate not implemented"); }
+
+CAMLprim value unix_truncate_64(value path, value len)
+{ caml_invalid_argument("truncate not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c
new file mode 100644
index 00000000..90fd970d
--- /dev/null
+++ b/otherlibs/unix/umask.c
@@ -0,0 +1,24 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_umask(value perm)
+{
+  return Val_int(umask(Int_val(perm)));
+}
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
new file mode 100644
index 00000000..fa7f90d1
--- /dev/null
+++ b/otherlibs/unix/unix.ml
@@ -0,0 +1,1100 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error =
+    E2BIG
+  | EACCES
+  | EAGAIN
+  | EBADF
+  | EBUSY
+  | ECHILD
+  | EDEADLK
+  | EDOM
+  | EEXIST
+  | EFAULT
+  | EFBIG
+  | EINTR
+  | EINVAL
+  | EIO
+  | EISDIR
+  | EMFILE
+  | EMLINK
+  | ENAMETOOLONG
+  | ENFILE
+  | ENODEV
+  | ENOENT
+  | ENOEXEC
+  | ENOLCK
+  | ENOMEM
+  | ENOSPC
+  | ENOSYS
+  | ENOTDIR
+  | ENOTEMPTY
+  | ENOTTY
+  | ENXIO
+  | EPERM
+  | EPIPE
+  | ERANGE
+  | EROFS
+  | ESPIPE
+  | ESRCH
+  | EXDEV
+  | EWOULDBLOCK
+  | EINPROGRESS
+  | EALREADY
+  | ENOTSOCK
+  | EDESTADDRREQ
+  | EMSGSIZE
+  | EPROTOTYPE
+  | ENOPROTOOPT
+  | EPROTONOSUPPORT
+  | ESOCKTNOSUPPORT
+  | EOPNOTSUPP
+  | EPFNOSUPPORT
+  | EAFNOSUPPORT
+  | EADDRINUSE
+  | EADDRNOTAVAIL
+  | ENETDOWN
+  | ENETUNREACH
+  | ENETRESET
+  | ECONNABORTED
+  | ECONNRESET
+  | ENOBUFS
+  | EISCONN
+  | ENOTCONN
+  | ESHUTDOWN
+  | ETOOMANYREFS
+  | ETIMEDOUT
+  | ECONNREFUSED
+  | EHOSTDOWN
+  | EHOSTUNREACH
+  | ELOOP
+  | EOVERFLOW
+  | EUNKNOWNERR of int
+
+exception Unix_error of error * string * string
+
+let _ = Callback.register_exception "Unix.Unix_error"
+                                    (Unix_error(E2BIG, "", ""))
+
+external error_message : error -> string = "unix_error_message"
+
+let () =
+  Printexc.register_printer
+    (function
+      | Unix_error (e, s, s') ->
+          let msg = match e with
+          | E2BIG -> "E2BIG"
+          | EACCES -> "EACCES"
+          | EAGAIN -> "EAGAIN"
+          | EBADF -> "EBADF"
+          | EBUSY -> "EBUSY"
+          | ECHILD -> "ECHILD"
+          | EDEADLK -> "EDEADLK"
+          | EDOM -> "EDOM"
+          | EEXIST -> "EEXIST"
+          | EFAULT -> "EFAULT"
+          | EFBIG -> "EFBIG"
+          | EINTR -> "EINTR"
+          | EINVAL -> "EINVAL"
+          | EIO -> "EIO"
+          | EISDIR -> "EISDIR"
+          | EMFILE -> "EMFILE"
+          | EMLINK -> "EMLINK"
+          | ENAMETOOLONG -> "ENAMETOOLONG"
+          | ENFILE -> "ENFILE"
+          | ENODEV -> "ENODEV"
+          | ENOENT -> "ENOENT"
+          | ENOEXEC -> "ENOEXEC"
+          | ENOLCK -> "ENOLCK"
+          | ENOMEM -> "ENOMEM"
+          | ENOSPC -> "ENOSPC"
+          | ENOSYS -> "ENOSYS"
+          | ENOTDIR -> "ENOTDIR"
+          | ENOTEMPTY -> "ENOTEMPTY"
+          | ENOTTY -> "ENOTTY"
+          | ENXIO -> "ENXIO"
+          | EPERM -> "EPERM"
+          | EPIPE -> "EPIPE"
+          | ERANGE -> "ERANGE"
+          | EROFS -> "EROFS"
+          | ESPIPE -> "ESPIPE"
+          | ESRCH -> "ESRCH"
+          | EXDEV -> "EXDEV"
+          | EWOULDBLOCK -> "EWOULDBLOCK"
+          | EINPROGRESS -> "EINPROGRESS"
+          | EALREADY -> "EALREADY"
+          | ENOTSOCK -> "ENOTSOCK"
+          | EDESTADDRREQ -> "EDESTADDRREQ"
+          | EMSGSIZE -> "EMSGSIZE"
+          | EPROTOTYPE -> "EPROTOTYPE"
+          | ENOPROTOOPT -> "ENOPROTOOPT"
+          | EPROTONOSUPPORT -> "EPROTONOSUPPORT"
+          | ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT"
+          | EOPNOTSUPP -> "EOPNOTSUPP"
+          | EPFNOSUPPORT -> "EPFNOSUPPORT"
+          | EAFNOSUPPORT -> "EAFNOSUPPORT"
+          | EADDRINUSE -> "EADDRINUSE"
+          | EADDRNOTAVAIL -> "EADDRNOTAVAIL"
+          | ENETDOWN -> "ENETDOWN"
+          | ENETUNREACH -> "ENETUNREACH"
+          | ENETRESET -> "ENETRESET"
+          | ECONNABORTED -> "ECONNABORTED"
+          | ECONNRESET -> "ECONNRESET"
+          | ENOBUFS -> "ENOBUFS"
+          | EISCONN -> "EISCONN"
+          | ENOTCONN -> "ENOTCONN"
+          | ESHUTDOWN -> "ESHUTDOWN"
+          | ETOOMANYREFS -> "ETOOMANYREFS"
+          | ETIMEDOUT -> "ETIMEDOUT"
+          | ECONNREFUSED -> "ECONNREFUSED"
+          | EHOSTDOWN -> "EHOSTDOWN"
+          | EHOSTUNREACH -> "EHOSTUNREACH"
+          | ELOOP -> "ELOOP"
+          | EOVERFLOW -> "EOVERFLOW"
+          | EUNKNOWNERR x -> Printf.sprintf "EUNKNOWNERR %d" x in
+          Some (Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" msg s s')
+      | _ -> None)
+
+let handle_unix_error f arg =
+  try
+    f arg
+  with Unix_error(err, fun_name, arg) ->
+    prerr_string Sys.argv.(0);
+    prerr_string ": \"";
+    prerr_string fun_name;
+    prerr_string "\" failed";
+    if String.length arg > 0 then begin
+      prerr_string " on \"";
+      prerr_string arg;
+      prerr_string "\""
+    end;
+    prerr_string ": ";
+    prerr_endline (error_message err);
+    exit 2
+
+external environment : unit -> string array = "unix_environment"
+external getenv: string -> string = "caml_sys_getenv"
+(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *)
+external putenv: string -> string -> unit = "unix_putenv"
+
+type process_status =
+    WEXITED of int
+  | WSIGNALED of int
+  | WSTOPPED of int
+
+type wait_flag =
+    WNOHANG
+  | WUNTRACED
+
+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 fork : unit -> int = "unix_fork"
+external wait : unit -> int * process_status = "unix_wait"
+external waitpid : wait_flag list -> int -> int * process_status
+   = "unix_waitpid"
+external getpid : unit -> int = "unix_getpid"
+external getppid : unit -> int = "unix_getppid"
+external nice : int -> int = "unix_nice"
+
+type file_descr = int
+
+let stdin = 0
+let stdout = 1
+let stderr = 2
+
+type open_flag =
+    O_RDONLY
+  | O_WRONLY
+  | O_RDWR
+  | O_NONBLOCK
+  | O_APPEND
+  | O_CREAT
+  | O_TRUNC
+  | O_EXCL
+  | O_NOCTTY
+  | O_DSYNC
+  | O_SYNC
+  | O_RSYNC
+  | O_SHARE_DELETE
+  | O_CLOEXEC
+  | O_KEEPEXEC
+
+type file_perm = int
+
+
+external openfile : string -> open_flag list -> file_perm -> file_descr
+           = "unix_open"
+
+external close : file_descr -> unit = "unix_close"
+external unsafe_read : file_descr -> bytes -> int -> int -> int
+   = "unix_read"
+external unsafe_write : file_descr -> bytes -> int -> int -> int = "unix_write"
+external unsafe_single_write : file_descr -> bytes -> int -> int -> int
+   = "unix_single_write"
+
+let read fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.read"
+  else unsafe_read fd buf ofs len
+let write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > Bytes.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).
+   single_write fixes this by never calling write twice. *)
+let single_write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.single_write"
+  else unsafe_single_write fd buf ofs len
+
+let write_substring fd buf ofs len =
+  write fd (Bytes.unsafe_of_string buf) ofs len
+
+let single_write_substring fd buf ofs len =
+  single_write fd (Bytes.unsafe_of_string buf) ofs len
+
+external in_channel_of_descr : file_descr -> in_channel
+                             = "caml_ml_open_descriptor_in"
+external out_channel_of_descr : file_descr -> out_channel
+                              = "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
+                              = "caml_channel_descriptor"
+
+type seek_command =
+    SEEK_SET
+  | SEEK_CUR
+  | SEEK_END
+
+external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
+external truncate : string -> int -> unit = "unix_truncate"
+external ftruncate : file_descr -> int -> unit = "unix_ftruncate"
+
+type file_kind =
+    S_REG
+  | S_DIR
+  | S_CHR
+  | S_BLK
+  | S_LNK
+  | S_FIFO
+  | S_SOCK
+
+type stats =
+  { st_dev : int;
+    st_ino : int;
+    st_kind : file_kind;
+    st_perm : file_perm;
+    st_nlink : int;
+    st_uid : int;
+    st_gid : int;
+    st_rdev : int;
+    st_size : int;
+    st_atime : float;
+    st_mtime : float;
+    st_ctime : float }
+
+external stat : string -> stats = "unix_stat"
+external lstat : string -> stats = "unix_lstat"
+external fstat : file_descr -> stats = "unix_fstat"
+external isatty : file_descr -> bool = "unix_isatty"
+external unlink : string -> unit = "unix_unlink"
+external rename : string -> string -> unit = "unix_rename"
+external link : string -> string -> unit = "unix_link"
+
+module LargeFile =
+  struct
+    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 =
+      { st_dev : int;
+        st_ino : int;
+        st_kind : file_kind;
+        st_perm : file_perm;
+        st_nlink : int;
+        st_uid : int;
+        st_gid : int;
+        st_rdev : int;
+        st_size : int64;
+        st_atime : float;
+        st_mtime : float;
+        st_ctime : float;
+      }
+    external stat : string -> stats = "unix_stat_64"
+    external lstat : string -> stats = "unix_lstat_64"
+    external fstat : file_descr -> stats = "unix_fstat_64"
+  end
+
+type access_permission =
+    R_OK
+  | W_OK
+  | X_OK
+  | F_OK
+
+external chmod : string -> file_perm -> unit = "unix_chmod"
+external fchmod : file_descr -> file_perm -> unit = "unix_fchmod"
+external chown : string -> int -> int -> unit = "unix_chown"
+external fchown : file_descr -> int -> int -> unit = "unix_fchown"
+external umask : int -> int = "unix_umask"
+external access : string -> access_permission list -> unit = "unix_access"
+
+external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
+external dup2 :
+   ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2"
+external set_nonblock : file_descr -> unit = "unix_set_nonblock"
+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"
+
+external mkdir : string -> file_perm -> unit = "unix_mkdir"
+external rmdir : string -> unit = "unix_rmdir"
+external chdir : string -> unit = "unix_chdir"
+external getcwd : unit -> string = "unix_getcwd"
+external chroot : string -> unit = "unix_chroot"
+
+type dir_handle
+
+external opendir : string -> dir_handle = "unix_opendir"
+external readdir : dir_handle -> string = "unix_readdir"
+external rewinddir : dir_handle -> unit = "unix_rewinddir"
+external closedir : dir_handle -> unit = "unix_closedir"
+
+external pipe :
+  ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
+external symlink : ?to_dir:bool -> string -> string -> unit = "unix_symlink"
+external has_symlink : unit -> bool = "unix_has_symlink"
+external readlink : string -> string = "unix_readlink"
+external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
+external select :
+  file_descr list -> file_descr list -> file_descr list -> float ->
+        file_descr list * file_descr list * file_descr list = "unix_select"
+
+type lock_command =
+    F_ULOCK
+  | F_LOCK
+  | F_TLOCK
+  | F_TEST
+  | F_RLOCK
+  | F_TRLOCK
+
+external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf"
+external kill : int -> int -> unit = "unix_kill"
+type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
+external sigprocmask: sigprocmask_command -> int list -> int list
+        = "unix_sigprocmask"
+external sigpending: unit -> int list = "unix_sigpending"
+external sigsuspend: int list -> unit = "unix_sigsuspend"
+
+let pause() =
+  let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs
+
+type process_times =
+  { tms_utime : float;
+    tms_stime : float;
+    tms_cutime : float;
+    tms_cstime : float }
+
+type tm =
+  { tm_sec : int;
+    tm_min : int;
+    tm_hour : int;
+    tm_mday : int;
+    tm_mon : int;
+    tm_year : int;
+    tm_wday : int;
+    tm_yday : int;
+    tm_isdst : bool }
+
+external time : unit -> float = "unix_time"
+external gettimeofday : unit -> float = "unix_gettimeofday"
+external gmtime : float -> tm = "unix_gmtime"
+external localtime : float -> tm = "unix_localtime"
+external mktime : tm -> float * tm = "unix_mktime"
+external alarm : int -> int = "unix_alarm"
+external sleepf : float -> unit = "unix_sleep"
+let sleep duration = sleepf (float duration)
+external times : unit -> process_times = "unix_times"
+external utimes : string -> float -> float -> unit = "unix_utimes"
+
+type interval_timer =
+    ITIMER_REAL
+  | ITIMER_VIRTUAL
+  | ITIMER_PROF
+
+type interval_timer_status =
+  { it_interval: float;                 (* Period *)
+    it_value: float }                   (* Current value of the timer *)
+
+external getitimer: interval_timer -> interval_timer_status = "unix_getitimer"
+external setitimer:
+  interval_timer -> interval_timer_status -> interval_timer_status
+  = "unix_setitimer"
+
+external getuid : unit -> int = "unix_getuid"
+external geteuid : unit -> int = "unix_geteuid"
+external setuid : int -> unit = "unix_setuid"
+external getgid : unit -> int = "unix_getgid"
+external getegid : unit -> int = "unix_getegid"
+external setgid : int -> unit = "unix_setgid"
+external getgroups : unit -> int array = "unix_getgroups"
+external setgroups : int array -> unit = "unix_setgroups"
+external initgroups : string -> int -> unit = "unix_initgroups"
+
+type passwd_entry =
+  { pw_name : string;
+    pw_passwd : string;
+    pw_uid : int;
+    pw_gid : int;
+    pw_gecos : string;
+    pw_dir : string;
+    pw_shell : string }
+
+type group_entry =
+  { gr_name : string;
+    gr_passwd : string;
+    gr_gid : int;
+    gr_mem : string array }
+
+
+external getlogin : unit -> string = "unix_getlogin"
+external getpwnam : string -> passwd_entry = "unix_getpwnam"
+external getgrnam : string -> group_entry = "unix_getgrnam"
+external getpwuid : int -> passwd_entry = "unix_getpwuid"
+external getgrgid : int -> group_entry = "unix_getgrgid"
+
+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"
+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
+  | SOCK_DGRAM
+  | SOCK_RAW
+  | SOCK_SEQPACKET
+
+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
+  | SHUTDOWN_ALL
+
+type msg_flag =
+    MSG_OOB
+  | MSG_DONTROUTE
+  | MSG_PEEK
+
+external socket : 
+  ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
+  = "unix_socket"
+external socketpair :
+  ?cloexec: bool -> socket_domain -> socket_type -> int ->
+                                           file_descr * file_descr
+  = "unix_socketpair"
+external accept :
+  ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
+external bind : file_descr -> sockaddr -> unit = "unix_bind"
+external connect : file_descr -> sockaddr -> unit = "unix_connect"
+external listen : file_descr -> int -> unit = "unix_listen"
+external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown"
+external getsockname : file_descr -> sockaddr = "unix_getsockname"
+external getpeername : file_descr -> sockaddr = "unix_getpeername"
+
+external unsafe_recv :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int
+                                  = "unix_recv"
+external unsafe_recvfrom :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr
+                                  = "unix_recvfrom"
+external unsafe_send :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int
+                                  = "unix_send"
+external unsafe_sendto :
+  file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int
+                                  = "unix_sendto" "unix_sendto_native"
+
+let recv fd buf ofs len flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.recv"
+  else unsafe_recv fd buf ofs len flags
+let recvfrom fd buf ofs len flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.recvfrom"
+  else unsafe_recvfrom fd buf ofs len flags
+let send fd buf ofs len flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.send"
+  else unsafe_send fd buf ofs len flags
+let sendto fd buf ofs len flags addr =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.sendto"
+  else unsafe_sendto fd buf ofs len flags addr
+
+let send_substring fd buf ofs len flags =
+  send fd (Bytes.unsafe_of_string buf) ofs len flags
+
+let sendto_substring fd buf ofs len flags addr =
+  sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr
+
+type socket_bool_option =
+    SO_DEBUG
+  | SO_BROADCAST
+  | SO_REUSEADDR
+  | SO_KEEPALIVE
+  | SO_DONTROUTE
+  | SO_OOBINLINE
+  | SO_ACCEPTCONN
+  | TCP_NODELAY
+  | IPV6_ONLY
+
+type socket_int_option =
+    SO_SNDBUF
+  | SO_RCVBUF
+  | SO_ERROR
+  | SO_TYPE
+  | SO_RCVLOWAT
+  | SO_SNDLOWAT
+
+type socket_optint_option = SO_LINGER
+
+type socket_float_option =
+    SO_RCVTIMEO
+  | SO_SNDTIMEO
+
+type socket_error_option = SO_ERROR
+
+module SO: sig
+  type ('opt, 'v) t
+  val bool: (socket_bool_option, bool) t
+  val int: (socket_int_option, int) t
+  val optint: (socket_optint_option, int option) t
+  val float: (socket_float_option, float) t
+  val error: (socket_error_option, error option) t
+  val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
+  val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
+end = struct
+  type ('opt, 'v) t = int
+  let bool = 0
+  let int = 1
+  let optint = 2
+  let float = 3
+  let error = 4
+  external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
+              = "unix_getsockopt"
+  external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
+              = "unix_setsockopt"
+end
+
+let getsockopt fd opt = SO.get SO.bool fd opt
+let setsockopt fd opt v = SO.set SO.bool fd opt v
+
+let getsockopt_int fd opt = SO.get SO.int fd opt
+let setsockopt_int fd opt v = SO.set SO.int fd opt v
+
+let getsockopt_optint fd opt = SO.get SO.optint fd opt
+let setsockopt_optint fd opt v = SO.set SO.optint fd opt v
+
+let getsockopt_float fd opt = SO.get SO.float fd opt
+let setsockopt_float fd opt v = SO.set SO.float fd opt v
+
+let getsockopt_error fd = SO.get SO.error fd SO_ERROR
+
+type host_entry =
+  { h_name : string;
+    h_aliases : string array;
+    h_addrtype : socket_domain;
+    h_addr_list : inet_addr array }
+
+type protocol_entry =
+  { p_name : string;
+    p_aliases : string array;
+    p_proto : int }
+
+type service_entry =
+  { s_name : string;
+    s_aliases : string array;
+    s_port : int;
+    s_proto : string }
+
+external gethostname : unit -> string = "unix_gethostname"
+external gethostbyname : string -> host_entry = "unix_gethostbyname"
+external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr"
+external getprotobyname : string -> protocol_entry
+                                         = "unix_getprotobyname"
+external getprotobynumber : int -> protocol_entry
+                                         = "unix_getprotobynumber"
+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;
+    mutable c_ignpar: bool;
+    mutable c_parmrk: bool;
+    mutable c_inpck: bool;
+    mutable c_istrip: bool;
+    mutable c_inlcr: bool;
+    mutable c_igncr: bool;
+    mutable c_icrnl: bool;
+    mutable c_ixon: bool;
+    mutable c_ixoff: bool;
+    mutable c_opost: bool;
+    mutable c_obaud: int;
+    mutable c_ibaud: int;
+    mutable c_csize: int;
+    mutable c_cstopb: int;
+    mutable c_cread: bool;
+    mutable c_parenb: bool;
+    mutable c_parodd: bool;
+    mutable c_hupcl: bool;
+    mutable c_clocal: bool;
+    mutable c_isig: bool;
+    mutable c_icanon: bool;
+    mutable c_noflsh: bool;
+    mutable c_echo: bool;
+    mutable c_echoe: bool;
+    mutable c_echok: bool;
+    mutable c_echonl: bool;
+    mutable c_vintr: char;
+    mutable c_vquit: char;
+    mutable c_verase: char;
+    mutable c_vkill: char;
+    mutable c_veof: char;
+    mutable c_veol: char;
+    mutable c_vmin: int;
+    mutable c_vtime: int;
+    mutable c_vstart: char;
+    mutable c_vstop: char
+  }
+
+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"
+external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak"
+external tcdrain: file_descr -> unit = "unix_tcdrain"
+
+type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
+
+external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush"
+
+type flow_action = TCOOFF | TCOON | TCIOFF | TCION
+
+external tcflow: file_descr -> flow_action -> unit = "unix_tcflow"
+
+external setsid : unit -> int = "unix_setsid"
+
+(* High-level process management (system, popen) *)
+
+let rec waitpid_non_intr pid =
+  try waitpid [] pid
+  with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let system cmd =
+  match fork() with
+     0 -> begin try
+            execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
+          with _ ->
+            sys_exit 127
+          end
+  | id -> snd(waitpid_non_intr id)
+
+(* Duplicate [fd] if needed to make sure it isn't one of the
+   standard descriptors (stdin, stdout, stderr).
+   Note that this function always leaves the standard descriptors open,
+   the caller must take care of closing them if needed.
+   The "cloexec" mode doesn't matter, because
+   the descriptor returned by [dup] will be closed before the [exec],
+   and because no other thread is running concurrently
+   (we are in the child process of a fork).
+ *)
+let rec file_descr_not_standard fd =
+  if fd >= 3 then fd else file_descr_not_standard (dup fd)
+
+let safe_close fd =
+  try close fd with Unix_error(_,_,_) -> ()
+
+let perform_redirections new_stdin new_stdout new_stderr =
+  let new_stdin = file_descr_not_standard new_stdin in
+  let new_stdout = file_descr_not_standard new_stdout in
+  let new_stderr = file_descr_not_standard new_stderr in
+  (*  The three dup2 close the original stdin, stdout, stderr,
+      which are the descriptors possibly left open
+      by file_descr_not_standard *)
+  dup2 ~cloexec:false new_stdin stdin;
+  dup2 ~cloexec:false new_stdout stdout;
+  dup2 ~cloexec:false new_stderr stderr;
+  safe_close new_stdin;
+  safe_close new_stdout;
+  safe_close new_stderr
+
+let create_process cmd args new_stdin new_stdout new_stderr =
+  match fork() with
+    0 ->
+      begin try
+        perform_redirections new_stdin new_stdout new_stderr;
+        execvp cmd args
+      with _ ->
+        sys_exit 127
+      end
+  | id -> id
+
+let create_process_env cmd args env new_stdin new_stdout new_stderr =
+  match fork() with
+    0 ->
+      begin try
+        perform_redirections new_stdin new_stdout new_stderr;
+        execvpe cmd args env
+      with _ ->
+        sys_exit 127
+      end
+  | id -> id
+
+type popen_process =
+    Process of in_channel * out_channel
+  | Process_in of in_channel
+  | Process_out of out_channel
+  | Process_full of in_channel * out_channel * in_channel
+
+let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
+
+let open_proc cmd envopt proc input output error =
+   match fork() with
+     0 -> perform_redirections input output error;
+          let shell = "/bin/sh" in
+          let argv = [| shell; "-c"; cmd |] in
+          begin try
+            match envopt with
+            | Some env -> execve shell argv env
+            | None     -> execv shell argv
+          with _ ->
+            sys_exit 127
+          end
+   | id -> Hashtbl.add popen_processes proc id
+
+let open_process_in cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let inchan = in_channel_of_descr in_read in
+  begin
+    try
+      open_proc cmd None (Process_in inchan) stdin in_write stderr
+    with e ->
+      close_in inchan;
+      close in_write;
+      raise e
+  end;
+  close in_write;
+  inchan
+
+let open_process_out cmd =
+  let (out_read, out_write) = pipe ~cloexec:true () in
+  let outchan = out_channel_of_descr out_write in
+  begin
+    try
+      open_proc cmd None (Process_out outchan) out_read stdout stderr
+    with e ->
+    close_out outchan;
+    close out_read;
+    raise e
+  end;
+  close out_read;
+  outchan
+
+let open_process cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let (out_read, out_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write; raise e in
+  let inchan = in_channel_of_descr in_read in
+  let outchan = out_channel_of_descr out_write in
+  begin
+    try
+      open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
+    with e ->
+      close out_read; close out_write;
+      close in_read; close in_write;
+      raise e
+  end;
+  close out_read;
+  close in_write;
+  (inchan, outchan)
+
+let open_process_full cmd env =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let (out_read, out_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write; raise e in
+  let (err_read, err_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write;
+              close out_read; close out_write; raise e in
+  let inchan = in_channel_of_descr in_read in
+  let outchan = out_channel_of_descr out_write in
+  let errchan = in_channel_of_descr err_read in
+  begin
+    try
+      open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
+                out_read in_write err_write
+    with e ->
+      close out_read; close out_write;
+      close in_read; close in_write;
+      close err_read; close err_write; 
+      raise e
+  end;
+  close out_read;
+  close in_write;
+  close err_write;
+  (inchan, outchan, errchan)
+
+let find_proc_id fun_name proc =
+  try
+    let pid = Hashtbl.find popen_processes proc in
+    Hashtbl.remove popen_processes proc;
+    pid
+  with Not_found ->
+    raise(Unix_error(EBADF, fun_name, ""))
+
+let close_process_in inchan =
+  let pid = find_proc_id "close_process_in" (Process_in inchan) in
+  close_in inchan;
+  snd(waitpid_non_intr pid)
+
+let close_process_out outchan =
+  let pid = find_proc_id "close_process_out" (Process_out outchan) in
+  (* The application may have closed [outchan] already to signal
+     end-of-input to the process.  *)
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr pid)
+
+let close_process (inchan, outchan) =
+  let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  snd(waitpid_non_intr pid)
+
+let close_process_full (inchan, outchan, errchan) =
+  let pid =
+    find_proc_id "close_process_full"
+                 (Process_full(inchan, outchan, errchan)) in
+  close_in inchan;
+  begin try close_out outchan with Sys_error _ -> () end;
+  close_in errchan;
+  snd(waitpid_non_intr pid)
+
+(* High-level network functions *)
+
+let open_connection sockaddr =
+  let sock =
+    socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+  try
+    connect sock sockaddr;
+    (in_channel_of_descr sock, out_channel_of_descr sock)
+  with exn ->
+    close sock; raise exn
+
+let shutdown_connection inchan =
+  shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
+
+let rec accept_non_intr s =
+  try accept ~cloexec:true s
+  with Unix_error (EINTR, _, _) -> accept_non_intr s
+
+let establish_server server_fun sockaddr =
+  let sock =
+    socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+  setsockopt sock SO_REUSEADDR true;
+  bind sock sockaddr;
+  listen sock 5;
+  while true do
+    let (s, _caller) = accept_non_intr sock in
+    (* The "double fork" trick, the process which calls server_fun will not
+       leave a zombie process *)
+    match fork() with
+       0 -> if fork() <> 0 then sys_exit 0;
+                                (* The son exits, the grandson works *)
+            close sock;
+            let inchan = in_channel_of_descr s in
+            let outchan = out_channel_of_descr s in
+            server_fun inchan outchan;
+            (* Do not close inchan nor outchan, as the server_fun could
+               have done it already, and we are about to exit anyway
+               (PR#3794) *)
+            exit 0
+    | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *)
+  done
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
new file mode 100644
index 00000000..e414be00
--- /dev/null
+++ b/otherlibs/unix/unix.mli
@@ -0,0 +1,1611 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Interface to the Unix system.
+
+    Note: all the functions of this module (except {!error_message} and
+    {!handle_unix_error}) are liable to raise the {!Unix_error}
+    exception whenever the underlying system call signals an error. *)
+
+
+(** {6 Error report} *)
+
+
+type error =
+    E2BIG               (** Argument list too long *)
+  | EACCES              (** Permission denied *)
+  | EAGAIN              (** Resource temporarily unavailable; try again *)
+  | EBADF               (** Bad file descriptor *)
+  | EBUSY               (** Resource unavailable *)
+  | ECHILD              (** No child process *)
+  | EDEADLK             (** Resource deadlock would occur *)
+  | EDOM                (** Domain error for math functions, etc. *)
+  | EEXIST              (** File exists *)
+  | EFAULT              (** Bad address *)
+  | EFBIG               (** File too large *)
+  | EINTR               (** Function interrupted by signal *)
+  | EINVAL              (** Invalid argument *)
+  | EIO                 (** Hardware I/O error *)
+  | EISDIR              (** Is a directory *)
+  | EMFILE              (** Too many open files by the process *)
+  | EMLINK              (** Too many links *)
+  | ENAMETOOLONG        (** Filename too long *)
+  | ENFILE              (** Too many open files in the system *)
+  | ENODEV              (** No such device *)
+  | ENOENT              (** No such file or directory *)
+  | ENOEXEC             (** Not an executable file *)
+  | ENOLCK              (** No locks available *)
+  | ENOMEM              (** Not enough memory *)
+  | ENOSPC              (** No space left on device *)
+  | ENOSYS              (** Function not supported *)
+  | ENOTDIR             (** Not a directory *)
+  | ENOTEMPTY           (** Directory not empty *)
+  | ENOTTY              (** Inappropriate I/O control operation *)
+  | ENXIO               (** No such device or address *)
+  | EPERM               (** Operation not permitted *)
+  | EPIPE               (** Broken pipe *)
+  | ERANGE              (** Result too large *)
+  | EROFS               (** Read-only file system *)
+  | ESPIPE              (** Invalid seek e.g. on a pipe *)
+  | ESRCH               (** No such process *)
+  | EXDEV               (** Invalid link *)
+  | EWOULDBLOCK         (** Operation would block *)
+  | EINPROGRESS         (** Operation now in progress *)
+  | EALREADY            (** Operation already in progress *)
+  | ENOTSOCK            (** Socket operation on non-socket *)
+  | EDESTADDRREQ        (** Destination address required *)
+  | EMSGSIZE            (** Message too long *)
+  | EPROTOTYPE          (** Protocol wrong type for socket *)
+  | ENOPROTOOPT         (** Protocol not available *)
+  | EPROTONOSUPPORT     (** Protocol not supported *)
+  | ESOCKTNOSUPPORT     (** Socket type not supported *)
+  | EOPNOTSUPP          (** Operation not supported on socket *)
+  | EPFNOSUPPORT        (** Protocol family not supported *)
+  | EAFNOSUPPORT        (** Address family not supported by protocol family *)
+  | EADDRINUSE          (** Address already in use *)
+  | EADDRNOTAVAIL       (** Can't assign requested address *)
+  | ENETDOWN            (** Network is down *)
+  | ENETUNREACH         (** Network is unreachable *)
+  | ENETRESET           (** Network dropped connection on reset *)
+  | ECONNABORTED        (** Software caused connection abort *)
+  | ECONNRESET          (** Connection reset by peer *)
+  | ENOBUFS             (** No buffer space available *)
+  | EISCONN             (** Socket is already connected *)
+  | ENOTCONN            (** Socket is not connected *)
+  | ESHUTDOWN           (** Can't send after socket shutdown *)
+  | ETOOMANYREFS        (** Too many references: can't splice *)
+  | ETIMEDOUT           (** Connection timed out *)
+  | ECONNREFUSED        (** Connection refused *)
+  | EHOSTDOWN           (** Host is down *)
+  | EHOSTUNREACH        (** No route to host *)
+  | ELOOP               (** Too many levels of symbolic links *)
+  | EOVERFLOW           (** File size or position not representable *)
+
+  | EUNKNOWNERR of int  (** Unknown error *)
+(** The type of error codes.
+   Errors defined in the POSIX standard
+   and additional errors from UNIX98 and BSD.
+   All other errors are mapped to EUNKNOWNERR.
+*)
+
+
+exception Unix_error of error * string * string
+(** Raised by the system calls below when an error is encountered.
+   The first component is the error code; the second component
+   is the function name; the third component is the string parameter
+   to the function, if it has one, or the empty string otherwise. *)
+
+val error_message : error -> string
+(** Return a string describing the given error code. *)
+
+val handle_unix_error : ('a -> 'b) -> 'a -> 'b
+(** [handle_unix_error f x] applies [f] to [x] and returns the result.
+   If the exception {!Unix_error} is raised, it prints a message
+   describing the error and exits with code 2. *)
+
+
+(** {6 Access to the process environment} *)
+
+
+val environment : unit -> string array
+(** Return the process environment, as an array of strings
+    with the format ``variable=value''. *)
+
+val getenv : string -> string
+(** Return the value associated to a variable in the process
+   environment, unless the process has special privileges.
+   @raise Not_found if the variable is unbound or the process has
+   special privileges.
+
+   (This function is identical to {!Sys.getenv}. *)
+
+(*
+val unsafe_getenv : string -> string
+(** Return the value associated to a variable in the process
+   environment.
+
+   Unlike {!getenv}, this function returns the value even if the
+   process has special privileges. It is considered unsafe because the
+   programmer of a setuid or setgid program must be careful to avoid
+   using maliciously crafted environment variables in the search path
+   for executables, the locations for temporary files or logs, and the
+   like.
+
+   @raise Not_found if the variable is unbound.  *)
+*)
+
+val putenv : string -> string -> unit
+(** [Unix.putenv name value] sets the value associated to a
+   variable in the process environment.
+   [name] is the name of the environment variable,
+   and [value] its new associated value. *)
+
+
+(** {6 Process handling} *)
+
+
+type process_status =
+    WEXITED of int
+        (** The process terminated normally by [exit];
+           the argument is the return code. *)
+  | WSIGNALED of int
+        (** The process was killed by a signal;
+           the argument is the signal number. *)
+  | WSTOPPED of int
+        (** The process was stopped by a signal; the argument is the
+           signal number. *)
+(** The termination status of a process.  See module {!Sys} for the
+    definitions of the standard signal numbers.  Note that they are
+    not the numbers used by the OS. *)
+
+
+type wait_flag =
+    WNOHANG (** Do not block if no child has
+               died yet, but immediately return with a pid equal to 0.*)
+  | WUNTRACED (** Report also the children that receive stop signals. *)
+(** Flags for {!Unix.waitpid}. *)
+
+val execv : string -> string array -> 'a
+(** [execv prog args] execute the program in file [prog], with
+   the arguments [args], and the current process environment.
+   These [execv*] functions never return: on success, the current
+   program is replaced by the new one.
+   @raise Unix.Unix_error on failure. *)
+
+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 -> 'a
+(** Same as {!Unix.execv}, except that
+   the program is searched in the path. *)
+
+val execvpe : string -> string array -> string array -> 'a
+(** Same as {!Unix.execve}, except that
+   the program is searched in the path. *)
+
+val fork : unit -> int
+(** Fork a new process. The returned integer is 0 for the child
+   process, the pid of the child process for the parent process.
+
+   On Windows: not implemented, use {!create_process} or threads. *)
+
+val wait : unit -> int * process_status
+(** Wait until one of the children processes die, and return its pid
+   and termination status.
+
+   On Windows: Not implemented, use {!waitpid}. *)
+
+val waitpid : wait_flag list -> int -> int * process_status
+(** 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.
+   Negative pid arguments represent process groups.
+   The list of options indicates whether [waitpid] should return
+   immediately without waiting, and whether it should report stopped
+   children.
+
+   On Windows, this function can only wait for a given PID, not any
+   child process. *)
+
+val system : string -> process_status
+(** Execute the given command, wait until it terminates, and return
+   its termination status. The string is interpreted by the shell
+   [/bin/sh] (or the command interpreter [cmd.exe] on Windows) and
+   therefore can contain redirections, quotes, variables, etc. The
+   result [WEXITED 127] indicates that the shell couldn't be
+   executed. *)
+
+val getpid : unit -> int
+(** Return the pid of the process. *)
+
+val getppid : unit -> int
+(** Return the pid of the parent process.
+   On Windows: not implemented (because it is meaningless). *)
+
+val nice : int -> int
+(** Change the process priority. The integer argument is added to the
+   ``nice'' value. (Higher values of the ``nice'' value mean
+   lower priorities.) Return the new nice value.
+
+   On Windows: not implemented. *)
+
+
+(** {6 Basic file input/output} *)
+
+
+type file_descr
+(** The abstract type of file descriptors. *)
+
+val stdin : file_descr
+(** File descriptor for standard input.*)
+
+val stdout : file_descr
+(** File descriptor for standard output.*)
+
+val stderr : file_descr
+(** File descriptor for standard error. *)
+
+type open_flag =
+    O_RDONLY                    (** Open for reading *)
+  | O_WRONLY                    (** Open for writing *)
+  | O_RDWR                      (** Open for reading and writing *)
+  | O_NONBLOCK                  (** Open in non-blocking mode *)
+  | O_APPEND                    (** Open for append *)
+  | O_CREAT                     (** Create if nonexistent *)
+  | O_TRUNC                     (** Truncate to 0 length if existing *)
+  | O_EXCL                      (** Fail if existing *)
+  | O_NOCTTY                    (** Don't make this dev a controlling tty *)
+  | O_DSYNC                     (** Writes complete as `Synchronised I/O data
+                                   integrity completion' *)
+  | O_SYNC                      (** Writes complete as `Synchronised I/O file
+                                   integrity completion' *)
+  | O_RSYNC                     (** Reads complete as writes (depending on
+                                   O_SYNC/O_DSYNC) *)
+  | O_SHARE_DELETE              (** Windows only: allow the file to be deleted
+                                   while still open *)
+  | O_CLOEXEC                   (** Set the close-on-exec flag on the
+                                   descriptor returned by {!openfile}.
+                                   See {!set_close_on_exec} for more
+                                   information. *)
+  | O_KEEPEXEC                  (** Clear the close-on-exec flag.
+                                    This is currently the default. *)
+(** The flags to {!Unix.openfile}. *)
+
+
+type file_perm = int
+(** 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 the
+   permissions to give to the file if it is created (see
+   {!umask}). Return a file descriptor on the named file. *)
+
+val close : file_descr -> unit
+(** Close a file descriptor. *)
+
+val read : file_descr -> bytes -> int -> int -> int
+(** [read fd buff ofs len] reads [len] bytes from descriptor [fd],
+    storing them in byte sequence [buff], starting at position [ofs] in
+    [buff]. Return the number of bytes actually read. *)
+
+val write : file_descr -> bytes -> int -> int -> int
+(** [write fd buff ofs len] writes [len] bytes to descriptor [fd],
+    taking them from byte sequence [buff], starting at position [ofs]
+    in [buff]. Return the number of bytes actually written.  [write]
+    repeats the writing operation until all bytes have been written or
+    an error occurs.  *)
+
+val single_write : file_descr -> bytes -> 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. *)
+
+val write_substring : file_descr -> string -> int -> int -> int
+(** Same as [write], but take the data from a string instead of a byte
+    sequence.
+    @since 4.02.0 *)
+
+val single_write_substring : file_descr -> string -> int -> int -> int
+(** Same as [single_write], but take the data from a string instead of
+    a byte sequence.
+    @since 4.02.0 *)
+
+(** {6 Interfacing with the standard input/output library} *)
+
+
+
+val in_channel_of_descr : file_descr -> in_channel
+(** Create an input channel reading from the given descriptor.
+   The channel is initially in binary mode; use
+   [set_binary_mode_in ic false] if text mode is desired.
+   Text mode is supported only if the descriptor refers to a file
+   or pipe, but is not supported if it refers to a socket.
+   On Windows, [set_binary_mode_in] always fails on channels created
+   with this function.
+
+   Beware that channels are buffered so more characters may have been
+   read from the file descriptor than those accessed using channel functions.
+   Channels also keep a copy of the current position in the file.
+
+   You need to explicitly close all channels created with this function.
+   Closing the channel also closes the underlying file descriptor (unless
+   it was already closed). *)
+
+val out_channel_of_descr : file_descr -> out_channel
+(** Create an output channel writing on the given descriptor.
+   The channel is initially in binary mode; use
+   [set_binary_mode_out oc false] if text mode is desired.
+   Text mode is supported only if the descriptor refers to a file
+   or pipe, but is not supported if it refers to a socket.
+   On Windows, [set_binary_mode_out] always fails on channels created
+   with this function.
+
+   Beware that channels are buffered so you may have to [flush] them
+   to ensure that all data has been sent to the file descriptor.
+   Channels also keep a copy of the current position in the file.
+
+   You need to explicitly close all channels created with this function.
+   Closing the channel flushes the data and closes the underlying file
+   descriptor (unless it has already been closed, in which case the
+   buffered data is lost).*)
+
+val descr_of_in_channel : in_channel -> file_descr
+(** Return the descriptor corresponding to an input channel. *)
+
+val descr_of_out_channel : out_channel -> file_descr
+(** Return the descriptor corresponding to an output channel. *)
+
+
+(** {6 Seeking and truncating} *)
+
+
+type seek_command =
+    SEEK_SET (** indicates positions relative to the beginning of the file *)
+  | SEEK_CUR (** indicates positions relative to the current position *)
+  | SEEK_END (** indicates positions relative to the end of the file *)
+(** Positioning modes for {!Unix.lseek}. *)
+
+
+val lseek : file_descr -> int -> seek_command -> int
+(** Set the current position for a file descriptor, and return the resulting
+    offset (from the beginning of the file). *)
+
+val truncate : string -> int -> unit
+(** Truncates the named file to the given size.
+
+  On Windows: not implemented. *)
+
+val ftruncate : file_descr -> int -> unit
+(** Truncates the file corresponding to the given descriptor
+   to the given size.
+
+  On Windows: not implemented. *)
+
+
+(** {6 File status} *)
+
+
+type file_kind =
+    S_REG                       (** Regular file *)
+  | S_DIR                       (** Directory *)
+  | S_CHR                       (** Character device *)
+  | S_BLK                       (** Block device *)
+  | S_LNK                       (** Symbolic link *)
+  | S_FIFO                      (** Named pipe *)
+  | S_SOCK                      (** Socket *)
+
+type stats =
+  { st_dev : int;               (** Device number *)
+    st_ino : int;               (** Inode number *)
+    st_kind : file_kind;        (** Kind of the file *)
+    st_perm : file_perm;        (** Access rights *)
+    st_nlink : int;             (** Number of links *)
+    st_uid : int;               (** User id of the owner *)
+    st_gid : int;               (** Group ID of the file's group *)
+    st_rdev : int;              (** Device minor number *)
+    st_size : int;              (** Size in bytes *)
+    st_atime : float;           (** Last access time *)
+    st_mtime : float;           (** Last modification time *)
+    st_ctime : float;           (** Last status change time *)
+  }
+(** The information returned by the {!Unix.stat} calls. *)
+
+val stat : string -> stats
+(** Return the information for the named file. *)
+
+val lstat : string -> stats
+(** Same as {!Unix.stat}, but in case the file is a symbolic link,
+   return the information for the link itself. *)
+
+val fstat : file_descr -> stats
+(** Return the information for the file associated with the given
+   descriptor. *)
+
+val isatty : file_descr -> bool
+(** Return [true] if the given file descriptor refers to a terminal or
+   console window, [false] otherwise. *)
+
+(** {6 File operations on large files} *)
+
+module LargeFile :
+  sig
+    val lseek : file_descr -> int64 -> seek_command -> int64
+    (** See {!Unix.lseek}. *)
+
+    val truncate : string -> int64 -> unit
+    (** See {!Unix.truncate}. *)
+
+    val ftruncate : file_descr -> int64 -> unit
+    (** See {!Unix.ftruncate}. *)
+
+    type stats =
+      { st_dev : int;               (** Device number *)
+        st_ino : int;               (** Inode number *)
+        st_kind : file_kind;        (** Kind of the file *)
+        st_perm : file_perm;        (** Access rights *)
+        st_nlink : int;             (** Number of links *)
+        st_uid : int;               (** User id of the owner *)
+        st_gid : int;               (** Group ID of the file's group *)
+        st_rdev : int;              (** Device minor number *)
+        st_size : int64;            (** Size in bytes *)
+        st_atime : float;           (** Last access time *)
+        st_mtime : float;           (** Last modification time *)
+        st_ctime : float;           (** Last status change time *)
+      }
+    val stat : string -> stats
+    val lstat : string -> stats
+    val fstat : file_descr -> stats
+  end
+(** File operations on large files.
+  This sub-module provides 64-bit variants of the functions
+  {!Unix.lseek} (for positioning a file descriptor),
+  {!Unix.truncate} and {!Unix.ftruncate} (for changing the size of a file),
+  and {!Unix.stat}, {!Unix.lstat} and {!Unix.fstat} (for obtaining
+  information on files).  These alternate functions represent
+  positions and sizes by 64-bit integers (type [int64]) instead of
+  regular integers (type [int]), thus allowing operating on files
+  whose sizes are greater than [max_int]. *)
+
+(** {6 Operations on file names} *)
+
+
+val unlink : string -> unit
+(** Removes the named file.
+
+    If the named file is a directory, raises:
+    {ul
+    {- [EPERM] on POSIX compliant system}
+    {- [EISDIR] on Linux >= 2.1.132}
+    {- [EACCESS] on Windows}}
+*)
+
+val rename : string -> string -> unit
+(** [rename old new] changes the name of a file from [old] to [new]. *)
+
+val link : string -> string -> unit
+(** [link source dest] creates a hard link named [dest] to the file
+   named [source]. *)
+
+
+(** {6 File permissions and ownership} *)
+
+
+type access_permission =
+    R_OK                        (** Read permission *)
+  | W_OK                        (** Write permission *)
+  | X_OK                        (** Execution permission *)
+  | F_OK                        (** File exists *)
+(** Flags for the {!Unix.access} call. *)
+
+
+val chmod : string -> file_perm -> unit
+(** Change the permissions of the named file. *)
+
+val fchmod : file_descr -> file_perm -> unit
+(** Change the permissions of an opened file.
+    On Windows: not implemented. *)
+
+val chown : string -> int -> int -> unit
+(** Change the owner uid and owner gid of the named file.
+    On Windows: not implemented (make no sense on a DOS file system). *)
+
+val fchown : file_descr -> int -> int -> unit
+(** Change the owner uid and owner gid of an opened file.
+    On Windows: not implemented (make no sense on a DOS file system).  *)
+
+val umask : int -> int
+(** Set the process's file mode creation mask, and return the previous
+    mask.
+    On Windows: not implemented. *)
+
+val access : string -> access_permission list -> unit
+(** Check that the process has the given permissions over the named file.
+   @raise Unix_error otherwise.
+
+   On Windows, execute permission [X_OK], cannot be tested, it just
+   tests for read permission instead. *)
+
+
+(** {6 Operations on file descriptors} *)
+
+
+val dup : ?cloexec:bool -> file_descr -> file_descr
+(** Return a new file descriptor referencing the same file as
+   the given descriptor.
+   See {!set_close_on_exec} for documentation on the [cloexec]
+   optional argument. *)
+
+val dup2 : ?cloexec:bool -> file_descr -> file_descr -> unit
+(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
+   opened.
+   See {!set_close_on_exec} for documentation on the [cloexec]
+   optional argument. *)
+
+val set_nonblock : file_descr -> unit
+(** Set the ``non-blocking'' flag on the given descriptor.
+   When the non-blocking flag is set, reading on a descriptor
+   on which there is temporarily no data available raises the
+   [EAGAIN] or [EWOULDBLOCK] error instead of blocking;
+   writing on a descriptor on which there is temporarily no room
+   for writing also raises [EAGAIN] or [EWOULDBLOCK]. *)
+
+val clear_nonblock : file_descr -> unit
+(** Clear the ``non-blocking'' flag on the given descriptor.
+   See {!Unix.set_nonblock}.*)
+
+val set_close_on_exec : file_descr -> unit
+(** Set the ``close-on-exec'' flag on the given descriptor.
+   A descriptor with the close-on-exec flag is automatically
+   closed when the current process starts another program with
+   one of the [exec], [create_process] and [open_process] functions.
+
+   It is often a security hole to leak file descriptors opened on, say,
+   a private file to an external program: the program, then, gets access
+   to the private file and can do bad things with it.  Hence, it is
+   highly recommended to set all file descriptors ``close-on-exec'',
+   except in the very few cases where a file descriptor actually needs
+   to be transmitted to another program.  
+
+   The best way to set a file descriptor ``close-on-exec'' is to create
+   it in this state.  To this end, the [openfile] function has
+   [O_CLOEXEC] and [O_KEEPEXEC] flags to enforce ``close-on-exec'' mode
+   or ``keep-on-exec'' mode, respectively.  All other operations in
+   the Unix module that create file descriptors have an optional
+   argument [?cloexec:bool] to indicate whether the file descriptor
+   should be created in ``close-on-exec'' mode (by writing
+   [~cloexec:true]) or in ``keep-on-exec'' mode (by writing
+   [~cloexec:false]).  For historical reasons, the default file
+   descriptor creation mode is ``keep-on-exec'', if no [cloexec] optional
+   argument is given.  This is not a safe default, hence it is highly
+   recommended to pass explicit [cloexec] arguments to operations that
+   create file descriptors.
+
+   The [cloexec] optional arguments and the [O_KEEPEXEC] flag were introduced
+   in OCaml 4.05.  Earlier, the common practice was to create file descriptors
+   in the default, ``keep-on-exec'' mode, then call [set_close_on_exec]
+   on those freshly-created file descriptors.  This is not as safe as
+   creating the file descriptor in ``close-on-exec'' mode because, in
+   multithreaded programs, a window of vulnerability exists between the time
+   when the file descriptor is created and the time [set_close_on_exec]
+   completes.  If another thread spawns another program during this window,
+   the descriptor will leak, as it is still in the ``keep-on-exec'' mode.
+
+   Regarding the atomicity guarantees given by [~cloexec:true] or by
+   the use of the [O_CLOEXEC] flag: on all platforms it is guaranteed
+   that a concurrently-executing Caml thread cannot leak the descriptor
+   by starting a new process.  On Linux, this guarantee extends to
+   concurrently-executing C threads.  As of Feb 2017, other operating
+   systems lack the necessary system calls and still expose a window
+   of vulnerability during which a C thread can see the newly-created
+   file descriptor in ``keep-on-exec'' mode.
+ *)
+
+val clear_close_on_exec : file_descr -> unit
+(** Clear the ``close-on-exec'' flag on the given descriptor.
+   See {!Unix.set_close_on_exec}.*)
+
+
+(** {6 Directories} *)
+
+
+val mkdir : string -> file_perm -> unit
+(** Create a directory with the given permissions (see {!umask}). *)
+
+val rmdir : string -> unit
+(** Remove an empty directory. *)
+
+val chdir : string -> unit
+(** Change the process working directory. *)
+
+val getcwd : unit -> string
+(** Return the name of the current working directory. *)
+
+val chroot : string -> unit
+(** Change the process root directory.
+    On Windows: not implemented. *)
+
+type dir_handle
+(** The type of descriptors over opened directories. *)
+
+val opendir : string -> dir_handle
+(** Open a descriptor on a directory *)
+
+val readdir : dir_handle -> string
+(** Return the next entry in a directory.
+   @raise End_of_file when the end of the directory has been reached. *)
+
+val rewinddir : dir_handle -> unit
+(** Reposition the descriptor to the beginning of the directory *)
+
+val closedir : dir_handle -> unit
+(** Close a directory descriptor. *)
+
+
+
+(** {6 Pipes and redirections} *)
+
+
+val pipe : ?cloexec:bool -> unit -> file_descr * file_descr
+(** Create a pipe. The first component of the result is opened
+   for reading, that's the exit to the pipe. The second component is
+   opened for writing, that's the entrance to the pipe.
+   See {!set_close_on_exec} for documentation on the [cloexec]
+   optional argument. *)
+
+val mkfifo : string -> file_perm -> unit
+(** Create a named pipe with the given permissions (see {!umask}).
+   On Windows: not implemented. *)
+
+
+(** {6 High-level process and redirection management} *)
+
+
+val create_process :
+  string -> string array -> file_descr -> file_descr -> file_descr -> int
+(** [create_process prog args new_stdin new_stdout new_stderr]
+   forks a new process that executes the program
+   in file [prog], with arguments [args]. The pid of the new
+   process is returned immediately; the new process executes
+   concurrently with the current process.
+   The standard input and outputs of the new process are connected
+   to the descriptors [new_stdin], [new_stdout] and [new_stderr].
+   Passing e.g. [stdout] for [new_stdout] prevents the redirection
+   and causes the new process to have the same standard output
+   as the current process.
+   The executable file [prog] is searched in the path.
+   The new process has the same environment as the current process. *)
+
+val create_process_env :
+  string -> string array -> string array -> file_descr -> file_descr ->
+    file_descr -> int
+(** [create_process_env prog args env new_stdin new_stdout new_stderr]
+   works as {!Unix.create_process}, except that the extra argument
+   [env] specifies the environment passed to the program. *)
+
+
+val open_process_in : string -> in_channel
+(** High-level pipe and process management. This function
+   runs the given command in parallel with the program.
+   The standard output of the command is redirected to a pipe,
+   which can be read via the returned input channel.
+   The command is interpreted by the shell [/bin/sh]
+   (or [cmd.exe] on Windows), cf. [system]. *)
+
+val open_process_out : string -> out_channel
+(** Same as {!Unix.open_process_in}, but redirect the standard input of
+   the command to a pipe.  Data written to the returned output channel
+   is sent to the standard input of the command.
+   Warning: writes on output channels are buffered, hence be careful
+   to call {!Pervasives.flush} at the right times to ensure
+   correct synchronization. *)
+
+val open_process : string -> in_channel * out_channel
+(** Same as {!Unix.open_process_out}, but redirects both the standard input
+   and standard output of the command to pipes connected to the two
+   returned channels.  The input channel is connected to the output
+   of the command, and the output channel to the input of the command. *)
+
+val open_process_full :
+  string -> string array -> in_channel * out_channel * in_channel
+(** Similar to {!Unix.open_process}, but the second argument specifies
+   the environment passed to the command.  The result is a triple
+   of channels connected respectively to the standard output, standard input,
+   and standard error of the command. *)
+
+val close_process_in : in_channel -> process_status
+(** Close channels opened by {!Unix.open_process_in},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+val close_process_out : out_channel -> process_status
+(** Close channels opened by {!Unix.open_process_out},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+val close_process : in_channel * out_channel -> process_status
+(** Close channels opened by {!Unix.open_process},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+val close_process_full :
+  in_channel * out_channel * in_channel -> process_status
+(** Close channels opened by {!Unix.open_process_full},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+
+(** {6 Symbolic links} *)
+
+
+val symlink : ?to_dir:bool -> string -> string -> unit
+(** [symlink ?to_dir source dest] creates the file [dest] as a symbolic link
+   to the file [source]. On Windows, [~to_dir] indicates if the symbolic link
+   points to a directory or a file; if omitted, [symlink] examines [source]
+   using [stat] and picks appropriately, if [source] does not exist then [false]
+   is assumed (for this reason, it is recommended that the [~to_dir] parameter
+   be specified in new code). On Unix, [~to_dir] is ignored.
+
+   Windows symbolic links are available in Windows Vista onwards. There are some
+   important differences between Windows symlinks and their POSIX counterparts.
+
+   Windows symbolic links come in two flavours: directory and regular, which
+   designate whether the symbolic link points to a directory or a file. The type
+   must be correct - a directory symlink which actually points to a file cannot
+   be selected with chdir and a file symlink which actually points to a
+   directory cannot be read or written (note that Cygwin's emulation layer
+   ignores this distinction).
+
+   When symbolic links are created to existing targets, this distinction doesn't
+   matter and [symlink] will automatically create the correct kind of symbolic
+   link. The distinction matters when a symbolic link is created to a
+   non-existent target.
+
+   The other caveat is that by default symbolic links are a privileged
+   operation. Administrators will always need to be running elevated (or with
+   UAC disabled) and by default normal user accounts need to be granted the
+   SeCreateSymbolicLinkPrivilege via Local Security Policy (secpol.msc) or via
+   Active Directory.
+
+   {!has_symlink} can be used to check that a process is able to create symbolic
+   links. *)
+
+val has_symlink : unit -> bool
+(** Returns [true] if the user is able to create symbolic links. On Windows,
+   this indicates that the user not only has the SeCreateSymbolicLinkPrivilege
+   but is also running elevated, if necessary. On other platforms, this is
+   simply indicates that the symlink system call is available.
+   @since 4.03.0 *)
+
+val readlink : string -> string
+(** Read the contents of a symbolic link. *)
+
+
+(** {6 Polling} *)
+
+
+val select :
+  file_descr list -> file_descr list -> file_descr list -> float ->
+    file_descr list * file_descr list * file_descr list
+(** Wait until some input/output operations become possible on
+   some channels. The three list arguments are, respectively, a set
+   of descriptors to check for reading (first argument), for writing
+   (second argument), or for exceptional conditions (third argument).
+   The fourth argument is the maximal timeout, in seconds; a
+   negative fourth argument means no timeout (unbounded wait).
+   The result is composed of three sets of descriptors: those ready
+   for reading (first component), ready for writing (second component),
+   and over which an exceptional condition is pending (third
+   component). *)
+
+
+(** {6 Locking} *)
+
+type lock_command =
+    F_ULOCK       (** Unlock a region *)
+  | F_LOCK        (** Lock a region for writing, and block if already locked *)
+  | F_TLOCK       (** Lock a region for writing, or fail if already locked *)
+  | F_TEST        (** Test a region for other process locks *)
+  | F_RLOCK       (** Lock a region for reading, and block if already locked *)
+  | F_TRLOCK      (** Lock a region for reading, or fail if already locked *)
+(** Commands for {!Unix.lockf}. *)
+
+val lockf : file_descr -> lock_command -> int -> unit
+(** [lockf fd cmd size] puts a lock on a region of the file opened
+   as [fd]. The region starts at the current read/write position for
+   [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 prevents any other
+   process from acquiring a read or write lock on the region.
+   A read lock prevents any other
+   process from acquiring a write lock on the region, but lets
+   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.
+
+   What happens when a process tries to lock a region of a file that is
+   already locked by the same process depends on the OS.  On POSIX-compliant
+   systems, the second lock operation succeeds and may "promote" the older
+   lock from read lock to write lock.  On Windows, the second lock
+   operation will block or fail.
+*)
+
+
+(** {6 Signals}
+   Note: installation of signal handlers is performed via
+   the functions {!Sys.signal} and {!Sys.set_signal}.
+*)
+
+val kill : int -> int -> unit
+(** [kill pid sig] sends signal number [sig] to the process
+   with id [pid].  On Windows, only the {!Sys.sigkill} signal
+   is emulated. *)
+
+type sigprocmask_command =
+    SIG_SETMASK
+  | SIG_BLOCK
+  | SIG_UNBLOCK
+
+val sigprocmask : sigprocmask_command -> int list -> int list
+(** [sigprocmask cmd sigs] changes the set of blocked signals.
+   If [cmd] is [SIG_SETMASK], blocked signals are set to those in
+   the list [sigs].
+   If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to
+   the set of blocked signals.
+   If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed
+   from the set of blocked signals.
+   [sigprocmask] returns the set of previously blocked signals.
+
+   On Windows: not implemented (no inter-process signals on Windows). *)
+
+val sigpending : unit -> int list
+(** Return the set of blocked signals that are currently pending.
+
+   On Windows: not implemented (no inter-process signals on Windows). *)
+
+val sigsuspend : int list -> unit
+(** [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.
+
+   On Windows: not implemented (no inter-process signals on Windows). *)
+
+val pause : unit -> unit
+(** Wait until a non-ignored, non-blocked signal is delivered.
+
+  On Windows: not implemented (no inter-process signals on Windows). *)
+
+
+(** {6 Time functions} *)
+
+
+type process_times =
+  { tms_utime : float;  (** User time for the process *)
+    tms_stime : float;  (** System time for the process *)
+    tms_cutime : float; (** User time for the children processes *)
+    tms_cstime : float; (** System time for the children processes *)
+  }
+(** The execution times (CPU times) of a process. *)
+
+type tm =
+  { tm_sec : int;               (** Seconds 0..60 *)
+    tm_min : int;               (** Minutes 0..59 *)
+    tm_hour : int;              (** Hours 0..23 *)
+    tm_mday : int;              (** Day of month 1..31 *)
+    tm_mon : int;               (** Month of year 0..11 *)
+    tm_year : int;              (** Year - 1900 *)
+    tm_wday : int;              (** Day of week (Sunday is 0) *)
+    tm_yday : int;              (** Day of year 0..365 *)
+    tm_isdst : bool;            (** Daylight time savings in effect *)
+  }
+(** The type representing wallclock time and calendar date. *)
+
+
+val time : unit -> float
+(** Return the current time since 00:00:00 GMT, Jan. 1, 1970,
+   in seconds. *)
+
+val gettimeofday : unit -> float
+(** Same as {!Unix.time}, but with resolution better than 1 second. *)
+
+val gmtime : float -> tm
+(** Convert a time in seconds, as returned by {!Unix.time}, into a date and
+   a time. Assumes UTC (Coordinated Universal Time), also known as GMT.
+   To perform the inverse conversion, set the TZ environment variable
+   to "UTC", use {!mktime}, and then restore the original value of TZ. *)
+
+val localtime : float -> tm
+(** Convert a time in seconds, as returned by {!Unix.time}, into a date and
+   a time. Assumes the local time zone.
+   The function performing the inverse conversion is {!mktime}. *)
+
+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}.  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.
+
+   On Windows: not implemented. *)
+
+val sleep : int -> unit
+(** Stop execution for the given number of seconds. *)
+
+val sleepf : float -> unit
+(** Stop execution for the given number of seconds.  Like [sleep],
+    but fractions of seconds are supported.
+
+    @since 4.03.0 *)
+
+val times : unit -> process_times
+(** Return the execution times of the process.
+   On Windows, it is partially implemented, will not report timings
+   for child processes. *)
+
+val utimes : string -> float -> float -> unit
+(** Set the last access time (second arg) and last modification time
+   (third arg) for a file. Times are expressed in seconds from
+   00:00:00 GMT, Jan. 1, 1970.  If both times are [0.0], the access
+   and last modification times are both set to the current time. *)
+
+type interval_timer =
+    ITIMER_REAL
+      (** decrements in real time, and sends the signal [SIGALRM] when
+         expired.*)
+  | ITIMER_VIRTUAL
+      (** decrements in process virtual time, and sends [SIGVTALRM]
+          when expired. *)
+  | ITIMER_PROF
+      (** (for profiling) decrements both when the process
+         is running and when the system is running on behalf of the
+         process; it sends [SIGPROF] when expired. *)
+(** The three kinds of interval timers. *)
+
+type interval_timer_status =
+  { it_interval : float;         (** Period *)
+    it_value : float;            (** Current value of the timer *)
+  }
+(** The type describing the status of an interval timer *)
+
+val getitimer : interval_timer -> interval_timer_status
+(** Return the current status of the given interval timer.
+
+   On Windows: not implemented. *)
+
+val setitimer :
+  interval_timer -> interval_timer_status -> interval_timer_status
+(** [setitimer t s] sets the interval timer [t] and returns
+   its previous status. The [s] argument is interpreted as follows:
+   [s.it_value], if nonzero, is the time to the next timer expiration;
+   [s.it_interval], if nonzero, specifies a value to
+   be used in reloading [it_value] when the timer expires.
+   Setting [s.it_value] to zero disables the timer.
+   Setting [s.it_interval] to zero causes the timer to be disabled
+   after its next expiration.
+
+   On Windows: not implemented. *)
+
+
+(** {6 User id, group id} *)
+
+
+val getuid : unit -> int
+(** Return the user id of the user executing the process.
+   On Windows, always return [1]. *)
+
+val geteuid : unit -> int
+(** Return the effective user id under which the process runs.
+   On Windows, always return [1]. *)
+
+val setuid : int -> unit
+(** Set the real user id and effective user id for the process.
+   On Windows: not implemented. *)
+
+val getgid : unit -> int
+(** Return the group id of the user executing the process.
+   On Windows, always return [1]. *)
+
+val getegid : unit -> int
+(** Return the effective group id under which the process runs.
+   On Windows, always return [1]. *)
+
+val setgid : int -> unit
+(** Set the real group id and effective group id for the process.
+   On Windows: not implemented. *)
+
+val getgroups : unit -> int array
+(** Return the list of groups to which the user executing the process
+   belongs.
+   On Windows, always return [[|1|]]. *)
+
+val setgroups : int array -> unit
+(** [setgroups groups] sets the supplementary group IDs for the
+    calling process. Appropriate privileges are required.
+    On Windows: not implemented. *)
+
+val initgroups : string -> int -> unit
+(** [initgroups user group] initializes the group access list by
+    reading the group database /etc/group and using all groups of
+    which [user] is a member. The additional group [group] is also
+    added to the list.
+    On Windows: not implemented. *)
+
+type passwd_entry =
+  { pw_name : string;
+    pw_passwd : string;
+    pw_uid : int;
+    pw_gid : int;
+    pw_gecos : string;
+    pw_dir : string;
+    pw_shell : string
+  }
+(** Structure of entries in the [passwd] database. *)
+
+type group_entry =
+  { gr_name : string;
+    gr_passwd : string;
+    gr_gid : int;
+    gr_mem : string array
+  }
+(** Structure of entries in the [groups] database. *)
+
+val getlogin : unit -> string
+(** Return the login name of the user executing the process. *)
+
+val getpwnam : string -> passwd_entry
+(** Find an entry in [passwd] with the given name.
+   @raise Not_found if no such entry exist.
+
+   On Windows, always raise [Not_found]. *)
+
+val getgrnam : string -> group_entry
+(** Find an entry in [group] with the given name.
+   @raise Not_found if no such entry exist.
+
+   On Windows, always raise [Not_found]. *)
+
+val getpwuid : int -> passwd_entry
+(** Find an entry in [passwd] with the given user id.
+   @raise Not_found if no such entry exist.
+
+   On Windows, always raise [Not_found]. *)
+
+val getgrgid : int -> group_entry
+(** Find an entry in [group] with the given group id.
+   @raise Not_found if no such entry exist.
+
+   On Windows, always raise [Not_found]. *)
+
+
+(** {6 Internet addresses} *)
+
+
+type inet_addr
+(** The abstract type of Internet addresses. *)
+
+val inet_addr_of_string : string -> inet_addr
+(** 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
+(** 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 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 (IPv4) *)
+  | PF_INET6                    (** Internet domain (IPv6) *)
+(** The type of socket domains.  Not all platforms support
+    IPv6 sockets (type [PF_INET6]).  Windows does not support
+    [PF_UNIX]. *)
+
+type socket_type =
+    SOCK_STREAM                 (** Stream socket *)
+  | SOCK_DGRAM                  (** Datagram socket *)
+  | SOCK_RAW                    (** Raw socket *)
+  | SOCK_SEQPACKET              (** Sequenced packets socket *)
+(** The type of socket kinds, specifying the semantics of
+   communications.  [SOCK_SEQPACKET] is included for completeness,
+   but is rarely supported by the OS, and needs system calls that
+   are not available in this library. *)
+
+type sockaddr =
+    ADDR_UNIX of string
+  | ADDR_INET of inet_addr * int
+(** The type of socket addresses. [ADDR_UNIX name] is a socket
+   address in the Unix domain; [name] is a file name in the file
+   system. [ADDR_INET(addr,port)] is a socket address in the Internet
+   domain; [addr] is the Internet address of the machine, and
+   [port] is the port number. *)
+
+val socket :
+    ?cloexec:bool -> socket_domain -> socket_type -> int -> file_descr
+(** Create a new socket in the given domain, and with the
+   given kind. The third argument is the protocol type; 0 selects
+   the default protocol for that kind of sockets.
+   See {!set_close_on_exec} for documentation on the [cloexec]
+   optional argument. *)
+
+val domain_of_sockaddr: sockaddr -> socket_domain
+(** Return the socket domain adequate for the given socket address. *)
+
+val socketpair :
+     ?cloexec:bool -> socket_domain -> socket_type -> int ->
+                                                 file_descr * file_descr
+(** Create a pair of unnamed sockets, connected together.
+   See {!set_close_on_exec} for documentation on the [cloexec]
+   optional argument. *)
+
+val accept : ?cloexec:bool -> file_descr -> file_descr * sockaddr
+(** Accept connections on the given socket. The returned descriptor
+   is a socket connected to the client; the returned address is
+   the address of the connecting client.
+   See {!set_close_on_exec} for documentation on the [cloexec]
+   optional argument. *)
+
+val bind : file_descr -> sockaddr -> unit
+(** Bind a socket to an address. *)
+
+val connect : file_descr -> sockaddr -> unit
+(** Connect a socket to an address. *)
+
+val listen : file_descr -> int -> unit
+(** Set up a socket for receiving connection requests. The integer
+   argument is the maximal number of pending requests. *)
+
+type shutdown_command =
+    SHUTDOWN_RECEIVE            (** Close for receiving *)
+  | SHUTDOWN_SEND               (** Close for sending *)
+  | SHUTDOWN_ALL                (** Close both *)
+(** The type of commands for [shutdown]. *)
+
+
+val shutdown : file_descr -> shutdown_command -> unit
+(** Shutdown a socket connection. [SHUTDOWN_SEND] as second argument
+   causes reads on the other end of the connection to return
+   an end-of-file condition.
+   [SHUTDOWN_RECEIVE] causes writes on the other end of the connection
+   to return a closed pipe condition ([SIGPIPE] signal). *)
+
+val getsockname : file_descr -> sockaddr
+(** Return the address of the given socket. *)
+
+val getpeername : file_descr -> sockaddr
+(** Return the address of the host connected to the given socket. *)
+
+type msg_flag =
+    MSG_OOB
+  | MSG_DONTROUTE
+  | MSG_PEEK
+(** The flags for {!Unix.recv},  {!Unix.recvfrom},
+   {!Unix.send} and {!Unix.sendto}. *)
+
+val recv : file_descr -> bytes -> int -> int -> msg_flag list -> int
+(** Receive data from a connected socket. *)
+
+val recvfrom :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr
+(** Receive data from an unconnected socket. *)
+
+val send : file_descr -> bytes -> int -> int -> msg_flag list -> int
+(** Send data over a connected socket. *)
+
+val send_substring : file_descr -> string -> int -> int -> msg_flag list -> int
+(** Same as [send], but take the data from a string instead of a byte
+    sequence.
+    @since 4.02.0 *)
+
+val sendto :
+  file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int
+(** Send data over an unconnected socket. *)
+
+val sendto_substring :
+  file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int
+(** Same as [sendto], but take the data from a string instead of a
+    byte sequence.
+    @since 4.02.0 *)
+
+
+(** {6 Socket options} *)
+
+
+type socket_bool_option =
+    SO_DEBUG       (** Record debugging information *)
+  | SO_BROADCAST   (** Permit sending of broadcast messages *)
+  | SO_REUSEADDR   (** Allow reuse of local addresses for bind *)
+  | SO_KEEPALIVE   (** Keep connection active *)
+  | SO_DONTROUTE   (** Bypass the standard routing algorithms *)
+  | SO_OOBINLINE   (** Leave out-of-band data in line *)
+  | SO_ACCEPTCONN  (** Report whether socket listening is enabled *)
+  | TCP_NODELAY    (** Control the Nagle algorithm for TCP sockets *)
+  | IPV6_ONLY      (** Forbid binding an IPv6 socket to an IPv4 address *)
+(** The socket options that can be consulted with {!Unix.getsockopt}
+   and modified with {!Unix.setsockopt}.  These options have a boolean
+   ([true]/[false]) value. *)
+
+type socket_int_option =
+    SO_SNDBUF      (** Size of send buffer *)
+  | SO_RCVBUF      (** Size of received buffer *)
+  | SO_ERROR       (** Deprecated.  Use {!Unix.getsockopt_error} instead. *)
+  | SO_TYPE        (** Report the socket type *)
+  | SO_RCVLOWAT    (** Minimum number of bytes to process for input operations*)
+  | SO_SNDLOWAT    (** Minimum number of bytes to process for output
+                       operations *)
+(** The socket options that can be consulted with {!Unix.getsockopt_int}
+   and modified with {!Unix.setsockopt_int}.  These options have an
+   integer value. *)
+
+type socket_optint_option =
+  SO_LINGER      (** Whether to linger on closed connections
+                    that have data present, and for how long
+                    (in seconds) *)
+(** The socket options that can be consulted with {!Unix.getsockopt_optint}
+   and modified with {!Unix.setsockopt_optint}.  These options have a
+   value of type [int option], with [None] meaning ``disabled''. *)
+
+type socket_float_option =
+    SO_RCVTIMEO    (** Timeout for input operations *)
+  | SO_SNDTIMEO    (** Timeout for output operations *)
+(** The socket options that can be consulted with {!Unix.getsockopt_float}
+   and modified with {!Unix.setsockopt_float}.  These options have a
+   floating-point value representing a time in seconds.
+   The value 0 means infinite timeout. *)
+
+val getsockopt : file_descr -> socket_bool_option -> bool
+(** Return the current status of a boolean-valued option
+   in the given socket. *)
+
+val setsockopt : file_descr -> socket_bool_option -> bool -> unit
+(** Set or clear a boolean-valued option in the given socket. *)
+
+val getsockopt_int : file_descr -> socket_int_option -> int
+(** Same as {!Unix.getsockopt} for an integer-valued socket option. *)
+
+val setsockopt_int : file_descr -> socket_int_option -> int -> unit
+(** Same as {!Unix.setsockopt} for an integer-valued socket option. *)
+
+val getsockopt_optint : file_descr -> socket_optint_option -> int option
+(** Same as {!Unix.getsockopt} for a socket option whose value is an
+   [int option]. *)
+
+val setsockopt_optint :
+      file_descr -> socket_optint_option -> int option -> unit
+(** Same as {!Unix.setsockopt} for a socket option whose value is an
+   [int option]. *)
+
+val getsockopt_float : file_descr -> socket_float_option -> float
+(** Same as {!Unix.getsockopt} for a socket option whose value is a
+   floating-point number. *)
+
+val setsockopt_float : file_descr -> socket_float_option -> float -> unit
+(** Same as {!Unix.setsockopt} for a socket option whose value is a
+   floating-point number. *)
+
+val getsockopt_error : file_descr -> error option
+(** Return the error condition associated with the given socket,
+    and clear it. *)
+
+
+(** {6 High-level network connection functions} *)
+
+
+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. *)
+
+val shutdown_connection : in_channel -> unit
+(** ``Shut down'' a connection established with {!Unix.open_connection};
+   that is, transmit an end-of-file condition to the server reading
+   on the other side of the connection. This does not fully close the
+   file descriptor associated with the channel, which you must remember
+   to free via {!Pervasives.close_in}. *)
+
+val establish_server : (in_channel -> out_channel -> unit) -> sockaddr -> unit
+(** Establish a server on the given address.
+   The function given as first argument is called for each connection
+   with two buffered channels connected to the client. A new process
+   is created for each connection. The function {!Unix.establish_server}
+   never returns normally.
+
+   On Windows, it is not implemented.  Use threads. *)
+
+
+(** {6 Host and protocol databases} *)
+
+
+type host_entry =
+  { h_name : string;
+    h_aliases : string array;
+    h_addrtype : socket_domain;
+    h_addr_list : inet_addr array
+  }
+(** Structure of entries in the [hosts] database. *)
+
+type protocol_entry =
+  { p_name : string;
+    p_aliases : string array;
+    p_proto : int
+  }
+(** Structure of entries in the [protocols] database. *)
+
+type service_entry =
+  { s_name : string;
+    s_aliases : string array;
+    s_port : int;
+    s_proto : string
+  }
+(** Structure of entries in the [services] database. *)
+
+val gethostname : unit -> string
+(** Return the name of the local host. *)
+
+val gethostbyname : string -> host_entry
+(** Find an entry in [hosts] with the given name.
+    @raise Not_found if no such entry exist. *)
+
+val gethostbyaddr : inet_addr -> host_entry
+(** Find an entry in [hosts] with the given address.
+    @raise Not_found if no such entry exist. *)
+
+val getprotobyname : string -> protocol_entry
+(** Find an entry in [protocols] with the given name.
+    @raise Not_found if no such entry exist. *)
+
+val getprotobynumber : int -> protocol_entry
+(** Find an entry in [protocols] with the given protocol number.
+    @raise Not_found if no such entry exist. *)
+
+val getservbyname : string -> string -> service_entry
+(** Find an entry in [services] with the given name.
+    @raise Not_found if no such entry exist. *)
+
+val getservbyport : int -> string -> service_entry
+(** Find an entry in [services] with the given service number.
+    @raise Not_found if no such entry exist. *)
+
+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} *)
+
+
+(** The following functions implement the POSIX standard terminal
+   interface. They provide control over asynchronous communication ports
+   and pseudo-terminals. Refer to the [termios] man page for a
+   complete description. *)
+
+type terminal_io =
+  {
+    (* input modes *)
+    mutable c_ignbrk : bool;  (** Ignore the break condition. *)
+    mutable c_brkint : bool;  (** Signal interrupt on break condition. *)
+    mutable c_ignpar : bool;  (** Ignore characters with parity errors. *)
+    mutable c_parmrk : bool;  (** Mark parity errors. *)
+    mutable c_inpck : bool;   (** Enable parity check on input. *)
+    mutable c_istrip : bool;  (** Strip 8th bit on input characters. *)
+    mutable c_inlcr : bool;   (** Map NL to CR on input. *)
+    mutable c_igncr : bool;   (** Ignore CR on input. *)
+    mutable c_icrnl : bool;   (** Map CR to NL on input. *)
+    mutable c_ixon : bool;    (** Recognize XON/XOFF characters on input. *)
+    mutable c_ixoff : bool;   (** Emit XON/XOFF chars to control input flow. *)
+    (* Output modes: *)
+    mutable c_opost : bool;   (** Enable output processing. *)
+    (* Control modes: *)
+    mutable c_obaud : int;    (** Output baud rate (0 means close connection).*)
+    mutable c_ibaud : int;    (** Input baud rate. *)
+    mutable c_csize : int;    (** Number of bits per character (5-8). *)
+    mutable c_cstopb : int;   (** Number of stop bits (1-2). *)
+    mutable c_cread : bool;   (** Reception is enabled. *)
+    mutable c_parenb : bool;  (** Enable parity generation and detection. *)
+    mutable c_parodd : bool;  (** Specify odd parity instead of even. *)
+    mutable c_hupcl : bool;   (** Hang up on last close. *)
+    mutable c_clocal : bool;  (** Ignore modem status lines. *)
+    (* Local modes: *)
+    mutable c_isig : bool;    (** Generate signal on INTR, QUIT, SUSP. *)
+    mutable c_icanon : bool;  (** Enable canonical processing
+                                 (line buffering and editing) *)
+    mutable c_noflsh : bool;  (** Disable flush after INTR, QUIT, SUSP. *)
+    mutable c_echo : bool;    (** Echo input characters. *)
+    mutable c_echoe : bool;   (** Echo ERASE (to erase previous character). *)
+    mutable c_echok : bool;   (** Echo KILL (to erase the current line). *)
+    mutable c_echonl : bool;  (** Echo NL even if c_echo is not set. *)
+    (* Control characters: *)
+    mutable c_vintr : char;   (** Interrupt character (usually ctrl-C). *)
+    mutable c_vquit : char;   (** Quit character (usually ctrl-\). *)
+    mutable c_verase : char;  (** Erase character (usually DEL or ctrl-H). *)
+    mutable c_vkill : char;   (** Kill line character (usually ctrl-U). *)
+    mutable c_veof : char;    (** End-of-file character (usually ctrl-D). *)
+    mutable c_veol : char;    (** Alternate end-of-line char. (usually none). *)
+    mutable c_vmin : int;     (** Minimum number of characters to read
+                                 before the read request is satisfied. *)
+    mutable c_vtime : int;    (** Maximum read wait (in 0.1s units). *)
+    mutable c_vstart : char;  (** Start character (usually ctrl-Q). *)
+    mutable c_vstop : char;   (** Stop character (usually ctrl-S). *)
+  }
+
+val tcgetattr : file_descr -> terminal_io
+(** Return the status of the terminal referred to by the given
+   file descriptor.
+   On Windows, not implemented. *)
+
+type setattr_when =
+    TCSANOW
+  | TCSADRAIN
+  | TCSAFLUSH
+
+val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit
+(** Set the status of the terminal referred to by the given
+   file descriptor. The second argument indicates when the
+   status change takes place: immediately ([TCSANOW]),
+   when all pending output has been transmitted ([TCSADRAIN]),
+   or after flushing all input that has been received but not
+   read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing
+   the output parameters; [TCSAFLUSH], when changing the input
+   parameters.
+
+   On Windows, not implemented. *)
+
+val tcsendbreak : file_descr -> int -> unit
+(** Send a break condition on the given file descriptor.
+   The second argument is the duration of the break, in 0.1s units;
+   0 means standard duration (0.25s).
+
+   On Windows, not implemented. *)
+
+val tcdrain : file_descr -> unit
+(** Waits until all output written on the given file descriptor
+   has been transmitted.
+
+   On Windows, not implemented. *)
+
+type flush_queue =
+    TCIFLUSH
+  | TCOFLUSH
+  | TCIOFLUSH
+
+val tcflush : file_descr -> flush_queue -> unit
+(** Discard data written on the given file descriptor but not yet
+   transmitted, or data received but not yet read, depending on the
+   second argument: [TCIFLUSH] flushes data received but not read,
+   [TCOFLUSH] flushes data written but not transmitted, and
+   [TCIOFLUSH] flushes both.
+
+   On Windows, not implemented. *)
+
+type flow_action =
+    TCOOFF
+  | TCOON
+  | TCIOFF
+  | TCION
+
+val tcflow : file_descr -> flow_action -> unit
+(** Suspend or restart reception or transmission of data on
+   the given file descriptor, depending on the second argument:
+   [TCOOFF] suspends output, [TCOON] restarts output,
+   [TCIOFF] transmits a STOP character to suspend input,
+   and [TCION] transmits a START character to restart input.
+
+   On Windows, not implemented. *)
+
+val setsid : unit -> int
+(** Put the calling process in a new session and detach it from
+   its controlling terminal.
+
+   On Windows, not implemented. *)
diff --git a/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml
new file mode 100644
index 00000000..3da36995
--- /dev/null
+++ b/otherlibs/unix/unixLabels.ml
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [UnixLabels]: labelled Unix module *)
+
+include Unix
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
new file mode 100644
index 00000000..f1e68061
--- /dev/null
+++ b/otherlibs/unix/unixLabels.mli
@@ -0,0 +1,1401 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Interface to the Unix system.
+   To use as replacement to default {!Unix} module,
+   add [module Unix = UnixLabels] in your implementation.
+*)
+
+(** {6 Error report} *)
+
+
+type error = Unix.error =
+    E2BIG               (** Argument list too long *)
+  | EACCES              (** Permission denied *)
+  | EAGAIN              (** Resource temporarily unavailable; try again *)
+  | EBADF               (** Bad file descriptor *)
+  | EBUSY               (** Resource unavailable *)
+  | ECHILD              (** No child process *)
+  | EDEADLK             (** Resource deadlock would occur *)
+  | EDOM                (** Domain error for math functions, etc. *)
+  | EEXIST              (** File exists *)
+  | EFAULT              (** Bad address *)
+  | EFBIG               (** File too large *)
+  | EINTR               (** Function interrupted by signal *)
+  | EINVAL              (** Invalid argument *)
+  | EIO                 (** Hardware I/O error *)
+  | EISDIR              (** Is a directory *)
+  | EMFILE              (** Too many open files by the process *)
+  | EMLINK              (** Too many links *)
+  | ENAMETOOLONG        (** Filename too long *)
+  | ENFILE              (** Too many open files in the system *)
+  | ENODEV              (** No such device *)
+  | ENOENT              (** No such file or directory *)
+  | ENOEXEC             (** Not an executable file *)
+  | ENOLCK              (** No locks available *)
+  | ENOMEM              (** Not enough memory *)
+  | ENOSPC              (** No space left on device *)
+  | ENOSYS              (** Function not supported *)
+  | ENOTDIR             (** Not a directory *)
+  | ENOTEMPTY           (** Directory not empty *)
+  | ENOTTY              (** Inappropriate I/O control operation *)
+  | ENXIO               (** No such device or address *)
+  | EPERM               (** Operation not permitted *)
+  | EPIPE               (** Broken pipe *)
+  | ERANGE              (** Result too large *)
+  | EROFS               (** Read-only file system *)
+  | ESPIPE              (** Invalid seek e.g. on a pipe *)
+  | ESRCH               (** No such process *)
+  | EXDEV               (** Invalid link *)
+  | EWOULDBLOCK         (** Operation would block *)
+  | EINPROGRESS         (** Operation now in progress *)
+  | EALREADY            (** Operation already in progress *)
+  | ENOTSOCK            (** Socket operation on non-socket *)
+  | EDESTADDRREQ        (** Destination address required *)
+  | EMSGSIZE            (** Message too long *)
+  | EPROTOTYPE          (** Protocol wrong type for socket *)
+  | ENOPROTOOPT         (** Protocol not available *)
+  | EPROTONOSUPPORT     (** Protocol not supported *)
+  | ESOCKTNOSUPPORT     (** Socket type not supported *)
+  | EOPNOTSUPP          (** Operation not supported on socket *)
+  | EPFNOSUPPORT        (** Protocol family not supported *)
+  | EAFNOSUPPORT        (** Address family not supported by protocol family *)
+  | EADDRINUSE          (** Address already in use *)
+  | EADDRNOTAVAIL       (** Can't assign requested address *)
+  | ENETDOWN            (** Network is down *)
+  | ENETUNREACH         (** Network is unreachable *)
+  | ENETRESET           (** Network dropped connection on reset *)
+  | ECONNABORTED        (** Software caused connection abort *)
+  | ECONNRESET          (** Connection reset by peer *)
+  | ENOBUFS             (** No buffer space available *)
+  | EISCONN             (** Socket is already connected *)
+  | ENOTCONN            (** Socket is not connected *)
+  | ESHUTDOWN           (** Can't send after socket shutdown *)
+  | ETOOMANYREFS        (** Too many references: can't splice *)
+  | ETIMEDOUT           (** Connection timed out *)
+  | ECONNREFUSED        (** Connection refused *)
+  | EHOSTDOWN           (** Host is down *)
+  | EHOSTUNREACH        (** No route to host *)
+  | ELOOP               (** Too many levels of symbolic links *)
+  | EOVERFLOW           (** File size or position not representable *)
+
+  | EUNKNOWNERR of int  (** Unknown error *)
+(** The type of error codes.
+   Errors defined in the POSIX standard
+   and additional errors from UNIX98 and BSD.
+   All other errors are mapped to EUNKNOWNERR.
+*)
+
+
+exception Unix_error of error * string * string
+(** Raised by the system calls below when an error is encountered.
+   The first component is the error code; the second component
+   is the function name; the third component is the string parameter
+   to the function, if it has one, or the empty string otherwise. *)
+
+val error_message : error -> string
+(** Return a string describing the given error code. *)
+
+val handle_unix_error : ('a -> 'b) -> 'a -> 'b
+(** [handle_unix_error f x] applies [f] to [x] and returns the result.
+   If the exception [Unix_error] is raised, it prints a message
+   describing the error and exits with code 2. *)
+
+
+(** {6 Access to the process environment} *)
+
+
+val environment : unit -> string array
+(** Return the process environment, as an array of strings
+    with the format ``variable=value''. *)
+
+val getenv : string -> string
+(** Return the value associated to a variable in the process
+   environment. Raise [Not_found] if the variable is unbound.
+   (This function is identical to [Sys.getenv].) *)
+
+(*
+val unsafe_getenv : string -> string
+(** Return the value associated to a variable in the process
+   environment.
+
+   Unlike {!getenv}, this function returns the value even if the
+   process has special privileges. It is considered unsafe because the
+   programmer of a setuid or setgid program must be careful to avoid
+   using maliciously crafted environment variables in the search path
+   for executables, the locations for temporary files or logs, and the
+   like.
+
+   @raise Not_found if the variable is unbound.  *)
+*)
+
+val putenv : string -> string -> unit
+(** [Unix.putenv name value] sets the value associated to a
+   variable in the process environment.
+   [name] is the name of the environment variable,
+   and [value] its new associated value. *)
+
+
+(** {6 Process handling} *)
+
+
+type process_status = Unix.process_status =
+    WEXITED of int
+        (** The process terminated normally by [exit];
+           the argument is the return code. *)
+  | WSIGNALED of int
+        (** The process was killed by a signal;
+           the argument is the signal number. *)
+  | WSTOPPED of int
+        (** The process was stopped by a signal; the argument is the
+           signal number. *)
+(** The termination status of a process.  See module {!Sys} for the
+    definitions of the standard signal numbers.  Note that they are
+    not the numbers used by the OS. *)
+
+
+type wait_flag = Unix.wait_flag =
+    WNOHANG (** do not block if no child has
+               died yet, but immediately return with a pid equal to 0.*)
+  | WUNTRACED (** report also the children that receive stop signals. *)
+(** Flags for {!UnixLabels.waitpid}. *)
+
+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.
+   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 -> 'a
+(** Same as {!UnixLabels.execv}, except that the third argument provides the
+   environment to the program executed. *)
+
+val execvp : prog:string -> args:string array -> 'a
+(** Same as {!UnixLabels.execv}, except that
+   the program is searched in the path. *)
+
+val execvpe : prog:string -> args:string array -> env:string array -> 'a
+(** Same as {!UnixLabels.execve}, except that
+   the program is searched in the path. *)
+
+val fork : unit -> int
+(** Fork a new process. The returned integer is 0 for the child
+   process, the pid of the child process for the parent process. *)
+
+val wait : unit -> int * process_status
+(** Wait until one of the children processes die, and return its pid
+   and termination status. *)
+
+val waitpid : mode:wait_flag list -> int -> int * process_status
+(** Same as {!UnixLabels.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.
+   Negative pid arguments represent process groups.
+   The list of options indicates whether [waitpid] should return
+   immediately without waiting, or also report stopped children. *)
+
+val system : string -> process_status
+(** Execute the given command, wait until it terminates, and return
+   its termination status. The string is interpreted by the shell
+   [/bin/sh] and therefore can contain redirections, quotes, variables,
+   etc. The result [WEXITED 127] indicates that the shell couldn't
+   be executed. *)
+
+val getpid : unit -> int
+(** Return the pid of the process. *)
+
+val getppid : unit -> int
+(** Return the pid of the parent process. *)
+
+val nice : int -> int
+(** Change the process priority. The integer argument is added to the
+   ``nice'' value. (Higher values of the ``nice'' value mean
+   lower priorities.) Return the new nice value. *)
+
+
+(** {6 Basic file input/output} *)
+
+
+type file_descr = Unix.file_descr
+(** The abstract type of file descriptors. *)
+
+val stdin : file_descr
+(** File descriptor for standard input.*)
+
+val stdout : file_descr
+(** File descriptor for standard output.*)
+
+val stderr : file_descr
+(** File descriptor for standard error. *)
+
+type open_flag = Unix.open_flag =
+    O_RDONLY                    (** Open for reading *)
+  | O_WRONLY                    (** Open for writing *)
+  | O_RDWR                      (** Open for reading and writing *)
+  | O_NONBLOCK                  (** Open in non-blocking mode *)
+  | O_APPEND                    (** Open for append *)
+  | O_CREAT                     (** Create if nonexistent *)
+  | O_TRUNC                     (** Truncate to 0 length if existing *)
+  | O_EXCL                      (** Fail if existing *)
+  | O_NOCTTY                    (** Don't make this dev a controlling tty *)
+  | O_DSYNC                     (** Writes complete as `Synchronised I/O data
+                                    integrity completion' *)
+  | O_SYNC                      (** Writes complete as `Synchronised I/O file
+                                    integrity completion' *)
+  | O_RSYNC                     (** Reads complete as writes (depending
+                                    on O_SYNC/O_DSYNC) *)
+  | O_SHARE_DELETE              (** Windows only: allow the file to be deleted
+                                    while still open *)
+  | O_CLOEXEC                   (** Set the close-on-exec flag on the
+                                   descriptor returned by {!openfile} *)
+  | O_KEEPEXEC                  (** Clear the close-on-exec flag.
+                                    This is currently the default. *)
+(** The flags to {!UnixLabels.openfile}. *)
+
+
+type file_perm = int
+(** The type of file access rights, e.g. [0o640] is read and write for user,
+    read for group, none for others *)
+
+val openfile : string -> mode:open_flag list -> perm:file_perm -> file_descr
+(** Open the named file with the given flags. Third argument is
+   the permissions to give to the file if it is created. Return
+   a file descriptor on the named file. *)
+
+val close : file_descr -> unit
+(** Close a file descriptor. *)
+
+val read : file_descr -> buf:bytes -> pos:int -> len:int -> int
+(** [read fd buff ofs len] reads [len] bytes from descriptor [fd],
+    storing them in byte sequence [buff], starting at position [ofs] in
+    [buff]. Return the number of bytes actually read. *)
+
+val write : file_descr -> buf:bytes -> pos:int -> len:int -> int
+(** [write fd buff ofs len] writes [len] bytes to descriptor [fd],
+    taking them from byte sequence [buff], starting at position [ofs]
+    in [buff]. Return the number of bytes actually written.  [write]
+    repeats the writing operation until all bytes have been written or
+    an error occurs.  *)
+
+val single_write : file_descr -> buf:bytes -> pos:int -> len: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. *)
+
+val write_substring : file_descr -> buf:string -> pos:int -> len:int -> int
+(** Same as [write], but take the data from a string instead of a byte
+    sequence.
+    @since 4.02.0 *)
+
+val single_write_substring :
+  file_descr -> buf:string -> pos:int -> len:int -> int
+(** Same as [single_write], but take the data from a string instead of
+    a byte sequence.
+    @since 4.02.0 *)
+
+(** {6 Interfacing with the standard input/output library} *)
+
+
+
+val in_channel_of_descr : file_descr -> in_channel
+(** Create an input channel reading from the given descriptor.
+   The channel is initially in binary mode; use
+   [set_binary_mode_in ic false] if text mode is desired. *)
+
+val out_channel_of_descr : file_descr -> out_channel
+(** Create an output channel writing on the given descriptor.
+   The channel is initially in binary mode; use
+   [set_binary_mode_out oc false] if text mode is desired. *)
+
+val descr_of_in_channel : in_channel -> file_descr
+(** Return the descriptor corresponding to an input channel. *)
+
+val descr_of_out_channel : out_channel -> file_descr
+(** Return the descriptor corresponding to an output channel. *)
+
+
+(** {6 Seeking and truncating} *)
+
+
+type seek_command = Unix.seek_command =
+    SEEK_SET (** indicates positions relative to the beginning of the file *)
+  | SEEK_CUR (** indicates positions relative to the current position *)
+  | SEEK_END (** indicates positions relative to the end of the file *)
+(** Positioning modes for {!UnixLabels.lseek}. *)
+
+
+val lseek : file_descr -> int -> mode:seek_command -> int
+(** Set the current position for a file descriptor, and return the resulting
+    offset (from the beginning of the file). *)
+
+val truncate : string -> len:int -> unit
+(** Truncates the named file to the given size. *)
+
+val ftruncate : file_descr -> len:int -> unit
+(** Truncates the file corresponding to the given descriptor
+   to the given size. *)
+
+
+(** {6 File status} *)
+
+
+type file_kind = Unix.file_kind =
+    S_REG                       (** Regular file *)
+  | S_DIR                       (** Directory *)
+  | S_CHR                       (** Character device *)
+  | S_BLK                       (** Block device *)
+  | S_LNK                       (** Symbolic link *)
+  | S_FIFO                      (** Named pipe *)
+  | S_SOCK                      (** Socket *)
+
+type stats = Unix.stats =
+  { st_dev : int;               (** Device number *)
+    st_ino : int;               (** Inode number *)
+    st_kind : file_kind;        (** Kind of the file *)
+    st_perm : file_perm;        (** Access rights *)
+    st_nlink : int;             (** Number of links *)
+    st_uid : int;               (** User id of the owner *)
+    st_gid : int;               (** Group ID of the file's group *)
+    st_rdev : int;              (** Device minor number *)
+    st_size : int;              (** Size in bytes *)
+    st_atime : float;           (** Last access time *)
+    st_mtime : float;           (** Last modification time *)
+    st_ctime : float;           (** Last status change time *)
+  }
+(** The information returned by the {!UnixLabels.stat} calls. *)
+
+val stat : string -> stats
+(** Return the information for the named file. *)
+
+val lstat : string -> stats
+(** Same as {!UnixLabels.stat}, but in case the file is a symbolic link,
+   return the information for the link itself. *)
+
+val fstat : file_descr -> stats
+(** Return the information for the file associated with the given
+   descriptor. *)
+
+val isatty : file_descr -> bool
+(** Return [true] if the given file descriptor refers to a terminal or
+   console window, [false] otherwise. *)
+
+(** {6 File operations on large files} *)
+
+module LargeFile :
+  sig
+    val lseek : file_descr -> int64 -> mode:seek_command -> int64
+    val truncate : string -> len:int64 -> unit
+    val ftruncate : file_descr -> len:int64 -> unit
+    type stats = Unix.LargeFile.stats =
+      { st_dev : int;               (** Device number *)
+        st_ino : int;               (** Inode number *)
+        st_kind : file_kind;        (** Kind of the file *)
+        st_perm : file_perm;        (** Access rights *)
+        st_nlink : int;             (** Number of links *)
+        st_uid : int;               (** User id of the owner *)
+        st_gid : int;               (** Group ID of the file's group *)
+        st_rdev : int;              (** Device minor number *)
+        st_size : int64;            (** Size in bytes *)
+        st_atime : float;           (** Last access time *)
+        st_mtime : float;           (** Last modification time *)
+        st_ctime : float;           (** Last status change time *)
+      }
+    val stat : string -> stats
+    val lstat : string -> stats
+    val fstat : file_descr -> stats
+  end
+(** File operations on large files.
+  This sub-module provides 64-bit variants of the functions
+  {!UnixLabels.lseek} (for positioning a file descriptor),
+  {!UnixLabels.truncate} and {!UnixLabels.ftruncate}
+  (for changing the size of a file),
+  and {!UnixLabels.stat}, {!UnixLabels.lstat} and {!UnixLabels.fstat}
+  (for obtaining information on files).  These alternate functions represent
+  positions and sizes by 64-bit integers (type [int64]) instead of
+  regular integers (type [int]), thus allowing operating on files
+  whose sizes are greater than [max_int]. *)
+
+
+(** {6 Operations on file names} *)
+
+
+val unlink : string -> unit
+(** Removes the named file *)
+
+val rename : src:string -> dst:string -> unit
+(** [rename old new] changes the name of a file from [old] to [new]. *)
+
+val link : src:string -> dst:string -> unit
+(** [link source dest] creates a hard link named [dest] to the file
+   named [source]. *)
+
+
+(** {6 File permissions and ownership} *)
+
+
+type access_permission = Unix.access_permission =
+    R_OK                        (** Read permission *)
+  | W_OK                        (** Write permission *)
+  | X_OK                        (** Execution permission *)
+  | F_OK                        (** File exists *)
+(** Flags for the {!UnixLabels.access} call. *)
+
+
+val chmod : string -> perm:file_perm -> unit
+(** Change the permissions of the named file. *)
+
+val fchmod : file_descr -> perm:file_perm -> unit
+(** Change the permissions of an opened file. *)
+
+val chown : string -> uid:int -> gid:int -> unit
+(** Change the owner uid and owner gid of the named file. *)
+
+val fchown : file_descr -> uid:int -> gid:int -> unit
+(** Change the owner uid and owner gid of an opened file. *)
+
+val umask : int -> int
+(** Set the process's file mode creation mask, and return the previous
+    mask. *)
+
+val access : string -> perm:access_permission list -> unit
+(** Check that the process has the given permissions over the named
+   file. Raise [Unix_error] otherwise. *)
+
+
+(** {6 Operations on file descriptors} *)
+
+
+val dup : ?cloexec:bool -> file_descr -> file_descr
+(** Return a new file descriptor referencing the same file as
+   the given descriptor. *)
+
+val dup2 : ?cloexec:bool -> src:file_descr -> dst:file_descr -> unit
+(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
+   opened. *)
+
+val set_nonblock : file_descr -> unit
+(** Set the ``non-blocking'' flag on the given descriptor.
+   When the non-blocking flag is set, reading on a descriptor
+   on which there is temporarily no data available raises the
+   [EAGAIN] or [EWOULDBLOCK] error instead of blocking;
+   writing on a descriptor on which there is temporarily no room
+   for writing also raises [EAGAIN] or [EWOULDBLOCK]. *)
+
+val clear_nonblock : file_descr -> unit
+(** Clear the ``non-blocking'' flag on the given descriptor.
+   See {!UnixLabels.set_nonblock}.*)
+
+val set_close_on_exec : file_descr -> unit
+(** Set the ``close-on-exec'' flag on the given descriptor.
+   A descriptor with the close-on-exec flag is automatically
+   closed when the current process starts another program with
+   one of the [exec] functions. *)
+
+val clear_close_on_exec : file_descr -> unit
+(** Clear the ``close-on-exec'' flag on the given descriptor.
+   See {!UnixLabels.set_close_on_exec}.*)
+
+
+(** {6 Directories} *)
+
+
+val mkdir : string -> perm:file_perm -> unit
+(** Create a directory with the given permissions. *)
+
+val rmdir : string -> unit
+(** Remove an empty directory. *)
+
+val chdir : string -> unit
+(** Change the process working directory. *)
+
+val getcwd : unit -> string
+(** Return the name of the current working directory. *)
+
+val chroot : string -> unit
+(** Change the process root directory. *)
+
+type dir_handle = Unix.dir_handle
+(** The type of descriptors over opened directories. *)
+
+val opendir : string -> dir_handle
+(** Open a descriptor on a directory *)
+
+val readdir : dir_handle -> string
+(** Return the next entry in a directory.
+   @raise End_of_file when the end of the directory has been reached. *)
+
+val rewinddir : dir_handle -> unit
+(** Reposition the descriptor to the beginning of the directory *)
+
+val closedir : dir_handle -> unit
+(** Close a directory descriptor. *)
+
+
+
+(** {6 Pipes and redirections} *)
+
+
+val pipe : ?cloexec:bool -> unit -> file_descr * file_descr
+(** Create a pipe. The first component of the result is opened
+   for reading, that's the exit to the pipe. The second component is
+   opened for writing, that's the entrance to the pipe. *)
+
+val mkfifo : string -> perm:file_perm -> unit
+(** Create a named pipe with the given permissions. *)
+
+
+(** {6 High-level process and redirection management} *)
+
+
+val create_process :
+  prog:string -> args:string array -> stdin:file_descr -> stdout:file_descr ->
+    stderr:file_descr -> int
+(** [create_process prog args new_stdin new_stdout new_stderr]
+   forks a new process that executes the program
+   in file [prog], with arguments [args]. The pid of the new
+   process is returned immediately; the new process executes
+   concurrently with the current process.
+   The standard input and outputs of the new process are connected
+   to the descriptors [new_stdin], [new_stdout] and [new_stderr].
+   Passing e.g. [stdout] for [new_stdout] prevents the redirection
+   and causes the new process to have the same standard output
+   as the current process.
+   The executable file [prog] is searched in the path.
+   The new process has the same environment as the current process. *)
+
+val create_process_env :
+  prog:string -> args:string array -> env:string array -> stdin:file_descr ->
+    stdout:file_descr -> stderr:file_descr -> int
+(** [create_process_env prog args env new_stdin new_stdout new_stderr]
+   works as {!UnixLabels.create_process}, except that the extra argument
+   [env] specifies the environment passed to the program. *)
+
+
+val open_process_in : string -> in_channel
+(** High-level pipe and process management. This function
+   runs the given command in parallel with the program.
+   The standard output of the command is redirected to a pipe,
+   which can be read via the returned input channel.
+   The command is interpreted by the shell [/bin/sh] (cf. [system]). *)
+
+val open_process_out : string -> out_channel
+(** Same as {!UnixLabels.open_process_in}, but redirect the standard input of
+   the command to a pipe.  Data written to the returned output channel
+   is sent to the standard input of the command.
+   Warning: writes on output channels are buffered, hence be careful
+   to call {!Pervasives.flush} at the right times to ensure
+   correct synchronization. *)
+
+val open_process : string -> in_channel * out_channel
+(** Same as {!UnixLabels.open_process_out}, but redirects both the standard
+   input and standard output of the command to pipes connected to the two
+   returned channels.  The input channel is connected to the output
+   of the command, and the output channel to the input of the command. *)
+
+val open_process_full :
+  string -> env:string array -> in_channel * out_channel * in_channel
+(** Similar to {!UnixLabels.open_process}, but the second argument specifies
+   the environment passed to the command.  The result is a triple
+   of channels connected respectively to the standard output, standard input,
+   and standard error of the command. *)
+
+val close_process_in : in_channel -> process_status
+(** Close channels opened by {!UnixLabels.open_process_in},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+val close_process_out : out_channel -> process_status
+(** Close channels opened by {!UnixLabels.open_process_out},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+val close_process : in_channel * out_channel -> process_status
+(** Close channels opened by {!UnixLabels.open_process},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+val close_process_full :
+  in_channel * out_channel * in_channel -> process_status
+(** Close channels opened by {!UnixLabels.open_process_full},
+   wait for the associated command to terminate,
+   and return its termination status. *)
+
+
+(** {6 Symbolic links} *)
+
+
+val symlink : ?to_dir:bool -> src:string -> dst:string -> unit
+(** [symlink source dest] creates the file [dest] as a symbolic link
+   to the file [source]. See {!Unix.symlink} for details of [~to_dir] *)
+
+val has_symlink : unit -> bool
+(** Returns [true] if the user is able to create symbolic links. On Windows,
+   this indicates that the user not only has the SeCreateSymbolicLinkPrivilege
+   but is also running elevated, if necessary. On other platforms, this is
+   simply indicates that the symlink system call is available.
+   @since 4.03.0 *)
+
+val readlink : string -> string
+(** Read the contents of a link. *)
+
+
+(** {6 Polling} *)
+
+
+val select :
+  read:file_descr list -> write:file_descr list -> except:file_descr list ->
+    timeout:float -> file_descr list * file_descr list * file_descr list
+(** Wait until some input/output operations become possible on
+   some channels. The three list arguments are, respectively, a set
+   of descriptors to check for reading (first argument), for writing
+   (second argument), or for exceptional conditions (third argument).
+   The fourth argument is the maximal timeout, in seconds; a
+   negative fourth argument means no timeout (unbounded wait).
+   The result is composed of three sets of descriptors: those ready
+   for reading (first component), ready for writing (second component),
+   and over which an exceptional condition is pending (third
+   component). *)
+
+(** {6 Locking} *)
+
+
+type lock_command = Unix.lock_command =
+    F_ULOCK       (** Unlock a region *)
+  | F_LOCK        (** Lock a region for writing, and block if already locked *)
+  | F_TLOCK       (** Lock a region for writing, or fail if already locked *)
+  | F_TEST        (** Test a region for other process locks *)
+  | F_RLOCK       (** Lock a region for reading, and block if already locked *)
+  | F_TRLOCK      (** Lock a region for reading, or fail if already locked *)
+(** Commands for {!UnixLabels.lockf}. *)
+
+val lockf : file_descr -> mode:lock_command -> len:int -> unit
+(** [lockf fd cmd size] puts a lock on a region of the file opened
+   as [fd]. The region starts at the current read/write position for
+   [fd] (as set by {!UnixLabels.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 prevents any other
+   process from acquiring a read or write lock on the region.
+   A read lock prevents any other
+   process from acquiring a write lock on the region, but lets
+   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}
+   Note: installation of signal handlers is performed via
+   the functions {!Sys.signal} and {!Sys.set_signal}.
+*)
+
+val kill : pid:int -> signal:int -> unit
+(** [kill pid sig] sends signal number [sig] to the process
+   with id [pid]. *)
+
+type sigprocmask_command = Unix.sigprocmask_command =
+    SIG_SETMASK
+  | SIG_BLOCK
+  | SIG_UNBLOCK
+
+val sigprocmask : mode:sigprocmask_command -> int list -> int list
+(** [sigprocmask cmd sigs] changes the set of blocked signals.
+   If [cmd] is [SIG_SETMASK], blocked signals are set to those in
+   the list [sigs].
+   If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to
+   the set of blocked signals.
+   If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed
+   from the set of blocked signals.
+   [sigprocmask] returns the set of previously blocked signals. *)
+
+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 [sigs]
+   and waits for a non-ignored, non-blocked signal to be delivered.
+   On return, the blocked signals are reset to their initial value. *)
+
+val pause : unit -> unit
+(** Wait until a non-ignored, non-blocked signal is delivered. *)
+
+
+(** {6 Time functions} *)
+
+
+type process_times = Unix.process_times =
+  { tms_utime : float;  (** User time for the process *)
+    tms_stime : float;  (** System time for the process *)
+    tms_cutime : float; (** User time for the children processes *)
+    tms_cstime : float; (** System time for the children processes *)
+  }
+(** The execution times (CPU times) of a process. *)
+
+type tm = Unix.tm =
+  { tm_sec : int;               (** Seconds 0..60 *)
+    tm_min : int;               (** Minutes 0..59 *)
+    tm_hour : int;              (** Hours 0..23 *)
+    tm_mday : int;              (** Day of month 1..31 *)
+    tm_mon : int;               (** Month of year 0..11 *)
+    tm_year : int;              (** Year - 1900 *)
+    tm_wday : int;              (** Day of week (Sunday is 0) *)
+    tm_yday : int;              (** Day of year 0..365 *)
+    tm_isdst : bool;            (** Daylight time savings in effect *)
+  }
+(** The type representing wallclock time and calendar date. *)
+
+
+val time : unit -> float
+(** Return the current time since 00:00:00 GMT, Jan. 1, 1970,
+   in seconds. *)
+
+val gettimeofday : unit -> float
+(** Same as {!UnixLabels.time}, but with resolution better than 1 second. *)
+
+val gmtime : float -> tm
+(** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date
+   and a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *)
+
+val localtime : float -> tm
+(** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date
+   and a time. Assumes the local time zone. *)
+
+val mktime : tm -> float * tm
+(** Convert a date and time, specified by the [tm] argument, into
+   a time in seconds, as returned by {!UnixLabels.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. *)
+
+val sleep : int -> unit
+(** Stop execution for the given number of seconds. *)
+
+val times : unit -> process_times
+(** Return the execution times of the process. *)
+
+val utimes : string -> access:float -> modif:float -> unit
+(** Set the last access time (second arg) and last modification time
+   (third arg) for a file. Times are expressed in seconds from
+   00:00:00 GMT, Jan. 1, 1970.  A time of [0.0] is interpreted as the
+   current time. *)
+
+type interval_timer = Unix.interval_timer =
+    ITIMER_REAL
+      (** decrements in real time, and sends the signal [SIGALRM] when
+          expired.*)
+  | ITIMER_VIRTUAL
+      (** decrements in process virtual time, and sends [SIGVTALRM] when
+          expired. *)
+  | ITIMER_PROF
+      (** (for profiling) decrements both when the process
+         is running and when the system is running on behalf of the
+         process; it sends [SIGPROF] when expired. *)
+(** The three kinds of interval timers. *)
+
+type interval_timer_status = Unix.interval_timer_status =
+  { it_interval : float;         (** Period *)
+    it_value : float;            (** Current value of the timer *)
+  }
+(** The type describing the status of an interval timer *)
+
+val getitimer : interval_timer -> interval_timer_status
+(** Return the current status of the given interval timer. *)
+
+val setitimer :
+  interval_timer -> interval_timer_status -> interval_timer_status
+(** [setitimer t s] sets the interval timer [t] and returns
+   its previous status. The [s] argument is interpreted as follows:
+   [s.it_value], if nonzero, is the time to the next timer expiration;
+   [s.it_interval], if nonzero, specifies a value to
+   be used in reloading it_value when the timer expires.
+   Setting [s.it_value] to zero disable the timer.
+   Setting [s.it_interval] to zero causes the timer to be disabled
+   after its next expiration. *)
+
+
+(** {6 User id, group id} *)
+
+
+val getuid : unit -> int
+(** Return the user id of the user executing the process. *)
+
+val geteuid : unit -> int
+(** Return the effective user id under which the process runs. *)
+
+val setuid : int -> unit
+(** Set the real user id and effective user id for the process. *)
+
+val getgid : unit -> int
+(** Return the group id of the user executing the process. *)
+
+val getegid : unit -> int
+(** Return the effective group id under which the process runs. *)
+
+val setgid : int -> unit
+(** Set the real group id and effective group id for the process. *)
+
+val getgroups : unit -> int array
+(** Return the list of groups to which the user executing the process
+   belongs. *)
+
+val setgroups : int array -> unit
+  (** [setgroups groups] sets the supplementary group IDs for the
+      calling process. Appropriate privileges are required. *)
+
+val initgroups : string -> int -> unit
+  (** [initgroups user group] initializes the group access list by
+      reading the group database /etc/group and using all groups of
+      which [user] is a member. The additional group [group] is also
+      added to the list. *)
+
+type passwd_entry = Unix.passwd_entry =
+  { pw_name : string;
+    pw_passwd : string;
+    pw_uid : int;
+    pw_gid : int;
+    pw_gecos : string;
+    pw_dir : string;
+    pw_shell : string
+  }
+(** Structure of entries in the [passwd] database. *)
+
+type group_entry = Unix.group_entry =
+  { gr_name : string;
+    gr_passwd : string;
+    gr_gid : int;
+    gr_mem : string array
+  }
+(** Structure of entries in the [groups] database. *)
+
+val getlogin : unit -> string
+(** Return the login name of the user executing the process. *)
+
+val getpwnam : string -> passwd_entry
+(** Find an entry in [passwd] with the given name, or raise
+   [Not_found]. *)
+
+val getgrnam : string -> group_entry
+(** Find an entry in [group] with the given name, or raise
+   [Not_found]. *)
+
+val getpwuid : int -> passwd_entry
+(** Find an entry in [passwd] with the given user id, or raise
+   [Not_found]. *)
+
+val getgrgid : int -> group_entry
+(** Find an entry in [group] with the given group id, or raise
+   [Not_found]. *)
+
+
+(** {6 Internet addresses} *)
+
+
+type inet_addr = Unix.inet_addr
+(** The abstract type of Internet addresses. *)
+
+val inet_addr_of_string : string -> inet_addr
+(** 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
+(** 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 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 = Unix.socket_domain =
+    PF_UNIX                     (** Unix domain *)
+  | PF_INET                     (** Internet domain (IPv4) *)
+  | PF_INET6                    (** Internet domain (IPv6) *)
+(** The type of socket domains.  Not all platforms support
+    IPv6 sockets (type [PF_INET6]). *)
+
+type socket_type = Unix.socket_type =
+    SOCK_STREAM                 (** Stream socket *)
+  | SOCK_DGRAM                  (** Datagram socket *)
+  | SOCK_RAW                    (** Raw socket *)
+  | SOCK_SEQPACKET              (** Sequenced packets socket *)
+(** The type of socket kinds, specifying the semantics of
+   communications. *)
+
+type sockaddr = Unix.sockaddr =
+    ADDR_UNIX of string
+  | ADDR_INET of inet_addr * int
+(** The type of socket addresses. [ADDR_UNIX name] is a socket
+   address in the Unix domain; [name] is a file name in the file
+   system. [ADDR_INET(addr,port)] is a socket address in the Internet
+   domain; [addr] is the Internet address of the machine, and
+   [port] is the port number. *)
+
+val socket :
+  ?cloexec:bool -> domain:socket_domain -> kind:socket_type -> protocol:int ->
+     file_descr
+(** Create a new socket in the given domain, and with the
+   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 :
+  ?cloexec:bool -> domain:socket_domain -> kind:socket_type -> protocol:int ->
+    file_descr * file_descr
+(** Create a pair of unnamed sockets, connected together. *)
+
+val accept : ?cloexec:bool -> file_descr -> file_descr * sockaddr
+(** Accept connections on the given socket. The returned descriptor
+   is a socket connected to the client; the returned address is
+   the address of the connecting client. *)
+
+val bind : file_descr -> addr:sockaddr -> unit
+(** Bind a socket to an address. *)
+
+val connect : file_descr -> addr:sockaddr -> unit
+(** Connect a socket to an address. *)
+
+val listen : file_descr -> max:int -> unit
+(** Set up a socket for receiving connection requests. The integer
+   argument is the maximal number of pending requests. *)
+
+type shutdown_command = Unix.shutdown_command =
+    SHUTDOWN_RECEIVE            (** Close for receiving *)
+  | SHUTDOWN_SEND               (** Close for sending *)
+  | SHUTDOWN_ALL                (** Close both *)
+(** The type of commands for [shutdown]. *)
+
+
+val shutdown : file_descr -> mode:shutdown_command -> unit
+(** Shutdown a socket connection. [SHUTDOWN_SEND] as second argument
+   causes reads on the other end of the connection to return
+   an end-of-file condition.
+   [SHUTDOWN_RECEIVE] causes writes on the other end of the connection
+   to return a closed pipe condition ([SIGPIPE] signal). *)
+
+val getsockname : file_descr -> sockaddr
+(** Return the address of the given socket. *)
+
+val getpeername : file_descr -> sockaddr
+(** Return the address of the host connected to the given socket. *)
+
+type msg_flag = Unix.msg_flag =
+    MSG_OOB
+  | MSG_DONTROUTE
+  | MSG_PEEK
+(** The flags for {!UnixLabels.recv},  {!UnixLabels.recvfrom},
+   {!UnixLabels.send} and {!UnixLabels.sendto}. *)
+
+val recv :
+  file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list -> int
+(** Receive data from a connected socket. *)
+
+val recvfrom :
+  file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list ->
+    int * sockaddr
+(** Receive data from an unconnected socket. *)
+
+val send :
+  file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list -> int
+(** Send data over a connected socket. *)
+
+val send_substring :
+  file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int
+(** Same as [send], but take the data from a string instead of a byte
+    sequence.
+    @since 4.02.0 *)
+
+val sendto :
+  file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list ->
+    addr:sockaddr -> int
+(** Send data over an unconnected socket. *)
+
+val sendto_substring :
+  file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list
+  -> sockaddr -> int
+(** Same as [sendto], but take the data from a string instead of a
+    byte sequence.
+    @since 4.02.0 *)
+
+
+
+(** {6 Socket options} *)
+
+
+type socket_bool_option =
+    SO_DEBUG       (** Record debugging information *)
+  | SO_BROADCAST   (** Permit sending of broadcast messages *)
+  | SO_REUSEADDR   (** Allow reuse of local addresses for bind *)
+  | SO_KEEPALIVE   (** Keep connection active *)
+  | SO_DONTROUTE   (** Bypass the standard routing algorithms *)
+  | SO_OOBINLINE   (** Leave out-of-band data in line *)
+  | SO_ACCEPTCONN  (** Report whether socket listening is enabled *)
+  | TCP_NODELAY    (** Control the Nagle algorithm for TCP sockets *)
+  | IPV6_ONLY      (** Forbid binding an IPv6 socket to an IPv4 address *)
+(** The socket options that can be consulted with {!UnixLabels.getsockopt}
+   and modified with {!UnixLabels.setsockopt}.  These options have a boolean
+   ([true]/[false]) value. *)
+
+type socket_int_option =
+    SO_SNDBUF    (** Size of send buffer *)
+  | SO_RCVBUF    (** Size of received buffer *)
+  | SO_ERROR     (** Deprecated.  Use {!Unix.getsockopt_error} instead. *)
+  | SO_TYPE      (** Report the socket type *)
+  | SO_RCVLOWAT  (** Minimum number of bytes to process for input operations *)
+  | SO_SNDLOWAT  (** Minimum number of bytes to process for output operations *)
+(** The socket options that can be consulted with {!UnixLabels.getsockopt_int}
+   and modified with {!UnixLabels.setsockopt_int}.  These options have an
+   integer value. *)
+
+type socket_optint_option =
+  SO_LINGER      (** Whether to linger on closed connections
+                    that have data present, and for how long
+                    (in seconds) *)
+(** The socket options that can be consulted with {!Unix.getsockopt_optint}
+   and modified with {!Unix.setsockopt_optint}.  These options have a
+   value of type [int option], with [None] meaning ``disabled''. *)
+
+type socket_float_option =
+    SO_RCVTIMEO    (** Timeout for input operations *)
+  | SO_SNDTIMEO    (** Timeout for output operations *)
+(** The socket options that can be consulted with {!UnixLabels.getsockopt_float}
+   and modified with {!UnixLabels.setsockopt_float}.  These options have a
+   floating-point value representing a time in seconds.
+   The value 0 means infinite timeout. *)
+
+val getsockopt : file_descr -> socket_bool_option -> bool
+(** Return the current status of a boolean-valued option
+   in the given socket. *)
+
+val setsockopt : file_descr -> socket_bool_option -> bool -> unit
+(** Set or clear a boolean-valued option in the given socket. *)
+
+val getsockopt_int : file_descr -> socket_int_option -> int
+(** Same as {!Unix.getsockopt} for an integer-valued socket option. *)
+
+val setsockopt_int : file_descr -> socket_int_option -> int -> unit
+(** Same as {!Unix.setsockopt} for an integer-valued socket option. *)
+
+val getsockopt_optint : file_descr -> socket_optint_option -> int option
+(** Same as {!Unix.getsockopt} for a socket option whose value is
+    an [int option]. *)
+
+val setsockopt_optint :
+      file_descr -> socket_optint_option -> int option -> unit
+(** Same as {!Unix.setsockopt} for a socket option whose value is
+    an [int option]. *)
+
+val getsockopt_float : file_descr -> socket_float_option -> float
+(** Same as {!Unix.getsockopt} for a socket option whose value is a
+    floating-point number. *)
+
+val setsockopt_float : file_descr -> socket_float_option -> float -> unit
+(** Same as {!Unix.setsockopt} for a socket option whose value is a
+    floating-point number. *)
+
+val getsockopt_error : file_descr -> error option
+(** Return the error condition associated with the given socket,
+    and clear it. *)
+
+(** {6 High-level network connection functions} *)
+
+
+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. *)
+
+val shutdown_connection : in_channel -> unit
+(** ``Shut down'' a connection established with {!UnixLabels.open_connection};
+   that is, transmit an end-of-file condition to the server reading
+   on the other side of the connection. *)
+
+val establish_server :
+  (in_channel -> out_channel -> unit) -> addr:sockaddr -> unit
+(** Establish a server on the given address.
+   The function given as first argument is called for each connection
+   with two buffered channels connected to the client. A new process
+   is created for each connection. The function {!UnixLabels.establish_server}
+   never returns normally. *)
+
+
+(** {6 Host and protocol databases} *)
+
+
+type host_entry = Unix.host_entry =
+  { h_name : string;
+    h_aliases : string array;
+    h_addrtype : socket_domain;
+    h_addr_list : inet_addr array
+  }
+(** Structure of entries in the [hosts] database. *)
+
+type protocol_entry = Unix.protocol_entry =
+  { p_name : string;
+    p_aliases : string array;
+    p_proto : int
+  }
+(** Structure of entries in the [protocols] database. *)
+
+type service_entry = Unix.service_entry =
+  { s_name : string;
+    s_aliases : string array;
+    s_port : int;
+    s_proto : string
+  }
+(** Structure of entries in the [services] database. *)
+
+val gethostname : unit -> string
+(** Return the name of the local host. *)
+
+val gethostbyname : string -> host_entry
+(** Find an entry in [hosts] with the given name, or raise
+   [Not_found]. *)
+
+val gethostbyaddr : inet_addr -> host_entry
+(** Find an entry in [hosts] with the given address, or raise
+   [Not_found]. *)
+
+val getprotobyname : string -> protocol_entry
+(** Find an entry in [protocols] with the given name, or raise
+   [Not_found]. *)
+
+val getprotobynumber : int -> protocol_entry
+(** Find an entry in [protocols] with the given protocol number,
+   or raise [Not_found]. *)
+
+val getservbyname : string -> protocol:string -> service_entry
+(** Find an entry in [services] with the given name, or raise
+   [Not_found]. *)
+
+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} *)
+
+
+(** The following functions implement the POSIX standard terminal
+   interface. They provide control over asynchronous communication ports
+   and pseudo-terminals. Refer to the [termios] man page for a
+   complete description. *)
+
+type terminal_io = Unix.terminal_io =
+  {
+    (* input modes *)
+    mutable c_ignbrk : bool;  (** Ignore the break condition. *)
+    mutable c_brkint : bool;  (** Signal interrupt on break condition. *)
+    mutable c_ignpar : bool;  (** Ignore characters with parity errors. *)
+    mutable c_parmrk : bool;  (** Mark parity errors. *)
+    mutable c_inpck : bool;   (** Enable parity check on input. *)
+    mutable c_istrip : bool;  (** Strip 8th bit on input characters. *)
+    mutable c_inlcr : bool;   (** Map NL to CR on input. *)
+    mutable c_igncr : bool;   (** Ignore CR on input. *)
+    mutable c_icrnl : bool;   (** Map CR to NL on input. *)
+    mutable c_ixon : bool;    (** Recognize XON/XOFF characters on input. *)
+    mutable c_ixoff : bool;   (** Emit XON/XOFF chars to control input flow. *)
+    (* Output modes: *)
+    mutable c_opost : bool;   (** Enable output processing. *)
+    (* Control modes: *)
+    mutable c_obaud : int;    (** Output baud rate (0 means close connection).*)
+    mutable c_ibaud : int;    (** Input baud rate. *)
+    mutable c_csize : int;    (** Number of bits per character (5-8). *)
+    mutable c_cstopb : int;   (** Number of stop bits (1-2). *)
+    mutable c_cread : bool;   (** Reception is enabled. *)
+    mutable c_parenb : bool;  (** Enable parity generation and detection. *)
+    mutable c_parodd : bool;  (** Specify odd parity instead of even. *)
+    mutable c_hupcl : bool;   (** Hang up on last close. *)
+    mutable c_clocal : bool;  (** Ignore modem status lines. *)
+    (* Local modes: *)
+    mutable c_isig : bool;    (** Generate signal on INTR, QUIT, SUSP. *)
+    mutable c_icanon : bool;  (** Enable canonical processing
+                                 (line buffering and editing) *)
+    mutable c_noflsh : bool;  (** Disable flush after INTR, QUIT, SUSP. *)
+    mutable c_echo : bool;    (** Echo input characters. *)
+    mutable c_echoe : bool;   (** Echo ERASE (to erase previous character). *)
+    mutable c_echok : bool;   (** Echo KILL (to erase the current line). *)
+    mutable c_echonl : bool;  (** Echo NL even if c_echo is not set. *)
+    (* Control characters: *)
+    mutable c_vintr : char;   (** Interrupt character (usually ctrl-C). *)
+    mutable c_vquit : char;   (** Quit character (usually ctrl-\). *)
+    mutable c_verase : char;  (** Erase character (usually DEL or ctrl-H). *)
+    mutable c_vkill : char;   (** Kill line character (usually ctrl-U). *)
+    mutable c_veof : char;    (** End-of-file character (usually ctrl-D). *)
+    mutable c_veol : char;    (** Alternate end-of-line char. (usually none). *)
+    mutable c_vmin : int;     (** Minimum number of characters to read
+                                 before the read request is satisfied. *)
+    mutable c_vtime : int;    (** Maximum read wait (in 0.1s units). *)
+    mutable c_vstart : char;  (** Start character (usually ctrl-Q). *)
+    mutable c_vstop : char;   (** Stop character (usually ctrl-S). *)
+  }
+
+val tcgetattr : file_descr -> terminal_io
+(** Return the status of the terminal referred to by the given
+   file descriptor. *)
+
+type setattr_when = Unix.setattr_when =
+    TCSANOW
+  | TCSADRAIN
+  | TCSAFLUSH
+
+val tcsetattr : file_descr -> mode:setattr_when -> terminal_io -> unit
+(** Set the status of the terminal referred to by the given
+   file descriptor. The second argument indicates when the
+   status change takes place: immediately ([TCSANOW]),
+   when all pending output has been transmitted ([TCSADRAIN]),
+   or after flushing all input that has been received but not
+   read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing
+   the output parameters; [TCSAFLUSH], when changing the input
+   parameters. *)
+
+val tcsendbreak : file_descr -> duration:int -> unit
+(** Send a break condition on the given file descriptor.
+   The second argument is the duration of the break, in 0.1s units;
+   0 means standard duration (0.25s). *)
+
+val tcdrain : file_descr -> unit
+(** Waits until all output written on the given file descriptor
+   has been transmitted. *)
+
+type flush_queue = Unix.flush_queue =
+    TCIFLUSH
+  | TCOFLUSH
+  | TCIOFLUSH
+
+val tcflush : file_descr -> mode:flush_queue -> unit
+(** Discard data written on the given file descriptor but not yet
+   transmitted, or data received but not yet read, depending on the
+   second argument: [TCIFLUSH] flushes data received but not read,
+   [TCOFLUSH] flushes data written but not transmitted, and
+   [TCIOFLUSH] flushes both. *)
+
+type flow_action = Unix.flow_action =
+    TCOOFF
+  | TCOON
+  | TCIOFF
+  | TCION
+
+val tcflow : file_descr -> mode:flow_action -> unit
+(** Suspend or restart reception or transmission of data on
+   the given file descriptor, depending on the second argument:
+   [TCOOFF] suspends output, [TCOON] restarts output,
+   [TCIOFF] transmits a STOP character to suspend input,
+   and [TCION] transmits a START character to restart input. *)
+
+val setsid : unit -> int
+(** Put the calling process in a new session and detach it from
+   its controlling terminal. *)
diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c
new file mode 100644
index 00000000..b3ff8a4b
--- /dev/null
+++ b/otherlibs/unix/unixsupport.c
@@ -0,0 +1,347 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+#include "cst2constr.h"
+#include <errno.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
+
+#ifndef E2BIG
+#define E2BIG (-1)
+#endif
+#ifndef EACCES
+#define EACCES (-1)
+#endif
+#ifndef EAGAIN
+#define EAGAIN (-1)
+#endif
+#ifndef EBADF
+#define EBADF (-1)
+#endif
+#ifndef EBUSY
+#define EBUSY (-1)
+#endif
+#ifndef ECHILD
+#define ECHILD (-1)
+#endif
+#ifndef EDEADLK
+#define EDEADLK (-1)
+#endif
+#ifndef EDOM
+#define EDOM (-1)
+#endif
+#ifndef EEXIST
+#define EEXIST (-1)
+#endif
+
+#ifndef EFAULT
+#define EFAULT (-1)
+#endif
+#ifndef EFBIG
+#define EFBIG (-1)
+#endif
+#ifndef EINTR
+#define EINTR (-1)
+#endif
+#ifndef EINVAL
+#define EINVAL (-1)
+#endif
+#ifndef EIO
+#define EIO (-1)
+#endif
+#ifndef EISDIR
+#define EISDIR (-1)
+#endif
+#ifndef EMFILE
+#define EMFILE (-1)
+#endif
+#ifndef EMLINK
+#define EMLINK (-1)
+#endif
+#ifndef ENAMETOOLONG
+#define ENAMETOOLONG (-1)
+#endif
+#ifndef ENFILE
+#define ENFILE (-1)
+#endif
+#ifndef ENODEV
+#define ENODEV (-1)
+#endif
+#ifndef ENOENT
+#define ENOENT (-1)
+#endif
+#ifndef ENOEXEC
+#define ENOEXEC (-1)
+#endif
+#ifndef ENOLCK
+#define ENOLCK (-1)
+#endif
+#ifndef ENOMEM
+#define ENOMEM (-1)
+#endif
+#ifndef ENOSPC
+#define ENOSPC (-1)
+#endif
+#ifndef ENOSYS
+#define ENOSYS (-1)
+#endif
+#ifndef ENOTDIR
+#define ENOTDIR (-1)
+#endif
+#ifndef ENOTEMPTY
+#define ENOTEMPTY (-1)
+#endif
+#ifndef ENOTTY
+#define ENOTTY (-1)
+#endif
+#ifndef ENXIO
+#define ENXIO (-1)
+#endif
+#ifndef EPERM
+#define EPERM (-1)
+#endif
+#ifndef EPIPE
+#define EPIPE (-1)
+#endif
+#ifndef ERANGE
+#define ERANGE (-1)
+#endif
+#ifndef EROFS
+#define EROFS (-1)
+#endif
+#ifndef ESPIPE
+#define ESPIPE (-1)
+#endif
+#ifndef ESRCH
+#define ESRCH (-1)
+#endif
+#ifndef EXDEV
+#define EXDEV (-1)
+#endif
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK (-1)
+#endif
+#ifndef EINPROGRESS
+#define EINPROGRESS (-1)
+#endif
+#ifndef EALREADY
+#define EALREADY (-1)
+#endif
+#ifndef ENOTSOCK
+#define ENOTSOCK (-1)
+#endif
+#ifndef EDESTADDRREQ
+#define EDESTADDRREQ (-1)
+#endif
+#ifndef EMSGSIZE
+#define EMSGSIZE (-1)
+#endif
+#ifndef EPROTOTYPE
+#define EPROTOTYPE (-1)
+#endif
+#ifndef ENOPROTOOPT
+#define ENOPROTOOPT (-1)
+#endif
+#ifndef EPROTONOSUPPORT
+#define EPROTONOSUPPORT (-1)
+#endif
+#ifndef ESOCKTNOSUPPORT
+#define ESOCKTNOSUPPORT (-1)
+#endif
+#ifndef EOPNOTSUPP
+#  ifdef ENOTSUP
+#    define EOPNOTSUPP ENOTSUP
+#  else
+#    define EOPNOTSUPP (-1)
+#  endif
+#endif
+#ifndef EPFNOSUPPORT
+#define EPFNOSUPPORT (-1)
+#endif
+#ifndef EAFNOSUPPORT
+#define EAFNOSUPPORT (-1)
+#endif
+#ifndef EADDRINUSE
+#define EADDRINUSE (-1)
+#endif
+#ifndef EADDRNOTAVAIL
+#define EADDRNOTAVAIL (-1)
+#endif
+#ifndef ENETDOWN
+#define ENETDOWN (-1)
+#endif
+#ifndef ENETUNREACH
+#define ENETUNREACH (-1)
+#endif
+#ifndef ENETRESET
+#define ENETRESET (-1)
+#endif
+#ifndef ECONNABORTED
+#define ECONNABORTED (-1)
+#endif
+#ifndef ECONNRESET
+#define ECONNRESET (-1)
+#endif
+#ifndef ENOBUFS
+#define ENOBUFS (-1)
+#endif
+#ifndef EISCONN
+#define EISCONN (-1)
+#endif
+#ifndef ENOTCONN
+#define ENOTCONN (-1)
+#endif
+#ifndef ESHUTDOWN
+#define ESHUTDOWN (-1)
+#endif
+#ifndef ETOOMANYREFS
+#define ETOOMANYREFS (-1)
+#endif
+#ifndef ETIMEDOUT
+#define ETIMEDOUT (-1)
+#endif
+#ifndef ECONNREFUSED
+#define ECONNREFUSED (-1)
+#endif
+#ifndef EHOSTDOWN
+#define EHOSTDOWN (-1)
+#endif
+#ifndef EHOSTUNREACH
+#define EHOSTUNREACH (-1)
+#endif
+#ifndef ENOTEMPTY
+#define ENOTEMPTY (-1)
+#endif
+#ifndef ELOOP
+#define ELOOP (-1)
+#endif
+#ifndef EOVERFLOW
+#define EOVERFLOW (-1)
+#endif
+
+int error_table[] = {
+  E2BIG, EACCES, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM,
+  EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK,
+  ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC,
+  ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE,
+  EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY,
+  ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT,
+  EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT,
+  EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH,
+  ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN,
+  ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN,
+  EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */
+};
+
+static value * unix_error_exn = NULL;
+
+value unix_error_of_code (int errcode)
+{
+  int errconstr;
+  value err;
+
+#if defined(ENOTSUP) && (EOPNOTSUPP != ENOTSUP)
+  if (errcode == ENOTSUP)
+    errcode = EOPNOTSUPP;
+#endif
+
+  errconstr =
+      cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
+  if (errconstr == Val_int(-1)) {
+    err = caml_alloc_small(1, 0);
+    Field(err, 0) = Val_int(errcode);
+  } else {
+    err = errconstr;
+  }
+  return err;
+}
+
+extern int code_of_unix_error (value error)
+{
+  if (Is_block(error)) {
+    return Int_val(Field(error, 0));
+  } else {
+    return error_table[Int_val(error)];
+  }
+}
+
+void unix_error(int errcode, char *cmdname, value cmdarg)
+{
+  value res;
+  value name = Val_unit, err = Val_unit, arg = Val_unit;
+
+  Begin_roots3 (name, err, arg);
+    arg = cmdarg == Nothing ? caml_copy_string("") : cmdarg;
+    name = caml_copy_string(cmdname);
+    err = unix_error_of_code (errcode);
+    if (unix_error_exn == NULL) {
+      unix_error_exn = caml_named_value("Unix.Unix_error");
+      if (unix_error_exn == NULL)
+        caml_invalid_argument("Exception Unix.Unix_error not initialized,"
+                         " please link unix.cma");
+    }
+    res = caml_alloc_small(4, 0);
+    Field(res, 0) = *unix_error_exn;
+    Field(res, 1) = err;
+    Field(res, 2) = name;
+    Field(res, 3) = arg;
+  End_roots();
+  caml_raise(res);
+}
+
+void uerror(char *cmdname, value cmdarg)
+{
+  unix_error(errno, cmdname, cmdarg);
+}
+
+void caml_unix_check_path(value path, char * cmdname)
+{
+  if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
+}
+
+int unix_cloexec_default = 0;
+
+int unix_cloexec_p(value cloexec)
+{
+  /* [cloexec] is a [bool option].  */
+  if (Is_block(cloexec))
+    return Bool_val(Field(cloexec, 0));
+  else
+    return unix_cloexec_default;
+}
+
+void unix_set_cloexec(int fd, char *cmdname, value cmdarg)
+{
+  int flags = fcntl(fd, F_GETFD, 0);
+  if (flags == -1 ||
+      fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
+    uerror(cmdname, cmdarg);
+}
+
+void unix_clear_cloexec(int fd, char *cmdname, value cmdarg)
+{
+  int flags = fcntl(fd, F_GETFD, 0);
+  if (flags == -1 ||
+      fcntl(fd, F_SETFD, flags & ~FD_CLOEXEC) == -1)
+    uerror(cmdname, cmdarg);
+}
diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
new file mode 100644
index 00000000..41698e64
--- /dev/null
+++ b/otherlibs/unix/unixsupport.h
@@ -0,0 +1,57 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_UNIXSUPPORT_H
+#define CAML_UNIXSUPPORT_H
+
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define Nothing ((value) 0)
+
+extern value unix_error_of_code (int errcode);
+extern int code_of_unix_error (value error);
+
+CAMLnoreturn_start
+extern void unix_error (int errcode, char * cmdname, value arg)
+CAMLnoreturn_end;
+
+CAMLnoreturn_start
+extern void uerror (char * cmdname, value arg)
+CAMLnoreturn_end;
+
+extern void caml_unix_check_path(value path, char * cmdname);
+
+#define UNIX_BUFFER_SIZE 65536
+
+#define DIR_Val(v) *((DIR **) &Field(v, 0))
+
+extern char ** cstringvect(value arg, char * cmdname);
+
+extern int unix_cloexec_default;
+extern int unix_cloexec_p(value cloexec);
+extern void unix_set_cloexec(int fd, char * cmdname, value arg);
+extern void unix_clear_cloexec(int fd, char * cmdname, value arg);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_UNIXSUPPORT_H */
diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c
new file mode 100644
index 00000000..c06dd363
--- /dev/null
+++ b/otherlibs/unix/unlink.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_unlink(value path)
+{
+  CAMLparam1(path);
+  char * p;
+  int ret;
+  caml_unix_check_path(path, "unlink");
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = unlink(p);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("unlink", path);
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c
new file mode 100644
index 00000000..f60fbbce
--- /dev/null
+++ b/otherlibs/unix/utimes.c
@@ -0,0 +1,95 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/fail.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#if defined(HAS_UTIMES)
+
+#include <sys/types.h>
+#include <sys/time.h>
+
+CAMLprim value unix_utimes(value path, value atime, value mtime)
+{
+  CAMLparam3(path, atime, mtime);
+  struct timeval tv[2], * t;
+  char * p;
+  int ret;
+  double at, mt;
+  caml_unix_check_path(path, "utimes");
+  at = Double_val(atime);
+  mt = Double_val(mtime);
+  if (at == 0.0 && mt == 0.0) {
+    t = (struct timeval *) NULL;
+  } else {
+    tv[0].tv_sec = at;
+    tv[0].tv_usec = (at - tv[0].tv_sec) * 1000000;
+    tv[1].tv_sec = mt;
+    tv[1].tv_usec = (mt - tv[1].tv_sec) * 1000000;
+    t = tv;
+  }
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = utimes(p, t);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("utimes", path);
+  CAMLreturn(Val_unit);
+}
+
+#elif defined(HAS_UTIME)
+
+#include <sys/types.h>
+#ifndef _WIN32
+#include <utime.h>
+#else
+#include <sys/utime.h>
+#endif
+
+CAMLprim value unix_utimes(value path, value atime, value mtime)
+{
+  CAMLparam3(path, atime, mtime);
+  struct utimbuf times, * t;
+  char * p;
+  int ret;
+  double at, mt;
+  caml_unix_check_path(path, "utimes");
+  at = Double_val(atime);
+  mt = Double_val(mtime);
+  if (at == 0.0 && mt == 0.0) {
+    t = (struct utimbuf *) NULL;
+  } else {
+    times.actime = at;
+    times.modtime = mt;
+    t = ×
+  }
+  p = caml_strdup(String_val(path));
+  caml_enter_blocking_section();
+  ret = utime(p, t);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1) uerror("utimes", path);
+  CAMLreturn(Val_unit);
+}
+
+#else
+
+CAMLprim value unix_utimes(value path, value atime, value mtime)
+{ caml_invalid_argument("utimes not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
new file mode 100644
index 00000000..448b3f31
--- /dev/null
+++ b/otherlibs/unix/wait.c
@@ -0,0 +1,104 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \
+      defined(WSTOPSIG) && defined(WTERMSIG))
+/* Assume old-style V7 status word */
+#define WIFEXITED(status) (((status) & 0xFF) == 0)
+#define WEXITSTATUS(status) (((status) >> 8) & 0xFF)
+#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF)
+#define WSTOPSIG(status) (((status) >> 8) & 0xFF)
+#define WTERMSIG(status) ((status) & 0x3F)
+#endif
+
+#define TAG_WEXITED 0
+#define TAG_WSIGNALED 1
+#define TAG_WSTOPPED 2
+
+static value alloc_process_status(int pid, int status)
+{
+  value st, res;
+
+  if (WIFEXITED(status)) {
+    st = caml_alloc_small(1, TAG_WEXITED);
+    Field(st, 0) = Val_int(WEXITSTATUS(status));
+  }
+  else if (WIFSTOPPED(status)) {
+    st = caml_alloc_small(1, TAG_WSTOPPED);
+    Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
+  }
+  else {
+    st = caml_alloc_small(1, TAG_WSIGNALED);
+    Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
+  }
+  Begin_root (st);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = Val_int(pid);
+    Field(res, 1) = st;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_wait(value unit)
+{
+  int pid, status;
+
+  caml_enter_blocking_section();
+  pid = wait(&status);
+  caml_leave_blocking_section();
+  if (pid == -1) uerror("wait", Nothing);
+  return alloc_process_status(pid, status);
+}
+
+#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
+
+#ifndef HAS_WAITPID
+#define waitpid(pid,status,opts) wait4(pid,status,opts,NULL)
+#endif
+
+static int wait_flag_table[] = {
+  WNOHANG, WUNTRACED
+};
+
+CAMLprim value unix_waitpid(value flags, value pid_req)
+{
+  int pid, status, cv_flags;
+
+  cv_flags = caml_convert_flag_list(flags, wait_flag_table);
+  caml_enter_blocking_section();
+  pid = waitpid(Int_val(pid_req), &status, cv_flags);
+  caml_leave_blocking_section();
+  if (pid == -1) uerror("waitpid", Nothing);
+  return alloc_process_status(pid, status);
+}
+
+#else
+
+CAMLprim value unix_waitpid(value flags, value pid_req)
+{ caml_invalid_argument("waitpid not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
new file mode 100644
index 00000000..8d5b6a87
--- /dev/null
+++ b/otherlibs/unix/write.c
@@ -0,0 +1,86 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+#ifndef EAGAIN
+#define EAGAIN (-1)
+#endif
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK (-1)
+#endif
+
+CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
+{
+  long ofs, len, written;
+  int numbytes, ret;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  Begin_root (buf);
+    ofs = Long_val(vofs);
+    len = Long_val(vlen);
+    written = 0;
+    while (len > 0) {
+      numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
+      memmove (iobuf, &Byte(buf, ofs), numbytes);
+      caml_enter_blocking_section();
+      ret = write(Int_val(fd), iobuf, numbytes);
+      caml_leave_blocking_section();
+      if (ret == -1) {
+        if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break;
+        uerror("write", Nothing);
+      }
+      written += ret;
+      ofs += ret;
+      len -= ret;
+    }
+  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);
+      caml_enter_blocking_section();
+      ret = write(Int_val(fd), iobuf, numbytes);
+      caml_leave_blocking_section();
+      if (ret == -1) uerror("single_write", Nothing);
+    }
+  End_roots();
+  return Val_int(ret);
+}
diff --git a/otherlibs/win32graph/Makefile b/otherlibs/win32graph/Makefile
new file mode 100644
index 00000000..244820ba
--- /dev/null
+++ b/otherlibs/win32graph/Makefile
@@ -0,0 +1,38 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+LIBNAME=graphics
+COBJS=open.$(O) draw.$(O) events.$(O)
+CAMLOBJS=graphics.cmo
+WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
+LINKOPTS=-cclib "\"$(WIN32LIBS)\""
+LDOPTS=-ldopt "$(WIN32LIBS)"
+
+include ../Makefile
+
+graphics.ml: ../graph/graphics.ml
+	cp ../graph/graphics.ml graphics.ml
+graphics.mli: ../graph/graphics.mli
+	cp ../graph/graphics.mli graphics.mli
+
+depend:
+
+graphics.cmo: graphics.cmi
+graphics.cmx: graphics.cmi
+draw.$(O): libgraph.h
+open.$(O): libgraph.h
+
+clean:: partialclean
+	rm -f graphics.ml graphics.mli
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
new file mode 100644
index 00000000..39ad54ae
--- /dev/null
+++ b/otherlibs/win32graph/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
new file mode 100644
index 00000000..209b76a6
--- /dev/null
+++ b/otherlibs/win32graph/draw.c
@@ -0,0 +1,648 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Developed by Jacob Navia, based on code by J-M Geffroy and X 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <math.h>
+#include "caml/mlvalues.h"
+#include "caml/alloc.h"
+#include "caml/fail.h"
+#include "libgraph.h"
+#include "caml/custom.h"
+#include "caml/memory.h"
+
+HDC gcMetaFile;
+int grdisplay_mode;
+int grremember_mode;
+GR_WINDOW grwindow;
+
+static void GetCurrentPosition(HDC hDC,POINT *pt)
+{
+        MoveToEx(hDC,0,0,pt);
+        MoveToEx(hDC,pt->x,pt->y,0);
+}
+
+static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry,
+                                 value vstart, value vend, BOOL fill);
+
+CAMLprim value caml_gr_plot(value vx, value vy)
+{
+        int x = Int_val(vx);
+        int y = Int_val(vy);
+        gr_check_open();
+        if(grremember_mode)
+                SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor);
+        if(grdisplay_mode) {
+                SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor);
+        }
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_moveto(value vx, value vy)
+{
+        grwindow.grx = Int_val(vx);
+        grwindow.gry = Int_val(vy);
+        if(grremember_mode)
+                MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0);
+        if (grdisplay_mode)
+                MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0);
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_current_x(value unit)
+{
+        return Val_int(grwindow.grx);
+}
+
+CAMLprim value caml_gr_current_y(value unit)
+{
+        return Val_int(grwindow.gry);
+}
+
+CAMLprim value caml_gr_lineto(value vx, value vy)
+{
+        int x = Int_val(vx);
+        int y = Int_val(vy);
+        gr_check_open();
+        SelectObject(grwindow.gc,grwindow.CurrentPen);
+        SelectObject(grwindow.gcBitmap,grwindow.CurrentPen);
+        if (grremember_mode)
+                LineTo(grwindow.gcBitmap,x,Wcvt(y));
+        if (grdisplay_mode)
+                LineTo(grwindow.gc, x, Wcvt(y));
+        grwindow.grx = x;
+        grwindow.gry = y;
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh)
+{
+        int     x, y, w, h;
+        POINT pt[5];
+        x=Int_val(vx);
+        y=Wcvt(Int_val(vy));
+        w=Int_val(vw);
+        h=Int_val(vh);
+
+        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);
+        }
+        if (grdisplay_mode) {
+                Polyline(grwindow.gc,pt, 5);
+        }
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_draw_text(value text,value x)
+{
+        POINT pt;
+        int oldmode = SetBkMode(grwindow.gc,TRANSPARENT);
+        SetBkMode(grwindow.gcBitmap,TRANSPARENT);
+        SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM);
+        SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM);
+        if (grremember_mode) {
+                TextOut(grwindow.gcBitmap,0,0,(char *)text,x);
+        }
+        if(grdisplay_mode) {
+                TextOut(grwindow.gc,0,0,(char *)text,x);
+        }
+        GetCurrentPosition(grwindow.gc,&pt);
+        grwindow.grx = pt.x;
+        grwindow.gry = grwindow.height - pt.y;
+        SetBkMode(grwindow.gc,oldmode);
+        SetBkMode(grwindow.gcBitmap,oldmode);
+        return Val_unit;
+}
+
+CAMLprim 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);
+        RECT rc;
+
+        gr_check_open();
+        rc.left = x;
+        rc.top = Wcvt(y);
+        rc.right = x+w;
+        rc.bottom = Wcvt(y)-h;
+        if (grdisplay_mode)
+                FillRect(grwindow.gc,&rc,grwindow.CurrentBrush);
+        if (grremember_mode)
+                FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush);
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_sound(value freq, value vdur)
+{
+        Beep(freq,vdur);
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_point_color(value vx, value vy)
+{
+        int x = Int_val(vx);
+        int y = Int_val(vy);
+        COLORREF rgb;
+        unsigned long b,g,r;
+
+        gr_check_open();
+        rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y));
+        b = (unsigned long)((rgb & 0xFF0000) >> 16);
+        g = (unsigned long)((rgb & 0x00FF00) >> 8);
+        r = (unsigned long)(rgb & 0x0000FF);
+        return Val_long((r<<16) + (g<<8) + b);
+}
+
+CAMLprim value caml_gr_circle(value x,value y,value radius)
+{
+        int left,top,right,bottom;
+
+        gr_check_open();
+        left = x - radius/2;
+        top = Wcvt(y) - radius/2;
+        right = left+radius;
+        bottom = top+radius;
+        Ellipse(grwindow.gcBitmap,left,top,right,bottom);
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_set_window_title(value text)
+{
+        SetWindowText(grwindow.hwnd,(char *)text);
+        return Val_unit;
+}
+
+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 caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry,
+                                    value vstart, value vend)
+{
+  return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE);
+}
+
+CAMLprim value caml_gr_set_line_width(value vwidth)
+{
+        int width = Int_val(vwidth);
+        HPEN oldPen,newPen;
+
+        gr_check_open();
+        oldPen = grwindow.CurrentPen;
+        newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor);
+        SelectObject(grwindow.gcBitmap,newPen);
+        SelectObject(grwindow.gc,newPen);
+        DeleteObject(oldPen);
+        grwindow.CurrentPen = newPen;
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_set_color(value vcolor)
+{
+        HBRUSH oldBrush, newBrush;
+        LOGBRUSH lb;
+        LOGPEN pen;
+        HPEN newPen;
+        int color = Long_val(vcolor);
+
+        int  r = (color & 0xFF0000) >> 16,
+        g = (color & 0x00FF00) >> 8 ,
+        b =  color & 0x0000FF;
+        COLORREF c = RGB(r,g,b);
+        memset(&lb,0,sizeof(lb));
+        memset(&pen,0,sizeof(LOGPEN));
+        gr_check_open();
+        GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen);
+        pen.lopnColor = c;
+        newPen = CreatePenIndirect(&pen);
+        SelectObject(grwindow.gcBitmap,newPen);
+        SelectObject(grwindow.gc,newPen);
+        DeleteObject(grwindow.CurrentPen);
+        grwindow.CurrentPen = newPen;
+        SetTextColor(grwindow.gc,c);
+        SetTextColor(grwindow.gcBitmap,c);
+        oldBrush = grwindow.CurrentBrush;
+        lb.lbStyle = BS_SOLID;
+        lb.lbColor = c;
+        newBrush = CreateBrushIndirect(&lb);
+        SelectObject(grwindow.gc,newBrush);
+        SelectObject(grwindow.gcBitmap,newBrush);
+        DeleteObject(oldBrush);
+        grwindow.CurrentBrush = newBrush;
+        grwindow.CurrentColor = c;
+        return Val_unit;
+}
+
+
+static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry,
+                                 value vstart, value vend, BOOL fill)
+{
+        int x, y, r_x, r_y, start, end;
+        int     x1, y1, x2, y2, x3, y3, x4, y4;
+        double cvt = 3.141592653/180.0;
+
+        r_x = Int_val(vrx);
+        r_y = Int_val(vry);
+        if ((r_x < 0) || (r_y < 0))
+                caml_invalid_argument("draw_arc: radius must be positive");
+        x     = Int_val(vx);
+        y     = Int_val(vy);
+        start = Int_val(vstart);
+        end   = Int_val(vend);
+
+        // Upper-left corner of bounding rect.
+        x1=     x - r_x;
+        y1=     y + r_y;
+        // Lower-right corner of bounding rect.
+        x2=     x + r_x;
+        y2=     y - r_y;
+        // Starting point
+        x3=x + (int)(100.0*cos(cvt*start));
+        y3=y + (int)(100.0*sin(cvt*start));
+        // Ending point
+        x4=x + (int)(100.0*cos(cvt*end));
+        y4=y + (int)(100.0*sin(cvt*end));
+
+        if (grremember_mode) {
+                SelectObject(grwindow.gcBitmap,grwindow.CurrentPen);
+                SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
+                if( fill )
+                        Pie(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2),
+                                x3, Wcvt(y3), x4, Wcvt(y4));
+                else
+                        Arc(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2),
+                                x3, Wcvt(y3), x4, Wcvt(y4));
+        }
+        if( grdisplay_mode ) {
+                SelectObject(grwindow.gc,grwindow.CurrentPen);
+                SelectObject(grwindow.gc,grwindow.CurrentBrush);
+                if (fill)
+                        Pie(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2),
+                                x3, Wcvt(y3), x4, Wcvt(y4));
+                else
+                        Arc(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2),
+                                x3, Wcvt(y3), x4, Wcvt(y4));
+        }
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_get_mousex(value unit)
+{
+        POINT pt;
+        GetCursorPos(&pt);
+        MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
+        return pt.x;
+}
+
+CAMLprim value caml_gr_get_mousey(value unit)
+{
+        POINT pt;
+        GetCursorPos(&pt);
+        MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
+        return grwindow.height - pt.y - 1;
+}
+
+
+static void gr_font(char *fontname)
+{
+        HFONT hf = CreationFont(fontname);
+
+        if (hf && hf != INVALID_HANDLE_VALUE) {
+                HFONT oldFont = SelectObject(grwindow.gc,hf);
+                SelectObject(grwindow.gcBitmap,hf);
+                DeleteObject(grwindow.CurrentFont);
+                grwindow.CurrentFont = hf;
+        }
+}
+
+CAMLprim value caml_gr_set_font(value fontname)
+{
+        gr_check_open();
+        gr_font(String_val(fontname));
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_set_text_size (value sz)
+{
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_draw_char(value chr)
+{
+        char str[1];
+        gr_check_open();
+        str[0] = Int_val(chr);
+        caml_gr_draw_text((value)str, 1);
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_draw_string(value str)
+{
+        gr_check_open();
+        caml_gr_draw_text(str, caml_string_length(str));
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_text_size(value str)
+{
+        SIZE extent;
+        value res;
+
+        mlsize_t len = caml_string_length(str);
+        if (len > 32767) len = 32767;
+
+        GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent);
+
+        res = caml_alloc_tuple(2);
+        Field(res, 0) = Val_long(extent.cx);
+        Field(res, 1) = Val_long(extent.cy);
+
+        return res;
+}
+
+CAMLprim value caml_gr_fill_poly(value vect)
+{
+        int n_points, i;
+        POINT   *p,*poly;
+        n_points = Wosize_val(vect);
+        if (n_points < 3)
+                gr_fail("fill_poly: not enough points",0);
+
+        poly = (POINT *)malloc(n_points*sizeof(POINT));
+
+        p = poly;
+        for( i = 0; i < n_points; i++ ){
+                p->x = Int_val(Field(Field(vect,i),0));
+                p->y = Wcvt(Int_val(Field(Field(vect,i),1)));
+                p++;
+        }
+        if (grremember_mode) {
+                SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
+                Polygon(grwindow.gcBitmap,poly,n_points);
+        }
+        if (grdisplay_mode) {
+                SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
+                Polygon(grwindow.gc,poly,n_points);
+        }
+        free(poly);
+
+        return Val_unit;
+}
+
+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 caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry,
+                                    value vstart, value vend)
+{
+  return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE);
+}
+
+// Image primitives
+struct image {
+        int w;
+        int h;
+        HBITMAP data;
+        HBITMAP mask;
+};
+
+#define Width(i) (((struct image *)Data_custom_val(i))->w)
+#define Height(i) (((struct image *)Data_custom_val(i))->h)
+#define Data(i) (((struct image *)Data_custom_val(i))->data)
+#define Mask(i) (((struct image *)Data_custom_val(i))->mask)
+#define Max_image_mem 500000
+
+static void finalize_image (value i)
+{
+        DeleteObject (Data(i));
+        if (Mask(i) != NULL) DeleteObject(Mask(i));
+}
+
+static struct custom_operations image_ops = {
+        "_image",
+        finalize_image,
+        custom_compare_default,
+        custom_hash_default,
+        custom_serialize_default,
+        custom_deserialize_default,
+        custom_compare_ext_default
+};
+
+CAMLprim value caml_gr_create_image(value vw, value vh)
+{
+        HBITMAP cbm;
+        value res;
+        int w = Int_val(vw);
+        int h = Int_val(vh);
+
+        if (w < 0 || h < 0)
+                gr_fail("create_image: width and height must be positive",0);
+
+        cbm = CreateCompatibleBitmap(grwindow.gc, w, h);
+        if (cbm == NULL)
+                gr_fail("create_image: cannot create bitmap", 0);
+        res = caml_alloc_custom(&image_ops, sizeof(struct image),
+                w * h, Max_image_mem);
+        if (res) {
+                Width (res) = w;
+                Height (res) = h;
+                Data (res) = cbm;
+                Mask (res) = NULL;
+        }
+        return res;
+}
+
+CAMLprim value caml_gr_blit_image (value i, value x, value y)
+{
+        HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i));
+        int xsrc = Int_val(x);
+        int ysrc = Wcvt(Int_val(y) + Height(i) - 1);
+        BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i),
+                grwindow.gcBitmap, xsrc, ysrc, SRCCOPY);
+        SelectObject(grwindow.tempDC,oldBmp);
+        return Val_unit;
+}
+
+
+CAMLprim value caml_gr_draw_image(value i, value x, value y)
+{
+        HBITMAP oldBmp;
+
+        int xdst = Int_val(x);
+        int ydst = Wcvt(Int_val(y)+Height(i)-1);
+        if (Mask(i) == NULL) {
+                if (grremember_mode) {
+                        oldBmp = SelectObject(grwindow.tempDC,Data(i));
+                        BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i),
+                               Height(i),
+                                grwindow.tempDC, 0, 0, SRCCOPY);
+                        SelectObject(grwindow.tempDC,oldBmp);
+                }
+                if (grdisplay_mode) {
+                        oldBmp = SelectObject(grwindow.tempDC,Data(i));
+                        BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i),
+                                grwindow.tempDC, 0, 0, SRCCOPY);
+                        SelectObject(grwindow.tempDC,oldBmp);
+                }
+        }
+        else {
+                if (grremember_mode) {
+                        oldBmp = SelectObject(grwindow.tempDC,Mask(i));
+                        BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i),
+                               Height(i),
+                               grwindow.tempDC, 0, 0, SRCAND);
+                        SelectObject(grwindow.tempDC,Data(i));
+                        BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i),
+                               Height(i),
+                               grwindow.tempDC, 0, 0, SRCPAINT);
+                        SelectObject(grwindow.tempDC,oldBmp);
+                }
+                if (grdisplay_mode) {
+                        oldBmp = SelectObject(grwindow.tempDC,Mask(i));
+                        BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i),
+                                grwindow.tempDC, 0, 0, SRCAND);
+                        SelectObject(grwindow.tempDC,Data(i));
+                        BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i),
+                                grwindow.tempDC, 0, 0, SRCPAINT);
+                        SelectObject(grwindow.tempDC,oldBmp);
+                }
+        }
+
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_make_image(value matrix)
+{
+        int width, height,has_transp,i,j;
+        value img;
+        HBITMAP oldBmp;
+        height = Wosize_val(matrix);
+        if (height == 0) {
+                width = 0;
+        }
+        else {
+                width = Wosize_val(Field(matrix, 0));
+                for (i = 1; i < height; i++) {
+                        if (width != (int) Wosize_val(Field(matrix, i)))
+                                gr_fail("make_image: non-rectangular matrix",0);
+                }
+        }
+        Begin_roots1(matrix)
+                img = caml_gr_create_image(Val_int(width), Val_int(height));
+        End_roots();
+        has_transp = 0;
+        oldBmp = SelectObject(grwindow.tempDC,Data(img));
+        for (i = 0; i < height; i++) {
+                for (j = 0; j < width; j++) {
+                        int col = Long_val (Field (Field (matrix, i), j));
+                        if (col == -1){
+                                has_transp = 1;
+                                SetPixel(grwindow.tempDC,j, i, 0);
+                        }
+                        else {
+                                int red = (col >> 16) & 0xFF;
+                                int green = (col >> 8) & 0xFF;
+                                int blue = col & 0xFF;
+                                SetPixel(grwindow.tempDC,j, i,
+                                         RGB(red, green, blue));
+                        }
+                }
+        }
+        SelectObject(grwindow.tempDC,oldBmp);
+        if (has_transp) {
+                HBITMAP  cbm;
+                cbm = CreateCompatibleBitmap(grwindow.gc, width, height);
+                Mask(img) = cbm;
+                oldBmp = SelectObject(grwindow.tempDC,Mask(img));
+                for (i = 0; i < height; i++) {
+                        for (j = 0; j < width; j++) {
+                                int col = Long_val (Field (Field (matrix,i),j));
+                                SetPixel(grwindow.tempDC,j, i,
+                                         col == -1 ? 0xFFFFFF : 0);
+                        }
+                }
+                SelectObject(grwindow.tempDC,oldBmp);
+        }
+        return img;
+}
+
+static value alloc_int_vect(mlsize_t size)
+{
+        value res;
+        mlsize_t i;
+
+        if (size == 0) return Atom(0);
+        if (size <= Max_young_wosize) {
+                res = caml_alloc(size, 0);
+        }
+        else {
+                res = caml_alloc_shr(size, 0);
+        }
+        for (i = 0; i < size; i++) {
+                Field(res, i) = Val_long(0);
+        }
+        return res;
+}
+
+CAMLprim value caml_gr_dump_image (value img)
+{
+        int height = Height(img);
+        int width = Width(img);
+        value matrix = Val_unit;
+        int i, j;
+        HBITMAP oldBmp;
+
+        Begin_roots2(img, matrix)
+                matrix = alloc_int_vect (height);
+        for (i = 0; i < height; i++) {
+                caml_modify (&Field (matrix, i), alloc_int_vect (width));
+        }
+        End_roots();
+
+        oldBmp = SelectObject(grwindow.tempDC,Data(img));
+        for (i = 0; i < height; i++) {
+                for (j = 0; j < width; j++) {
+                        int col = GetPixel(grwindow.tempDC,j, i);
+                        int blue = (col >> 16) & 0xFF;
+                        int green = (col >> 8) & 0xFF;
+                        int red = col & 0xFF;
+                        Field(Field(matrix, i), j) = Val_long((red << 16) +
+                                        (green << 8) + blue);
+                }
+        }
+        SelectObject(grwindow.tempDC,oldBmp);
+        if (Mask(img) != NULL) {
+                oldBmp = SelectObject(grwindow.tempDC,Mask(img));
+                for (i = 0; i < height; i++) {
+                        for (j = 0; j < width; j++) {
+                                if (GetPixel(grwindow.tempDC,j, i) != 0)
+                                        Field(Field(matrix, i), j) =
+                                                Val_long(-1);
+                        }
+                }
+                SelectObject(grwindow.tempDC,oldBmp);
+        }
+        return matrix;
+}
diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
new file mode 100755
index 00000000..810d8632
--- /dev/null
+++ b/otherlibs/win32graph/events.c
@@ -0,0 +1,210 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/mlvalues.h"
+#include "caml/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,
+  EVENT_WINDOW_CLOSED = 16
+};
+
+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;
+  case WM_DESTROY:
+    // Release any calls to Graphics.wait_next_event
+    ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL);
+    break;
+  }
+}
+
+static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y,
+                                          int button,
+                                          int keypressed, int key)
+{
+  value res = caml_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];
+    /* Empty queue means the window was closed */
+    if (QueueIsEmpty) {
+      ev.kind = EVENT_WINDOW_CLOSED;
+    } else {
+      caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
+    }
+    LeaveCriticalSection(&caml_gr_queue_mutex);
+    /* Check if it matches */
+  } while ((ev.kind & mask) == 0);
+
+  if (ev.kind == EVENT_WINDOW_CLOSED) {
+    gr_fail("graphic screen not opened", NULL);
+  }
+
+  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 = EVENT_WINDOW_CLOSED;
+  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
new file mode 100644
index 00000000..674f92f5
--- /dev/null
+++ b/otherlibs/win32graph/libgraph.h
@@ -0,0 +1,78 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <windows.h>
+#include <windowsx.h>
+
+struct canvas {
+  int w, h;                     /* Dimensions of the drawable */
+  HWND win;                     /* The drawable itself */
+  HDC gc;                        /* The associated graphics context */
+};
+
+extern HWND grdisplay;     /* The display connection */
+extern COLORREF grbackground;
+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 HFONT * grfont;          /* Current font */
+
+extern BOOL direct_rgb;
+extern int byte_order;
+extern int bitmap_unit;
+extern int bits_per_pixel;
+
+#define Wcvt(y) (grwindow.height - 1 - (y))
+#define Bcvt(y) (grwindow.height - 1 - (y))
+#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h)
+
+#define DEFAULT_SCREEN_WIDTH 1024
+#define DEFAULT_SCREEN_HEIGHT 768
+#define BORDER_WIDTH 2
+#define WINDOW_NAME "OCaml graphics"
+#define ICON_NAME "OCaml graphics"
+#define SIZE_QUEUE 256
+
+void gr_fail(char *fmt, char *arg);
+void gr_check_open(void);
+CAMLprim value caml_gr_set_color(value vcolor);
+
+// Windows specific definitions
+extern RECT WindowRect;
+extern int grCurrentColor;
+
+typedef struct tagWindow {
+        HDC gc;
+        HDC gcBitmap;
+        HWND hwnd;
+        HBRUSH CurrentBrush;
+        HPEN CurrentPen;
+        DWORD CurrentColor;
+        int width;
+        int height;
+        int grx;
+        int gry;
+        HBITMAP hBitmap;
+        HFONT CurrentFont;
+        int CurrentFontSize;
+        HDC tempDC; // For image operations;
+} GR_WINDOW;
+
+extern GR_WINDOW grwindow;
+HFONT CreationFont(char *name);
+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
new file mode 100644
index 00000000..7e3b77de
--- /dev/null
+++ b/otherlibs/win32graph/open.c
@@ -0,0 +1,372 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Developed by Jacob Navia, based on code by J-M Geffroy and X 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <fcntl.h>
+#include <signal.h>
+#include "caml/mlvalues.h"
+#include "caml/fail.h"
+#include "libgraph.h"
+#include "caml/callback.h"
+#include <windows.h>
+
+static value gr_reset(void);
+static long tid;
+static HANDLE threadHandle;
+HWND grdisplay = NULL;
+int grscreen;
+COLORREF grwhite, grblack;
+COLORREF grbackground;
+int grCurrentColor;
+struct canvas grbstore;
+BOOL grdisplay_mode;
+BOOL grremember_mode;
+int grx, gry;
+int grcolor;
+extern HFONT * grfont;
+MSG msg;
+
+static char *szOcamlWindowClass = "OcamlWindowClass";
+static BOOL gr_initialized = 0;
+CAMLprim value caml_gr_clear_graph(value unit);
+HANDLE hInst;
+
+HFONT CreationFont(char *name)
+{
+   LOGFONT CurrentFont;
+   memset(&CurrentFont, 0, sizeof(LOGFONT));
+   CurrentFont.lfCharSet = ANSI_CHARSET;
+   CurrentFont.lfWeight = FW_NORMAL;
+   CurrentFont.lfHeight = grwindow.CurrentFontSize;
+   CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
+   strncpy(CurrentFont.lfFaceName, name, sizeof(CurrentFont.lfFaceName));
+   CurrentFont.lfFaceName[sizeof(CurrentFont.lfFaceName) - 1] = 0;
+   return (CreateFontIndirect(&CurrentFont));
+}
+
+void SetCoordinates(HWND hwnd)
+{
+        RECT rc;
+
+        GetClientRect(hwnd,&rc);
+        grwindow.width = rc.right;
+        grwindow.height = rc.bottom;
+        gr_reset();
+}
+
+void ResetForClose(HWND hwnd)
+{
+        DeleteDC(grwindow.tempDC);
+        DeleteDC(grwindow.gcBitmap);
+        DeleteObject(grwindow.hBitmap);
+        memset(&grwindow,0,sizeof(grwindow));
+        gr_initialized = 0;
+}
+
+
+
+static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,
+                                        LPARAM lParam)
+{
+        PAINTSTRUCT ps;
+        HDC hdc;
+
+        switch (msg) {
+                // Create the MDI client invisible window
+        case WM_CREATE:
+                break;
+        case WM_PAINT:
+                hdc = BeginPaint(hwnd,&ps);
+                BitBlt(hdc,0,0,grwindow.width,grwindow.height,
+                        grwindow.gcBitmap,0,0,SRCCOPY);
+                EndPaint(hwnd,&ps);
+                break;
+                // Move the child windows
+        case WM_SIZE:
+                // Position the MDI client window between the tool and
+                // status bars
+                if (wParam != SIZE_MINIMIZED) {
+                        SetCoordinates(hwnd);
+                }
+
+                return 0;
+                // End application
+        case WM_DESTROY:
+                ResetForClose(hwnd);
+                break;
+        }
+        caml_gr_handle_event(msg, wParam, lParam);
+        return DefWindowProc(hwnd, msg, wParam, lParam);
+}
+
+int DoRegisterClass(void)
+{
+        WNDCLASS wc;
+
+        memset(&wc,0,sizeof(WNDCLASS));
+        wc.style = CS_HREDRAW|CS_VREDRAW|CS_OWNDC ;
+        wc.lpfnWndProc = (WNDPROC)GraphicsWndProc;
+        wc.hInstance = hInst;
+        wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
+        wc.lpszClassName = szOcamlWindowClass;
+        wc.lpszMenuName = 0;
+        wc.hCursor = LoadCursor(NULL,IDC_ARROW);
+        wc.hIcon = 0;
+        return RegisterClass(&wc);
+}
+
+static value gr_reset(void)
+{
+        RECT rc;
+        int screenx,screeny;
+
+        screenx = GetSystemMetrics(SM_CXSCREEN);
+        screeny = GetSystemMetrics(SM_CYSCREEN);
+        GetClientRect(grwindow.hwnd,&rc);
+        grwindow.gc = GetDC(grwindow.hwnd);
+        grwindow.width = rc.right;
+        grwindow.height = rc.bottom;
+        if (grwindow.gcBitmap == (HDC)0) {
+                grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,
+                                                          screeny);
+                grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc);
+                grwindow.tempDC = CreateCompatibleDC(grwindow.gc);
+                SelectObject(grwindow.gcBitmap,grwindow.hBitmap);
+                SetMapMode(grwindow.gcBitmap,MM_TEXT);
+                MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0);
+                BitBlt(grwindow.gcBitmap,0,0,screenx,screeny,
+                        grwindow.gcBitmap,0,0,WHITENESS);
+                grwindow.CurrentFontSize = 15;
+                grwindow.CurrentFont = CreationFont("Courier");
+        }
+        grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT);
+        grwindow.grx = 0;
+        grwindow.gry = 0;
+        grwindow.CurrentPen = SelectObject(grwindow.gc,
+                                           GetStockObject(WHITE_PEN));
+        SelectObject(grwindow.gc,grwindow.CurrentPen);
+        SelectObject(grwindow.gcBitmap,grwindow.CurrentPen);
+        grwindow.CurrentBrush = SelectObject(grwindow.gc,
+                                             GetStockObject(WHITE_BRUSH));
+        SelectObject(grwindow.gc,grwindow.CurrentBrush);
+        SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
+        caml_gr_set_color(Val_long(0));
+        SelectObject(grwindow.gc,grwindow.CurrentFont);
+        SelectObject(grwindow.gcBitmap,grwindow.CurrentFont);
+        grdisplay_mode = grremember_mode = 1;
+        MoveToEx(grwindow.gc,0,grwindow.height-1,0);
+        MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0);
+        SetTextAlign(grwindow.gcBitmap,TA_BOTTOM);
+        SetTextAlign(grwindow.gc,TA_BOTTOM);
+        return Val_unit;
+}
+
+void SuspendGraphicThread(void)
+{
+        SuspendThread(threadHandle);
+}
+
+void ResumeGraphicThread(void)
+{
+        ResumeThread(threadHandle);
+}
+
+/* For handshake between the event handling thread and the main thread */
+static char * open_graph_errmsg;
+static HANDLE open_graph_event;
+
+static DWORD WINAPI gr_open_graph_internal(value arg)
+{
+  RECT rc;
+  int ret;
+  int event;
+  int x, y, w, h;
+  int screenx,screeny;
+  int attributes;
+  static int registered;
+  MSG msg;
+
+  gr_initialized = TRUE;
+  hInst = GetModuleHandle(NULL);
+  x = y = w = h = CW_USEDEFAULT;
+  sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y);
+
+  /* Open the display */
+  if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) {
+    if (!registered) {
+      registered = DoRegisterClass();
+      if (!registered) {
+        open_graph_errmsg = "Cannot register the window class";
+        SetEvent(open_graph_event);
+        return 1;
+      }
+    }
+    grwindow.hwnd = CreateWindow(szOcamlWindowClass,
+                                 WINDOW_NAME,
+                                 WS_OVERLAPPEDWINDOW,
+                                 x,y,
+                                 w,h,
+                                 NULL,0,hInst,NULL);
+    if (grwindow.hwnd == NULL) {
+      open_graph_errmsg = "Cannot create window";
+      SetEvent(open_graph_event);
+      return 1;
+    }
+#if 0
+    if (x != CW_USEDEFAULT) {
+      rc.left = 0;
+      rc.top = 0;
+      rc.right = w;
+      rc.bottom = h;
+      AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0);
+      MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1);
+    }
+#endif
+  }
+  gr_reset();
+  ShowWindow(grwindow.hwnd,SW_SHOWNORMAL);
+
+  /* Position the current point at origin */
+  grwindow.grx = 0;
+  grwindow.gry = 0;
+
+  caml_gr_init_event_queue();
+
+  /* The global data structures are now correctly initialized.
+     Restart the OCaml main thread. */
+  open_graph_errmsg = NULL;
+  SetEvent(open_graph_event);
+
+  /* Enter the message handling loop */
+  while (GetMessage(&msg,NULL,0,0)) {
+    TranslateMessage(&msg);  // Translates virtual key codes
+    DispatchMessage(&msg);   // Dispatches message to window
+    if (!IsWindow(grwindow.hwnd))
+      break;
+  }
+  return 0;
+}
+
+CAMLprim value caml_gr_open_graph(value arg)
+{
+  DWORD tid;
+  if (gr_initialized) return Val_unit;
+  open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL);
+  threadHandle =
+    CreateThread(NULL,0,
+                 (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg,
+                 0,
+                 &tid);
+  WaitForSingleObject(open_graph_event, INFINITE);
+  CloseHandle(open_graph_event);
+  if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg);
+  return Val_unit;
+}
+
+CAMLprim value caml_gr_close_graph(value unit)
+{
+        if (gr_initialized) {
+                PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0);
+                WaitForSingleObject(threadHandle, INFINITE);
+        }
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_clear_graph(value unit)
+{
+        gr_check_open();
+        if(grremember_mode) {
+                BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height,
+                        grwindow.gcBitmap,0,0,WHITENESS);
+        }
+        if(grdisplay_mode) {
+                BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height,
+                        grwindow.gc,0,0,WHITENESS);
+        }
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_size_x(value unit)
+{
+        gr_check_open();
+        return Val_int(grwindow.width);
+}
+
+CAMLprim value caml_gr_size_y(value unit)
+{
+        gr_check_open();
+        return Val_int(grwindow.height);
+}
+
+CAMLprim value caml_gr_resize_window (value vx, value vy)
+{
+  gr_check_open ();
+
+  /* FIXME TODO implement this function... */
+
+  return Val_unit;
+}
+
+CAMLprim value caml_gr_synchronize(value unit)
+{
+        gr_check_open();
+        BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height,
+                grwindow.gcBitmap,0,0,SRCCOPY);
+        return Val_unit ;
+}
+
+CAMLprim value caml_gr_display_mode(value flag)
+{
+        grdisplay_mode =  (Int_val(flag)) ? 1 : 0;
+        return Val_unit ;
+}
+
+CAMLprim value caml_gr_remember_mode(value flag)
+{
+        grremember_mode = (Int_val(flag)) ? 1 : 0;
+        return Val_unit ;
+}
+
+CAMLprim value caml_gr_sigio_signal(value unit)
+{
+        return Val_unit;
+}
+
+CAMLprim value caml_gr_sigio_handler(value unit)
+{
+        return Val_unit;
+}
+
+
+/* Processing of graphic errors */
+
+static value * graphic_failure_exn = NULL;
+void gr_fail(char *fmt, char *arg)
+{
+  char buffer[1024];
+
+  if (graphic_failure_exn == NULL) {
+    graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
+    if (graphic_failure_exn == NULL)
+      caml_invalid_argument("Exception Graphics.Graphic_failure not initialized, "
+                       "must link graphics.cma");
+  }
+  sprintf(buffer, fmt, arg);
+  caml_raise_with_string(*graphic_failure_exn, buffer);
+}
+
+void gr_check_open(void)
+{
+  if (!gr_initialized) gr_fail("graphic screen not opened", NULL);
+}
diff --git a/otherlibs/win32unix/.depend b/otherlibs/win32unix/.depend
new file mode 100644
index 00000000..a608240c
--- /dev/null
+++ b/otherlibs/win32unix/.depend
@@ -0,0 +1,5 @@
+unix.cmo: unix.cmi
+unix.cmx: unix.cmi
+unixLabels.cmo: unix.cmi unixLabels.cmi
+unixLabels.cmx: unix.cmx unixLabels.cmi
+unixLabels.cmi: unix.cmi
diff --git a/otherlibs/win32unix/Makefile b/otherlibs/win32unix/Makefile
new file mode 100644
index 00000000..3824905b
--- /dev/null
+++ b/otherlibs/win32unix/Makefile
@@ -0,0 +1,67 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Note: since this directory is Windows-specific, it may be good to make sure
+# its content can not be compiled under Unix.
+# This directory could even become a subdirectory of the unix directory.
+
+# Files in this directory
+WIN_FILES = accept.c bind.c channels.c close.c \
+  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
+  getpeername.c getpid.c getsockname.c gettimeofday.c \
+  link.c listen.c lockf.c lseek.c nonblock.c \
+  mkdir.c open.c pipe.c read.c readlink.c rename.c \
+  select.c sendrecv.c \
+  shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
+  symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
+  winlist.c winworker.c windbug.c
+
+# Files from the ../unix directory
+UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
+  cstringv.c envir.c execv.c execve.c execvp.c \
+  exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
+  getnameinfo.c getproto.c \
+  getserv.c gmtime.c putenv.c rmdir.c \
+  socketaddr.c strofaddr.c time.c unlink.c utimes.c
+
+UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
+
+ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
+WSOCKLIB=$(call SYSLIB,ws2_32)
+ADVAPI32LIB=$(call SYSLIB,advapi32)
+
+LIBNAME=unix
+COBJS=$(ALL_FILES:.c=.$(O))
+CAMLOBJS=unix.cmo unixLabels.cmo
+LINKOPTS=-cclib $(WSOCKLIB) -cclib $(ADVAPI32LIB)
+LDOPTS=-ldopt $(WSOCKLIB) -ldopt $(ADVAPI32LIB)
+EXTRACAMLFLAGS=-nolabels
+EXTRACFLAGS=-I../unix
+HEADERS=unixsupport.h socketaddr.h
+
+
+include ../Makefile
+
+clean::
+	rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
+
+$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
+	cp ../unix/$* $*
+
+depend:
+
+$(COBJS): unixsupport.h
+
+include .depend
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/otherlibs/win32unix/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c
new file mode 100644
index 00000000..0a15673e
--- /dev/null
+++ b/otherlibs/win32unix/accept.c
@@ -0,0 +1,53 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+CAMLprim value unix_accept(value cloexec, value sock)
+{
+  SOCKET sconn = Socket_val(sock);
+  SOCKET snew;
+  value fd = Val_unit, adr = Val_unit, res;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+  DWORD err = 0;
+
+  addr_len = sizeof(sock_addr);
+  caml_enter_blocking_section();
+  snew = accept(sconn, &addr.s_gen, &addr_len);
+  if (snew == INVALID_SOCKET) err = WSAGetLastError ();
+  caml_leave_blocking_section();
+  if (snew == INVALID_SOCKET) {
+    win32_maperr(err);
+    uerror("accept", Nothing);
+  }
+  /* This is a best effort, not guaranteed to work, so don't fail on error */
+  SetHandleInformation((HANDLE) snew,
+                       HANDLE_FLAG_INHERIT,
+                       unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
+  Begin_roots2 (fd, adr)
+    fd = win_alloc_socket(snew);
+    adr = alloc_sockaddr(&addr, addr_len, snew);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = fd;
+    Field(res, 1) = adr;
+  End_roots();
+  return res;
+}
diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c
new file mode 100644
index 00000000..b852f93f
--- /dev/null
+++ b/otherlibs/win32unix/bind.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+CAMLprim value unix_bind(socket, address)
+     value socket, address;
+{
+  int ret;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  get_sockaddr(address, &addr, &addr_len);
+  ret = bind(Socket_val(socket), &addr.s_gen, addr_len);
+  if (ret == -1) {
+    win32_maperr(WSAGetLastError());
+    uerror("bind", Nothing);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
new file mode 100644
index 00000000..0347bd38
--- /dev/null
+++ b/otherlibs/win32unix/channels.c
@@ -0,0 +1,100 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/io.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+#include <fcntl.h>
+#include <io.h>
+
+#if defined(_MSC_VER) && !defined(_INTPTR_T_DEFINED)
+typedef int intptr_t;
+#define _INTPTR_T_DEFINED
+#endif
+
+int win_CRT_fd_of_filedescr(value handle)
+{
+  if (CRT_fd_val(handle) != NO_CRT_FD) {
+    return CRT_fd_val(handle);
+  } else {
+    int fd = _open_osfhandle((intptr_t) Handle_val(handle), O_BINARY);
+    if (fd == -1) uerror("channel_of_descr", Nothing);
+    CRT_fd_val(handle) = fd;
+    return fd;
+  }
+}
+
+CAMLprim value win_inchannel_of_filedescr(value handle)
+{
+  CAMLparam1(handle);
+  CAMLlocal1(vchan);
+  struct channel * chan;
+
+#if defined(_MSC_VER) && _MSC_VER < 1400
+  fflush(stdin);
+#endif
+  chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle));
+  if (Descr_kind_val(handle) == KIND_SOCKET)
+    chan->flags |= CHANNEL_FLAG_FROM_SOCKET;
+  vchan = caml_alloc_channel(chan);
+  CAMLreturn(vchan);
+}
+
+CAMLprim value win_outchannel_of_filedescr(value handle)
+{
+  CAMLparam1(handle);
+  CAMLlocal1(vchan);
+  int fd;
+  struct channel * chan;
+
+  chan = caml_open_descriptor_out(win_CRT_fd_of_filedescr(handle));
+  if (Descr_kind_val(handle) == KIND_SOCKET)
+    chan->flags |= CHANNEL_FLAG_FROM_SOCKET;
+  vchan = caml_alloc_channel(chan);
+  CAMLreturn(vchan);
+}
+
+CAMLprim value win_filedescr_of_channel(value vchan)
+{
+  CAMLparam1(vchan);
+  CAMLlocal1(fd);
+  struct channel * chan;
+  HANDLE h;
+
+  chan = Channel(vchan);
+  if (chan->fd == -1) uerror("descr_of_channel", Nothing);
+  h = (HANDLE) _get_osfhandle(chan->fd);
+  if (chan->flags & CHANNEL_FLAG_FROM_SOCKET)
+    fd = win_alloc_socket((SOCKET) h);
+  else
+    fd = win_alloc_handle(h);
+  CRT_fd_val(fd) = chan->fd;
+  CAMLreturn(fd);
+}
+
+CAMLprim value win_handle_fd(value vfd)
+{
+  int crt_fd = Int_val(vfd);
+  /* PR#4750: do not use the _or_socket variant as it can cause performance
+     degradation and this function is only used with the standard
+     handles 0, 1, 2, which are not sockets. */
+  value res = win_alloc_handle((HANDLE) _get_osfhandle(crt_fd));
+  CRT_fd_val(res) = crt_fd;
+  return res;
+}
diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c
new file mode 100644
index 00000000..289e3b11
--- /dev/null
+++ b/otherlibs/win32unix/close.c
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include <caml/io.h>
+
+CAMLprim value unix_close(value fd)
+{
+  if (Descr_kind_val(fd) == KIND_SOCKET) {
+    if (closesocket(Socket_val(fd)) != 0) {
+      win32_maperr(WSAGetLastError());
+      uerror("close", Nothing);
+    }
+  } else {
+    /* If we have an fd then closing it also closes
+     * the underlying handle. Also, closing only
+     * the handle and not the fd leads to fd leaks. */
+    if (CRT_fd_val(fd) != NO_CRT_FD) {
+      if (_close(CRT_fd_val(fd)) != 0)
+         uerror("close", Nothing);
+    } else {
+      if (! CloseHandle(Handle_val(fd))) {
+        win32_maperr(GetLastError());
+        uerror("close", Nothing);
+      }
+    }
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c
new file mode 100644
index 00000000..79dd56a8
--- /dev/null
+++ b/otherlibs/win32unix/close_on.c
@@ -0,0 +1,43 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include <windows.h>
+
+int win_set_inherit(value fd, BOOL inherit)
+{
+  /* According to the MSDN, SetHandleInformation may not work
+     for console handles on WinNT4 and earlier versions. */
+  if (! SetHandleInformation(Handle_val(fd),
+                             HANDLE_FLAG_INHERIT,
+                             inherit ? HANDLE_FLAG_INHERIT : 0)) {
+    win32_maperr(GetLastError());
+    return -1;
+  }
+  return 0;
+}
+
+CAMLprim value win_set_close_on_exec(value fd)
+{
+  if (win_set_inherit(fd, FALSE) == -1) uerror("set_close_on_exec", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value win_clear_close_on_exec(value fd)
+{
+  if (win_set_inherit(fd, TRUE) == -1) uerror("clear_close_on_exec", Nothing);
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c
new file mode 100644
index 00000000..9ce86c03
--- /dev/null
+++ b/otherlibs/win32unix/connect.c
@@ -0,0 +1,39 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+CAMLprim value unix_connect(socket, address)
+     value socket, address;
+{
+  SOCKET s = Socket_val(socket);
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+  DWORD err = 0;
+
+  get_sockaddr(address, &addr, &addr_len);
+  caml_enter_blocking_section();
+  if (connect(s, &addr.s_gen, addr_len) == -1)
+    err = WSAGetLastError();
+  caml_leave_blocking_section();
+  if (err) {
+    win32_maperr(err);
+    uerror("connect", Nothing);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c
new file mode 100644
index 00000000..8c855aa1
--- /dev/null
+++ b/otherlibs/win32unix/createprocess.c
@@ -0,0 +1,124 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include "unixsupport.h"
+#include <windows.h>
+#include <caml/osdeps.h>
+#include <errno.h>
+
+static int win_has_console(void);
+
+value win_create_process_native(value cmd, value cmdline, value env,
+                                value fd1, value fd2, value fd3)
+{
+  PROCESS_INFORMATION pi;
+  STARTUPINFO si;
+  char * exefile, * envp;
+  DWORD flags, err;
+  HANDLE hp;
+
+  caml_unix_check_path(cmd, "create_process");
+  if (! caml_string_is_c_safe(cmdline))
+    unix_error(EINVAL, "create_process", cmdline);
+  /* [env] is checked for null bytes at construction time, see unix.ml */
+
+  err = ERROR_SUCCESS;
+  exefile = caml_search_exe_in_path(String_val(cmd));
+  if (env != Val_int(0)) {
+    envp = String_val(Field(env, 0));
+  } else {
+    envp = NULL;
+  }
+  /* Prepare stdin/stdout/stderr redirection */
+  ZeroMemory(&si, sizeof(STARTUPINFO));
+  si.cb = sizeof(STARTUPINFO);
+  si.dwFlags = STARTF_USESTDHANDLES;
+  /* Duplicate the handles fd1, fd2, fd3 to make sure they are inheritable */
+  hp = GetCurrentProcess();
+  if (! DuplicateHandle(hp, Handle_val(fd1), hp, &(si.hStdInput),
+                        0, TRUE, DUPLICATE_SAME_ACCESS)) {
+    err = GetLastError(); goto ret1;
+  }
+  if (! DuplicateHandle(hp, Handle_val(fd2), hp, &(si.hStdOutput),
+                        0, TRUE, DUPLICATE_SAME_ACCESS)) {
+    err = GetLastError(); goto ret2;
+  }
+  if (! DuplicateHandle(hp, Handle_val(fd3), hp, &(si.hStdError),
+                        0, TRUE, DUPLICATE_SAME_ACCESS)) {
+    err = GetLastError(); goto ret3;
+  }
+  /* If we do not have a console window, then we must create one
+     before running the process (keep it hidden for apparence).
+     If we are starting a GUI application, the newly created
+     console should not matter. */
+  if (win_has_console())
+    flags = 0;
+  else {
+    flags = CREATE_NEW_CONSOLE;
+    si.dwFlags = (STARTF_USESHOWWINDOW | STARTF_USESTDHANDLES);
+    si.wShowWindow = SW_HIDE;
+  }
+  /* Create the process */
+  if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL,
+                      TRUE, flags, envp, NULL, &si, &pi)) {
+    err = GetLastError(); goto ret4;
+  }
+  CloseHandle(pi.hThread);
+ ret4:
+  CloseHandle(si.hStdError);
+ ret3:
+  CloseHandle(si.hStdOutput);
+ ret2:
+  CloseHandle(si.hStdInput);
+ ret1:
+  caml_stat_free(exefile);
+  if (err != ERROR_SUCCESS) {
+    win32_maperr(err);
+    uerror("create_process", cmd);
+  }
+  /* Return the process handle as pseudo-PID
+     (this is consistent with the wait() emulation in the MSVC C library */
+  return Val_long(pi.hProcess);
+}
+
+CAMLprim value win_create_process(value * argv, int argn)
+{
+  return win_create_process_native(argv[0], argv[1], argv[2],
+                                   argv[3], argv[4], argv[5]);
+}
+
+static int win_has_console(void)
+{
+  HANDLE h, log;
+  int i;
+
+  h = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
+                 OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+  if (h == INVALID_HANDLE_VALUE) {
+    return 0;
+  } else {
+    CloseHandle(h);
+    return 1;
+  }
+}
+
+CAMLprim value win_terminate_process(value v_pid)
+{
+  return (Val_bool(TerminateProcess((HANDLE) Long_val(v_pid), 0)));
+}
diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c
new file mode 100644
index 00000000..c02153b5
--- /dev/null
+++ b/otherlibs/win32unix/dup.c
@@ -0,0 +1,35 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_dup(value cloexec, value fd)
+{
+  HANDLE newh;
+  value newfd;
+  int kind = Descr_kind_val(fd);
+  if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd),
+                        GetCurrentProcess(), &newh,
+                        0L,
+                        unix_cloexec_p(cloexec) ? FALSE : TRUE,
+                        DUPLICATE_SAME_ACCESS)) {
+    win32_maperr(GetLastError());
+    return -1;
+  }
+  newfd = win_alloc_handle(newh);
+  Descr_kind_val(newfd) = kind;
+  return newfd;
+}
diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c
new file mode 100644
index 00000000..44ff41d6
--- /dev/null
+++ b/otherlibs/win32unix/dup2.c
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_dup2(value cloexec, value fd1, value fd2)
+{
+  HANDLE oldh, newh;
+
+  oldh = Handle_val(fd2);
+  if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1),
+                        GetCurrentProcess(), &newh,
+                        0L,
+                        unix_cloexec_p(cloexec) ? FALSE : TRUE,
+                        DUPLICATE_SAME_ACCESS)) {
+    win32_maperr(GetLastError());
+    return -1;
+  }
+  Handle_val(fd2) = newh;
+  if (Descr_kind_val(fd2) == KIND_SOCKET)
+    closesocket((SOCKET) oldh);
+  else
+    CloseHandle(oldh);
+  Descr_kind_val(fd2) = Descr_kind_val(fd1);
+  /* Reflect the dup2 on the CRT fds, if any */
+  if (CRT_fd_val(fd1) != NO_CRT_FD || CRT_fd_val(fd2) != NO_CRT_FD)
+    _dup2(win_CRT_fd_of_filedescr(fd1), win_CRT_fd_of_filedescr(fd2));
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
new file mode 100644
index 00000000..16a93ed4
--- /dev/null
+++ b/otherlibs/win32unix/errmsg.c
@@ -0,0 +1,43 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+
+extern int error_table[];
+
+CAMLprim value unix_error_message(value err)
+{
+  int errnum;
+  char buffer[512];
+
+  errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
+  if (errnum > 0)
+    return caml_copy_string(strerror(errnum));
+  if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
+                    NULL,
+                    -errnum,
+                    0,
+                    buffer,
+                    sizeof(buffer),
+                    NULL))
+    return caml_copy_string(buffer);
+  sprintf(buffer, "unknown error #%d", errnum);
+  return caml_copy_string(buffer);
+}
diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c
new file mode 100644
index 00000000..d022a847
--- /dev/null
+++ b/otherlibs/win32unix/getpeername.c
@@ -0,0 +1,35 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+CAMLprim value unix_getpeername(sock)
+     value sock;
+{
+  int retcode;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  addr_len = sizeof(sock_addr);
+  retcode = getpeername(Socket_val(sock),
+                        &addr.s_gen, &addr_len);
+  if (retcode == -1) {
+    win32_maperr(WSAGetLastError());
+    uerror("getpeername", Nothing);
+  }
+  return alloc_sockaddr(&addr, addr_len, -1);
+}
diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c
new file mode 100644
index 00000000..71e9c141
--- /dev/null
+++ b/otherlibs/win32unix/getpid.c
@@ -0,0 +1,24 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+extern value val_process_id;
+
+CAMLprim value unix_getpid(value unit)
+{
+  return val_process_id;
+}
diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c
new file mode 100644
index 00000000..6df6adfb
--- /dev/null
+++ b/otherlibs/win32unix/getsockname.c
@@ -0,0 +1,32 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+CAMLprim value unix_getsockname(sock)
+     value sock;
+{
+  int retcode;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+
+  addr_len = sizeof(sock_addr);
+  retcode = getsockname(Socket_val(sock),
+                        &addr.s_gen, &addr_len);
+  if (retcode == -1) uerror("getsockname", Nothing);
+  return alloc_sockaddr(&addr, addr_len, -1);
+}
diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
new file mode 100644
index 00000000..20f62a1f
--- /dev/null
+++ b/otherlibs/win32unix/gettimeofday.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <time.h>
+
+#include "unixsupport.h"
+
+/* Unix epoch as a Windows timestamp in hundreds of ns */
+#define epoch_ft 116444736000000000.0;
+
+CAMLprim value unix_gettimeofday(value unit)
+{
+  FILETIME ft;
+  double tm;
+  GetSystemTimeAsFileTime(&ft);
+#if defined(_MSC_VER) && _MSC_VER < 1300
+  /* This compiler can't cast uint64_t to double! Fortunately, this doesn't
+     matter since SYSTEMTIME is only ever 63-bit (maximum value 31-Dec-30827
+     23:59:59.999, and it requires some skill to set the clock past 2099!)
+   */
+  tm = *(int64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
+#else
+  tm = *(uint64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
+#endif
+  return caml_copy_double(tm * 1e-7);  /* tm is in 100ns */
+}
diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c
new file mode 100644
index 00000000..54897de1
--- /dev/null
+++ b/otherlibs/win32unix/link.c
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                  File contributed by Lionel Fourquaux                  */
+/*                                                                        */
+/*   Copyright 2001 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+#include <windows.h>
+
+typedef
+BOOL (WINAPI *tCreateHardLink)(
+  LPCTSTR lpFileName,
+  LPCTSTR lpExistingFileName,
+  LPSECURITY_ATTRIBUTES lpSecurityAttributes
+);
+
+CAMLprim value unix_link(value path1, value path2)
+{
+  HMODULE hModKernel32;
+  tCreateHardLink pCreateHardLink;
+  hModKernel32 = GetModuleHandle("KERNEL32.DLL");
+  pCreateHardLink =
+    (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA");
+  if (pCreateHardLink == NULL)
+    caml_invalid_argument("Unix.link not implemented");
+  caml_unix_check_path(path1, "link");
+  caml_unix_check_path(path2, "link");
+  if (! pCreateHardLink(String_val(path2), String_val(path1), NULL)) {
+    win32_maperr(GetLastError());
+    uerror("link", path2);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c
new file mode 100644
index 00000000..364b4be4
--- /dev/null
+++ b/otherlibs/win32unix/listen.c
@@ -0,0 +1,27 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_listen(sock, backlog)
+     value sock, backlog;
+{
+  if (listen(Socket_val(sock), Int_val(backlog)) == -1) {
+    win32_maperr(WSAGetLastError());
+    uerror("listen", Nothing);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c
new file mode 100644
index 00000000..83bf4a96
--- /dev/null
+++ b/otherlibs/win32unix/lockf.c
@@ -0,0 +1,160 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*    Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com>    */
+/*                  Further improvements by Reed Wilson                   */
+/*                                                                        */
+/*   Copyright 2002 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <fcntl.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+#include <stdio.h>
+#include <caml/signals.h>
+
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER (-1)
+#endif
+
+/* Sets handle h to a position based on gohere */
+/* output, if set, is changed to the new location */
+
+static void set_file_pointer(HANDLE h, LARGE_INTEGER gohere,
+                             PLARGE_INTEGER output, DWORD method)
+{
+  LONG high = gohere.HighPart;
+  DWORD ret = SetFilePointer(h, gohere.LowPart, &high, method);
+  if(ret == INVALID_SET_FILE_POINTER) {
+    DWORD err = GetLastError();
+    if(err != NO_ERROR) {
+      win32_maperr(err);
+      uerror("lockf", Nothing);
+    }
+  }
+  if(output != NULL) {
+    output->LowPart = ret;
+    output->HighPart = high;
+  }
+}
+
+CAMLprim value unix_lockf(value fd, value cmd, value span)
+{
+  CAMLparam3(fd, cmd, span);
+  OVERLAPPED overlap;
+  intnat l_len;
+  HANDLE h;
+  OSVERSIONINFO version;
+  LARGE_INTEGER cur_position;
+  LARGE_INTEGER beg_position;
+  LARGE_INTEGER lock_len;
+  LARGE_INTEGER zero;
+  DWORD err = NO_ERROR;
+
+  version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+  if(GetVersionEx(&version) == 0) {
+    caml_invalid_argument("lockf only supported on WIN32_NT platforms:"
+                     " could not determine current platform.");
+  }
+  if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) {
+    caml_invalid_argument("lockf only supported on WIN32_NT platforms");
+  }
+
+  h = Handle_val(fd);
+
+  l_len = Long_val(span);
+
+  /* No matter what, we need the current position in the file */
+  zero.HighPart = zero.LowPart = 0;
+  set_file_pointer(h, zero, &cur_position, FILE_CURRENT);
+
+  /* All unused fields must be set to zero */
+  memset(&overlap, 0, sizeof(overlap));
+
+  if(l_len == 0) {
+    /* Lock from cur to infinity */
+    lock_len.QuadPart = -1;
+    overlap.OffsetHigh = cur_position.HighPart;
+    overlap.Offset     = cur_position.LowPart ;
+  }
+  else if(l_len > 0) {
+    /* Positive file offset */
+    lock_len.QuadPart = l_len;
+    overlap.OffsetHigh = cur_position.HighPart;
+    overlap.Offset     = cur_position.LowPart ;
+  }
+  else {
+    /* Negative file offset */
+    lock_len.QuadPart = - l_len;
+    if (lock_len.QuadPart > cur_position.QuadPart) {
+      errno = EINVAL;
+      uerror("lockf", Nothing);
+    }
+    beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart;
+    overlap.OffsetHigh = beg_position.HighPart;
+    overlap.Offset     = beg_position.LowPart ;
+  }
+
+  switch(Int_val(cmd)) {
+  case 0: /* F_ULOCK - unlock */
+    if (! UnlockFileEx(h, 0,
+                       lock_len.LowPart, lock_len.HighPart, &overlap))
+      err = GetLastError();
+    break;
+  case 1: /* F_LOCK - blocking write lock */
+    caml_enter_blocking_section();
+    if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0,
+                     lock_len.LowPart, lock_len.HighPart, &overlap))
+      err = GetLastError();
+    caml_leave_blocking_section();
+    break;
+  case 2: /* F_TLOCK - non-blocking write lock */
+    if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
+                     lock_len.LowPart, lock_len.HighPart, &overlap))
+      err = GetLastError();
+    break;
+  case 3: /* F_TEST - check whether a write lock can be obtained */
+    /*  I'm doing this by aquiring an immediate write
+     * lock and then releasing it. It is not clear that
+     * this behavior matches anything in particular, but
+     * it is not clear the nature of the lock test performed
+     * by ocaml (unix) currently. */
+    if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
+                   lock_len.LowPart, lock_len.HighPart, &overlap)) {
+      UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap);
+    } else {
+      err = GetLastError();
+    }
+    break;
+  case 4: /* F_RLOCK - blocking read lock */
+    caml_enter_blocking_section();
+    if (! LockFileEx(h, 0, 0,
+                     lock_len.LowPart, lock_len.HighPart, &overlap))
+      err = GetLastError();
+    caml_leave_blocking_section();
+    break;
+  case 5: /* F_TRLOCK - non-blocking read lock */
+    if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0,
+                     lock_len.LowPart, lock_len.HighPart, &overlap))
+      err = GetLastError();
+    break;
+  default:
+    errno = EINVAL;
+    uerror("lockf", Nothing);
+  }
+  if (err != NO_ERROR) {
+    win32_maperr(err);
+    uerror("lockf", Nothing);
+  }
+  CAMLreturn(Val_unit);
+}
diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c
new file mode 100644
index 00000000..79639870
--- /dev/null
+++ b/otherlibs/win32unix/lseek.c
@@ -0,0 +1,70 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#else
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+
+static DWORD seek_command_table[] = {
+  FILE_BEGIN, FILE_CURRENT, FILE_END
+};
+
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER (-1)
+#endif
+
+static __int64 caml_set_file_pointer(HANDLE h, __int64 dist, DWORD mode)
+{
+  LARGE_INTEGER i;
+  DWORD err;
+
+  i.QuadPart = dist;
+  i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode);
+  if (i.LowPart == INVALID_SET_FILE_POINTER) {
+    err = GetLastError();
+    if (err != NO_ERROR) { win32_maperr(err); uerror("lseek", Nothing); }
+  }
+  return i.QuadPart;
+}
+
+CAMLprim value unix_lseek(value fd, value ofs, value cmd)
+{
+  __int64 ret;
+
+  ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs),
+                              seek_command_table[Int_val(cmd)]);
+  if (ret > Max_long) {
+    win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
+    uerror("lseek", Nothing);
+  }
+  return Val_long(ret);
+}
+
+CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
+{
+  __int64 ret;
+
+  ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs),
+                              seek_command_table[Int_val(cmd)]);
+  return caml_copy_int64(ret);
+}
diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c
new file mode 100644
index 00000000..7aaf040a
--- /dev/null
+++ b/otherlibs/win32unix/mkdir.c
@@ -0,0 +1,25 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_mkdir(path, perm)
+     value path, perm;
+{
+  caml_unix_check_path(path, "mkdir");
+  if (_mkdir(String_val(path)) == -1) uerror("mkdir", path);
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c
new file mode 100755
index 00000000..599445e6
--- /dev/null
+++ b/otherlibs/win32unix/nonblock.c
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2002 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_set_nonblock(socket)
+     value socket;
+{
+  u_long non_block = 1;
+
+  if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) {
+    win32_maperr(WSAGetLastError());
+    uerror("unix_set_nonblock", Nothing);
+  }
+  Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING;
+  return Val_unit;
+}
+
+CAMLprim value unix_clear_nonblock(socket)
+     value socket;
+{
+  u_long non_block = 0;
+
+  if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) {
+    win32_maperr(WSAGetLastError());
+    uerror("unix_clear_nonblock", Nothing);
+  }
+  Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING;
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c
new file mode 100644
index 00000000..cff95259
--- /dev/null
+++ b/otherlibs/win32unix/open.c
@@ -0,0 +1,84 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+#include <fcntl.h>
+
+static int open_access_flags[15] = {
+  GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+};
+
+static int open_create_flags[15] = {
+  0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0, 0
+};
+
+static int open_share_flags[15] = {
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0, 0
+};
+
+enum { CLOEXEC = 1, KEEPEXEC = 2 };
+
+static int open_cloexec_flags[15] = {
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, CLOEXEC, KEEPEXEC
+};
+
+CAMLprim value unix_open(value path, value flags, value perm)
+{
+  int fileaccess, createflags, fileattrib, filecreate, sharemode, cloexec;
+  SECURITY_ATTRIBUTES attr;
+  HANDLE h;
+
+  caml_unix_check_path(path, "open");
+  fileaccess = caml_convert_flag_list(flags, open_access_flags);
+  sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE
+              | caml_convert_flag_list(flags, open_share_flags);
+
+  createflags = caml_convert_flag_list(flags, open_create_flags);
+  if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
+    filecreate = CREATE_NEW;
+  else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC))
+    filecreate = CREATE_ALWAYS;
+  else if (createflags & O_TRUNC)
+    filecreate = TRUNCATE_EXISTING;
+  else if (createflags & O_CREAT)
+    filecreate = OPEN_ALWAYS;
+  else
+    filecreate = OPEN_EXISTING;
+
+  if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0)
+    fileattrib = FILE_ATTRIBUTE_READONLY;
+  else
+    fileattrib = FILE_ATTRIBUTE_NORMAL;
+
+  cloexec = caml_convert_flag_list(flags, open_cloexec_flags);
+  attr.nLength = sizeof(attr);
+  attr.lpSecurityDescriptor = NULL;
+  attr.bInheritHandle =
+    cloexec & CLOEXEC ? FALSE
+                      : cloexec & KEEPEXEC ? TRUE
+                                           : !unix_cloexec_default;
+
+  h = CreateFile(String_val(path), fileaccess,
+                 sharemode, &attr,
+                 filecreate, fileattrib, NULL);
+  if (h == INVALID_HANDLE_VALUE) {
+    win32_maperr(GetLastError());
+    uerror("open", path);
+  }
+  return win_alloc_handle(h);
+}
diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c
new file mode 100644
index 00000000..a48c686a
--- /dev/null
+++ b/otherlibs/win32unix/pipe.c
@@ -0,0 +1,46 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+#include <fcntl.h>
+
+/* PR#4749: pick a size that matches that of I/O buffers */
+#define SIZEBUF 4096
+
+CAMLprim value unix_pipe(value cloexec, value unit)
+{
+  SECURITY_ATTRIBUTES attr;
+  HANDLE readh, writeh;
+  value readfd = Val_unit, writefd = Val_unit, res;
+
+  attr.nLength = sizeof(attr);
+  attr.lpSecurityDescriptor = NULL;
+  attr.bInheritHandle = unix_cloexec_p(cloexec) ? FALSE : TRUE;
+  if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
+    win32_maperr(GetLastError());
+    uerror("pipe", Nothing);
+  }
+  Begin_roots2(readfd, writefd)
+    readfd = win_alloc_handle(readh);
+    writefd = win_alloc_handle(writeh);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = readfd;
+    Field(res, 1) = writefd;
+  End_roots();
+  return res;
+}
diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c
new file mode 100644
index 00000000..a96951e4
--- /dev/null
+++ b/otherlibs/win32unix/read.c
@@ -0,0 +1,61 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_read(value fd, value buf, value ofs, value vlen)
+{
+  intnat len;
+  DWORD numbytes, numread;
+  char iobuf[UNIX_BUFFER_SIZE];
+  DWORD err = 0;
+
+  Begin_root (buf);
+    len = Long_val(vlen);
+    numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
+    if (Descr_kind_val(fd) == KIND_SOCKET) {
+      int ret;
+      SOCKET s = Socket_val(fd);
+      caml_enter_blocking_section();
+      ret = recv(s, iobuf, numbytes, 0);
+      if (ret == SOCKET_ERROR) err = WSAGetLastError();
+      caml_leave_blocking_section();
+      numread = ret;
+    } else {
+      HANDLE h = Handle_val(fd);
+      caml_enter_blocking_section();
+      if (! ReadFile(h, iobuf, numbytes, &numread, NULL))
+        err = GetLastError();
+      caml_leave_blocking_section();
+    }
+    if (err) {
+      if (err == ERROR_BROKEN_PIPE) {
+        // The write handle for an anonymous pipe has been closed. We match the
+        // Unix behavior, and treat this as a zero-read instead of a Unix_error.
+        err = 0;
+        numread = 0;
+      } else {
+        win32_maperr(err);
+        uerror("read", Nothing);
+      }
+    }
+    memmove (&Byte(buf, Long_val(ofs)), iobuf, numread);
+  End_roots();
+  return Val_int(numread);
+}
diff --git a/otherlibs/win32unix/readlink.c b/otherlibs/win32unix/readlink.c
new file mode 100644
index 00000000..7b20614c
--- /dev/null
+++ b/otherlibs/win32unix/readlink.c
@@ -0,0 +1,112 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                David Allsopp, MetaStack Solutions Ltd.                 */
+/*                                                                        */
+/*   Copyright 2015 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <errno.h>
+#include <winioctl.h>
+
+CAMLprim value unix_readlink(value opath)
+{
+  CAMLparam1(opath);
+  CAMLlocal1(result);
+  HANDLE h;
+  char* path;
+  DWORD attributes;
+  caml_unix_check_path(opath, "readlink");
+  path = caml_strdup(String_val(opath));
+
+  caml_enter_blocking_section();
+  attributes = GetFileAttributes(path);
+  caml_leave_blocking_section();
+
+  if (attributes == INVALID_FILE_ATTRIBUTES) {
+    caml_stat_free(path);
+    win32_maperr(GetLastError());
+    uerror("readlink", opath);
+  }
+  else if (!(attributes & FILE_ATTRIBUTE_REPARSE_POINT)) {
+    caml_stat_free(path);
+    errno = EINVAL;
+    uerror("readlink", opath);
+  }
+  else {
+    caml_enter_blocking_section();
+    if ((h = CreateFile(path,
+                        FILE_READ_ATTRIBUTES,
+                        FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
+                        NULL,
+                        OPEN_EXISTING,
+                        FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
+                        NULL)) == INVALID_HANDLE_VALUE) {
+      caml_leave_blocking_section();
+      caml_stat_free(path);
+      errno = ENOENT;
+      uerror("readlink", opath);
+    }
+    else {
+      char buffer[16384];
+      DWORD read;
+      REPARSE_DATA_BUFFER* point;
+
+      caml_stat_free(path);
+
+      if (DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, 16384, &read, NULL)) {
+        caml_leave_blocking_section();
+        point = (REPARSE_DATA_BUFFER*)buffer;
+        if (point->ReparseTag == IO_REPARSE_TAG_SYMLINK) {
+          int cbLen = point->SymbolicLinkReparseBuffer.SubstituteNameLength / sizeof(WCHAR);
+          int len;
+          len = WideCharToMultiByte(
+                  CP_THREAD_ACP,
+                  0,
+                  point->SymbolicLinkReparseBuffer.PathBuffer + point->SymbolicLinkReparseBuffer.SubstituteNameOffset / 2,
+                  cbLen,
+                  NULL,
+                  0,
+                  NULL,
+                  NULL);
+          result = caml_alloc_string(len);
+          WideCharToMultiByte(
+            CP_THREAD_ACP,
+            0,
+            point->SymbolicLinkReparseBuffer.PathBuffer + point->SymbolicLinkReparseBuffer.SubstituteNameOffset / 2,
+            cbLen,
+            String_val(result),
+            len,
+            NULL,
+            NULL);
+          CloseHandle(h);
+        }
+        else {
+          errno = EINVAL;
+          CloseHandle(h);
+          uerror("readline", opath);
+        }
+      }
+      else {
+        caml_leave_blocking_section();
+        win32_maperr(GetLastError());
+        CloseHandle(h);
+        uerror("readlink", opath);
+      }
+    }
+  }
+
+  CAMLreturn(result);
+}
diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
new file mode 100644
index 00000000..155a73fb
--- /dev/null
+++ b/otherlibs/win32unix/rename.c
@@ -0,0 +1,45 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com>     */
+/*                                                                        */
+/*   Copyright 2002 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_rename(value path1, value path2)
+{
+  static int supports_MoveFileEx = -1; /* don't know yet */
+  BOOL ok;
+
+  caml_unix_check_path(path1, "rename");
+  caml_unix_check_path(path2, "rename");
+  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);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
new file mode 100644
index 00000000..dd263869
--- /dev/null
+++ b/otherlibs/win32unix/select.c
@@ -0,0 +1,1330 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include "winworker.h"
+#include <stdio.h>
+#include "windbug.h"
+#include "winlist.h"
+
+/* This constant define the maximum number of objects that
+ * can be handle by a SELECTDATA.
+ * It takes the following parameters into account:
+ * - limitation on number of objects is mostly due to limitation
+ *   a WaitForMultipleObjects
+ * - there is always an event "hStop" to watch
+ *
+ * This lead to pick the following value as the biggest possible
+ * value
+ */
+#define MAXIMUM_SELECT_OBJECTS (MAXIMUM_WAIT_OBJECTS - 1)
+
+/* Manage set of handle */
+typedef struct _SELECTHANDLESET {
+  LPHANDLE lpHdl;
+  DWORD    nMax;
+  DWORD    nLast;
+} SELECTHANDLESET;
+
+typedef SELECTHANDLESET *LPSELECTHANDLESET;
+
+void handle_set_init (LPSELECTHANDLESET hds, LPHANDLE lpHdl, DWORD max)
+{
+  DWORD i;
+
+  hds->lpHdl = lpHdl;
+  hds->nMax  = max;
+  hds->nLast = 0;
+
+  /* Set to invalid value every entry of the handle */
+  for (i = 0; i < hds->nMax; i++)
+  {
+    hds->lpHdl[i] = INVALID_HANDLE_VALUE;
+  };
+}
+
+void handle_set_add (LPSELECTHANDLESET hds, HANDLE hdl)
+{
+  LPSELECTHANDLESET res;
+
+  if (hds->nLast < hds->nMax)
+  {
+    hds->lpHdl[hds->nLast] = hdl;
+    hds->nLast++;
+  }
+
+  DEBUG_PRINT("Adding handle %x to set %x", hdl, hds);
+}
+
+BOOL handle_set_mem (LPSELECTHANDLESET hds, HANDLE hdl)
+{
+  BOOL  res;
+  DWORD i;
+
+  res = FALSE;
+  for (i = 0; !res && i < hds->nLast; i++)
+  {
+    res = (hds->lpHdl[i] == hdl);
+  }
+
+  return res;
+}
+
+void handle_set_reset (LPSELECTHANDLESET hds)
+{
+  DWORD i;
+
+  for (i = 0; i < hds->nMax; i++)
+  {
+    hds->lpHdl[i] = INVALID_HANDLE_VALUE;
+  }
+  hds->nMax  = 0;
+  hds->nLast = 0;
+  hds->lpHdl = NULL;
+}
+
+/* Data structure for handling select */
+
+typedef enum _SELECTHANDLETYPE {
+  SELECT_HANDLE_NONE = 0,
+  SELECT_HANDLE_DISK,
+  SELECT_HANDLE_CONSOLE,
+  SELECT_HANDLE_PIPE,
+  SELECT_HANDLE_SOCKET,
+} SELECTHANDLETYPE;
+
+typedef enum _SELECTMODE {
+  SELECT_MODE_NONE = 0,
+  SELECT_MODE_READ = 1,
+  SELECT_MODE_WRITE = 2,
+  SELECT_MODE_EXCEPT = 4,
+} SELECTMODE;
+
+typedef enum _SELECTSTATE {
+  SELECT_STATE_NONE = 0,
+  SELECT_STATE_INITFAILED,
+  SELECT_STATE_ERROR,
+  SELECT_STATE_SIGNALED
+} SELECTSTATE;
+
+typedef enum _SELECTTYPE {
+  SELECT_TYPE_NONE = 0,
+  SELECT_TYPE_STATIC,       /* Result is known without running anything */
+  SELECT_TYPE_CONSOLE_READ, /* Reading data on console */
+  SELECT_TYPE_PIPE_READ,    /* Reading data on pipe */
+  SELECT_TYPE_SOCKET        /* Classic select */
+} SELECTTYPE;
+
+/* Data structure for results */
+typedef struct _SELECTRESULT {
+  LIST       lst;
+  SELECTMODE EMode;
+  int        lpOrigIdx;
+} SELECTRESULT;
+
+typedef SELECTRESULT *LPSELECTRESULT;
+
+/* Data structure for query */
+typedef struct _SELECTQUERY {
+  LIST         lst;
+  SELECTMODE   EMode;
+  HANDLE       hFileDescr;
+  int          lpOrigIdx;
+  unsigned int uFlagsFd; /* Copy of filedescr->flags_fd */
+} SELECTQUERY;
+
+typedef SELECTQUERY *LPSELECTQUERY;
+
+typedef struct _SELECTDATA {
+  LIST             lst;
+  SELECTTYPE       EType;
+  /* Sockets may generate a result for all three lists from one single
+     query object
+   */
+  SELECTRESULT     aResults[MAXIMUM_SELECT_OBJECTS * 3];
+  DWORD            nResultsCount;
+  /* Data following are dedicated to APC like call, they
+     will be initialized if required.
+     */
+  WORKERFUNC       funcWorker;
+  SELECTQUERY      aQueries[MAXIMUM_SELECT_OBJECTS];
+  DWORD            nQueriesCount;
+  SELECTSTATE      EState;
+  DWORD            nError;
+  LPWORKER         lpWorker;
+} SELECTDATA;
+
+typedef SELECTDATA *LPSELECTDATA;
+
+/* Get error status if associated condition is false */
+static BOOL check_error(LPSELECTDATA lpSelectData, BOOL bFailed)
+{
+  if (bFailed && lpSelectData->nError == 0)
+  {
+    lpSelectData->EState = SELECT_STATE_ERROR;
+    lpSelectData->nError = GetLastError();
+  }
+  return bFailed;
+}
+
+/* Create data associated with a  select operation */
+LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType)
+{
+  /* Allocate the data structure */
+  LPSELECTDATA res;
+  DWORD        i;
+
+  res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA));
+
+  /* Init common data */
+  list_init((LPLIST)res);
+  list_next_set((LPLIST)res, (LPLIST)lpSelectData);
+  res->EType         = EType;
+  res->nResultsCount = 0;
+
+
+  /* Data following are dedicated to APC like call, they
+     will be initialized if required. For now they are set to
+     invalid values.
+     */
+  res->funcWorker    = NULL;
+  res->nQueriesCount = 0;
+  res->EState        = SELECT_STATE_NONE;
+  res->nError        = 0;
+  res->lpWorker  = NULL;
+
+  return res;
+}
+
+/* Free select data */
+void select_data_free (LPSELECTDATA lpSelectData)
+{
+  DWORD i;
+
+  DEBUG_PRINT("Freeing data of %x", lpSelectData);
+
+  /* Free APC related data, if they exists */
+  if (lpSelectData->lpWorker != NULL)
+  {
+    worker_job_finish(lpSelectData->lpWorker);
+    lpSelectData->lpWorker = NULL;
+  };
+
+  /* Make sure results/queries cannot be accessed */
+  lpSelectData->nResultsCount = 0;
+  lpSelectData->nQueriesCount = 0;
+
+  caml_stat_free(lpSelectData);
+}
+
+/* Add a result to select data, return zero if something goes wrong. */
+DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode,
+                              int lpOrigIdx)
+{
+  DWORD res;
+  DWORD i;
+
+  res = 0;
+  if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS * 3)
+  {
+    i = lpSelectData->nResultsCount;
+    lpSelectData->aResults[i].EMode  = EMode;
+    lpSelectData->aResults[i].lpOrigIdx = lpOrigIdx;
+    lpSelectData->nResultsCount++;
+    res = 1;
+  }
+
+  return res;
+}
+
+/* Add a query to select data, return zero if something goes wrong */
+DWORD select_data_query_add (LPSELECTDATA lpSelectData,
+                             SELECTMODE EMode,
+                             HANDLE hFileDescr,
+                             int lpOrigIdx,
+                             unsigned int uFlagsFd)
+{
+  DWORD res;
+  DWORD i;
+
+  res = 0;
+  if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS)
+  {
+    i = lpSelectData->nQueriesCount;
+    lpSelectData->aQueries[i].EMode      = EMode;
+    lpSelectData->aQueries[i].hFileDescr = hFileDescr;
+    lpSelectData->aQueries[i].lpOrigIdx  = lpOrigIdx;
+    lpSelectData->aQueries[i].uFlagsFd   = uFlagsFd;
+    lpSelectData->nQueriesCount++;
+    res = 1;
+  }
+
+  return res;
+}
+
+/* Search for a job that has available query slots and that match provided type.
+ * If none is found, create a new one. Return the corresponding SELECTDATA, and
+ * update provided SELECTDATA head, if required.
+ */
+LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData,
+                                     SELECTTYPE EType)
+{
+  LPSELECTDATA res;
+
+  res = NULL;
+
+  /* Search for job */
+  DEBUG_PRINT("Searching an available job for type %d", EType);
+  res = *lppSelectData;
+  while (
+      res != NULL
+      && !(
+        res->EType == EType
+        && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS
+        )
+      )
+  {
+    res = LIST_NEXT(LPSELECTDATA, res);
+  }
+
+  /* No matching job found, create one */
+  if (res == NULL)
+  {
+    DEBUG_PRINT("No job for type %d found, create one", EType);
+    res = select_data_new(*lppSelectData, EType);
+    *lppSelectData = res;
+  }
+
+  return res;
+}
+
+/***********************/
+/*      Console        */
+/***********************/
+
+void read_console_poll(HANDLE hStop, void *_data)
+{
+  HANDLE events[2];
+  INPUT_RECORD record;
+  DWORD waitRes;
+  DWORD n;
+  LPSELECTDATA  lpSelectData;
+  LPSELECTQUERY lpQuery;
+
+  DEBUG_PRINT("Waiting for data on console");
+
+  record;
+  waitRes = 0;
+  n = 0;
+  lpSelectData = (LPSELECTDATA)_data;
+  lpQuery = &(lpSelectData->aQueries[0]);
+
+  events[0] = hStop;
+  events[1] = lpQuery->hFileDescr;
+  while (lpSelectData->EState == SELECT_STATE_NONE)
+  {
+    waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE);
+    if (waitRes == WAIT_OBJECT_0
+        || check_error(lpSelectData, waitRes == WAIT_FAILED))
+    {
+      /* stop worker event or error */
+      break;
+    }
+    /* console event */
+    if (check_error(lpSelectData, PeekConsoleInput(lpQuery->hFileDescr,
+                                                   &record, 1, &n)
+                    == 0))
+    {
+      break;
+    }
+    /* check for ASCII keypress only */
+    if (record.EventType == KEY_EVENT &&
+      record.Event.KeyEvent.bKeyDown &&
+      record.Event.KeyEvent.uChar.AsciiChar != 0)
+    {
+      select_data_result_add(lpSelectData, lpQuery->EMode, lpQuery->lpOrigIdx);
+      lpSelectData->EState = SELECT_STATE_SIGNALED;
+      break;
+    }
+    else
+    {
+      /* discard everything else and try again */
+      if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr,
+                                                     &record, 1, &n)
+                      == 0))
+      {
+        break;
+      }
+    }
+  };
+}
+
+/* Add a function to monitor console input */
+LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData,
+                                    SELECTMODE EMode,
+                                    HANDLE hFileDescr,
+                                    int lpOrigIdx,
+                                    unsigned int uFlagsFd)
+{
+  LPSELECTDATA res;
+
+  res = select_data_new(lpSelectData, SELECT_TYPE_CONSOLE_READ);
+  res->funcWorker = read_console_poll;
+  select_data_query_add(res, SELECT_MODE_READ, hFileDescr, lpOrigIdx, uFlagsFd);
+
+  return res;
+}
+
+/***********************/
+/*        Pipe         */
+/***********************/
+
+/* Monitor a pipe for input */
+void read_pipe_poll (HANDLE hStop, void *_data)
+{
+  DWORD         res;
+  DWORD         event;
+  DWORD         n;
+  LPSELECTQUERY iterQuery;
+  LPSELECTDATA  lpSelectData;
+  DWORD         i;
+  DWORD         wait;
+
+  /* Poll pipe */
+  event = 0;
+  n = 0;
+  lpSelectData = (LPSELECTDATA)_data;
+  wait = 1;
+
+  DEBUG_PRINT("Checking data pipe");
+  while (lpSelectData->EState == SELECT_STATE_NONE)
+  {
+    for (i = 0; i < lpSelectData->nQueriesCount; i++)
+    {
+      iterQuery = &(lpSelectData->aQueries[i]);
+      res = PeekNamedPipe(
+          iterQuery->hFileDescr,
+          NULL,
+          0,
+          NULL,
+          &n,
+          NULL);
+      if (check_error(lpSelectData,
+            (res == 0) &&
+            (GetLastError() != ERROR_BROKEN_PIPE)))
+      {
+        break;
+      };
+
+      if ((n > 0) || (res == 0))
+      {
+        lpSelectData->EState = SELECT_STATE_SIGNALED;
+        select_data_result_add(lpSelectData, iterQuery->EMode,
+                               iterQuery->lpOrigIdx);
+      };
+    };
+
+    /* Alas, nothing except polling seems to work for pipes.
+       Check the state & stop_worker_event every 10 ms
+     */
+    if (lpSelectData->EState == SELECT_STATE_NONE)
+    {
+      event = WaitForSingleObject(hStop, wait);
+
+      /* Fast start: begin to wait 1, 2, 4, 8 and then 10 ms.
+       * If we are working with the output of a program there is
+       * a chance that one of the 4 first calls succeed.
+       */
+      wait = 2 * wait;
+      if (wait > 10)
+      {
+        wait = 10;
+      };
+      if (event == WAIT_OBJECT_0
+          || check_error(lpSelectData, event == WAIT_FAILED))
+      {
+        break;
+      }
+    }
+  }
+  DEBUG_PRINT("Finish checking data on pipe");
+}
+
+/* Add a function to monitor pipe input */
+LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData,
+                                 SELECTMODE EMode,
+                                 HANDLE hFileDescr,
+                                 int lpOrigIdx,
+                                 unsigned int uFlagsFd)
+{
+  LPSELECTDATA res;
+  LPSELECTDATA hd;
+
+  hd = lpSelectData;
+  /* Polling pipe is a non blocking operation by default. This means that each
+     worker can handle many pipe. We begin to try to find a worker that is
+     polling pipe, but for which there is under the limit of pipe per worker.
+     */
+  DEBUG_PRINT("Searching an available worker handling pipe");
+  res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ);
+
+  /* Add a new pipe to poll */
+  res->funcWorker = read_pipe_poll;
+  select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+
+  return hd;
+}
+
+/***********************/
+/*       Socket        */
+/***********************/
+
+/* Monitor socket */
+void socket_poll (HANDLE hStop, void *_data)
+{
+  LPSELECTDATA   lpSelectData;
+  LPSELECTQUERY    iterQuery;
+  HANDLE           aEvents[MAXIMUM_SELECT_OBJECTS];
+  DWORD            nEvents;
+  long             maskEvents;
+  DWORD            i;
+  u_long           iMode;
+  SELECTMODE       mode;
+  WSANETWORKEVENTS events;
+
+  lpSelectData = (LPSELECTDATA)_data;
+
+  DEBUG_PRINT("Worker has %d queries to service", lpSelectData->nQueriesCount);
+  for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++)
+  {
+    iterQuery = &(lpSelectData->aQueries[nEvents]);
+    aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL);
+    maskEvents = 0;
+    mode = iterQuery->EMode;
+    if ((mode & SELECT_MODE_READ) != 0)
+    {
+      DEBUG_PRINT("Polling read for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_READ | FD_ACCEPT | FD_CLOSE;
+    }
+    if ((mode & SELECT_MODE_WRITE) != 0)
+    {
+      DEBUG_PRINT("Polling write for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_WRITE | FD_CONNECT | FD_CLOSE;
+    }
+    if ((mode & SELECT_MODE_EXCEPT) != 0)
+    {
+      DEBUG_PRINT("Polling exceptions for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_OOB;
+    }
+
+    check_error(lpSelectData,
+        WSAEventSelect(
+          (SOCKET)(iterQuery->hFileDescr),
+          aEvents[nEvents],
+          maskEvents) == SOCKET_ERROR);
+  }
+
+  /* Add stop event */
+  aEvents[nEvents]  = hStop;
+  nEvents++;
+
+  if (lpSelectData->nError == 0)
+  {
+    check_error(lpSelectData,
+        WaitForMultipleObjects(
+          nEvents,
+          aEvents,
+          FALSE,
+          INFINITE) == WAIT_FAILED);
+  };
+
+  if (lpSelectData->nError == 0)
+  {
+    for (i = 0; i < lpSelectData->nQueriesCount; i++)
+    {
+      iterQuery = &(lpSelectData->aQueries[i]);
+      if (WaitForSingleObject(aEvents[i], 0) == WAIT_OBJECT_0)
+      {
+        DEBUG_PRINT("Socket %d has pending events", (i - 1));
+        if (iterQuery != NULL)
+        {
+          /* Find out what kind of events were raised
+           */
+          if (WSAEnumNetworkEvents((SOCKET)(iterQuery->hFileDescr),
+                                   aEvents[i], &events) == 0)
+          {
+            if ((iterQuery->EMode & SELECT_MODE_READ) != 0
+                && (events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE))
+                   != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_READ,
+                                     iterQuery->lpOrigIdx);
+            }
+            if ((iterQuery->EMode & SELECT_MODE_WRITE) != 0
+                && (events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE))
+                   != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_WRITE,
+                                     iterQuery->lpOrigIdx);
+            }
+            if ((iterQuery->EMode & SELECT_MODE_EXCEPT) != 0
+                && (events.lNetworkEvents & FD_OOB) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_EXCEPT,
+                                     iterQuery->lpOrigIdx);
+            }
+          }
+        }
+      }
+      /* WSAEventSelect() automatically sets socket to nonblocking mode.
+         Restore the blocking one. */
+      if (iterQuery->uFlagsFd & FLAGS_FD_IS_BLOCKING)
+      {
+        DEBUG_PRINT("Restore a blocking socket");
+        iMode = 0;
+        check_error(lpSelectData,
+          WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0 ||
+          ioctlsocket((SOCKET)(iterQuery->hFileDescr), FIONBIO, &iMode) != 0);
+      }
+      else
+      {
+        check_error(lpSelectData,
+          WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0);
+      };
+
+      CloseHandle(aEvents[i]);
+      aEvents[i] = INVALID_HANDLE_VALUE;
+    }
+  }
+}
+
+/* Add a function to monitor socket */
+LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData,
+                              SELECTMODE EMode,
+                              HANDLE hFileDescr,
+                              int lpOrigIdx,
+                              unsigned int uFlagsFd)
+{
+  LPSELECTDATA res;
+  LPSELECTDATA candidate;
+  long i;
+  LPSELECTQUERY aQueries;
+
+  res = lpSelectData;
+  candidate = NULL;
+  aQueries = NULL;
+
+  /* Polling socket can be done mulitple handle at the same time. You just
+     need one worker to use it. Try to find if there is already a worker
+     handling this kind of request.
+     Only one event can be associated with a given socket which means
+     that if a socket is in more than one of the fd_sets then we have
+     to find that particular query and update EMode with the
+     additional flag.
+     */
+  DEBUG_PRINT("Scanning list of worker to find one that already handle socket");
+  /* Search for job */
+  DEBUG_PRINT("Searching for an available job for type %d for descriptor %d",
+              SELECT_TYPE_SOCKET, hFileDescr);
+  while (res != NULL)
+  {
+    if (res->EType == SELECT_TYPE_SOCKET)
+    {
+      i = res->nQueriesCount - 1;
+      aQueries = res->aQueries;
+      while (i >= 0 && aQueries[i].hFileDescr != hFileDescr)
+      {
+        i--;
+      }
+      /* If we didn't find the socket but this worker has available
+         slots, store it
+       */
+      if (i < 0)
+      {
+        if ( res->nQueriesCount < MAXIMUM_SELECT_OBJECTS)
+        {
+          candidate = res;
+        }
+        res = LIST_NEXT(LPSELECTDATA, res);
+      }
+      else
+      {
+        /* Previous socket query located -- we're finished
+         */
+        aQueries = &aQueries[i];
+        break;
+      }
+    }
+    else
+    {
+      res = LIST_NEXT(LPSELECTDATA, res);
+    }
+  }
+
+  if (res == NULL)
+  {
+    res = candidate;
+
+    /* No matching job found, create one */
+    if (res == NULL)
+    {
+      DEBUG_PRINT("No job for type %d found, create one", SELECT_TYPE_SOCKET);
+      res = select_data_new(lpSelectData, SELECT_TYPE_SOCKET);
+      res->funcWorker = socket_poll;
+      res->nQueriesCount = 1;
+      aQueries = &res->aQueries[0];
+    }
+    else
+    {
+      aQueries = &(res->aQueries[res->nQueriesCount++]);
+    }
+    aQueries->EMode = EMode;
+    aQueries->hFileDescr = hFileDescr;
+    aQueries->lpOrigIdx = lpOrigIdx;
+    aQueries->uFlagsFd = uFlagsFd;
+    DEBUG_PRINT("Socket %x added", hFileDescr);
+  }
+  else
+  {
+    aQueries->EMode |= EMode;
+    DEBUG_PRINT("Socket %x updated to %d", hFileDescr, aQueries->EMode);
+  }
+
+  return res;
+}
+
+/***********************/
+/*       Static        */
+/***********************/
+
+/* Add a static result */
+LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData,
+                              SELECTMODE EMode,
+                              HANDLE hFileDescr,
+                              int lpOrigIdx,
+                              unsigned int uFlagsFd)
+{
+  LPSELECTDATA res;
+  LPSELECTDATA hd;
+
+  /* Look for an already initialized static element */
+  hd = lpSelectData;
+  res = select_data_job_search(&hd, SELECT_TYPE_STATIC);
+
+  /* Add a new query/result */
+  select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+  select_data_result_add(res, EMode, lpOrigIdx);
+
+  return hd;
+}
+
+/********************************/
+/* Generic select data handling */
+/********************************/
+
+/* Guess handle type */
+static SELECTHANDLETYPE get_handle_type(value fd)
+{
+  DWORD            mode;
+  SELECTHANDLETYPE res;
+
+  CAMLparam1(fd);
+
+  mode = 0;
+  res = SELECT_HANDLE_NONE;
+
+  if (Descr_kind_val(fd) == KIND_SOCKET)
+  {
+    res = SELECT_HANDLE_SOCKET;
+  }
+  else
+  {
+    switch(GetFileType(Handle_val(fd)))
+    {
+      case FILE_TYPE_DISK:
+        res = SELECT_HANDLE_DISK;
+        break;
+
+      case FILE_TYPE_CHAR: /* character file or a console */
+        if (GetConsoleMode(Handle_val(fd), &mode) != 0)
+        {
+          res = SELECT_HANDLE_CONSOLE;
+        }
+        else
+        {
+          res = SELECT_HANDLE_NONE;
+        };
+        break;
+
+      case FILE_TYPE_PIPE: /* a named or an anonymous pipe (socket
+                              already handled) */
+        res = SELECT_HANDLE_PIPE;
+        break;
+    };
+  };
+
+  CAMLreturnT(SELECTHANDLETYPE, res);
+}
+
+/* Choose what to do with given data */
+LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode,
+                                   value fd, int lpOrigIdx)
+{
+  LPSELECTDATA    res;
+  HANDLE          hFileDescr;
+  struct sockaddr sa;
+  int             sa_len;
+  BOOL            alreadyAdded;
+  unsigned int    uFlagsFd;
+
+  CAMLparam1(fd);
+
+  res          = lpSelectData;
+  hFileDescr   = Handle_val(fd);
+  sa_len       = sizeof(sa);
+  alreadyAdded = FALSE;
+  uFlagsFd     = Flags_fd_val(fd);
+
+  DEBUG_PRINT("Begin dispatching handle %x", hFileDescr);
+
+  DEBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr);
+
+  /* There is only 2 way to have except mode: transmission of OOB data through
+     a socket TCP/IP and through a strange interaction with a TTY.
+     With windows, we only consider the TCP/IP except condition
+  */
+  switch(get_handle_type(fd))
+  {
+    case SELECT_HANDLE_DISK:
+      DEBUG_PRINT("Handle %x is a disk handle", hFileDescr);
+      /* Disk is always ready in read/write operation */
+      if (EMode == SELECT_MODE_READ || EMode == SELECT_MODE_WRITE)
+      {
+        res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+      };
+      break;
+
+    case SELECT_HANDLE_CONSOLE:
+      DEBUG_PRINT("Handle %x is a console handle", hFileDescr);
+      /* Console is always ready in write operation, need to check for read. */
+      if (EMode == SELECT_MODE_READ)
+      {
+        res = read_console_poll_add(res, EMode, hFileDescr, lpOrigIdx,
+                                    uFlagsFd);
+      }
+      else if (EMode == SELECT_MODE_WRITE)
+      {
+        res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+      };
+      break;
+
+    case SELECT_HANDLE_PIPE:
+      DEBUG_PRINT("Handle %x is a pipe handle", hFileDescr);
+      /* Console is always ready in write operation, need to check for read. */
+      if (EMode == SELECT_MODE_READ)
+      {
+        DEBUG_PRINT("Need to check availability of data on pipe");
+        res = read_pipe_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+      }
+      else if (EMode == SELECT_MODE_WRITE)
+      {
+        DEBUG_PRINT("No need to check availability of data on pipe, "
+                    "write operation always possible");
+        res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+      };
+      break;
+
+    case SELECT_HANDLE_SOCKET:
+      DEBUG_PRINT("Handle %x is a socket handle", hFileDescr);
+      if (getsockname((SOCKET)hFileDescr, &sa, &sa_len) == SOCKET_ERROR)
+      {
+        if (WSAGetLastError() == WSAEINVAL)
+        {
+          /* Socket is not bound */
+          DEBUG_PRINT("Socket is not connected");
+          if (EMode == SELECT_MODE_WRITE || EMode == SELECT_MODE_READ)
+          {
+            res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+            alreadyAdded = TRUE;
+          }
+        }
+      }
+      if (!alreadyAdded)
+      {
+        res = socket_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
+      }
+      break;
+
+    default:
+      DEBUG_PRINT("Handle %x is unknown", hFileDescr);
+      win32_maperr(ERROR_INVALID_HANDLE);
+      uerror("select", Nothing);
+      break;
+  };
+
+  DEBUG_PRINT("Finish dispatching handle %x", hFileDescr);
+
+  CAMLreturnT(LPSELECTDATA, res);
+}
+
+static DWORD caml_list_length (value lst)
+{
+  DWORD res;
+
+  CAMLparam1 (lst);
+  CAMLlocal1 (l);
+
+  for (res = 0, l = lst; l != Val_int(0); l = Field(l, 1), res++)
+  { }
+
+  CAMLreturnT(DWORD, res);
+}
+
+static value find_handle(LPSELECTRESULT iterResult, value readfds,
+                         value writefds, value exceptfds)
+{
+  CAMLparam3(readfds, writefds, exceptfds);
+  CAMLlocal2(result, list);
+  int i;
+
+  switch( iterResult->EMode )
+  {
+    case SELECT_MODE_READ:
+      list = readfds;
+      break;
+    case SELECT_MODE_WRITE:
+      list = writefds;
+      break;
+    case SELECT_MODE_EXCEPT:
+      list = exceptfds;
+      break;
+    case SELECT_MODE_NONE:
+      CAMLassert(0);
+  };
+
+  for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i )
+  {
+    list = Field(list, 1);
+  }
+
+  if (list == Val_unit)
+    caml_failwith ("select.c: original file handle not found");
+
+  result = Field(list, 0);
+
+  CAMLreturn( result );
+}
+
+#define MAX(a, b) ((a) > (b) ? (a) : (b))
+
+/* Convert fdlist to an fd_set if all the handles in fdlist are
+ * sockets and return 1.  Returns 0 if a non-socket value is
+ * encountered, or if there are more than FD_SETSIZE sockets.
+ */
+static int fdlist_to_fdset(value fdlist, fd_set *fdset)
+{
+  value l, c;
+  int n = 0;
+  FD_ZERO(fdset);
+  for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    if (++n > FD_SETSIZE) {
+      DEBUG_PRINT("More than FD_SETSIZE sockets");
+      return 0;
+    }
+    c = Field(l, 0);
+    if (Descr_kind_val(c) == KIND_SOCKET) {
+      FD_SET(Socket_val(c), fdset);
+    } else {
+      DEBUG_PRINT("Non socket value encountered");
+      return 0;
+    }
+  }
+  return 1;
+}
+
+static value fdset_to_fdlist(value fdlist, fd_set *fdset)
+{
+  value res = Val_int(0);
+  Begin_roots2(fdlist, res)
+    for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
+      value s = Field(fdlist, 0);
+      if (FD_ISSET(Socket_val(s), fdset)) {
+        value newres = caml_alloc_small(2, 0);
+        Field(newres, 0) = s;
+        Field(newres, 1) = res;
+        res = newres;
+      }
+    }
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_select(value readfds, value writefds, value exceptfds,
+                           value timeout)
+{
+  /* Event associated to handle */
+  DWORD   nEventsCount;
+  DWORD   nEventsMax;
+  HANDLE *lpEventsDone;
+
+  /* Data for all handles */
+  LPSELECTDATA lpSelectData;
+  LPSELECTDATA iterSelectData;
+
+  /* Iterator for results */
+  LPSELECTRESULT iterResult;
+
+  /* Iterator */
+  DWORD i;
+
+  /* Error status */
+  DWORD err;
+
+  /* Time to wait */
+  DWORD milliseconds;
+
+  /* Is there static select data */
+  BOOL  hasStaticData = FALSE;
+
+  /* Wait return */
+  DWORD waitRet;
+
+  /* Set of handle */
+  SELECTHANDLESET hds;
+  DWORD           hdsMax;
+  LPHANDLE        hdsData;
+
+  /* Length of each list */
+  DWORD readfds_len;
+  DWORD writefds_len;
+  DWORD exceptfds_len;
+
+  CAMLparam4 (readfds, writefds, exceptfds, timeout);
+  CAMLlocal5 (read_list, write_list, except_list, res, l);
+  CAMLlocal1 (fd);
+
+  fd_set read, write, except;
+  double tm;
+  struct timeval tv;
+  struct timeval * tvp;
+
+  DEBUG_PRINT("in select");
+
+  err = 0;
+  tm = Double_val(timeout);
+  if (readfds == Val_int(0)
+      && writefds == Val_int(0)
+      && exceptfds == Val_int(0)) {
+    DEBUG_PRINT("nothing to do");
+    if ( tm > 0.0 ) {
+      caml_enter_blocking_section();
+      Sleep( (int)(tm * 1000));
+      caml_leave_blocking_section();
+    }
+    read_list = write_list = except_list = Val_int(0);
+  } else {
+    if (fdlist_to_fdset(readfds, &read)
+        && fdlist_to_fdset(writefds, &write)
+        && fdlist_to_fdset(exceptfds, &except)) {
+      DEBUG_PRINT("only sockets to select on, using classic select");
+      if (tm < 0.0) {
+        tvp = (struct timeval *) NULL;
+      } else {
+        tv.tv_sec = (int) tm;
+        tv.tv_usec = (int) (1e6 * (tm - (int) tm));
+        tvp = &tv;
+      }
+      caml_enter_blocking_section();
+      if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) {
+        err = WSAGetLastError();
+        DEBUG_PRINT("Error %ld occurred", err);
+      }
+      caml_leave_blocking_section();
+      if (err) {
+        DEBUG_PRINT("Error %ld occurred", err);
+        win32_maperr(err);
+        uerror("select", Nothing);
+      }
+      read_list = fdset_to_fdlist(readfds, &read);
+      write_list = fdset_to_fdlist(writefds, &write);
+      except_list = fdset_to_fdlist(exceptfds, &except);
+    } else {
+      nEventsCount   = 0;
+      nEventsMax     = 0;
+      lpEventsDone   = NULL;
+      lpSelectData   = NULL;
+      iterSelectData = NULL;
+      iterResult     = NULL;
+      hasStaticData  = 0;
+      waitRet        = 0;
+      readfds_len    = caml_list_length(readfds);
+      writefds_len   = caml_list_length(writefds);
+      exceptfds_len  = caml_list_length(exceptfds);
+      hdsMax         = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
+
+      hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
+
+      if (tm >= 0.0)
+        {
+          milliseconds = 1000 * tm;
+          DEBUG_PRINT("Will wait %d ms", milliseconds);
+        }
+      else
+        {
+          milliseconds = INFINITE;
+        }
+
+
+      /* Create list of select data, based on the different list of fd
+         to watch */
+      DEBUG_PRINT("Dispatch read fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = readfds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData,
+                                                  SELECT_MODE_READ, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor "
+                          "for read", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+
+      DEBUG_PRINT("Dispatch write fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = writefds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData,
+                                                  SELECT_MODE_WRITE, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor "
+                          "for write", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+
+      DEBUG_PRINT("Dispatch exceptional fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData,
+                                                  SELECT_MODE_EXCEPT, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor "
+                          "for exceptional", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+
+      /* Building the list of handle to wait for */
+      DEBUG_PRINT("Building events done array");
+      nEventsMax   = list_length((LPLIST)lpSelectData);
+      nEventsCount = 0;
+      lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
+
+      iterSelectData = lpSelectData;
+      while (iterSelectData != NULL)
+        {
+          /* Check if it is static data. If this is the case, launch everything
+           * but don't wait for events. It helps to test if there are events on
+           * any other fd (which are not static), knowing that there is at least
+           * one result (the static data).
+           */
+          if (iterSelectData->EType == SELECT_TYPE_STATIC)
+            {
+              hasStaticData = TRUE;
+            };
+
+          /* Execute APC */
+          if (iterSelectData->funcWorker != NULL)
+            {
+              iterSelectData->lpWorker =
+                worker_job_submit(
+                                  iterSelectData->funcWorker,
+                                  (void *)iterSelectData);
+              DEBUG_PRINT("Job submitted to worker %x",
+                          iterSelectData->lpWorker);
+              lpEventsDone[nEventsCount]
+                = worker_job_event_done(iterSelectData->lpWorker);
+              nEventsCount++;
+            };
+          iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+        };
+
+      DEBUG_PRINT("Need to watch %d workers", nEventsCount);
+
+      /* Processing select itself */
+      caml_enter_blocking_section();
+      /* There are worker started, waiting to be monitored */
+      if (nEventsCount > 0)
+        {
+          /* Waiting for event */
+          if (err == 0 && !hasStaticData)
+            {
+              DEBUG_PRINT("Waiting for one select worker to be done");
+              switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE,
+                                             milliseconds))
+                {
+                case WAIT_FAILED:
+                  err = GetLastError();
+                  break;
+
+                case WAIT_TIMEOUT:
+                  DEBUG_PRINT("Select timeout");
+                  break;
+
+                default:
+                  DEBUG_PRINT("One worker is done");
+                  break;
+                };
+            }
+
+          /* Ordering stop to every worker */
+          DEBUG_PRINT("Sending stop signal to every select workers");
+          iterSelectData = lpSelectData;
+          while (iterSelectData != NULL)
+            {
+              if (iterSelectData->lpWorker != NULL)
+                {
+                  worker_job_stop(iterSelectData->lpWorker);
+                };
+              iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+            };
+
+          DEBUG_PRINT("Waiting for every select worker to be done");
+          switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE,
+                                         INFINITE))
+            {
+            case WAIT_FAILED:
+              err = GetLastError();
+              break;
+
+            default:
+              DEBUG_PRINT("Every worker is done");
+              break;
+            }
+        }
+      /* Nothing to monitor but some time to wait. */
+      else if (!hasStaticData)
+        {
+          Sleep(milliseconds);
+        }
+      caml_leave_blocking_section();
+
+      DEBUG_PRINT("Error status: %d (0 is ok)", err);
+      /* Build results */
+      if (err == 0)
+        {
+          DEBUG_PRINT("Building result");
+          read_list = Val_unit;
+          write_list = Val_unit;
+          except_list = Val_unit;
+
+          iterSelectData = lpSelectData;
+          while (iterSelectData != NULL)
+            {
+              for (i = 0; i < iterSelectData->nResultsCount; i++)
+                {
+                  iterResult = &(iterSelectData->aResults[i]);
+                  l = caml_alloc_small(2, 0);
+                  Store_field(l, 0, find_handle(iterResult, readfds, writefds,
+                                                exceptfds));
+                  switch (iterResult->EMode)
+                    {
+                    case SELECT_MODE_READ:
+                      Store_field(l, 1, read_list);
+                      read_list = l;
+                      break;
+                    case SELECT_MODE_WRITE:
+                      Store_field(l, 1, write_list);
+                      write_list = l;
+                      break;
+                    case SELECT_MODE_EXCEPT:
+                      Store_field(l, 1, except_list);
+                      except_list = l;
+                      break;
+                    case SELECT_MODE_NONE:
+                      CAMLassert(0);
+                    }
+                }
+              /* We try to only process the first error, bypass other errors */
+              if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
+                {
+                  err = iterSelectData->nError;
+                }
+              iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+            }
+        }
+
+      /* Free resources */
+      DEBUG_PRINT("Free selectdata resources");
+      iterSelectData = lpSelectData;
+      while (iterSelectData != NULL)
+        {
+          lpSelectData = iterSelectData;
+          iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+          select_data_free(lpSelectData);
+        }
+      lpSelectData = NULL;
+
+      /* Free allocated events/handle set array */
+      DEBUG_PRINT("Free local allocated resources");
+      caml_stat_free(lpEventsDone);
+      caml_stat_free(hdsData);
+
+      DEBUG_PRINT("Raise error if required");
+      if (err != 0)
+        {
+          win32_maperr(err);
+          uerror("select", Nothing);
+        }
+    }
+  }
+
+  DEBUG_PRINT("Build final result");
+  res = caml_alloc_small(3, 0);
+  Store_field(res, 0, read_list);
+  Store_field(res, 1, write_list);
+  Store_field(res, 2, except_list);
+
+  DEBUG_PRINT("out select");
+
+  CAMLreturn(res);
+}
diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c
new file mode 100644
index 00000000..1daa8e99
--- /dev/null
+++ b/otherlibs/win32unix/sendrecv.c
@@ -0,0 +1,143 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+static int msg_flag_table[] = {
+  MSG_OOB, MSG_DONTROUTE, MSG_PEEK
+};
+
+CAMLprim value unix_recv(value sock, value buff, value ofs, value len,
+                         value flags)
+{
+  SOCKET s = Socket_val(sock);
+  int flg = caml_convert_flag_list(flags, msg_flag_table);
+  int ret;
+  intnat numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+  DWORD err = 0;
+
+  Begin_root (buff);
+    numbytes = Long_val(len);
+    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+    caml_enter_blocking_section();
+    ret = recv(s, iobuf, (int) numbytes, flg);
+    if (ret == -1) err = WSAGetLastError();
+    caml_leave_blocking_section();
+    if (ret == -1) {
+      win32_maperr(err);
+      uerror("recv", Nothing);
+    }
+    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
+  End_roots();
+  return Val_int(ret);
+}
+
+CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len,
+                             value flags)
+{
+  SOCKET s = Socket_val(sock);
+  int flg = caml_convert_flag_list(flags, msg_flag_table);
+  int ret;
+  intnat numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+  value res;
+  value adr = Val_unit;
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+  DWORD err = 0;
+
+  Begin_roots2 (buff, adr);
+    numbytes = Long_val(len);
+    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+    addr_len = sizeof(sock_addr);
+    caml_enter_blocking_section();
+    ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len);
+    if (ret == -1) err = WSAGetLastError();
+    caml_leave_blocking_section();
+    if (ret == -1) {
+      win32_maperr(err);
+      uerror("recvfrom", Nothing);
+    }
+    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
+    adr = alloc_sockaddr(&addr, addr_len, -1);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = Val_int(ret);
+    Field(res, 1) = adr;
+  End_roots();
+  return res;
+}
+
+CAMLprim value unix_send(value sock, value buff, value ofs, value len,
+                         value flags)
+{
+  SOCKET s = Socket_val(sock);
+  int flg = caml_convert_flag_list(flags, msg_flag_table);
+  int ret;
+  intnat numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+  DWORD err = 0;
+
+  numbytes = Long_val(len);
+  if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+  memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
+  caml_enter_blocking_section();
+  ret = send(s, iobuf, (int) numbytes, flg);
+  if (ret == -1) err = WSAGetLastError();
+  caml_leave_blocking_section();
+  if (ret == -1) {
+    win32_maperr(err);
+    uerror("send", Nothing);
+  }
+  return Val_int(ret);
+}
+
+value unix_sendto_native(value sock, value buff, value ofs, value len,
+                         value flags, value dest)
+{
+  SOCKET s = Socket_val(sock);
+  int flg = caml_convert_flag_list(flags, msg_flag_table);
+  int ret;
+  intnat numbytes;
+  char iobuf[UNIX_BUFFER_SIZE];
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+  DWORD err = 0;
+
+  get_sockaddr(dest, &addr, &addr_len);
+  numbytes = Long_val(len);
+  if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
+  memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
+  caml_enter_blocking_section();
+  ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len);
+  if (ret == -1) err = WSAGetLastError();
+  caml_leave_blocking_section();
+  if (ret == -1) {
+    win32_maperr(err);
+    uerror("sendto", Nothing);
+  }
+  return Val_int(ret);
+}
+
+CAMLprim value unix_sendto(value * argv, int argc)
+{
+  return unix_sendto_native
+           (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+}
diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c
new file mode 100644
index 00000000..d70f280e
--- /dev/null
+++ b/otherlibs/win32unix/shutdown.c
@@ -0,0 +1,32 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+static int shutdown_command_table[] = {
+  0, 1, 2
+};
+
+CAMLprim value unix_shutdown(sock, cmd)
+     value sock, cmd;
+{
+  if (shutdown(Socket_val(sock),
+               shutdown_command_table[Int_val(cmd)]) == -1) {
+    win32_maperr(WSAGetLastError());
+    uerror("shutdown", Nothing);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
new file mode 100644
index 00000000..40127376
--- /dev/null
+++ b/otherlibs/win32unix/sleep.c
@@ -0,0 +1,28 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_sleep(t)
+     value t;
+{
+  double d = Double_val(t);
+  caml_enter_blocking_section();
+  Sleep(d * 1e3);
+  caml_leave_blocking_section();
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c
new file mode 100644
index 00000000..dc88fcbb
--- /dev/null
+++ b/otherlibs/win32unix/socket.c
@@ -0,0 +1,56 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+int socket_domain_table[] = {
+  PF_UNIX, PF_INET,
+#if defined(HAS_IPV6)
+  PF_INET6
+#else
+  0
+#endif
+};
+
+int socket_type_table[] = {
+  SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
+};
+
+CAMLprim value unix_socket(value cloexec, value domain, value type, value proto)
+{
+  SOCKET s;
+
+  #ifndef HAS_IPV6
+  /* IPv6 requires WinSock2, we must raise an error on PF_INET6 */
+  if (Int_val(domain) >= sizeof(socket_domain_table)/sizeof(int)) {
+    win32_maperr(WSAEPFNOSUPPORT);
+    uerror("socket", Nothing);
+  }
+  #endif
+
+  s = socket(socket_domain_table[Int_val(domain)],
+                   socket_type_table[Int_val(type)],
+                   Int_val(proto));
+  if (s == INVALID_SOCKET) {
+    win32_maperr(WSAGetLastError());
+    uerror("socket", Nothing);
+  }
+  /* This is a best effort, not guaranteed to work, so don't fail on error */
+  SetHandleInformation((HANDLE) s,
+                       HANDLE_FLAG_INHERIT,
+                       unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
+  return win_alloc_socket(s);
+}
diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h
new file mode 100644
index 00000000..e951bece
--- /dev/null
+++ b/otherlibs/win32unix/socketaddr.h
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_SOCKETADDR_H
+#define CAML_SOCKETADDR_H
+
+#include "caml/misc.h"
+
+union sock_addr_union {
+  struct sockaddr s_gen;
+  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
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+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, int close_on_error);
+CAMLprim value alloc_inet_addr (struct in_addr * inaddr);
+#define GET_INET_ADDR(v) (*((struct in_addr *) (v)))
+
+#ifdef HAS_IPV6
+CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr);
+#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v)))
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_SOCKETADDR_H */
diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c
new file mode 100644
index 00000000..6035556f
--- /dev/null
+++ b/otherlibs/win32unix/sockopt.c
@@ -0,0 +1,229 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+#include "socketaddr.h"
+
+#ifndef IPPROTO_IPV6
+#define IPPROTO_IPV6 (-1)
+#endif
+#ifndef IPV6_V6ONLY
+#define IPV6_V6ONLY (-1)
+#endif
+
+enum option_type {
+  TYPE_BOOL = 0,
+  TYPE_INT = 1,
+  TYPE_LINGER = 2,
+  TYPE_TIMEVAL = 3,
+  TYPE_UNIX_ERROR = 4
+};
+
+struct socket_option {
+  int level;
+  int option;
+};
+
+/* Table of options, indexed by type */
+
+static struct socket_option sockopt_bool[] = {
+  { SOL_SOCKET, SO_DEBUG },
+  { SOL_SOCKET, SO_BROADCAST },
+  { SOL_SOCKET, SO_REUSEADDR },
+  { SOL_SOCKET, SO_KEEPALIVE },
+  { SOL_SOCKET, SO_DONTROUTE },
+  { SOL_SOCKET, SO_OOBINLINE },
+  { SOL_SOCKET, SO_ACCEPTCONN },
+  { IPPROTO_TCP, TCP_NODELAY },
+  { IPPROTO_IPV6, IPV6_V6ONLY}
+};
+
+static struct socket_option sockopt_int[] = {
+  { SOL_SOCKET, SO_SNDBUF },
+  { SOL_SOCKET, SO_RCVBUF },
+  { SOL_SOCKET, SO_ERROR },
+  { SOL_SOCKET, SO_TYPE },
+  { SOL_SOCKET, SO_RCVLOWAT },
+  { SOL_SOCKET, SO_SNDLOWAT } };
+
+static struct socket_option sockopt_linger[] = {
+  { SOL_SOCKET, SO_LINGER }
+};
+
+static struct socket_option sockopt_timeval[] = {
+  { SOL_SOCKET, SO_RCVTIMEO },
+  { SOL_SOCKET, SO_SNDTIMEO }
+};
+
+static struct socket_option sockopt_unix_error[] = {
+  { SOL_SOCKET, SO_ERROR }
+};
+
+static struct socket_option * sockopt_table[] = {
+  sockopt_bool,
+  sockopt_int,
+  sockopt_linger,
+  sockopt_timeval,
+  sockopt_unix_error
+};
+
+static char * getsockopt_fun_name[] = {
+  "getsockopt",
+  "getsockopt_int",
+  "getsockopt_optint",
+  "getsockopt_float",
+  "getsockopt_error"
+};
+
+static char * setsockopt_fun_name[] = {
+  "setsockopt",
+  "setsockopt_int",
+  "setsockopt_optint",
+  "setsockopt_float",
+  "setsockopt_error"
+};
+
+union option_value {
+  int i;
+  struct linger lg;
+  struct timeval tv;
+};
+
+CAMLexport value
+unix_getsockopt_aux(char * name,
+                    enum option_type ty, int level, int option,
+                    value socket)
+{
+  union option_value optval;
+  socklen_param_type optsize;
+
+
+  switch (ty) {
+  case TYPE_BOOL:
+  case TYPE_INT:
+  case TYPE_UNIX_ERROR:
+    optsize = sizeof(optval.i); break;
+  case TYPE_LINGER:
+    optsize = sizeof(optval.lg); break;
+  case TYPE_TIMEVAL:
+    optsize = sizeof(optval.tv); break;
+  default:
+    unix_error(EINVAL, name, Nothing);
+  }
+
+  if (getsockopt(Socket_val(socket), level, option,
+                 (void *) &optval, &optsize) == -1)
+    uerror(name, Nothing);
+
+  switch (ty) {
+  case TYPE_BOOL:
+  case TYPE_INT:
+    return Val_int(optval.i);
+  case TYPE_LINGER:
+    if (optval.lg.l_onoff == 0) {
+      return Val_int(0);        /* None */
+    } else {
+      value res = caml_alloc_small(1, 0); /* Some */
+      Field(res, 0) = Val_int(optval.lg.l_linger);
+      return res;
+    }
+  case TYPE_TIMEVAL:
+    return caml_copy_double((double) optval.tv.tv_sec
+                       + (double) optval.tv.tv_usec / 1e6);
+  case TYPE_UNIX_ERROR:
+    if (optval.i == 0) {
+      return Val_int(0);        /* None */
+    } else {
+      value err, res;
+      err = unix_error_of_code(optval.i);
+      Begin_root(err);
+        res = caml_alloc_small(1, 0); /* Some */
+        Field(res, 0) = err;
+      End_roots();
+      return res;
+    }
+  default:
+    unix_error(EINVAL, name, Nothing);
+    return Val_unit; /* Avoid warning */
+  }
+}
+
+CAMLexport value
+unix_setsockopt_aux(char * name,
+                    enum option_type ty, int level, int option,
+                    value socket, value val)
+{
+  union option_value optval;
+  socklen_param_type optsize;
+  double f;
+
+  switch (ty) {
+  case TYPE_BOOL:
+  case TYPE_INT:
+    optsize = sizeof(optval.i);
+    optval.i = Int_val(val);
+    break;
+  case TYPE_LINGER:
+    optsize = sizeof(optval.lg);
+    optval.lg.l_onoff = Is_block (val);
+    if (optval.lg.l_onoff)
+      optval.lg.l_linger = Int_val (Field (val, 0));
+    break;
+  case TYPE_TIMEVAL:
+    f = Double_val(val);
+    optsize = sizeof(optval.tv);
+    optval.tv.tv_sec = (int) f;
+    optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec));
+    break;
+  case TYPE_UNIX_ERROR:
+  default:
+    unix_error(EINVAL, name, Nothing);
+  }
+
+  if (setsockopt(Socket_val(socket), level, option,
+                 (void *) &optval, optsize) == -1)
+    uerror(name, Nothing);
+
+  return Val_unit;
+}
+
+CAMLprim value unix_getsockopt(value vty, value vsocket, value voption)
+{
+  enum option_type ty = Int_val(vty);
+  struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]);
+  return unix_getsockopt_aux(getsockopt_fun_name[ty],
+                             ty,
+                             opt->level,
+                             opt->option,
+                             vsocket);
+}
+
+CAMLprim value unix_setsockopt(value vty, value vsocket, value voption,
+                               value val)
+{
+  enum option_type ty = Int_val(vty);
+  struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]);
+  return unix_setsockopt_aux(setsockopt_fun_name[ty],
+                             ty,
+                             opt->level,
+                             opt->option,
+                             vsocket,
+                             val);
+}
diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c
new file mode 100644
index 00000000..844ebd5b
--- /dev/null
+++ b/otherlibs/win32unix/startup.c
@@ -0,0 +1,51 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <fcntl.h>
+#include <stdlib.h>
+#include <caml/mlvalues.h>
+#include "winworker.h"
+#include "windbug.h"
+
+value val_process_id;
+
+CAMLprim value win_startup(unit)
+     value unit;
+{
+  WSADATA wsaData;
+  int i;
+  HANDLE h;
+
+  (void) WSAStartup(MAKEWORD(2, 0), &wsaData);
+  DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(),
+                  GetCurrentProcess(), &h, 0, TRUE,
+                  DUPLICATE_SAME_ACCESS);
+  val_process_id = Val_int(h);
+
+  worker_init();
+
+  return Val_unit;
+}
+
+CAMLprim value win_cleanup(unit)
+     value unit;
+{
+  worker_cleanup();
+
+  (void) WSACleanup();
+
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
new file mode 100644
index 00000000..45360a06
--- /dev/null
+++ b/otherlibs/win32unix/stat.c
@@ -0,0 +1,409 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                David Allsopp, MetaStack Solutions Ltd.                 */
+/*                                                                        */
+/*   Copyright 2015 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include "cst2constr.h"
+#define _INTEGRAL_MAX_BITS 64
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <time.h>
+#include <winioctl.h>
+
+#ifndef S_IFLNK
+/*
+ * The Microsoft CRT doesn't support lstat and so has no S_IFLNK
+ * The implementation uses comparison, so rather than allocating another bit, in
+ * a potentially future-incompatible way, just create a value with multiple bits
+ * set.
+ */
+#define S_IFLNK (S_IFDIR | S_IFREG)
+#endif
+#ifndef S_IFIFO
+#ifdef _S_IFIFO
+#define S_IFIFO _S_IFIFO
+#else
+#define S_IFIFO (S_IFREG | S_IFCHR)
+#endif
+#endif
+#ifndef S_IFSOCK
+#define S_IFSOCK (S_IFDIR | S_IFCHR)
+#endif
+#ifndef S_IFBLK
+#define S_IFBLK 0
+#endif
+
+static int file_kind_table[] = {
+  S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK
+};
+
+static value stat_aux(int use_64, __int64 st_ino, struct _stat64 *buf)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (v);
+
+  v = caml_alloc (12, 0);
+  Store_field (v, 0, Val_int (buf->st_dev));
+  Store_field (v, 1, Val_int (st_ino ? st_ino & Max_long : buf->st_ino));
+  Store_field (v, 2, cst_to_constr (buf->st_mode & S_IFMT, file_kind_table,
+                                    sizeof(file_kind_table) / sizeof(int), 0));
+  Store_field (v, 3, Val_int(buf->st_mode & 07777));
+  Store_field (v, 4, Val_int (buf->st_nlink));
+  Store_field (v, 5, Val_int (buf->st_uid));
+  Store_field (v, 6, Val_int (buf->st_gid));
+  Store_field (v, 7, Val_int (buf->st_rdev));
+  Store_field (v, 8,
+               use_64 ? caml_copy_int64(buf->st_size) : Val_int (buf->st_size));
+  Store_field (v, 9, caml_copy_double((double) buf->st_atime / 10000000.0));
+  Store_field (v, 10, caml_copy_double((double) buf->st_mtime / 10000000.0));
+  Store_field (v, 11, caml_copy_double((double) buf->st_ctime / 10000000.0));
+  CAMLreturn (v);
+}
+
+/*
+ * The long and ugly story of Microsoft CRT stat and symbolic links
+ *
+ * msvcrt.dll - which is now a core Windows component - is basically Visual
+ * Studio .NET 2003 CRT (Version 7). It is the version usually linked against by
+ * mingw64-gcc Its behaviour is as follows:
+ *   a) st_mode is correctly populated
+ *   b) st_atime, st_mtime and st_ctime are those for the symbolic link, not the
+ *      target
+ *   c) stat incorrectly returns information even if the target doesn't exist
+ *
+ * The next CRT of interest is Visual Studio 2008 (Version 9 - msvcr900.dll), as
+ * that's included with the Windows 7 SDK. This worked until 2011 when Microsoft
+ * produced security advisory KB2467174 (see https://bugs.python.org/issue6727)
+ * at which point stat returns ENOENT for symbolic links.
+ *
+ * This persists until Visual Studio 2010, when a hotfix
+ * (https://support.microsoft.com/en-gb/kb/2890375) was produced which was
+ * supposed to fix this behaviour. This CRT has one problem: it returns S_REG
+ * instead of S_DIR for directory symbolic links because of a subtle error in
+ * its implementation (it calls fstat which quite reasonably always assumes its
+ * looking at a regular file).
+ *
+ * The bug persists in Visual Studio 2012. Visual Studio 2015 features the
+ * "great refactored" CRT (written in C++!). This CRT correctly returns st_mode
+ * for directory symbolic links. Its two limitations are that it doesn't return
+ * the st_size correctly for symbolic links and it doesn't populate st_nlink
+ * correctly.
+ *
+ * However, even if fixed, mingw64 is limited to msvcrt.dll (by default, anyway)
+ * and that's a lot of buggy CRTs out there.
+ *
+ * There is also no implementation given for lstat in any CRT.
+ *
+ * do_stat therefore reimplements stat - but the algorithms for populating the
+ * resulting _stat64 are identical to Microsoft's (with the exception of correct
+ * handling of st_nlink for symbolic links), being based upon the code for the
+ * Microsoft CRT given in Microsoft Visual Studio 2013 Express
+ */
+
+static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
+{
+  /* Tempting though it may be, MSDN prohibits casting FILETIME directly
+   * to __int64 for alignment concerns. While this doesn't affect our supported
+   * platforms, it's easier to go with the flow...
+   */
+  ULARGE_INTEGER utime = {{time->dwLowDateTime, time->dwHighDateTime}};
+
+  if (utime.QuadPart) {
+    /* There are 11644473600000 seconds between 1 January 1601 (the NT Epoch)
+     * and 1 January 1970 (the Unix Epoch). FILETIME is measured in 100ns ticks.
+     */
+    *result = (utime.QuadPart - INT64_LITERAL(116444736000000000U));
+  }
+  else {
+    *result = def;
+  }
+
+  return 1;
+}
+
+/* path allocated outside the OCaml heap */
+static int safe_do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+{
+  BY_HANDLE_FILE_INFORMATION info;
+  int i;
+  char* ptr;
+  char c;
+  HANDLE h;
+  unsigned short mode;
+  int is_symlink = 0;
+
+  if (!path) {
+    h = fstat;
+  }
+  else {
+    caml_enter_blocking_section();
+    h = CreateFile(path,
+                   FILE_READ_ATTRIBUTES,
+                   FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
+                   NULL,
+                   OPEN_EXISTING,
+                   FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
+                   NULL);
+    caml_leave_blocking_section();
+  }
+  if (h == INVALID_HANDLE_VALUE) {
+    errno = ENOENT;
+    return 0;
+  }
+  else {
+    caml_enter_blocking_section();
+    if (!GetFileInformationByHandle(h, &info)) {
+      win32_maperr(GetLastError());
+      caml_leave_blocking_section();
+      if (path) CloseHandle(h);
+      return 0;
+    }
+    caml_leave_blocking_section();
+
+    /*
+     * It shouldn't be possible to call this via fstat and have a reparse point
+     * open, but the test on path guarantees this.
+     */
+    if (info.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT && path) {
+      /*
+       * Only symbolic links should be processed specially. The call to
+       * DeviceIoControl solves two problems at the same time:
+       *   a) Although FindFirstFileEx gives the reparse tag in dwReserved0,
+       *      GetFileInformationByHandle does not and using the Ex version (or
+       *      GetFileAttributesEx) makes Windows XP support harder
+       *   b) Windows returns 0 for the size of a symbolic link - reading the
+       *      reparse point allows a POSIX-compatible value to be returned in
+       *      st_size
+       */
+      char buffer[16384];
+      DWORD read;
+      REPARSE_DATA_BUFFER* point;
+
+      caml_enter_blocking_section();
+      if (DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, 16384, &read, NULL)) {
+        if (((REPARSE_DATA_BUFFER*)buffer)->ReparseTag == IO_REPARSE_TAG_SYMLINK) {
+          is_symlink = do_lstat;
+          res->st_size = ((REPARSE_DATA_BUFFER*)buffer)->SymbolicLinkReparseBuffer.SubstituteNameLength / 2;
+        }
+      }
+      caml_leave_blocking_section();
+
+      if (!is_symlink) {
+        CloseHandle(h);
+        caml_enter_blocking_section();
+        if ((h = CreateFile(path,
+                            FILE_READ_ATTRIBUTES,
+                            FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
+                            NULL,
+                            OPEN_EXISTING,
+                            FILE_FLAG_BACKUP_SEMANTICS,
+                            NULL)) == INVALID_HANDLE_VALUE) {
+          errno = ENOENT;
+          caml_leave_blocking_section();
+          return 0;
+        }
+        else {
+          if (!GetFileInformationByHandle(h, &info)) {
+            win32_maperr(GetLastError());
+            caml_leave_blocking_section();
+            CloseHandle(h);
+            return 0;
+          }
+          caml_leave_blocking_section();
+        }
+      }
+    }
+
+    if (path) CloseHandle(h);
+
+    if (!is_symlink) {
+      /*
+       * The size returned seems to vary depending on whether it's a directory
+       * (in which case it's 0) or a symbolic link (in which case it looks like
+       * allocated sector size).
+       * Neither is interesting, so return 0.
+       */
+      if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
+        res->st_size = 0;
+      }
+      else {
+        res->st_size = ((__int64)(info.nFileSizeHigh)) << 32 |
+                       ((__int64)info.nFileSizeLow);
+      }
+    }
+
+    if (!use_64 && res->st_size > Max_long) {
+      win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
+      return 0;
+    }
+
+    if (!convert_time(&info.ftLastWriteTime, &res->st_mtime, 0) ||
+        !convert_time(&info.ftLastAccessTime, &res->st_atime, res->st_mtime) ||
+        !convert_time(&info.ftCreationTime, &res->st_ctime, res->st_mtime)) {
+      win32_maperr(GetLastError());
+      return 0;
+    }
+
+    /*
+     * Note MS CRT (still) puts st_nlink = 1 and gives st_ino = 0
+     */
+    res->st_nlink = info.nNumberOfLinks;
+    res->st_dev = info.dwVolumeSerialNumber;
+    *st_ino = ((__int64)(info.nFileIndexHigh)) << 32 | ((__int64)info.nFileIndexLow);
+  }
+
+  if (do_lstat && is_symlink) {
+    mode = S_IFLNK | S_IEXEC | S_IWRITE;
+  }
+  else {
+    mode = (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY ? _S_IFDIR | _S_IEXEC : _S_IFREG);
+  }
+  mode |= (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY ? _S_IREAD : _S_IREAD | _S_IWRITE);
+  /*
+   * The simulation of the execute bit is ignored for fstat. It could be
+   * emulated using GetFinalPathNameByHandle, but the pre-Vista emulation is a
+   * bit too much effort for a simulated value, so it's simply ignored!
+   */
+  if (path && (ptr = strrchr(path, '.')) && (!_stricmp(ptr, ".exe") ||
+                                             !_stricmp(ptr, ".cmd") ||
+                                             !_stricmp(ptr, ".bat") ||
+                                             !_stricmp(ptr, ".com"))) {
+    mode |= _S_IEXEC;
+  }
+  mode |= (mode & 0700) >> 3;
+  mode |= (mode & 0700) >> 6;
+  res->st_mode = mode;
+  res->st_uid = res->st_gid = res->st_ino = 0;
+  res->st_rdev = res->st_dev;
+
+  return 1;
+}
+
+static int do_stat(int do_lstat, int use_64, char* opath, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+{
+  char* path;
+  int ret;
+  path = caml_strdup(opath);
+  ret = safe_do_stat(do_lstat, use_64, path, l, fstat, st_ino, res);
+  caml_stat_free(path);
+  return ret;
+}
+
+CAMLprim value unix_stat(value path)
+{
+  struct _stat64 buf;
+  __int64 st_ino;
+
+  caml_unix_check_path(path, "stat");
+  if (!do_stat(0, 0, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+    uerror("stat", path);
+  }
+  return stat_aux(0, st_ino, &buf);
+}
+
+CAMLprim value unix_stat_64(value path)
+{
+  struct _stat64 buf;
+  __int64 st_ino;
+
+  caml_unix_check_path(path, "stat");
+  if (!do_stat(0, 1, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+    uerror("stat", path);
+  }
+  return stat_aux(1, st_ino, &buf);
+}
+
+CAMLprim value unix_lstat(value path)
+{
+  struct _stat64 buf;
+  __int64 st_ino;
+
+  caml_unix_check_path(path, "lstat");
+  if (!do_stat(1, 0, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+    uerror("lstat", path);
+  }
+  return stat_aux(0, st_ino, &buf);
+}
+
+CAMLprim value unix_lstat_64(value path)
+{
+  struct _stat64 buf;
+  __int64 st_ino;
+
+  caml_unix_check_path(path, "lstat");
+  if (!do_stat(1, 1, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+    uerror("lstat", path);
+  }
+  return stat_aux(1, st_ino, &buf);
+}
+
+static value do_fstat(value handle, int use_64)
+{
+  int ret;
+  struct _stat64 buf;
+  __int64 st_ino;
+  HANDLE h;
+  DWORD ft;
+
+  st_ino = 0;
+  memset(&buf, 0, sizeof buf);
+  buf.st_nlink = 1;
+
+  h = Handle_val(handle);
+  ft = GetFileType(h) & ~FILE_TYPE_REMOTE;
+  switch(ft) {
+  case FILE_TYPE_DISK:
+    if (!safe_do_stat(0, use_64, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
+      uerror("fstat", Nothing);
+    }
+    break;
+  case FILE_TYPE_CHAR:
+    buf.st_mode = S_IFCHR;
+    break;
+  case FILE_TYPE_PIPE:
+    {
+      DWORD n_avail;
+      if (Descr_kind_val(handle) == KIND_SOCKET) {
+        buf.st_mode = S_IFSOCK;
+      }
+      else {
+        buf.st_mode = S_IFIFO;
+      }
+      if (PeekNamedPipe(h, NULL, 0, NULL, &n_avail, NULL)) {
+        buf.st_size = n_avail;
+      }
+    }
+    break;
+  case FILE_TYPE_UNKNOWN:
+    unix_error(EBADF, "fstat", Nothing);
+  default:
+    win32_maperr(GetLastError());
+    uerror("fstat", Nothing);
+  }
+  return stat_aux(use_64, st_ino, &buf);
+}
+
+CAMLprim value unix_fstat(value handle)
+{
+  return do_fstat(handle, 0);
+}
+
+CAMLprim value unix_fstat_64(value handle)
+{
+  return do_fstat(handle, 1);
+}
diff --git a/otherlibs/win32unix/symlink.c b/otherlibs/win32unix/symlink.c
new file mode 100644
index 00000000..326cefcb
--- /dev/null
+++ b/otherlibs/win32unix/symlink.c
@@ -0,0 +1,115 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                David Allsopp, MetaStack Solutions Ltd.                 */
+/*                                                                        */
+/*   Copyright 2015 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/*
+ * Windows Vista functions enabled
+ */
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0600
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+typedef BOOLEAN (WINAPI *LPFN_CREATESYMBOLICLINK) (LPTSTR, LPTSTR, DWORD);
+
+static LPFN_CREATESYMBOLICLINK pCreateSymbolicLink = NULL;
+static int no_symlink = 0;
+
+CAMLprim value unix_symlink(value to_dir, value osource, value odest)
+{
+  CAMLparam3(to_dir, osource, odest);
+  DWORD flags = (Bool_val(to_dir) ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0);
+  BOOLEAN result;
+  LPTSTR source;
+  LPTSTR dest;
+  caml_unix_check_path(osource, "symlink");
+  caml_unix_check_path(odest, "symlink");
+
+again:
+  if (no_symlink) {
+    caml_invalid_argument("symlink not available");
+  }
+
+  if (!pCreateSymbolicLink) {
+    pCreateSymbolicLink = (LPFN_CREATESYMBOLICLINK)GetProcAddress(GetModuleHandle("kernel32"), "CreateSymbolicLinkA");
+    no_symlink = !pCreateSymbolicLink;
+    goto again;
+  }
+
+  /* Copy source and dest outside the OCaml heap */
+  source = caml_strdup(String_val(osource));
+  dest = caml_strdup(String_val(odest));
+
+  caml_enter_blocking_section();
+  result = pCreateSymbolicLink(dest, source, flags);
+  caml_leave_blocking_section();
+
+  caml_stat_free(source);
+  caml_stat_free(dest);
+
+  if (!result) {
+    win32_maperr(GetLastError());
+    uerror("symlink", odest);
+  }
+
+  CAMLreturn(Val_unit);
+}
+
+#define luid_eq(l, r) (l.LowPart == r.LowPart && l.HighPart == r.HighPart)
+
+CAMLprim value unix_has_symlink(value unit)
+{
+  CAMLparam1(unit);
+  HANDLE hProcess = GetCurrentProcess();
+  BOOL result = FALSE;
+
+  if (OpenProcessToken(hProcess, TOKEN_READ, &hProcess)) {
+    LUID seCreateSymbolicLinkPrivilege;
+
+    if (LookupPrivilegeValue(NULL,
+                             SE_CREATE_SYMBOLIC_LINK_NAME,
+                             &seCreateSymbolicLinkPrivilege)) {
+      DWORD length;
+
+      if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
+        if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
+          TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)caml_stat_alloc(length);
+          if (GetTokenInformation(hProcess,
+                                  TokenPrivileges,
+                                  privileges,
+                                  length,
+                                  &length)) {
+            DWORD count = privileges->PrivilegeCount;
+
+            if (count) {
+              LUID_AND_ATTRIBUTES* privs = privileges->Privileges;
+              while (count-- && !(result = luid_eq(privs->Luid, seCreateSymbolicLinkPrivilege)))
+                privs++;
+            }
+          }
+
+          caml_stat_free(privileges);
+        }
+      }
+    }
+
+    CloseHandle(hProcess);
+  }
+
+  CAMLreturn(Val_bool(result));
+}
diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c
new file mode 100644
index 00000000..a7946b6e
--- /dev/null
+++ b/otherlibs/win32unix/system.c
@@ -0,0 +1,45 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <process.h>
+#include <stdio.h>
+
+CAMLprim value win_system(cmd)
+     value cmd;
+{
+  int ret;
+  value st;
+  char *buf;
+  intnat len;
+
+  caml_unix_check_path(cmd, "system");
+  len = caml_string_length (cmd);
+  buf = caml_stat_alloc (len + 1);
+  memmove (buf, String_val (cmd), len + 1);
+  caml_enter_blocking_section();
+  _flushall();
+  ret = system(buf);
+  caml_leave_blocking_section();
+  caml_stat_free(buf);
+  if (ret == -1) uerror("system", Nothing);
+  st = caml_alloc_small(1, 0); /* Tag 0: Exited */
+  Field(st, 0) = Val_int(ret);
+  return st;
+}
diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
new file mode 100644
index 00000000..18cd9aa9
--- /dev/null
+++ b/otherlibs/win32unix/times.c
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                  File contributed by Josh Berdine                      */
+/*                                                                        */
+/*   Copyright 2011 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "unixsupport.h"
+#include <windows.h>
+
+
+double to_sec(FILETIME ft) {
+#if defined(_MSC_VER) && _MSC_VER < 1300
+  /* See gettimeofday.c - it is not possible for these values to be 64-bit, so
+     there's no worry about using a signed struct in order to work around the
+     lack of support for casting int64_t to double.
+   */
+  LARGE_INTEGER tmp;
+#else
+  ULARGE_INTEGER tmp;
+#endif
+
+  tmp.u.LowPart = ft.dwLowDateTime;
+  tmp.u.HighPart = ft.dwHighDateTime;
+
+  /* convert to seconds:
+     GetProcessTimes returns number of 100-nanosecond intervals */
+  return tmp.QuadPart / 1e7;
+}
+
+
+value unix_times(value unit) {
+  value res;
+  FILETIME creation, exit, stime, utime;
+
+  if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime,
+                        &utime))) {
+    win32_maperr(GetLastError());
+    uerror("times", Nothing);
+  }
+
+  res = caml_alloc_small(4 * Double_wosize, Double_array_tag);
+  Store_double_field(res, 0, to_sec(utime));
+  Store_double_field(res, 1, to_sec(stime));
+  Store_double_field(res, 2, 0);
+  Store_double_field(res, 3, 0);
+  return res;
+}
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
new file mode 100644
index 00000000..7fa865aa
--- /dev/null
+++ b/otherlibs/win32unix/unix.ml
@@ -0,0 +1,1058 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Initialization *)
+
+external startup: unit -> unit = "win_startup"
+external cleanup: unit -> unit = "win_cleanup"
+
+let _ = startup(); at_exit cleanup
+
+(* Errors *)
+
+type error =
+  (* Errors defined in the POSIX standard *)
+    E2BIG               (* Argument list too long *)
+  | EACCES              (* Permission denied *)
+  | EAGAIN              (* Resource temporarily unavailable; try again *)
+  | EBADF               (* Bad file descriptor *)
+  | EBUSY               (* Resource unavailable *)
+  | ECHILD              (* No child process *)
+  | EDEADLK             (* Resource deadlock would occur *)
+  | EDOM                (* Domain error for math functions, etc. *)
+  | EEXIST              (* File exists *)
+  | EFAULT              (* Bad address *)
+  | EFBIG               (* File too large *)
+  | EINTR               (* Function interrupted by signal *)
+  | EINVAL              (* Invalid argument *)
+  | EIO                 (* Hardware I/O error *)
+  | EISDIR              (* Is a directory *)
+  | EMFILE              (* Too many open files by the process *)
+  | EMLINK              (* Too many links *)
+  | ENAMETOOLONG        (* Filename too long *)
+  | ENFILE              (* Too many open files in the system *)
+  | ENODEV              (* No such device *)
+  | ENOENT              (* No such file or directory *)
+  | ENOEXEC             (* Not an executable file *)
+  | ENOLCK              (* No locks available *)
+  | ENOMEM              (* Not enough memory *)
+  | ENOSPC              (* No space left on device *)
+  | ENOSYS              (* Function not supported *)
+  | ENOTDIR             (* Not a directory *)
+  | ENOTEMPTY           (* Directory not empty *)
+  | ENOTTY              (* Inappropriate I/O control operation *)
+  | ENXIO               (* No such device or address *)
+  | EPERM               (* Operation not permitted *)
+  | EPIPE               (* Broken pipe *)
+  | ERANGE              (* Result too large *)
+  | EROFS               (* Read-only file system *)
+  | ESPIPE              (* Invalid seek e.g. on a pipe *)
+  | ESRCH               (* No such process *)
+  | EXDEV               (* Invalid link *)
+  (* Additional errors, mostly BSD *)
+  | EWOULDBLOCK         (* Operation would block *)
+  | EINPROGRESS         (* Operation now in progress *)
+  | EALREADY            (* Operation already in progress *)
+  | ENOTSOCK            (* Socket operation on non-socket *)
+  | EDESTADDRREQ        (* Destination address required *)
+  | EMSGSIZE            (* Message too long *)
+  | EPROTOTYPE          (* Protocol wrong type for socket *)
+  | ENOPROTOOPT         (* Protocol not available *)
+  | EPROTONOSUPPORT     (* Protocol not supported *)
+  | ESOCKTNOSUPPORT     (* Socket type not supported *)
+  | EOPNOTSUPP          (* Operation not supported on socket *)
+  | EPFNOSUPPORT        (* Protocol family not supported *)
+  | EAFNOSUPPORT        (* Address family not supported by protocol family *)
+  | EADDRINUSE          (* Address already in use *)
+  | EADDRNOTAVAIL       (* Can't assign requested address *)
+  | ENETDOWN            (* Network is down *)
+  | ENETUNREACH         (* Network is unreachable *)
+  | ENETRESET           (* Network dropped connection on reset *)
+  | ECONNABORTED        (* Software caused connection abort *)
+  | ECONNRESET          (* Connection reset by peer *)
+  | ENOBUFS             (* No buffer space available *)
+  | EISCONN             (* Socket is already connected *)
+  | ENOTCONN            (* Socket is not connected *)
+  | ESHUTDOWN           (* Can't send after socket shutdown *)
+  | ETOOMANYREFS        (* Too many references: can't splice *)
+  | ETIMEDOUT           (* Connection timed out *)
+  | ECONNREFUSED        (* Connection refused *)
+  | EHOSTDOWN           (* Host is down *)
+  | EHOSTUNREACH        (* No route to host *)
+  | ELOOP               (* Too many levels of symbolic links *)
+  | EOVERFLOW
+  (* All other errors are mapped to EUNKNOWNERR *)
+  | EUNKNOWNERR of int  (* Unknown error *)
+
+exception Unix_error of error * string * string
+
+let _ = Callback.register_exception "Unix.Unix_error"
+                                    (Unix_error(E2BIG, "", ""))
+
+external error_message : error -> string = "unix_error_message"
+
+let handle_unix_error f arg =
+  try
+    f arg
+  with Unix_error(err, fun_name, arg) ->
+    prerr_string Sys.argv.(0);
+    prerr_string ": \"";
+    prerr_string fun_name;
+    prerr_string "\" failed";
+    if String.length arg > 0 then begin
+      prerr_string " on \"";
+      prerr_string arg;
+      prerr_string "\""
+    end;
+    prerr_string ": ";
+    prerr_endline (error_message err);
+    exit 2
+
+external environment : unit -> string array = "unix_environment"
+external getenv: string -> string = "caml_sys_getenv"
+(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *)
+external putenv: string -> string -> unit = "unix_putenv"
+
+type process_status =
+    WEXITED of int
+  | WSIGNALED of int
+  | WSTOPPED of int
+
+type wait_flag =
+    WNOHANG
+  | WUNTRACED
+
+type file_descr
+
+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"
+external getpid : unit -> int = "unix_getpid"
+
+let fork () = invalid_arg "Unix.fork not implemented"
+let wait () = invalid_arg "Unix.wait not implemented"
+let getppid () = invalid_arg "Unix.getppid not implemented"
+let nice _ = invalid_arg "Unix.nice not implemented"
+
+(* Basic file input/output *)
+
+external filedescr_of_fd : int -> file_descr = "win_handle_fd"
+
+let stdin = filedescr_of_fd 0
+let stdout = filedescr_of_fd 1
+let stderr = filedescr_of_fd 2
+
+type open_flag =
+    O_RDONLY
+  | O_WRONLY
+  | O_RDWR
+  | O_NONBLOCK
+  | O_APPEND
+  | O_CREAT
+  | O_TRUNC
+  | O_EXCL
+  | O_NOCTTY
+  | O_DSYNC
+  | O_SYNC
+  | O_RSYNC
+  | O_SHARE_DELETE
+  | O_CLOEXEC
+  | O_KEEPEXEC
+
+type file_perm = int
+
+external openfile : string -> open_flag list -> file_perm -> file_descr
+           = "unix_open"
+external close : file_descr -> unit = "unix_close"
+external unsafe_read : file_descr -> bytes -> int -> int -> int
+                     = "unix_read"
+external unsafe_write : file_descr -> bytes -> int -> int -> int
+                      = "unix_write"
+external unsafe_single_write : file_descr -> bytes -> int -> int -> int
+                      = "unix_single_write"
+
+let read fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.read"
+  else unsafe_read fd buf ofs len
+let write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > Bytes.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 > Bytes.length buf - len
+  then invalid_arg "Unix.single_write"
+  else unsafe_single_write fd buf ofs len
+
+let write_substring fd buf ofs len =
+  write fd (Bytes.unsafe_of_string buf) ofs len
+
+let single_write_substring fd buf ofs len =
+  single_write fd (Bytes.unsafe_of_string buf) ofs len
+
+(* Interfacing with the standard input/output library *)
+
+external in_channel_of_descr: file_descr -> in_channel
+   = "win_inchannel_of_filedescr"
+external out_channel_of_descr: file_descr -> out_channel
+   = "win_outchannel_of_filedescr"
+external descr_of_in_channel : in_channel -> file_descr
+   = "win_filedescr_of_channel"
+external descr_of_out_channel : out_channel -> file_descr
+   = "win_filedescr_of_channel"
+
+(* Seeking and truncating *)
+
+type seek_command =
+    SEEK_SET
+  | SEEK_CUR
+  | SEEK_END
+
+external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
+
+let truncate _name _len = invalid_arg "Unix.truncate not implemented"
+let ftruncate _fd _len = invalid_arg "Unix.ftruncate not implemented"
+
+(* File statistics *)
+
+type file_kind =
+    S_REG
+  | S_DIR
+  | S_CHR
+  | S_BLK
+  | S_LNK
+  | S_FIFO
+  | S_SOCK
+
+type stats =
+  { st_dev : int;
+    st_ino : int;
+    st_kind : file_kind;
+    st_perm : file_perm;
+    st_nlink : int;
+    st_uid : int;
+    st_gid : int;
+    st_rdev : int;
+    st_size : int;
+    st_atime : float;
+    st_mtime : float;
+    st_ctime : float }
+
+external stat : string -> stats = "unix_stat"
+external lstat : string -> stats = "unix_lstat"
+external fstat : file_descr -> stats = "unix_fstat"
+let isatty fd =
+  match (fstat fd).st_kind with S_CHR -> true | _ -> false
+
+(* Operations on file names *)
+
+external unlink : string -> unit = "unix_unlink"
+external rename : string -> string -> unit = "unix_rename"
+external link : string -> string -> unit = "unix_link"
+
+(* Operations on large files *)
+
+module LargeFile =
+  struct
+    external lseek : file_descr -> int64 -> seek_command -> int64
+       = "unix_lseek_64"
+    let truncate _name _len =
+      invalid_arg "Unix.LargeFile.truncate not implemented"
+    let ftruncate _name _len =
+      invalid_arg "Unix.LargeFile.ftruncate not implemented"
+    type stats =
+      { st_dev : int;
+        st_ino : int;
+        st_kind : file_kind;
+        st_perm : file_perm;
+        st_nlink : int;
+        st_uid : int;
+        st_gid : int;
+        st_rdev : int;
+        st_size : int64;
+        st_atime : float;
+        st_mtime : float;
+        st_ctime : float;
+      }
+    external stat : string -> stats = "unix_stat_64"
+    external lstat : string -> stats = "unix_lstat_64"
+    external fstat : file_descr -> stats = "unix_fstat_64"
+  end
+
+(* File permissions and ownership *)
+
+type access_permission =
+    R_OK
+  | W_OK
+  | X_OK
+  | F_OK
+
+external chmod : string -> file_perm -> unit = "unix_chmod"
+let fchmod _fd _perm = invalid_arg "Unix.fchmod not implemented"
+let chown _file _perm = invalid_arg "Unix.chown not implemented"
+let fchown _fd _perm = invalid_arg "Unix.fchown not implemented"
+let umask _msk = invalid_arg "Unix.umask not implemented"
+
+external access : string -> access_permission list -> unit = "unix_access"
+
+(* Operations on file descriptors *)
+
+external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
+external dup2 :
+   ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2"
+
+external set_nonblock : file_descr -> unit = "unix_set_nonblock"
+external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
+
+external set_close_on_exec : file_descr -> unit = "win_set_close_on_exec"
+external clear_close_on_exec : file_descr -> unit = "win_clear_close_on_exec"
+
+(* Directories *)
+
+external mkdir : string -> file_perm -> unit = "unix_mkdir"
+external rmdir : string -> unit = "unix_rmdir"
+external chdir : string -> unit = "unix_chdir"
+external getcwd : unit -> string = "unix_getcwd"
+let chroot _ = invalid_arg "Unix.chroot not implemented"
+
+type dir_entry =
+    Dir_empty
+  | Dir_read of string
+  | Dir_toread
+
+type dir_handle =
+  { dirname: string; mutable handle: int; mutable entry_read: dir_entry }
+
+external findfirst : string -> string * int = "win_findfirst"
+external findnext : int -> string= "win_findnext"
+
+let opendir dirname =
+  try
+    let (first_entry, handle) = findfirst (Filename.concat dirname "*.*") in
+    { dirname = dirname; handle = handle; entry_read = Dir_read first_entry }
+  with End_of_file ->
+    { dirname = dirname; handle = 0; entry_read = Dir_empty }
+
+let readdir d =
+  match d.entry_read with
+    Dir_empty -> raise End_of_file
+  | Dir_read name -> d.entry_read <- Dir_toread; name
+  | Dir_toread -> findnext d.handle
+
+external win_findclose : int -> unit = "win_findclose"
+
+let closedir d =
+  match d.entry_read with
+    Dir_empty -> ()
+  | _ -> win_findclose d.handle
+
+let rewinddir d =
+  closedir d;
+  try
+    let (first_entry, handle) = findfirst (d.dirname ^ "\\*.*") in
+    d.handle <- handle; d.entry_read <- Dir_read first_entry
+  with End_of_file ->
+    d.handle <- 0; d.entry_read <- Dir_empty
+
+(* Pipes *)
+
+external pipe :
+  ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
+
+let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
+
+(* Symbolic links *)
+
+external readlink : string -> string = "unix_readlink"
+external symlink_stub : bool -> string -> string -> unit = "unix_symlink"
+
+let symlink ?to_dir source dest =
+  let to_dir =
+    match to_dir with
+      Some to_dir ->
+        to_dir
+    | None ->
+        try
+          LargeFile.((stat source).st_kind = S_DIR)
+        with _ ->
+          false
+  in
+    symlink_stub to_dir source dest
+
+external has_symlink : unit -> bool = "unix_has_symlink"
+
+(* Locking *)
+
+type lock_command =
+    F_ULOCK
+  | F_LOCK
+  | F_TLOCK
+  | F_TEST
+  | F_RLOCK
+  | F_TRLOCK
+
+external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf"
+
+external terminate_process: int -> bool = "win_terminate_process"
+
+let kill pid signo =
+  if signo <> Sys.sigkill then
+    invalid_arg "Unix.kill"
+  else
+    if not (terminate_process pid) then
+      raise(Unix_error(ESRCH, "kill", ""))
+        (* could be more precise *)
+
+type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
+let sigprocmask _cmd _sigs = invalid_arg "Unix.sigprocmask not implemented"
+let sigpending () = invalid_arg "Unix.sigpending not implemented"
+let sigsuspend _sigs = invalid_arg "Unix.sigsuspend not implemented"
+let pause () = invalid_arg "Unix.pause not implemented"
+
+(* Time functions *)
+
+type process_times =
+  { tms_utime : float;
+    tms_stime : float;
+    tms_cutime : float;
+    tms_cstime : float }
+
+type tm =
+  { tm_sec : int;
+    tm_min : int;
+    tm_hour : int;
+    tm_mday : int;
+    tm_mon : int;
+    tm_year : int;
+    tm_wday : int;
+    tm_yday : int;
+    tm_isdst : bool }
+
+external time : unit -> float = "unix_time"
+external gettimeofday : unit -> float = "unix_gettimeofday"
+external gmtime : float -> tm = "unix_gmtime"
+external localtime : float -> tm = "unix_localtime"
+external mktime : tm -> float * tm = "unix_mktime"
+let alarm _n = invalid_arg "Unix.alarm not implemented"
+external sleepf : float -> unit = "unix_sleep"
+let sleep n = sleepf (float n)
+external times: unit -> process_times = "unix_times"
+external utimes : string -> float -> float -> unit = "unix_utimes"
+
+type interval_timer =
+    ITIMER_REAL
+  | ITIMER_VIRTUAL
+  | ITIMER_PROF
+
+type interval_timer_status =
+  { it_interval: float;
+    it_value: float }
+
+let getitimer _it = invalid_arg "Unix.getitimer not implemented"
+let setitimer _it _tm = invalid_arg "Unix.setitimer not implemented"
+
+(* User id, group id *)
+
+let getuid () = 1
+let geteuid = getuid
+let setuid _id = invalid_arg "Unix.setuid not implemented"
+
+let getgid () = 1
+let getegid = getgid
+let setgid _id = invalid_arg "Unix.setgid not implemented"
+
+let getgroups () = [|1|]
+let setgroups _ = invalid_arg "Unix.setgroups not implemented"
+let initgroups _ _ = invalid_arg "Unix.initgroups not implemented"
+
+type passwd_entry =
+  { pw_name : string;
+    pw_passwd : string;
+    pw_uid : int;
+    pw_gid : int;
+    pw_gecos : string;
+    pw_dir : string;
+    pw_shell : string }
+
+type group_entry =
+  { gr_name : string;
+    gr_passwd : string;
+    gr_gid : int;
+    gr_mem : string array }
+
+let getlogin () = try Sys.getenv "USERNAME" with Not_found -> ""
+let getpwnam _x = raise Not_found
+let getgrnam = getpwnam
+let getpwuid = getpwnam
+let getgrgid = getpwnam
+
+(* Internet addresses *)
+
+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"
+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
+  | SOCK_DGRAM
+  | SOCK_RAW
+  | SOCK_SEQPACKET
+
+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
+  | SHUTDOWN_ALL
+
+type msg_flag =
+    MSG_OOB
+  | MSG_DONTROUTE
+  | MSG_PEEK
+
+external socket : 
+  ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
+  = "unix_socket"
+let socketpair ?cloexec:_ _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
+external accept :
+  ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
+external bind : file_descr -> sockaddr -> unit = "unix_bind"
+external connect : file_descr -> sockaddr -> unit = "unix_connect"
+external listen : file_descr -> int -> unit = "unix_listen"
+external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown"
+external getsockname : file_descr -> sockaddr = "unix_getsockname"
+external getpeername : file_descr -> sockaddr = "unix_getpeername"
+
+external unsafe_recv :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int
+                                  = "unix_recv"
+external unsafe_recvfrom :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr
+                                  = "unix_recvfrom"
+external unsafe_send :
+  file_descr -> bytes -> int -> int -> msg_flag list -> int
+                                  = "unix_send"
+external unsafe_sendto :
+  file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int
+                                  = "unix_sendto" "unix_sendto_native"
+
+let recv fd buf ofs len flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.recv"
+  else unsafe_recv fd buf ofs len flags
+let recvfrom fd buf ofs len flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.recvfrom"
+  else unsafe_recvfrom fd buf ofs len flags
+let send fd buf ofs len flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.send"
+  else unsafe_send fd buf ofs len flags
+let sendto fd buf ofs len flags addr =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buf - len
+  then invalid_arg "Unix.sendto"
+  else unsafe_sendto fd buf ofs len flags addr
+
+let send_substring fd buf ofs len flags =
+  send fd (Bytes.unsafe_of_string buf) ofs len flags
+
+let sendto_substring fd buf ofs len flags addr =
+  sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr
+
+type socket_bool_option =
+    SO_DEBUG
+  | SO_BROADCAST
+  | SO_REUSEADDR
+  | SO_KEEPALIVE
+  | SO_DONTROUTE
+  | SO_OOBINLINE
+  | SO_ACCEPTCONN
+  | TCP_NODELAY
+  | IPV6_ONLY
+
+type socket_int_option =
+    SO_SNDBUF
+  | SO_RCVBUF
+  | SO_ERROR
+  | SO_TYPE
+  | SO_RCVLOWAT
+  | SO_SNDLOWAT
+
+type socket_optint_option = SO_LINGER
+
+type socket_float_option =
+    SO_RCVTIMEO
+  | SO_SNDTIMEO
+
+type socket_error_option = SO_ERROR
+
+module SO: sig
+  type ('opt, 'v) t
+  val bool: (socket_bool_option, bool) t
+  val int: (socket_int_option, int) t
+  val optint: (socket_optint_option, int option) t
+  val float: (socket_float_option, float) t
+  val error: (socket_error_option, error option) t
+  val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
+  val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
+end = struct
+  type ('opt, 'v) t = int
+  let bool = 0
+  let int = 1
+  let optint = 2
+  let float = 3
+  let error = 4
+  external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
+              = "unix_getsockopt"
+  external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
+              = "unix_setsockopt"
+end
+
+let getsockopt fd opt = SO.get SO.bool fd opt
+let setsockopt fd opt v = SO.set SO.bool fd opt v
+
+let getsockopt_int fd opt = SO.get SO.int fd opt
+let setsockopt_int fd opt v = SO.set SO.int fd opt v
+
+let getsockopt_optint fd opt = SO.get SO.optint fd opt
+let setsockopt_optint fd opt v = SO.set SO.optint fd opt v
+
+let getsockopt_float fd opt = SO.get SO.float fd opt
+let setsockopt_float fd opt v = SO.set SO.float fd opt v
+
+let getsockopt_error fd = SO.get SO.error fd SO_ERROR
+
+(* Host and protocol databases *)
+
+type host_entry =
+  { h_name : string;
+    h_aliases : string array;
+    h_addrtype : socket_domain;
+    h_addr_list : inet_addr array }
+
+type protocol_entry =
+  { p_name : string;
+    p_aliases : string array;
+    p_proto : int }
+
+type service_entry =
+  { s_name : string;
+    s_aliases : string array;
+    s_port : int;
+    s_proto : string }
+
+external gethostname : unit -> string = "unix_gethostname"
+external gethostbyname : string -> host_entry = "unix_gethostbyname"
+external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr"
+external getprotobyname : string -> protocol_entry
+                                         = "unix_getprotobyname"
+external getprotobynumber : int -> protocol_entry
+                                         = "unix_getprotobynumber"
+
+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
+
+(* 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 '\"' ||
+       String.contains f '\t' ||
+       f = ""
+    then Filename.quote f
+    else f in
+  String.concat " " (List.map maybe_quote (Array.to_list args))
+
+let make_process_env env =
+  Array.iter
+    (fun s -> if String.contains s '\000' then raise(Unix_error(EINVAL, "", s)))
+    env;
+  String.concat "\000" (Array.to_list env) ^ "\000"
+
+let create_process prog args 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 (make_cmdline args)
+                     (Some(make_process_env env))
+                     fd1 fd2 fd3
+
+external system: string -> process_status = "win_system"
+
+type popen_process =
+    Process of in_channel * out_channel
+  | Process_in of in_channel
+  | Process_out of out_channel
+  | Process_full of in_channel * out_channel * in_channel
+
+let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
+
+let open_proc cmd optenv proc input output error =
+  let shell =
+    try Sys.getenv "COMSPEC"
+    with Not_found -> raise(Unix_error(ENOEXEC, "open_proc", cmd)) in
+  let pid =
+    win_create_process shell (shell ^ " /c " ^ cmd) optenv
+                       input output error in
+  Hashtbl.add popen_processes proc pid
+
+let open_process_in cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let inchan = in_channel_of_descr in_read in
+  begin
+    try
+      open_proc cmd None (Process_in inchan) stdin in_write stderr
+    with e ->
+      close_in inchan;
+      close in_write;
+      raise e
+  end;
+  close in_write;
+  inchan
+
+let open_process_out cmd =
+  let (out_read, out_write) = pipe ~cloexec:true () in
+  let outchan = out_channel_of_descr out_write in
+  begin
+    try
+      open_proc cmd None (Process_out outchan) out_read stdout stderr
+    with e ->
+    close_out outchan;
+    close out_read;
+    raise e
+  end;
+  close out_read;
+  outchan
+
+let open_process cmd =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let (out_read, out_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write; raise e in
+  let inchan = in_channel_of_descr in_read in
+  let outchan = out_channel_of_descr out_write in
+  begin
+    try
+      open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
+    with e ->
+      close out_read; close out_write;
+      close in_read; close in_write;
+      raise e
+  end;
+  close out_read;
+  close in_write;
+  (inchan, outchan)
+
+let open_process_full cmd env =
+  let (in_read, in_write) = pipe ~cloexec:true () in
+  let (out_read, out_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write; raise e in
+  let (err_read, err_write) =
+    try pipe ~cloexec:true ()
+    with e -> close in_read; close in_write;
+              close out_read; close out_write; raise e in
+  let inchan = in_channel_of_descr in_read in
+  let outchan = out_channel_of_descr out_write in
+  let errchan = in_channel_of_descr err_read in
+  begin
+    try
+      open_proc cmd (Some (make_process_env env))
+               (Process_full(inchan, outchan, errchan))
+                out_read in_write err_write
+    with e ->
+      close out_read; close out_write;
+      close in_read; close in_write;
+      close err_read; close err_write; 
+      raise e
+  end;
+  close out_read;
+  close in_write;
+  close err_write;
+  (inchan, outchan, errchan)
+
+let find_proc_id fun_name proc =
+  try
+    let pid = Hashtbl.find popen_processes proc in
+    Hashtbl.remove popen_processes proc;
+    pid
+  with Not_found ->
+    raise(Unix_error(EBADF, fun_name, ""))
+
+let close_process_in inchan =
+  let pid = find_proc_id "close_process_in" (Process_in inchan) in
+  close_in inchan;
+  snd(waitpid [] pid)
+
+let close_process_out outchan =
+  let pid = find_proc_id "close_process_out" (Process_out outchan) in
+  close_out outchan;
+  snd(waitpid [] pid)
+
+let close_process (inchan, outchan) =
+  let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
+  close_in inchan; close_out outchan;
+  snd(waitpid [] pid)
+
+let close_process_full (inchan, outchan, errchan) =
+  let pid =
+    find_proc_id "close_process_full"
+                 (Process_full(inchan, outchan, errchan)) in
+  close_in inchan; close_out outchan; close_in errchan;
+  snd(waitpid [] pid)
+
+(* Polling *)
+
+external select :
+  file_descr list -> file_descr list -> file_descr list -> float ->
+        file_descr list * file_descr list * file_descr list = "unix_select"
+
+(* High-level network functions *)
+
+let open_connection sockaddr =
+  let sock =
+    socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+  try
+    connect sock sockaddr;
+    (in_channel_of_descr sock, out_channel_of_descr sock)
+  with exn ->
+    close sock; raise exn
+
+let shutdown_connection inchan =
+  shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
+
+let establish_server _server_fun _sockaddr =
+  invalid_arg "Unix.establish_server not implemented"
+
+(* Terminal interface *)
+
+type terminal_io = {
+    mutable c_ignbrk: bool;
+    mutable c_brkint: bool;
+    mutable c_ignpar: bool;
+    mutable c_parmrk: bool;
+    mutable c_inpck: bool;
+    mutable c_istrip: bool;
+    mutable c_inlcr: bool;
+    mutable c_igncr: bool;
+    mutable c_icrnl: bool;
+    mutable c_ixon: bool;
+    mutable c_ixoff: bool;
+    mutable c_opost: bool;
+    mutable c_obaud: int;
+    mutable c_ibaud: int;
+    mutable c_csize: int;
+    mutable c_cstopb: int;
+    mutable c_cread: bool;
+    mutable c_parenb: bool;
+    mutable c_parodd: bool;
+    mutable c_hupcl: bool;
+    mutable c_clocal: bool;
+    mutable c_isig: bool;
+    mutable c_icanon: bool;
+    mutable c_noflsh: bool;
+    mutable c_echo: bool;
+    mutable c_echoe: bool;
+    mutable c_echok: bool;
+    mutable c_echonl: bool;
+    mutable c_vintr: char;
+    mutable c_vquit: char;
+    mutable c_verase: char;
+    mutable c_vkill: char;
+    mutable c_veof: char;
+    mutable c_veol: char;
+    mutable c_vmin: int;
+    mutable c_vtime: int;
+    mutable c_vstart: char;
+    mutable c_vstop: char
+  }
+
+type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
+
+let tcgetattr _fd = invalid_arg "Unix.tcgetattr not implemented"
+let tcsetattr _fd _wh = invalid_arg "Unix.tcsetattr not implemented"
+let tcsendbreak _fd _n = invalid_arg "Unix.tcsendbreak not implemented"
+let tcdrain _fd = invalid_arg "Unix.tcdrain not implemented"
+
+type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
+let tcflush _fd _q = invalid_arg "Unix.tcflush not implemented"
+type flow_action = TCOOFF | TCOON | TCIOFF | TCION
+let tcflow _fd _fl = invalid_arg "Unix.tcflow not implemented"
+let setsid () = invalid_arg "Unix.setsid not implemented"
diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
new file mode 100644
index 00000000..ced62fd8
--- /dev/null
+++ b/otherlibs/win32unix/unixsupport.c
@@ -0,0 +1,327 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stddef.h>
+#include <caml/mlvalues.h>
+#include <caml/callback.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/custom.h>
+#include "unixsupport.h"
+#include "cst2constr.h"
+#include <errno.h>
+
+/* Heap-allocation of Windows file handles */
+
+static int win_handle_compare(value v1, value v2)
+{
+  HANDLE h1 = Handle_val(v1);
+  HANDLE h2 = Handle_val(v2);
+  return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
+}
+
+static intnat win_handle_hash(value v)
+{
+  return (intnat) Handle_val(v);
+}
+
+static struct custom_operations win_handle_ops = {
+  "_handle",
+  custom_finalize_default,
+  win_handle_compare,
+  win_handle_hash,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+value win_alloc_handle(HANDLE h)
+{
+  value res = caml_alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
+  Handle_val(res) = h;
+  Descr_kind_val(res) = KIND_HANDLE;
+  CRT_fd_val(res) = NO_CRT_FD;
+  Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING;
+  return res;
+}
+
+value win_alloc_socket(SOCKET s)
+{
+  value res = caml_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;
+  Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING;
+  return res;
+}
+
+#if 0
+/* PR#4750: this function is no longer used */
+value win_alloc_handle_or_socket(HANDLE h)
+{
+  value res = win_alloc_handle(h);
+  int opt;
+  int optlen = sizeof(opt);
+  if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0)
+    Descr_kind_val(res) = KIND_SOCKET;
+  return res;
+}
+#endif
+
+/* Mapping of Windows error codes to POSIX error codes */
+
+struct error_entry { DWORD win_code; int range; int posix_code; };
+
+static struct error_entry win_error_table[] = {
+  { ERROR_INVALID_FUNCTION, 0, EINVAL},
+  { ERROR_FILE_NOT_FOUND, 0, ENOENT},
+  { ERROR_PATH_NOT_FOUND, 0, ENOENT},
+  { ERROR_TOO_MANY_OPEN_FILES, 0, EMFILE},
+  { ERROR_ACCESS_DENIED, 0, EACCES},
+  { ERROR_INVALID_HANDLE, 0, EBADF},
+  { ERROR_ARENA_TRASHED, 0, ENOMEM},
+  { ERROR_NOT_ENOUGH_MEMORY, 0, ENOMEM},
+  { ERROR_INVALID_BLOCK, 0, ENOMEM},
+  { ERROR_BAD_ENVIRONMENT, 0, E2BIG},
+  { ERROR_BAD_FORMAT, 0, ENOEXEC},
+  { ERROR_INVALID_ACCESS, 0, EINVAL},
+  { ERROR_INVALID_DATA, 0, EINVAL},
+  { ERROR_INVALID_DRIVE, 0, ENOENT},
+  { ERROR_CURRENT_DIRECTORY, 0, EACCES},
+  { ERROR_NOT_SAME_DEVICE, 0, EXDEV},
+  { ERROR_NO_MORE_FILES, 0, ENOENT},
+  { ERROR_LOCK_VIOLATION, 0, EACCES},
+  { ERROR_BAD_NETPATH, 0, ENOENT},
+  { ERROR_NETWORK_ACCESS_DENIED, 0, EACCES},
+  { ERROR_BAD_NET_NAME, 0, ENOENT},
+  { ERROR_FILE_EXISTS, 0, EEXIST},
+  { ERROR_CANNOT_MAKE, 0, EACCES},
+  { ERROR_FAIL_I24, 0, EACCES},
+  { ERROR_INVALID_PARAMETER, 0, EINVAL},
+  { ERROR_NO_PROC_SLOTS, 0, EAGAIN},
+  { ERROR_DRIVE_LOCKED, 0, EACCES},
+  { ERROR_BROKEN_PIPE, 0, EPIPE},
+  { ERROR_NO_DATA, 0, EPIPE},
+  { ERROR_DISK_FULL, 0, ENOSPC},
+  { ERROR_INVALID_TARGET_HANDLE, 0, EBADF},
+  { ERROR_INVALID_HANDLE, 0, EINVAL},
+  { ERROR_WAIT_NO_CHILDREN, 0, ECHILD},
+  { ERROR_CHILD_NOT_COMPLETE, 0, ECHILD},
+  { ERROR_DIRECT_ACCESS_HANDLE, 0, EBADF},
+  { ERROR_NEGATIVE_SEEK, 0, EINVAL},
+  { ERROR_SEEK_ON_DEVICE, 0, EACCES},
+  { ERROR_DIR_NOT_EMPTY, 0, ENOTEMPTY},
+  { ERROR_NOT_LOCKED, 0, EACCES},
+  { ERROR_BAD_PATHNAME, 0, ENOENT},
+  { ERROR_MAX_THRDS_REACHED, 0, EAGAIN},
+  { ERROR_LOCK_FAILED, 0, EACCES},
+  { ERROR_ALREADY_EXISTS, 0, EEXIST},
+  { ERROR_FILENAME_EXCED_RANGE, 0, ENOENT},
+  { ERROR_NESTING_NOT_ALLOWED, 0, EAGAIN},
+  { ERROR_NOT_ENOUGH_QUOTA, 0, ENOMEM},
+  { ERROR_INVALID_STARTING_CODESEG,
+    ERROR_INFLOOP_IN_RELOC_CHAIN - ERROR_INVALID_STARTING_CODESEG,
+    ENOEXEC },
+  { ERROR_WRITE_PROTECT,
+    ERROR_SHARING_BUFFER_EXCEEDED - ERROR_WRITE_PROTECT,
+    EACCES },
+  { WSAEINVAL, 0, EINVAL },
+  { WSAEACCES, 0, EACCES },
+  { WSAEBADF, 0, EBADF },
+  { WSAEFAULT, 0, EFAULT },
+  { WSAEINTR, 0, EINTR },
+  { WSAEINVAL, 0, EINVAL },
+  { WSAEMFILE, 0, EMFILE },
+#ifdef WSANAMETOOLONG
+  { WSANAMETOOLONG, 0, ENAMETOOLONG },
+#endif
+#ifdef WSAENFILE
+  { WSAENFILE, 0, ENFILE },
+#endif
+  { WSAENOTEMPTY, 0, ENOTEMPTY },
+  { 0, -1, 0 }
+};
+
+void win32_maperr(DWORD errcode)
+{
+  int i;
+
+  for (i = 0; win_error_table[i].range >= 0; i++) {
+    if (errcode >= win_error_table[i].win_code &&
+        errcode <= win_error_table[i].win_code + win_error_table[i].range) {
+      errno = win_error_table[i].posix_code;
+      return;
+    }
+  }
+  /* Not found: save original error code, negated so that we can
+     recognize it in unix_error_message */
+  errno = -errcode;
+}
+
+/* Windows socket errors */
+#undef EWOULDBLOCK
+#define EWOULDBLOCK             -WSAEWOULDBLOCK
+#undef EINPROGRESS
+#define EINPROGRESS             -WSAEINPROGRESS
+#undef EALREADY
+#define EALREADY                -WSAEALREADY
+#undef ENOTSOCK
+#define ENOTSOCK                -WSAENOTSOCK
+#undef EDESTADDRREQ
+#define EDESTADDRREQ            -WSAEDESTADDRREQ
+#undef EMSGSIZE
+#define EMSGSIZE                -WSAEMSGSIZE
+#undef EPROTOTYPE
+#define EPROTOTYPE              -WSAEPROTOTYPE
+#undef ENOPROTOOPT
+#define ENOPROTOOPT             -WSAENOPROTOOPT
+#undef EPROTONOSUPPORT
+#define EPROTONOSUPPORT         -WSAEPROTONOSUPPORT
+#undef ESOCKTNOSUPPORT
+#define ESOCKTNOSUPPORT         -WSAESOCKTNOSUPPORT
+#undef EOPNOTSUPP
+#define EOPNOTSUPP              -WSAEOPNOTSUPP
+#undef EPFNOSUPPORT
+#define EPFNOSUPPORT            -WSAEPFNOSUPPORT
+#undef EAFNOSUPPORT
+#define EAFNOSUPPORT            -WSAEAFNOSUPPORT
+#undef EADDRINUSE
+#define EADDRINUSE              -WSAEADDRINUSE
+#undef EADDRNOTAVAIL
+#define EADDRNOTAVAIL           -WSAEADDRNOTAVAIL
+#undef ENETDOWN
+#define ENETDOWN                -WSAENETDOWN
+#undef ENETUNREACH
+#define ENETUNREACH             -WSAENETUNREACH
+#undef ENETRESET
+#define ENETRESET               -WSAENETRESET
+#undef ECONNABORTED
+#define ECONNABORTED            -WSAECONNABORTED
+#undef ECONNRESET
+#define ECONNRESET              -WSAECONNRESET
+#undef ENOBUFS
+#define ENOBUFS                 -WSAENOBUFS
+#undef EISCONN
+#define EISCONN                 -WSAEISCONN
+#undef ENOTCONN
+#define ENOTCONN                -WSAENOTCONN
+#undef ESHUTDOWN
+#define ESHUTDOWN               -WSAESHUTDOWN
+#undef ETOOMANYREFS
+#define ETOOMANYREFS            -WSAETOOMANYREFS
+#undef ETIMEDOUT
+#define ETIMEDOUT               -WSAETIMEDOUT
+#undef ECONNREFUSED
+#define ECONNREFUSED            -WSAECONNREFUSED
+#undef ELOOP
+#define ELOOP                   -WSAELOOP
+#undef EHOSTDOWN
+#define EHOSTDOWN               -WSAEHOSTDOWN
+#undef EHOSTUNREACH
+#define EHOSTUNREACH            -WSAEHOSTUNREACH
+#undef EPROCLIM
+#define EPROCLIM                -WSAEPROCLIM
+#undef EUSERS
+#define EUSERS                  -WSAEUSERS
+#undef EDQUOT
+#define EDQUOT                  -WSAEDQUOT
+#undef ESTALE
+#define ESTALE                  -WSAESTALE
+#undef EREMOTE
+#define EREMOTE                 -WSAEREMOTE
+
+#undef EOVERFLOW
+#define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW
+#undef EACCESS
+#define EACCESS EACCES
+
+int error_table[] = {
+  E2BIG, EACCESS, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM,
+  EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK,
+  ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC,
+  ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE,
+  EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY,
+  ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT,
+  EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT,
+  EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH,
+  ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN,
+  ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN,
+  EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */
+};
+
+static value * unix_error_exn = NULL;
+
+value unix_error_of_code (int errcode)
+{
+  int errconstr;
+  value err;
+
+  errconstr =
+      cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
+  if (errconstr == Val_int(-1)) {
+    err = caml_alloc_small(1, 0);
+    Field(err, 0) = Val_int(errcode);
+  } else {
+    err = errconstr;
+  }
+  return err;
+}
+
+void unix_error(int errcode, char *cmdname, value cmdarg)
+{
+  value res;
+  value name = Val_unit, err = Val_unit, arg = Val_unit;
+  int errconstr;
+
+  Begin_roots3 (name, err, arg);
+    arg = cmdarg == Nothing ? caml_copy_string("") : cmdarg;
+    name = caml_copy_string(cmdname);
+    err = unix_error_of_code (errcode);
+    if (unix_error_exn == NULL) {
+      unix_error_exn = caml_named_value("Unix.Unix_error");
+      if (unix_error_exn == NULL)
+        caml_invalid_argument("Exception Unix.Unix_error not initialized,"
+                         " please link unix.cma");
+    }
+    res = caml_alloc_small(4, 0);
+    Field(res, 0) = *unix_error_exn;
+    Field(res, 1) = err;
+    Field(res, 2) = name;
+    Field(res, 3) = arg;
+  End_roots();
+  caml_raise(res);
+}
+
+void uerror(char * cmdname, value cmdarg)
+{
+  unix_error(errno, cmdname, cmdarg);
+}
+
+void caml_unix_check_path(value path, char * cmdname)
+{
+  if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
+}
+
+int unix_cloexec_default = 0;
+
+int unix_cloexec_p(value cloexec)
+{
+  /* [cloexec] is a [bool option].  */
+  if (Is_block(cloexec))
+    return Bool_val(Field(cloexec, 0));
+  else
+    return unix_cloexec_default;
+}
diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h
new file mode 100644
index 00000000..139e179c
--- /dev/null
+++ b/otherlibs/win32unix/unixsupport.h
@@ -0,0 +1,130 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_UNIXSUPPORT_H
+#define CAML_UNIXSUPPORT_H
+
+#define WIN32_LEAN_AND_MEAN
+#include <wtypes.h>
+#include <winbase.h>
+#include <stdlib.h>
+#include <direct.h>
+#include <process.h>
+#include <sys/types.h>
+#include <winsock2.h>
+#ifdef HAS_IPV6
+#include <ws2tcpip.h>
+#include <wspiapi.h>
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+struct filedescr {
+  union {
+    HANDLE handle;
+    SOCKET socket;
+  } fd;                   /* Real windows handle */
+  enum { KIND_HANDLE, KIND_SOCKET } kind;
+  int crt_fd;             /* C runtime descriptor */
+  unsigned int flags_fd;  /* See FLAGS_FD_* */
+};
+
+#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle)
+#define Socket_val(v) (((struct filedescr *) Data_custom_val(v))->fd.socket)
+#define Descr_kind_val(v) (((struct filedescr *) Data_custom_val(v))->kind)
+#define CRT_fd_val(v) (((struct filedescr *) Data_custom_val(v))->crt_fd)
+#define Flags_fd_val(v) (((struct filedescr *) Data_custom_val(v))->flags_fd)
+
+/* extern value win_alloc_handle_or_socket(HANDLE); */
+extern value win_alloc_handle(HANDLE);
+extern value win_alloc_socket(SOCKET);
+extern int win_CRT_fd_of_filedescr(value handle);
+
+#define NO_CRT_FD (-1)
+#define Nothing ((value) 0)
+
+extern void win32_maperr(DWORD errcode);
+extern value unix_error_of_code (int errcode);
+
+CAMLnoreturn_start
+extern void unix_error (int errcode, char * cmdname, value arg)
+CAMLnoreturn_end;
+
+CAMLnoreturn_start
+extern void uerror (char * cmdname, value arg)
+CAMLnoreturn_end;
+
+extern void caml_unix_check_path(value path, char * cmdname);
+extern value unix_freeze_buffer (value);
+extern char ** cstringvect(value arg, char * cmdname);
+
+extern int unix_cloexec_default;
+extern int unix_cloexec_p(value cloexec);
+
+/* Information stored in flags_fd, describing more precisely the socket
+ * and its status. The whole flags_fd is initialized to 0.
+ */
+
+/* Blocking or nonblocking.  By default a filedescr is in blocking state */
+#define FLAGS_FD_IS_BLOCKING (1<<0)
+
+#define UNIX_BUFFER_SIZE 65536
+
+#ifdef __cplusplus
+}
+#endif
+
+/*
+ * This structure is defined inconsistently. mingw64 has it in ntdef.h (which
+ * doesn't look like a primary header) and technically it's part of ntifs.h in
+ * the WDK. Requiring the WDK is a bit extreme, so the definition is taken from
+ * ntdef.h. Both ntdef.h and ntifs.h define REPARSE_DATA_BUFFER_HEADER_SIZE
+ */
+#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
+typedef struct _REPARSE_DATA_BUFFER
+{
+  ULONG  ReparseTag;
+  USHORT ReparseDataLength;
+  USHORT Reserved;
+  union
+  {
+    struct
+    {
+      USHORT SubstituteNameOffset;
+      USHORT SubstituteNameLength;
+      USHORT PrintNameOffset;
+      USHORT PrintNameLength;
+      ULONG  Flags;
+      WCHAR  PathBuffer[1];
+    } SymbolicLinkReparseBuffer;
+    struct
+    {
+      USHORT SubstituteNameOffset;
+      USHORT SubstituteNameLength;
+      USHORT PrintNameOffset;
+      USHORT PrintNameLength;
+      WCHAR  PathBuffer[1];
+    } MountPointReparseBuffer;
+    struct
+    {
+      UCHAR  DataBuffer[1];
+    } GenericReparseBuffer;
+  };
+} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;
+#endif
+
+#endif /* CAML_UNIXSUPPORT_H */
diff --git a/otherlibs/win32unix/windbug.c b/otherlibs/win32unix/windbug.c
new file mode 100644
index 00000000..424dd920
--- /dev/null
+++ b/otherlibs/win32unix/windbug.c
@@ -0,0 +1,32 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "windbug.h"
+
+int debug_test (void)
+{
+  static int debug_init = 0;
+  static int debug = 0;
+
+#ifdef DEBUG
+  if (!debug_init)
+  {
+    debug = (getenv("OCAMLDEBUG") != NULL);
+    debug_init = 1;
+  };
+#endif
+
+  return debug;
+}
diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
new file mode 100644
index 00000000..cc5ee690
--- /dev/null
+++ b/otherlibs/win32unix/windbug.h
@@ -0,0 +1,70 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifdef DEBUG
+
+#include <stdio.h>
+#include <windows.h>
+
+/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty
+   argument lists)
+ */
+#define DEBUG_PRINT(fmt, ...) \
+  do \
+  { \
+    if (debug_test()) \
+    { \
+      fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), \
+              GetCurrentThreadId()); \
+      fprintf(stderr, fmt, ##__VA_ARGS__); \
+      fprintf(stderr, "\n"); \
+      fflush(stderr); \
+    }; \
+  } while(0)
+
+/* Test if we are in dbug mode */
+int  debug_test    (void);
+
+#elif defined(_MSC_VER) && _MSC_VER < 1300
+
+#define DEBUG_PRINT(fmt)
+
+/* __pragma wasn't added until Visual C++ .NET 2002, so simply disable the
+   warning entirely
+ */
+
+#pragma warning (disable:4002)
+
+#elif defined(_MSC_VER) && _MSC_VER <= 1400
+
+/* Not all versions of the Visual Studio 2005 C Compiler (Version 14) support
+   variadic macros, hence the test for this branch being <= 1400 rather than
+   < 1400.
+   This convoluted pair of macros allow DEBUG_PRINT to remain while temporarily
+   suppressing the warning displayed for a macro called with too many
+   parameters.
+ */
+#define DEBUG_PRINT_S(fmt) __pragma(warning(pop))
+#define DEBUG_PRINT \
+  __pragma(warning(push)) \
+  __pragma(warning(disable:4002)) \
+  DEBUG_PRINT_S
+
+#else
+
+/* Visual Studio supports variadic macros in all versions from 2008 (CL 15). */
+#define DEBUG_PRINT(fmt, ...)
+
+#endif
diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c
new file mode 100644
index 00000000..b0746d51
--- /dev/null
+++ b/otherlibs/win32unix/windir.c
@@ -0,0 +1,77 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*    Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <errno.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include "unixsupport.h"
+
+CAMLprim value win_findfirst(value name)
+{
+  HANDLE h;
+  value v;
+  WIN32_FIND_DATA fileinfo;
+  value valname = Val_unit;
+  value valh = Val_unit;
+
+  caml_unix_check_path(name, "opendir");
+  Begin_roots2 (valname,valh);
+    h = FindFirstFile(String_val(name),&fileinfo);
+    if (h == INVALID_HANDLE_VALUE) {
+      DWORD err = GetLastError();
+      if (err == ERROR_NO_MORE_FILES)
+        caml_raise_end_of_file();
+      else {
+        win32_maperr(err);
+        uerror("opendir", Nothing);
+      }
+    }
+    valname = caml_copy_string(fileinfo.cFileName);
+    valh = win_alloc_handle(h);
+    v = caml_alloc_small(2, 0);
+    Field(v,0) = valname;
+    Field(v,1) = valh;
+  End_roots();
+  return v;
+}
+
+CAMLprim value win_findnext(value valh)
+{
+  WIN32_FIND_DATA fileinfo;
+  BOOL retcode;
+
+  retcode = FindNextFile(Handle_val(valh), &fileinfo);
+  if (!retcode) {
+    DWORD err = GetLastError();
+    if (err == ERROR_NO_MORE_FILES)
+      caml_raise_end_of_file();
+    else {
+      win32_maperr(err);
+      uerror("readdir", Nothing);
+    }
+  }
+  return caml_copy_string(fileinfo.cFileName);
+}
+
+CAMLprim value win_findclose(value valh)
+{
+  if (! FindClose(Handle_val(valh))) {
+    win32_maperr(GetLastError());
+    uerror("closedir", Nothing);
+  }
+  return Val_unit;
+}
diff --git a/otherlibs/win32unix/winlist.c b/otherlibs/win32unix/winlist.c
new file mode 100644
index 00000000..c05dd11d
--- /dev/null
+++ b/otherlibs/win32unix/winlist.c
@@ -0,0 +1,80 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Basic list function in C. */
+
+#include "winlist.h"
+#include <windows.h>
+
+void list_init (LPLIST lst)
+{
+  lst->lpNext = NULL;
+}
+
+void list_cleanup (LPLIST lst)
+{
+  lst->lpNext = NULL;
+}
+
+void list_next_set (LPLIST lst, LPLIST next)
+{
+  lst->lpNext = next;
+}
+
+LPLIST list_next (LPLIST lst)
+{
+  return lst->lpNext;
+}
+
+int list_length (LPLIST lst)
+{
+  int length = 0;
+  LPLIST iter = lst;
+  while (iter != NULL)
+  {
+    length++;
+    iter = list_next(iter);
+  };
+  return length;
+}
+
+LPLIST list_concat (LPLIST lsta, LPLIST lstb)
+{
+  LPLIST res = NULL;
+  LPLIST iter = NULL;
+  LPLIST iterPrev = NULL;
+
+  if (lsta == NULL)
+  {
+    res = lstb;
+  }
+  else if (lstb == NULL)
+  {
+    res = lsta;
+  }
+  else
+  {
+    res = lsta;
+    iter = lsta;
+    while (iter != NULL)
+    {
+      iterPrev = iter;
+      iter = list_next(iter);
+    };
+    iterPrev->lpNext = lstb;
+  };
+
+  return res;
+}
diff --git a/otherlibs/win32unix/winlist.h b/otherlibs/win32unix/winlist.h
new file mode 100644
index 00000000..f5040060
--- /dev/null
+++ b/otherlibs/win32unix/winlist.h
@@ -0,0 +1,55 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef _WINLIST_H
+#define _WINLIST_H
+
+/* Basic list function in C. */
+
+/* Singly-linked list data structure.
+ * To transform a C struct into a list structure, you must include
+ * at first position of your C struct a "LIST lst" and call list_init
+ * on this data structure.
+ *
+ * See winworker.c for example.
+ */
+typedef struct _LIST LIST;
+typedef LIST *LPLIST;
+
+struct _LIST {
+  LPLIST lpNext;
+};
+
+/* Initialize list data structure */
+void list_init (LPLIST lst);
+
+/* Cleanup list data structure */
+void list_cleanup (LPLIST lst);
+
+/* Set next element */
+void list_next_set (LPLIST lst, LPLIST next);
+
+/* Return next element */
+LPLIST list_next (LPLIST);
+
+#define LIST_NEXT(T, e) ((T)(list_next((LPLIST)(e))))
+
+/* Get number of element */
+int list_length (LPLIST);
+
+/* Concat two list. */
+LPLIST list_concat (LPLIST, LPLIST);
+
+#endif /* _WINLIST_H */
diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c
new file mode 100644
index 00000000..2bf539f2
--- /dev/null
+++ b/otherlibs/win32unix/winwait.c
@@ -0,0 +1,70 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*    Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <windows.h>
+#include <sys/types.h>
+
+static value alloc_process_status(HANDLE pid, int status)
+{
+  value res, st;
+
+  st = caml_alloc(1, 0);
+  Field(st, 0) = Val_int(status);
+  Begin_root (st);
+    res = caml_alloc_small(2, 0);
+    Field(res, 0) = Val_long((intnat) pid);
+    Field(res, 1) = st;
+  End_roots();
+  return res;
+}
+
+enum { CAML_WNOHANG = 1, CAML_WUNTRACED = 2 };
+
+static int wait_flag_table[] = { CAML_WNOHANG, CAML_WUNTRACED };
+
+CAMLprim value win_waitpid(value vflags, value vpid_req)
+{
+  int flags;
+  DWORD status, retcode;
+  HANDLE pid_req = (HANDLE) Long_val(vpid_req);
+  DWORD err = 0;
+
+  flags = caml_convert_flag_list(vflags, wait_flag_table);
+  if ((flags & CAML_WNOHANG) == 0) {
+    caml_enter_blocking_section();
+    retcode = WaitForSingleObject(pid_req, INFINITE);
+    if (retcode == WAIT_FAILED) err = GetLastError();
+    caml_leave_blocking_section();
+    if (err) {
+      win32_maperr(err);
+      uerror("waitpid", Nothing);
+    }
+  }
+  if (! GetExitCodeProcess(pid_req, &status)) {
+    win32_maperr(GetLastError());
+    uerror("waitpid", Nothing);
+  }
+  if (status == STILL_ACTIVE)
+    return alloc_process_status((HANDLE) 0, 0);
+  else {
+    CloseHandle(pid_req);
+    return alloc_process_status(pid_req, status);
+  }
+}
diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c
new file mode 100644
index 00000000..8007bc2d
--- /dev/null
+++ b/otherlibs/win32unix/winworker.c
@@ -0,0 +1,322 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "winworker.h"
+#include "winlist.h"
+#include "windbug.h"
+
+typedef enum {
+  WORKER_CMD_NONE = 0,
+  WORKER_CMD_EXEC,
+  WORKER_CMD_STOP
+} WORKERCMD;
+
+struct _WORKER {
+  LIST       lst;           /* This structure is used as a list. */
+  HANDLE     hJobStarted;   /* Event representing that the function has begun.*/
+  HANDLE     hJobStop;      /* Event that can be used to notify the function
+                               that it should stop processing. */
+  HANDLE     hJobDone;      /* Event representing that the function has
+                               finished. */
+  void      *lpJobUserData; /* User data for the job. */
+  WORKERFUNC hJobFunc;      /* Function to be called during APC */
+  HANDLE     hWorkerReady;  /* Worker is ready. */
+  HANDLE     hCommandReady; /* Worker should execute command. */
+  WORKERCMD  ECommand;      /* Command to execute */
+  HANDLE     hThread;       /* Thread handle of the worker. */
+};
+
+#define THREAD_WORKERS_MAX 16
+#define THREAD_WORKERS_MEM 4000
+
+LPWORKER lpWorkers       = NULL;
+DWORD    nWorkersCurrent = 0;
+DWORD    nWorkersMax     = 0;
+HANDLE   hWorkersMutex   = INVALID_HANDLE_VALUE;
+
+DWORD WINAPI worker_wait (LPVOID _data)
+{
+  BOOL     bExit;
+  LPWORKER lpWorker;
+
+  lpWorker = (LPWORKER )_data;
+  bExit    = FALSE;
+
+  DEBUG_PRINT("Worker %x starting", lpWorker);
+  while (
+      !bExit
+      && SignalObjectAndWait(
+        lpWorker->hWorkerReady,
+        lpWorker->hCommandReady,
+        INFINITE,
+        TRUE) == WAIT_OBJECT_0)
+  {
+    DEBUG_PRINT("Worker %x running", lpWorker);
+    switch (lpWorker->ECommand)
+    {
+      case WORKER_CMD_NONE:
+        break;
+
+      case WORKER_CMD_EXEC:
+        if (lpWorker->hJobFunc != NULL)
+        {
+          SetEvent(lpWorker->hJobStarted);
+          lpWorker->hJobFunc(lpWorker->hJobStop, lpWorker->lpJobUserData);
+          SetEvent(lpWorker->hJobDone);
+        };
+        break;
+
+      case WORKER_CMD_STOP:
+        bExit = TRUE;
+        break;
+    }
+  };
+  DEBUG_PRINT("Worker %x exiting", lpWorker);
+
+  return 0;
+}
+
+LPWORKER worker_new (void)
+{
+  LPWORKER lpWorker = NULL;
+
+  lpWorker = (LPWORKER)caml_stat_alloc(sizeof(WORKER));
+  list_init((LPLIST)lpWorker);
+  lpWorker->hJobStarted  = CreateEvent(NULL, TRUE, FALSE, NULL);
+  lpWorker->hJobStop     = CreateEvent(NULL, TRUE, FALSE, NULL);
+  lpWorker->hJobDone     = CreateEvent(NULL, TRUE, FALSE, NULL);
+  lpWorker->lpJobUserData = NULL;
+  lpWorker->hWorkerReady       = CreateEvent(NULL, FALSE, FALSE, NULL);
+  lpWorker->hCommandReady      = CreateEvent(NULL, FALSE, FALSE, NULL);
+  lpWorker->ECommand           = WORKER_CMD_NONE;
+  lpWorker->hThread = CreateThread(
+    NULL,
+    THREAD_WORKERS_MEM,
+    worker_wait,
+    (LPVOID)lpWorker,
+    0,
+    NULL);
+
+  return lpWorker;
+};
+
+void worker_free (LPWORKER lpWorker)
+{
+  /* Wait for termination of the worker */
+  DEBUG_PRINT("Shutting down worker %x", lpWorker);
+  WaitForSingleObject(lpWorker->hWorkerReady, INFINITE);
+  lpWorker->ECommand = WORKER_CMD_STOP;
+  SetEvent(lpWorker->hCommandReady);
+  WaitForSingleObject(lpWorker->hThread, INFINITE);
+
+  /* Free resources */
+  DEBUG_PRINT("Freeing resources of worker %x", lpWorker);
+  if (lpWorker->hThread != INVALID_HANDLE_VALUE)
+  {
+    CloseHandle(lpWorker->hThread);
+    lpWorker->hThread = INVALID_HANDLE_VALUE;
+  }
+
+  if (lpWorker->hJobStarted != INVALID_HANDLE_VALUE)
+  {
+    CloseHandle(lpWorker->hJobStarted);
+    lpWorker->hJobStarted = INVALID_HANDLE_VALUE;
+  }
+
+  if (lpWorker->hJobStop != INVALID_HANDLE_VALUE)
+  {
+    CloseHandle(lpWorker->hJobStop);
+    lpWorker->hJobStop = INVALID_HANDLE_VALUE;
+  }
+
+  if (lpWorker->hJobDone != INVALID_HANDLE_VALUE)
+  {
+    CloseHandle(lpWorker->hJobDone);
+    lpWorker->hJobDone = INVALID_HANDLE_VALUE;
+  }
+
+  lpWorker->lpJobUserData = NULL;
+  lpWorker->hJobFunc = NULL;
+
+  if (lpWorker->hWorkerReady != INVALID_HANDLE_VALUE)
+  {
+    CloseHandle(lpWorker->hWorkerReady);
+    lpWorker->hWorkerReady = INVALID_HANDLE_VALUE;
+  }
+
+  if (lpWorker->hCommandReady != INVALID_HANDLE_VALUE)
+  {
+    CloseHandle(lpWorker->hCommandReady);
+    lpWorker->hCommandReady = INVALID_HANDLE_VALUE;
+  }
+
+  caml_stat_free(lpWorker);
+};
+
+LPWORKER worker_pop (void)
+{
+  LPWORKER lpWorkerFree = NULL;
+
+  WaitForSingleObject(hWorkersMutex, INFINITE);
+  /* Get the first worker of the list */
+  if (lpWorkers != NULL)
+  {
+    lpWorkerFree = lpWorkers;
+    lpWorkers = LIST_NEXT(LPWORKER, lpWorkers);
+  }
+  nWorkersCurrent++;
+  nWorkersMax = (nWorkersCurrent > nWorkersMax ? nWorkersCurrent : nWorkersMax);
+  DEBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d",
+      nWorkersCurrent,
+      nWorkersMax,
+      list_length((LPLIST)lpWorkers));
+  ReleaseMutex(hWorkersMutex);
+
+  if (lpWorkerFree == NULL)
+  {
+    /* We cannot find a free worker, create one. */
+    lpWorkerFree = worker_new();
+  }
+
+  /* Ensure that we don't get dangling pointer to old data. */
+  list_init((LPLIST)lpWorkerFree);
+  lpWorkerFree->lpJobUserData = NULL;
+
+  /* Reset events */
+  ResetEvent(lpWorkerFree->hJobStarted);
+  ResetEvent(lpWorkerFree->hJobStop);
+  ResetEvent(lpWorkerFree->hJobDone);
+
+  return lpWorkerFree;
+}
+
+void worker_push(LPWORKER lpWorker)
+{
+  BOOL bFreeWorker;
+
+  bFreeWorker = TRUE;
+
+  WaitForSingleObject(hWorkersMutex, INFINITE);
+  DEBUG_PRINT("Testing if we are under the maximum number of running workers");
+  if (list_length((LPLIST)lpWorkers) < THREAD_WORKERS_MAX)
+  {
+    DEBUG_PRINT("Saving this worker for future use");
+    DEBUG_PRINT("Next: %x", ((LPLIST)lpWorker)->lpNext);
+    lpWorkers = (LPWORKER)list_concat((LPLIST)lpWorker, (LPLIST)lpWorkers);
+    bFreeWorker = FALSE;
+  };
+  nWorkersCurrent--;
+  DEBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d",
+      nWorkersCurrent,
+      nWorkersMax,
+      list_length((LPLIST)lpWorkers));
+  ReleaseMutex(hWorkersMutex);
+
+  if (bFreeWorker)
+  {
+    DEBUG_PRINT("Freeing worker %x", lpWorker);
+    worker_free(lpWorker);
+  }
+}
+
+void worker_init (void)
+{
+  int i = 0;
+
+  /* Init a shared variable. The only way to ensure that no other
+     worker will be at the same point is to use a critical section.
+     */
+  DEBUG_PRINT("Allocating mutex for workers");
+  if (hWorkersMutex == INVALID_HANDLE_VALUE)
+  {
+    hWorkersMutex = CreateMutex(NULL, FALSE, NULL);
+  }
+}
+
+void worker_cleanup(void)
+{
+  LPWORKER lpWorker = NULL;
+
+  /* WARNING: we can have a race condition here, if while this code
+     is executed another worker is waiting to access hWorkersMutex,
+     he will never be able to get it...
+     */
+  if (hWorkersMutex != INVALID_HANDLE_VALUE)
+  {
+    WaitForSingleObject(hWorkersMutex, INFINITE);
+    DEBUG_PRINT("Freeing global resource of workers");
+    /* Empty the queue of worker worker */
+    while (lpWorkers != NULL)
+    {
+      ReleaseMutex(hWorkersMutex);
+      lpWorker = worker_pop();
+      DEBUG_PRINT("Freeing worker %x", lpWorker);
+      WaitForSingleObject(hWorkersMutex, INFINITE);
+      worker_free(lpWorker);
+    };
+    ReleaseMutex(hWorkersMutex);
+
+    /* Destroy associated mutex */
+    CloseHandle(hWorkersMutex);
+    hWorkersMutex = INVALID_HANDLE_VALUE;
+  };
+}
+
+LPWORKER worker_job_submit (WORKERFUNC f, void *user_data)
+{
+  LPWORKER lpWorker = worker_pop();
+
+  DEBUG_PRINT("Waiting for worker to be ready");
+  caml_enter_blocking_section();
+  WaitForSingleObject(lpWorker->hWorkerReady, INFINITE);
+  ResetEvent(lpWorker->hWorkerReady);
+  caml_leave_blocking_section();
+  DEBUG_PRINT("Worker is ready");
+
+  lpWorker->hJobFunc      = f;
+  lpWorker->lpJobUserData = user_data;
+  lpWorker->ECommand      = WORKER_CMD_EXEC;
+
+  DEBUG_PRINT("Call worker (func: %x, worker: %x)", f, lpWorker);
+  SetEvent(lpWorker->hCommandReady);
+
+  return (LPWORKER)lpWorker;
+}
+
+HANDLE worker_job_event_done (LPWORKER lpWorker)
+{
+  return lpWorker->hJobDone;
+}
+
+void worker_job_stop (LPWORKER lpWorker)
+{
+  DEBUG_PRINT("Sending stop signal to worker %x", lpWorker);
+  SetEvent(lpWorker->hJobStop);
+  DEBUG_PRINT("Signal sent to worker %x", lpWorker);
+}
+
+void worker_job_finish (LPWORKER lpWorker)
+{
+  DEBUG_PRINT("Finishing call of worker %x", lpWorker);
+  caml_enter_blocking_section();
+  WaitForSingleObject(lpWorker->hJobDone, INFINITE);
+  caml_leave_blocking_section();
+
+  worker_push(lpWorker);
+}
diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h
new file mode 100644
index 00000000..c3a5dd0e
--- /dev/null
+++ b/otherlibs/win32unix/winworker.h
@@ -0,0 +1,73 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*   Contributed by Sylvain Le Gall for Lexifi                            */
+/*                                                                        */
+/*   Copyright 2008 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef _WINWORKER_H
+#define _WINWORKER_H
+
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0400
+#include "unixsupport.h"
+#include <windows.h>
+
+/* Pool of worker threads.
+ *
+ * These functions help to manage a pool of worker thread and submit task to
+ * the pool. It helps to reduce the number of thread creation.
+ *
+ * Each worker are started in alertable wait state and jobs are submitted as
+ * APC (asynchronous procedure call).
+ */
+
+/* Data associated with submitted job */
+typedef struct _WORKER WORKER;
+typedef WORKER *LPWORKER;
+
+/* Function type of submitted job:
+ * void worker_call (HANDLE hStop, void *data)
+ *
+ * This function will be called using the data following:
+ * - hStop must be watched for change, since it represents an external command
+ *   to stop the call. This event is shared through the WORKER structure, which
+ *   can be access throuhg worker_job_event_done.
+ * - data is user provided data for the function.
+ */
+typedef void (*WORKERFUNC) (HANDLE, void *);
+
+/* Initialize global data structure for worker
+ */
+void worker_init (void);
+
+/* Free global data structure for worker
+ */
+void worker_cleanup (void);
+
+/* Submit a job to worker. Use returned data to synchronize with the procedure
+ * submitted.
+ */
+LPWORKER worker_job_submit (WORKERFUNC f, void *data);
+
+/* Get event to know when a job is done.
+ */
+HANDLE worker_job_event_done (LPWORKER);
+
+/* Ask a job to stop processing.
+ */
+void worker_job_stop (LPWORKER);
+
+/* End a job submitted to worker.
+ */
+void worker_job_finish (LPWORKER);
+
+#endif /* _WINWORKER_H */
diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
new file mode 100644
index 00000000..3114763a
--- /dev/null
+++ b/otherlibs/win32unix/write.c
@@ -0,0 +1,101 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <errno.h>
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
+{
+  intnat ofs, len, written;
+  DWORD numbytes, numwritten;
+  char iobuf[UNIX_BUFFER_SIZE];
+  DWORD err = 0;
+
+  Begin_root (buf);
+    ofs = Long_val(vofs);
+    len = Long_val(vlen);
+    written = 0;
+    while (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);
+        caml_enter_blocking_section();
+        ret = send(s, iobuf, numbytes, 0);
+        if (ret == SOCKET_ERROR) err = WSAGetLastError();
+        caml_leave_blocking_section();
+        numwritten = ret;
+      } else {
+        HANDLE h = Handle_val(fd);
+        caml_enter_blocking_section();
+        if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
+          err = GetLastError();
+        caml_leave_blocking_section();
+      }
+      if (err) {
+        win32_maperr(err);
+        uerror("write", Nothing);
+      }
+      written += numwritten;
+      ofs += numwritten;
+      len -= numwritten;
+    }
+  End_roots();
+  return Val_long(written);
+}
+
+CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
+{
+  intnat ofs, len, written;
+  DWORD numbytes, numwritten;
+  char iobuf[UNIX_BUFFER_SIZE];
+  DWORD err = 0;
+
+  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);
+        caml_enter_blocking_section();
+        ret = send(s, iobuf, numbytes, 0);
+        if (ret == SOCKET_ERROR) err = WSAGetLastError();
+        caml_leave_blocking_section();
+        numwritten = ret;
+      } else {
+        HANDLE h = Handle_val(fd);
+        caml_enter_blocking_section();
+        if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
+          err = GetLastError();
+        caml_leave_blocking_section();
+      }
+      if (err) {
+        win32_maperr(err);
+        uerror("single_write", Nothing);
+      }
+      written = numwritten;
+    }
+  End_roots();
+  return Val_long(written);
+}
diff --git a/parsing/HACKING.adoc b/parsing/HACKING.adoc
new file mode 100644
index 00000000..7da8b22f
--- /dev/null
+++ b/parsing/HACKING.adoc
@@ -0,0 +1,9 @@
+link:parsetree.mli[Parsetree] and link:asttypes.mli[Asttypes]::
+Parsetree is an Abstract Syntax Tree (AST) representation of OCaml
+source code. It is well annotated with examples and is a recommended
+read before any further exploration of the compiler.
+
+link:location.mli[Location]:: This module contains utilities
+related to locations and error handling. In particular, it contains
+handlers that are used for all the error reporting in the compiler.
+
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
new file mode 100644
index 00000000..ac1fc40d
--- /dev/null
+++ b/parsing/ast_helper.ml
@@ -0,0 +1,554 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments *)
+
+open Asttypes
+open Parsetree
+open Docstrings
+
+type lid = Longident.t loc
+type str = string loc
+type loc = Location.t
+type attrs = attribute list
+
+let default_loc = ref Location.none
+
+let with_default_loc l f =
+  let old = !default_loc in
+  default_loc := l;
+  try let r = f () in default_loc := old; r
+  with exn -> default_loc := old; raise exn
+
+module Const = struct
+  let integer ?suffix i = Pconst_integer (i, suffix)
+  let int ?suffix i = integer ?suffix (string_of_int i)
+  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
+  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
+  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
+  let float ?suffix f = Pconst_float (f, suffix)
+  let char c = Pconst_char c
+  let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter)
+end
+
+module Typ = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs}
+  let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
+  let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
+  let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
+  let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
+  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+
+  let force_poly t =
+    match t.ptyp_desc with
+    | Ptyp_poly _ -> t
+    | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
+
+  let varify_constructors var_names t =
+    let check_variable vl loc v =
+      if List.mem v vl then
+        raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
+    let var_names = List.map (fun v -> v.txt) var_names in
+    let rec loop t =
+      let desc =
+        match t.ptyp_desc with
+        | Ptyp_any -> Ptyp_any
+        | Ptyp_var x ->
+            check_variable var_names t.ptyp_loc x;
+            Ptyp_var x
+        | Ptyp_arrow (label,core_type,core_type') ->
+            Ptyp_arrow(label, loop core_type, loop core_type')
+        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+        | Ptyp_constr( { txt = Longident.Lident s }, [])
+          when List.mem s var_names ->
+            Ptyp_var s
+        | Ptyp_constr(longident, lst) ->
+            Ptyp_constr(longident, List.map loop lst)
+        | Ptyp_object (lst, o) ->
+            Ptyp_object
+              (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o)
+        | Ptyp_class (longident, lst) ->
+            Ptyp_class (longident, List.map loop lst)
+        | Ptyp_alias(core_type, string) ->
+            check_variable var_names t.ptyp_loc string;
+            Ptyp_alias(loop core_type, string)
+        | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+            Ptyp_variant(List.map loop_row_field row_field_list,
+                         flag, lbl_lst_option)
+        | Ptyp_poly(string_lst, core_type) ->
+          List.iter (fun v ->
+            check_variable var_names t.ptyp_loc v.txt) string_lst;
+            Ptyp_poly(string_lst, loop core_type)
+        | Ptyp_package(longident,lst) ->
+            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_extension (s, arg) ->
+            Ptyp_extension (s, arg)
+      in
+      {t with ptyp_desc = desc}
+    and loop_row_field  =
+      function
+        | Rtag(label,attrs,flag,lst) ->
+            Rtag(label,attrs,flag,List.map loop lst)
+        | Rinherit t ->
+            Rinherit (loop t)
+    in
+    loop t
+
+end
+
+module Pat = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs}
+  let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]}
+
+  let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
+  let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
+  let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
+  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a)
+  let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b))
+  let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
+  let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
+  let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
+end
+
+module Exp = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs}
+  let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
+  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
+  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
+  let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
+  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
+  let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
+  let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
+  let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))
+  let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b))
+  let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b))
+  let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c))
+  let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a)
+  let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c))
+  let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b))
+  let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
+  let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b))
+  let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c))
+  let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
+  let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
+  let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
+  let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
+  let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
+  let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
+  let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
+  let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
+  let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
+  let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
+  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
+
+  let case lhs ?guard rhs =
+    {
+     pc_lhs = lhs;
+     pc_guard = guard;
+     pc_rhs = rhs;
+    }
+end
+
+module Mty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs}
+  let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]}
+
+  let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
+  let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
+  let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c))
+  let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
+  let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
+end
+
+module Mod = struct
+let mk ?(loc = !default_loc) ?(attrs = []) d =
+  {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs}
+  let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]}
+
+  let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
+  let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
+  let functor_ ?loc ?attrs arg arg_ty body =
+    mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body))
+  let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
+  let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
+  let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a)
+end
+
+module Sig = struct
+  let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc}
+
+  let value ?loc a = mk ?loc (Psig_value a)
+  let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a))
+  let type_extension ?loc a = mk ?loc (Psig_typext a)
+  let exception_ ?loc a = mk ?loc (Psig_exception a)
+  let module_ ?loc a = mk ?loc (Psig_module a)
+  let rec_module ?loc a = mk ?loc (Psig_recmodule a)
+  let modtype ?loc a = mk ?loc (Psig_modtype a)
+  let open_ ?loc a = mk ?loc (Psig_open a)
+  let include_ ?loc a = mk ?loc (Psig_include a)
+  let class_ ?loc a = mk ?loc (Psig_class a)
+  let class_type ?loc a = mk ?loc (Psig_class_type a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Psig_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Str = struct
+  let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
+
+  let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
+  let value ?loc a b = mk ?loc (Pstr_value (a, b))
+  let primitive ?loc a = mk ?loc (Pstr_primitive a)
+  let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a))
+  let type_extension ?loc a = mk ?loc (Pstr_typext a)
+  let exception_ ?loc a = mk ?loc (Pstr_exception a)
+  let module_ ?loc a = mk ?loc (Pstr_module a)
+  let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
+  let modtype ?loc a = mk ?loc (Pstr_modtype a)
+  let open_ ?loc a = mk ?loc (Pstr_open a)
+  let class_ ?loc a = mk ?loc (Pstr_class a)
+  let class_type ?loc a = mk ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk ?loc (Pstr_include a)
+  let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
+  let attribute ?loc a = mk ?loc (Pstr_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+end
+
+module Cl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcl_desc = d;
+     pcl_loc = loc;
+     pcl_attributes = attrs;
+    }
+  let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
+  let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
+  let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+end
+
+module Cty = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) d =
+    {
+     pcty_desc = d;
+     pcty_loc = loc;
+     pcty_attributes = attrs;
+    }
+  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
+
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+end
+
+module Ctf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+           ?(docs = empty_docs) d =
+    {
+     pctf_desc = d;
+     pctf_loc = loc;
+     pctf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
+  let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
+  let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
+  let attribute ?loc a = mk ?loc (Pctf_attribute a)
+  let text txt =
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
+
+end
+
+module Cf = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) d =
+    {
+     pcf_desc = d;
+     pcf_loc = loc;
+     pcf_attributes = add_docs_attrs docs attrs;
+    }
+
+  let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
+  let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
+  let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
+  let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
+  let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
+  let attribute ?loc a = mk ?loc (Pcf_attribute a)
+  let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+    List.map
+      (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
+      f_txt
+
+  let virtual_ ct = Cfk_virtual ct
+  let concrete o e = Cfk_concrete (o, e)
+
+  let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
+
+end
+
+module Val = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(prim = []) name typ =
+    {
+     pval_name = name;
+     pval_type = typ;
+     pval_attributes = add_docs_attrs docs attrs;
+     pval_loc = loc;
+     pval_prim = prim;
+    }
+end
+
+module Md = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name typ =
+    {
+     pmd_name = name;
+     pmd_type = typ;
+     pmd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmd_loc = loc;
+    }
+end
+
+module Mtd = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) ?typ name =
+    {
+     pmtd_name = name;
+     pmtd_type = typ;
+     pmtd_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmtd_loc = loc;
+    }
+end
+
+module Mb = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = []) name expr =
+    {
+     pmb_name = name;
+     pmb_expr = expr;
+     pmb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pmb_loc = loc;
+    }
+end
+
+module Opn = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(override = Fresh) lid =
+    {
+     popen_lid = lid;
+     popen_override = override;
+     popen_loc = loc;
+     popen_attributes = add_docs_attrs docs attrs;
+    }
+end
+
+module Incl = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
+    {
+     pincl_mod = mexpr;
+     pincl_loc = loc;
+     pincl_attributes = add_docs_attrs docs attrs;
+    }
+
+end
+
+module Vb = struct
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+        ?(text = []) pat expr =
+    {
+     pvb_pat = pat;
+     pvb_expr = expr;
+     pvb_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pvb_loc = loc;
+    }
+end
+
+module Ci = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+        ?(virt = Concrete) ?(params = []) name expr =
+    {
+     pci_virt = virt;
+     pci_params = params;
+     pci_name = name;
+     pci_expr = expr;
+     pci_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     pci_loc = loc;
+    }
+end
+
+module Type = struct
+  let mk ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(text = [])
+      ?(params = [])
+      ?(cstrs = [])
+      ?(kind = Ptype_abstract)
+      ?(priv = Public)
+      ?manifest
+      name =
+    {
+     ptype_name = name;
+     ptype_params = params;
+     ptype_cstrs = cstrs;
+     ptype_kind = kind;
+     ptype_private = priv;
+     ptype_manifest = manifest;
+     ptype_attributes =
+       add_text_attrs text (add_docs_attrs docs attrs);
+     ptype_loc = loc;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(args = Pcstr_tuple []) ?res name =
+    {
+     pcd_name = name;
+     pcd_args = args;
+     pcd_res = res;
+     pcd_loc = loc;
+     pcd_attributes = add_info_attrs info attrs;
+    }
+
+  let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
+        ?(mut = Immutable) name typ =
+    {
+     pld_name = name;
+     pld_mutable = mut;
+     pld_type = typ;
+     pld_loc = loc;
+     pld_attributes = add_info_attrs info attrs;
+    }
+
+end
+
+(** Type extensions *)
+module Te = struct
+  let mk ?(attrs = []) ?(docs = empty_docs)
+        ?(params = []) ?(priv = Public) path constructors =
+    {
+     ptyext_path = path;
+     ptyext_params = params;
+     ptyext_constructors = constructors;
+     ptyext_private = priv;
+     ptyext_attributes = add_docs_attrs docs attrs;
+    }
+
+  let constructor ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name kind =
+    {
+     pext_name = name;
+     pext_kind = kind;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
+             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
+    {
+     pext_name = name;
+     pext_kind = Pext_decl(args, res);
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+  let rebind ?(loc = !default_loc) ?(attrs = [])
+        ?(docs = empty_docs) ?(info = empty_info) name lid =
+    {
+     pext_name = name;
+     pext_kind = Pext_rebind lid;
+     pext_loc = loc;
+     pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
+    }
+
+end
+
+module Csig = struct
+  let mk self fields =
+    {
+     pcsig_self = self;
+     pcsig_fields = fields;
+    }
+end
+
+module Cstr = struct
+  let mk self fields =
+    {
+     pcstr_self = self;
+     pcstr_fields = fields;
+    }
+end
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
new file mode 100644
index 00000000..0a216bdb
--- /dev/null
+++ b/parsing/ast_helper.mli
@@ -0,0 +1,439 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers to produce Parsetree fragments *)
+
+open Asttypes
+open Docstrings
+open Parsetree
+
+type lid = Longident.t loc
+type str = string loc
+type loc = Location.t
+type attrs = attribute list
+
+(** {2 Default locations} *)
+
+val default_loc: loc ref
+    (** Default value for all optional location arguments. *)
+
+val with_default_loc: loc -> (unit -> 'a) -> 'a
+    (** Set the [default_loc] within the scope of the execution
+        of the provided function. *)
+
+(** {2 Constants} *)
+
+module Const : sig
+  val char : char -> constant
+  val string : ?quotation_delimiter:string -> string -> constant
+  val integer : ?suffix:char -> string -> constant
+  val int : ?suffix:char -> int -> constant
+  val int32 : ?suffix:char -> int32 -> constant
+  val int64 : ?suffix:char -> int64 -> constant
+  val nativeint : ?suffix:char -> nativeint -> constant
+  val float : ?suffix:char -> string -> constant
+end
+
+(** {2 Core language} *)
+
+(** Type expressions *)
+module Typ :
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type
+    val attr: core_type -> attribute -> core_type
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
+    val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
+               -> core_type
+    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val object_: ?loc:loc -> ?attrs:attrs ->
+                  (str * attributes * core_type) list -> closed_flag ->
+                  core_type
+    val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
+    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+    val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
+                 -> label list option -> core_type
+    val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
+    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
+                 -> core_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
+
+    val force_poly: core_type -> core_type
+
+    val varify_constructors: str list -> core_type -> core_type
+    (** [varify_constructors newtypes te] is type expression [te], of which
+        any of nullary type constructor [tc] is replaced by type variable of
+        the same name, if [tc]'s name appears in [newtypes].
+        Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
+        appears in [newtypes].
+        @since 4.05
+     *)
+  end
+
+(** Patterns *)
+module Pat:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern
+    val attr:pattern -> attribute -> pattern
+
+    val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+    val var: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
+    val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
+    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag
+                -> pattern
+    val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
+    val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
+    val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
+    val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
+    val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
+  end
+
+(** Expressions *)
+module Exp:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression
+    val attr: expression -> attribute -> expression
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
+              -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
+              -> pattern -> expression -> expression
+    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
+    val apply: ?loc:loc -> ?attrs:attrs -> expression
+               -> (arg_label * expression) list -> expression
+    val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
+                -> expression
+    val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
+                   -> expression
+    val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
+                 -> expression
+    val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list
+                -> expression option -> expression
+    val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+    val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression
+                  -> expression
+    val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                    -> expression option -> expression
+    val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                  -> expression
+    val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+                -> expression
+    val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression
+              -> direction_flag -> expression -> expression
+    val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+                -> core_type -> expression
+    val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
+                     -> expression
+    val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
+    val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
+    val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
+                  -> expression
+    val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
+                   -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
+    val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
+    val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
+              -> expression
+    val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
+    val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression
+               -> expression
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
+
+    val case: pattern -> ?guard:expression -> expression -> case
+  end
+
+(** Value declarations *)
+module Val:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      ?prim:string list -> str -> core_type -> value_description
+  end
+
+(** Type declarations *)
+module Type:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?params:(core_type * variance) list ->
+      ?cstrs:(core_type * core_type * loc) list ->
+      ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
+      type_declaration
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      constructor_declaration
+    val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
+      ?mut:mutable_flag -> str -> core_type -> label_declaration
+  end
+
+(** Type extensions *)
+module Te:
+  sig
+    val mk: ?attrs:attrs -> ?docs:docs ->
+      ?params:(core_type * variance) list -> ?priv:private_flag ->
+      lid -> extension_constructor list -> type_extension
+
+    val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> extension_constructor_kind -> extension_constructor
+
+    val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      ?args:constructor_arguments -> ?res:core_type -> str ->
+      extension_constructor
+    val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
+      str -> lid -> extension_constructor
+  end
+
+(** {2 Module language} *)
+
+(** Module type expressions *)
+module Mty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type
+    val attr: module_type -> attribute -> module_type
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
+    val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      str -> module_type option -> module_type -> module_type
+    val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
+      with_constraint list -> module_type
+    val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
+  end
+
+(** Module expressions *)
+module Mod:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr
+    val attr: module_expr -> attribute -> module_expr
+
+    val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
+    val functor_: ?loc:loc -> ?attrs:attrs ->
+      str -> module_type option -> module_expr -> module_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
+      module_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
+      module_expr
+    val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr
+  end
+
+(** Signature items *)
+module Sig:
+  sig
+    val mk: ?loc:loc -> signature_item_desc -> signature_item
+
+    val value: ?loc:loc -> value_description -> signature_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item
+    val type_extension: ?loc:loc -> type_extension -> signature_item
+    val exception_: ?loc:loc -> extension_constructor -> signature_item
+    val module_: ?loc:loc -> module_declaration -> signature_item
+    val rec_module: ?loc:loc -> module_declaration list -> signature_item
+    val modtype: ?loc:loc -> module_type_declaration -> signature_item
+    val open_: ?loc:loc -> open_description -> signature_item
+    val include_: ?loc:loc -> include_description -> signature_item
+    val class_: ?loc:loc -> class_description list -> signature_item
+    val class_type: ?loc:loc -> class_type_declaration list -> signature_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
+    val attribute: ?loc:loc -> attribute -> signature_item
+    val text: text -> signature_item list
+  end
+
+(** Structure items *)
+module Str:
+  sig
+    val mk: ?loc:loc -> structure_item_desc -> structure_item
+
+    val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
+    val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item
+    val primitive: ?loc:loc -> value_description -> structure_item
+    val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item
+    val type_extension: ?loc:loc -> type_extension -> structure_item
+    val exception_: ?loc:loc -> extension_constructor -> structure_item
+    val module_: ?loc:loc -> module_binding -> structure_item
+    val rec_module: ?loc:loc -> module_binding list -> structure_item
+    val modtype: ?loc:loc -> module_type_declaration -> structure_item
+    val open_: ?loc:loc -> open_description -> structure_item
+    val class_: ?loc:loc -> class_declaration list -> structure_item
+    val class_type: ?loc:loc -> class_type_declaration list -> structure_item
+    val include_: ?loc:loc -> include_declaration -> structure_item
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
+    val attribute: ?loc:loc -> attribute -> structure_item
+    val text: text -> structure_item list
+  end
+
+(** Module declarations *)
+module Md:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str -> module_type -> module_declaration
+  end
+
+(** Module type declarations *)
+module Mtd:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?typ:module_type -> str -> module_type_declaration
+  end
+
+(** Module bindings *)
+module Mb:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      str -> module_expr -> module_binding
+  end
+
+(** Opens *)
+module Opn:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
+      ?override:override_flag -> lid -> open_description
+  end
+
+(** Includes *)
+module Incl:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
+  end
+
+(** Value bindings *)
+module Vb:
+  sig
+    val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      pattern -> expression -> value_binding
+  end
+
+
+(** {2 Class language} *)
+
+(** Class type expressions *)
+module Cty:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type
+    val attr: class_type -> attribute -> class_type
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
+    val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
+      class_type -> class_type
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+  end
+
+(** Class type fields *)
+module Ctf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
+      class_type_field_desc -> class_type_field
+    val attr: class_type_field -> attribute -> class_type_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      virtual_flag -> core_type -> class_type_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_type_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
+    val attribute: ?loc:loc -> attribute -> class_type_field
+    val text: text -> class_type_field list
+  end
+
+(** Class expressions *)
+module Cl:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr
+    val attr: class_expr -> attribute -> class_expr
+
+    val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
+    val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option ->
+      pattern -> class_expr -> class_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
+      (arg_label * expression) list -> class_expr
+    val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->
+      class_expr -> class_expr
+    val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
+      class_expr
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+  end
+
+(** Class fields *)
+module Cf:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc ->
+      class_field
+    val attr: class_field -> attribute -> class_field
+
+    val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
+      str option -> class_field
+    val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
+      class_field_kind -> class_field
+    val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
+      class_field_kind -> class_field
+    val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
+      class_field
+    val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
+    val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
+    val attribute: ?loc:loc -> attribute -> class_field
+    val text: text -> class_field list
+
+    val virtual_: core_type -> class_field_kind
+    val concrete: override_flag -> expression -> class_field_kind
+
+  end
+
+(** Classes *)
+module Ci:
+  sig
+    val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
+      ?virt:virtual_flag -> ?params:(core_type * variance) list ->
+      str -> 'a -> 'a class_infos
+  end
+
+(** Class signatures *)
+module Csig:
+  sig
+    val mk: core_type -> class_type_field list -> class_signature
+  end
+
+(** Class structures *)
+module Cstr:
+  sig
+    val mk: pattern -> class_field list -> class_structure
+  end
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
new file mode 100644
index 00000000..31ee17eb
--- /dev/null
+++ b/parsing/ast_invariants.ml
@@ -0,0 +1,166 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2015 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+open Ast_iterator
+
+let err = Syntaxerr.ill_formed_ast
+
+let empty_record loc = err loc "Records cannot be empty."
+let empty_variant loc = err loc "Variant types cannot be empty."
+let invalid_tuple loc = err loc "Tuples must have at least 2 components."
+let no_args loc = err loc "Function application with no argument."
+let empty_let loc = err loc "Let with no bindings."
+let empty_type loc = err loc "Type declarations cannot be empty."
+let complex_id loc = err loc "Functor application not allowed here."
+
+let simple_longident id =
+  let rec is_simple = function
+    | Longident.Lident _ -> true
+    | Longident.Ldot (id, _) -> is_simple id
+    | Longident.Lapply _ -> false
+  in
+  if not (is_simple id.txt) then complex_id id.loc
+
+let iterator =
+  let super = Ast_iterator.default_iterator in
+  let type_declaration self td =
+    super.type_declaration self td;
+    let loc = td.ptype_loc in
+    match td.ptype_kind with
+    | Ptype_record [] -> empty_record loc
+    | Ptype_variant [] -> empty_variant loc
+    | _ -> ()
+  in
+  let typ self ty =
+    super.typ self ty;
+    let loc = ty.ptyp_loc in
+    match ty.ptyp_desc with
+    | Ptyp_tuple ([] | [_]) -> invalid_tuple loc
+    | Ptyp_class (id, _) -> simple_longident id
+    | Ptyp_package (_, cstrs) ->
+      List.iter (fun (id, _) -> simple_longident id) cstrs
+    | _ -> ()
+  in
+  let pat self pat =
+    begin match pat.ppat_desc with
+    | Ppat_construct (_, Some ({ppat_desc = Ppat_tuple _} as p))
+      when Builtin_attributes.explicit_arity pat.ppat_attributes ->
+        super.pat self p (* allow unary tuple, see GPR#523. *)
+    | _ ->
+        super.pat self pat
+    end;
+    let loc = pat.ppat_loc in
+    match pat.ppat_desc with
+    | Ppat_tuple ([] | [_]) -> invalid_tuple loc
+    | Ppat_record ([], _) -> empty_record loc
+    | Ppat_construct (id, _) -> simple_longident id
+    | Ppat_record (fields, _) ->
+      List.iter (fun (id, _) -> simple_longident id) fields
+    | _ -> ()
+  in
+  let expr self exp =
+    begin match exp.pexp_desc with
+    | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e))
+      when Builtin_attributes.explicit_arity exp.pexp_attributes ->
+        super.expr self e (* allow unary tuple, see GPR#523. *)
+    | _ ->
+        super.expr self exp
+    end;
+    let loc = exp.pexp_loc in
+    match exp.pexp_desc with
+    | Pexp_tuple ([] | [_]) -> invalid_tuple loc
+    | Pexp_record ([], _) -> empty_record loc
+    | Pexp_apply (_, []) -> no_args loc
+    | Pexp_let (_, [], _) -> empty_let loc
+    | Pexp_ident id
+    | Pexp_construct (id, _)
+    | Pexp_field (_, id)
+    | Pexp_setfield (_, id, _)
+    | Pexp_new id
+    | Pexp_open (_, id, _) -> simple_longident id
+    | Pexp_record (fields, _) ->
+      List.iter (fun (id, _) -> simple_longident id) fields
+    | _ -> ()
+  in
+  let extension_constructor self ec =
+    super.extension_constructor self ec;
+    match ec.pext_kind with
+    | Pext_rebind id -> simple_longident id
+    | _ -> ()
+  in
+  let class_expr self ce =
+    super.class_expr self ce;
+    let loc = ce.pcl_loc in
+    match ce.pcl_desc with
+    | Pcl_apply (_, []) -> no_args loc
+    | Pcl_constr (id, _) -> simple_longident id
+    | _ -> ()
+  in
+  let module_type self mty =
+    super.module_type self mty;
+    match mty.pmty_desc with
+    | Pmty_alias id -> simple_longident id
+    | _ -> ()
+  in
+  let open_description self opn =
+    super.open_description self opn;
+    simple_longident opn.popen_lid
+  in
+  let with_constraint self wc =
+    super.with_constraint self wc;
+    match wc with
+    | Pwith_type (id, _)
+    | Pwith_module (id, _) -> simple_longident id
+    | _ -> ()
+  in
+  let module_expr self me =
+    super.module_expr self me;
+    match me.pmod_desc with
+    | Pmod_ident id -> simple_longident id
+    | _ -> ()
+  in
+  let structure_item self st =
+    super.structure_item self st;
+    let loc = st.pstr_loc in
+    match st.pstr_desc with
+    | Pstr_type (_, []) -> empty_type loc
+    | Pstr_value (_, []) -> empty_let loc
+    | _ -> ()
+  in
+  let signature_item self sg =
+    super.signature_item self sg;
+    let loc = sg.psig_loc in
+    match sg.psig_desc with
+    | Psig_type (_, []) -> empty_type loc
+    | _ -> ()
+  in
+  { super with
+    type_declaration
+  ; typ
+  ; pat
+  ; expr
+  ; extension_constructor
+  ; class_expr
+  ; module_expr
+  ; module_type
+  ; open_description
+  ; with_constraint
+  ; structure_item
+  ; signature_item
+  }
+
+let structure st = iterator.structure iterator st
+let signature sg = iterator.signature iterator sg
diff --git a/parsing/ast_invariants.mli b/parsing/ast_invariants.mli
new file mode 100644
index 00000000..51d3f9de
--- /dev/null
+++ b/parsing/ast_invariants.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2015 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Check AST invariants *)
+
+val structure : Parsetree.structure -> unit
+val signature : Parsetree.signature -> unit
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
new file mode 100755
index 00000000..8518438d
--- /dev/null
+++ b/parsing/ast_iterator.ml
@@ -0,0 +1,597 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+
+open Parsetree
+open Location
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+let iter_fst f (x, _) = f x
+let iter_snd f (_, y) = f y
+let iter_tuple f1 f2 (x, y) = f1 x; f2 y
+let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
+let iter_opt f = function None -> () | Some x -> f x
+
+let iter_loc sub {loc; txt = _} = sub.location sub loc
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub = function
+    | Rtag (_, attrs, _, tl) ->
+        sub.attributes sub attrs; List.iter (sub.typ sub) tl
+    | Rinherit t -> sub.typ sub t
+
+  let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ptyp_any
+    | Ptyp_var _ -> ()
+    | Ptyp_arrow (_lab, t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
+    | Ptyp_constr (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_object (l, _o) ->
+        let f (_, a, t) = sub.attributes sub a; sub.typ sub t in
+        List.iter f l
+    | Ptyp_class (lid, tl) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tl
+    | Ptyp_alias (t, _) -> sub.typ sub t
+    | Ptyp_variant (rl, _b, _ll) ->
+        List.iter (row_field sub) rl
+    | Ptyp_poly (_, t) -> sub.typ sub t
+    | Ptyp_package (lid, l) ->
+        iter_loc sub lid;
+        List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
+    | Ptyp_extension x -> sub.extension sub x
+
+  let iter_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private = _;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    iter_loc sub ptype_name;
+    List.iter (iter_fst (sub.typ sub)) ptype_params;
+    List.iter
+      (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+      ptype_cstrs;
+    sub.type_kind sub ptype_kind;
+    iter_opt (sub.typ sub) ptype_manifest;
+    sub.location sub ptype_loc;
+    sub.attributes sub ptype_attributes
+
+  let iter_type_kind sub = function
+    | Ptype_abstract -> ()
+    | Ptype_variant l ->
+        List.iter (sub.constructor_declaration sub) l
+    | Ptype_record l -> List.iter (sub.label_declaration sub) l
+    | Ptype_open -> ()
+
+  let iter_constructor_arguments sub = function
+    | Pcstr_tuple l -> List.iter (sub.typ sub) l
+    | Pcstr_record l ->
+        List.iter (sub.label_declaration sub) l
+
+  let iter_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private = _;
+       ptyext_attributes} =
+    iter_loc sub ptyext_path;
+    List.iter (sub.extension_constructor sub) ptyext_constructors;
+    List.iter (iter_fst (sub.typ sub)) ptyext_params;
+    sub.attributes sub ptyext_attributes
+
+  let iter_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto
+    | Pext_rebind li ->
+        iter_loc sub li
+
+  let iter_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    iter_loc sub pext_name;
+    iter_extension_constructor_kind sub pext_kind;
+    sub.location sub pext_loc;
+    sub.attributes sub pext_attributes
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcty_signature x -> sub.class_signature sub x
+    | Pcty_arrow (_lab, t, ct) ->
+        sub.typ sub t; sub.class_type sub ct
+    | Pcty_extension x -> sub.extension sub x
+
+  let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pctf_inherit ct -> sub.class_type sub ct
+    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
+    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
+    | Pctf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pctf_attribute x -> sub.attribute sub x
+    | Pctf_extension x -> sub.extension sub x
+
+  let iter_signature sub {pcsig_self; pcsig_fields} =
+    sub.typ sub pcsig_self;
+    List.iter (sub.class_type_field sub) pcsig_fields
+end
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmty_ident s -> iter_loc sub s
+    | Pmty_alias s -> iter_loc sub s
+    | Pmty_signature sg -> sub.signature sub sg
+    | Pmty_functor (s, mt1, mt2) ->
+        iter_loc sub s;
+        iter_opt (sub.module_type sub) mt1;
+        sub.module_type sub mt2
+    | Pmty_with (mt, l) ->
+        sub.module_type sub mt;
+        List.iter (sub.with_constraint sub) l
+    | Pmty_typeof me -> sub.module_expr sub me
+    | Pmty_extension x -> sub.extension sub x
+
+  let iter_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
+    | Pwith_module (lid, lid2) ->
+        iter_loc sub lid; iter_loc sub lid2
+    | Pwith_typesubst d -> sub.type_declaration sub d
+    | Pwith_modsubst (s, lid) ->
+        iter_loc sub s; iter_loc sub lid
+
+  let iter_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    sub.location sub loc;
+    match desc with
+    | Psig_value vd -> sub.value_description sub vd
+    | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l
+    | Psig_typext te -> sub.type_extension sub te
+    | Psig_exception ed -> sub.extension_constructor sub ed
+    | Psig_module x -> sub.module_declaration sub x
+    | Psig_recmodule l ->
+        List.iter (sub.module_declaration sub) l
+    | Psig_modtype x -> sub.module_type_declaration sub x
+    | Psig_open x -> sub.open_description sub x
+    | Psig_include x -> sub.include_description sub x
+    | Psig_class l -> List.iter (sub.class_description sub) l
+    | Psig_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Psig_extension (x, attrs) ->
+        sub.extension sub x; sub.attributes sub attrs
+    | Psig_attribute x -> sub.attribute sub x
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pmod_ident x -> iter_loc sub x
+    | Pmod_structure str -> sub.structure sub str
+    | Pmod_functor (arg, arg_ty, body) ->
+        iter_loc sub arg;
+        iter_opt (sub.module_type sub) arg_ty;
+        sub.module_expr sub body
+    | Pmod_apply (m1, m2) ->
+        sub.module_expr sub m1; sub.module_expr sub m2
+    | Pmod_constraint (m, mty) ->
+        sub.module_expr sub m; sub.module_type sub mty
+    | Pmod_unpack e -> sub.expr sub e
+    | Pmod_extension x -> sub.extension sub x
+
+  let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    sub.location sub loc;
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        sub.expr sub x; sub.attributes sub attrs
+    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_primitive vd -> sub.value_description sub vd
+    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
+    | Pstr_typext te -> sub.type_extension sub te
+    | Pstr_exception ed -> sub.extension_constructor sub ed
+    | Pstr_module x -> sub.module_binding sub x
+    | Pstr_recmodule l -> List.iter (sub.module_binding sub) l
+    | Pstr_modtype x -> sub.module_type_declaration sub x
+    | Pstr_open x -> sub.open_description sub x
+    | Pstr_class l -> List.iter (sub.class_declaration sub) l
+    | Pstr_class_type l ->
+        List.iter (sub.class_type_declaration sub) l
+    | Pstr_include x -> sub.include_declaration sub x
+    | Pstr_extension (x, attrs) ->
+        sub.extension sub x; sub.attributes sub attrs
+    | Pstr_attribute x -> sub.attribute sub x
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pexp_ident x -> iter_loc sub x
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.expr sub e
+    | Pexp_fun (_lab, def, p, e) ->
+        iter_opt (sub.expr sub) def;
+        sub.pat sub p;
+        sub.expr sub e
+    | Pexp_function pel -> sub.cases sub pel
+    | Pexp_apply (e, l) ->
+        sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l
+    | Pexp_match (e, pel) ->
+        sub.expr sub e; sub.cases sub pel
+    | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel
+    | Pexp_tuple el -> List.iter (sub.expr sub) el
+    | Pexp_construct (lid, arg) ->
+        iter_loc sub lid; iter_opt (sub.expr sub) arg
+    | Pexp_variant (_lab, eo) ->
+        iter_opt (sub.expr sub) eo
+    | Pexp_record (l, eo) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
+        iter_opt (sub.expr sub) eo
+    | Pexp_field (e, lid) ->
+        sub.expr sub e; iter_loc sub lid
+    | Pexp_setfield (e1, lid, e2) ->
+        sub.expr sub e1; iter_loc sub lid;
+        sub.expr sub e2
+    | Pexp_array el -> List.iter (sub.expr sub) el
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        sub.expr sub e1; sub.expr sub e2;
+        iter_opt (sub.expr sub) e3
+    | Pexp_sequence (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_while (e1, e2) ->
+        sub.expr sub e1; sub.expr sub e2
+    | Pexp_for (p, e1, e2, _d, e3) ->
+        sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
+        sub.expr sub e3
+    | Pexp_coerce (e, t1, t2) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t1;
+        sub.typ sub t2
+    | Pexp_constraint (e, t) ->
+        sub.expr sub e; sub.typ sub t
+    | Pexp_send (e, _s) -> sub.expr sub e
+    | Pexp_new lid -> iter_loc sub lid
+    | Pexp_setinstvar (s, e) ->
+        iter_loc sub s; sub.expr sub e
+    | Pexp_override sel ->
+        List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel
+    | Pexp_letmodule (s, me, e) ->
+        iter_loc sub s; sub.module_expr sub me;
+        sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        sub.expr sub e
+    | Pexp_assert e -> sub.expr sub e
+    | Pexp_lazy e -> sub.expr sub e
+    | Pexp_poly (e, t) ->
+        sub.expr sub e; iter_opt (sub.typ sub) t
+    | Pexp_object cls -> sub.class_structure sub cls
+    | Pexp_newtype (_s, e) -> sub.expr sub e
+    | Pexp_pack me -> sub.module_expr sub me
+    | Pexp_open (_ovf, lid, e) ->
+        iter_loc sub lid; sub.expr sub e
+    | Pexp_extension x -> sub.extension sub x
+    | Pexp_unreachable -> ()
+end
+
+module P = struct
+  (* Patterns *)
+
+  let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Ppat_any -> ()
+    | Ppat_var s -> iter_loc sub s
+    | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
+    | Ppat_constant _ -> ()
+    | Ppat_interval _ -> ()
+    | Ppat_tuple pl -> List.iter (sub.pat sub) pl
+    | Ppat_construct (l, p) ->
+        iter_loc sub l; iter_opt (sub.pat sub) p
+    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
+    | Ppat_record (lpl, _cf) ->
+        List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
+    | Ppat_array pl -> List.iter (sub.pat sub) pl
+    | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
+    | Ppat_constraint (p, t) ->
+        sub.pat sub p; sub.typ sub t
+    | Ppat_type s -> iter_loc sub s
+    | Ppat_lazy p -> sub.pat sub p
+    | Ppat_unpack s -> iter_loc sub s
+    | Ppat_exception p -> sub.pat sub p
+    | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        iter_loc sub lid; List.iter (sub.typ sub) tys
+    | Pcl_structure s ->
+        sub.class_structure sub s
+    | Pcl_fun (_lab, e, p, ce) ->
+        iter_opt (sub.expr sub) e;
+        sub.pat sub p;
+        sub.class_expr sub ce
+    | Pcl_apply (ce, l) ->
+        sub.class_expr sub ce;
+        List.iter (iter_snd (sub.expr sub)) l
+    | Pcl_let (_r, vbs, ce) ->
+        List.iter (sub.value_binding sub) vbs;
+        sub.class_expr sub ce
+    | Pcl_constraint (ce, ct) ->
+        sub.class_expr sub ce; sub.class_type sub ct
+    | Pcl_extension x -> sub.extension sub x
+
+  let iter_kind sub = function
+    | Cfk_concrete (_o, e) -> sub.expr sub e
+    | Cfk_virtual t -> sub.typ sub t
+
+  let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    sub.location sub loc;
+    sub.attributes sub attrs;
+    match desc with
+    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
+    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
+    | Pcf_method (s, _p, k) ->
+        iter_loc sub s; iter_kind sub k
+    | Pcf_constraint (t1, t2) ->
+        sub.typ sub t1; sub.typ sub t2
+    | Pcf_initializer e -> sub.expr sub e
+    | Pcf_attribute x -> sub.attribute sub x
+    | Pcf_extension x -> sub.extension sub x
+
+  let iter_structure sub {pcstr_self; pcstr_fields} =
+    sub.pat sub pcstr_self;
+    List.iter (sub.class_field sub) pcstr_fields
+
+  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    List.iter (iter_fst (sub.typ sub)) pl;
+    iter_loc sub pci_name;
+    f pci_expr;
+    sub.location sub pci_loc;
+    sub.attributes sub pci_attributes
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_iterator =
+  {
+    structure = (fun this l -> List.iter (this.structure_item this) l);
+    structure_item = M.iter_structure_item;
+    module_expr = M.iter;
+    signature = (fun this l -> List.iter (this.signature_item this) l);
+    signature_item = MT.iter_signature_item;
+    module_type = MT.iter;
+    with_constraint = MT.iter_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.iter;
+    class_field = CE.iter_field;
+    class_structure = CE.iter_structure;
+    class_type = CT.iter;
+    class_type_field = CT.iter_field;
+    class_signature = CT.iter_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.iter_type_declaration;
+    type_kind = T.iter_type_kind;
+    typ = T.iter;
+    type_extension = T.iter_type_extension;
+    extension_constructor = T.iter_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
+                 pval_attributes} ->
+        iter_loc this pval_name;
+        this.typ this pval_type;
+        this.attributes this pval_attributes;
+        this.location this pval_loc
+      );
+
+    pat = P.iter;
+    expr = E.iter;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         iter_loc this pmd_name;
+         this.module_type this pmd_type;
+         this.attributes this pmd_attributes;
+         this.location this pmd_loc
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         iter_loc this pmtd_name;
+         iter_opt (this.module_type this) pmtd_type;
+         this.attributes this pmtd_attributes;
+         this.location this pmtd_loc
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         iter_loc this pmb_name; this.module_expr this pmb_expr;
+         this.attributes this pmb_attributes;
+         this.location this pmb_loc
+      );
+
+
+    open_description =
+      (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} ->
+         iter_loc this popen_lid;
+         this.location this popen_loc;
+         this.attributes this popen_attributes
+      );
+
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_type this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         this.module_expr this pincl_mod;
+         this.location this pincl_loc;
+         this.attributes this pincl_attributes
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         this.pat this pvb_pat;
+         this.expr this pvb_expr;
+         this.location this pvb_loc;
+         this.attributes this pvb_attributes
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+         iter_loc this pcd_name;
+         T.iter_constructor_arguments this pcd_args;
+         iter_opt (this.typ this) pcd_res;
+         this.location this pcd_loc;
+         this.attributes this pcd_attributes
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
+         iter_loc this pld_name;
+         this.typ this pld_type;
+         this.location this pld_loc;
+         this.attributes this pld_attributes
+      );
+
+    cases = (fun this l -> List.iter (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         this.pat this pc_lhs;
+         iter_opt (this.expr this) pc_guard;
+         this.expr this pc_rhs
+      );
+
+    location = (fun _this _l -> ());
+
+    extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
+    attribute = (fun this (s, e) -> iter_loc this s; this.payload this e);
+    attributes = (fun this l -> List.iter (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> this.structure this x
+         | PSig x -> this.signature this x
+         | PTyp x -> this.typ this x
+         | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+      );
+  }
diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli
new file mode 100755
index 00000000..28df9af1
--- /dev/null
+++ b/parsing/ast_iterator.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {!iterator} allows to implement AST inspection using open recursion.  A
+    typical mapper would be based on {!default_iterator}, a trivial iterator,
+    and will fall back on it for handling the syntax it does not modify. *)
+
+open Parsetree
+
+(** {2 A generic Parsetree iterator} *)
+
+type iterator = {
+  attribute: iterator -> attribute -> unit;
+  attributes: iterator -> attribute list -> unit;
+  case: iterator -> case -> unit;
+  cases: iterator -> case list -> unit;
+  class_declaration: iterator -> class_declaration -> unit;
+  class_description: iterator -> class_description -> unit;
+  class_expr: iterator -> class_expr -> unit;
+  class_field: iterator -> class_field -> unit;
+  class_signature: iterator -> class_signature -> unit;
+  class_structure: iterator -> class_structure -> unit;
+  class_type: iterator -> class_type -> unit;
+  class_type_declaration: iterator -> class_type_declaration -> unit;
+  class_type_field: iterator -> class_type_field -> unit;
+  constructor_declaration: iterator -> constructor_declaration -> unit;
+  expr: iterator -> expression -> unit;
+  extension: iterator -> extension -> unit;
+  extension_constructor: iterator -> extension_constructor -> unit;
+  include_declaration: iterator -> include_declaration -> unit;
+  include_description: iterator -> include_description -> unit;
+  label_declaration: iterator -> label_declaration -> unit;
+  location: iterator -> Location.t -> unit;
+  module_binding: iterator -> module_binding -> unit;
+  module_declaration: iterator -> module_declaration -> unit;
+  module_expr: iterator -> module_expr -> unit;
+  module_type: iterator -> module_type -> unit;
+  module_type_declaration: iterator -> module_type_declaration -> unit;
+  open_description: iterator -> open_description -> unit;
+  pat: iterator -> pattern -> unit;
+  payload: iterator -> payload -> unit;
+  signature: iterator -> signature -> unit;
+  signature_item: iterator -> signature_item -> unit;
+  structure: iterator -> structure -> unit;
+  structure_item: iterator -> structure_item -> unit;
+  typ: iterator -> core_type -> unit;
+  type_declaration: iterator -> type_declaration -> unit;
+  type_extension: iterator -> type_extension -> unit;
+  type_kind: iterator -> type_kind -> unit;
+  value_binding: iterator -> value_binding -> unit;
+  value_description: iterator -> value_description -> unit;
+  with_constraint: iterator -> with_constraint -> unit;
+}
+(** A [iterator] record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the iterator to be applied to children in the syntax
+    tree. *)
+
+val default_iterator: iterator
+(** A default iterator, which implements a "do not do anything" mapping. *)
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
new file mode 100644
index 00000000..d58663ec
--- /dev/null
+++ b/parsing/ast_mapper.ml
@@ -0,0 +1,928 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+(*
+[@@@ocaml.warning "+9"]
+  (* Ensure that record patterns don't miss any field. *)
+*)
+
+
+open Parsetree
+open Ast_helper
+open Location
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let row_field sub = function
+    | Rtag (l, attrs, b, tl) ->
+        Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
+    | Rinherit t -> Rinherit (sub.typ sub t)
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+    let open Typ in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ptyp_any -> any ~loc ~attrs ()
+    | Ptyp_var s -> var ~loc ~attrs s
+    | Ptyp_arrow (lab, t1, t2) ->
+        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_constr (lid, tl) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_object (l, o) ->
+        let f (s, a, t) =
+          (map_loc sub s, sub.attributes sub a, sub.typ sub t) in
+        object_ ~loc ~attrs (List.map f l) o
+    | Ptyp_class (lid, tl) ->
+        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+    | Ptyp_variant (rl, b, ll) ->
+        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc ~attrs
+                             (List.map (map_loc sub) sl) (sub.typ sub t)
+    | Ptyp_package (lid, l) ->
+        package ~loc ~attrs (map_loc sub lid)
+          (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+    | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_type_declaration sub
+      {ptype_name; ptype_params; ptype_cstrs;
+       ptype_kind;
+       ptype_private;
+       ptype_manifest;
+       ptype_attributes;
+       ptype_loc} =
+    Type.mk (map_loc sub ptype_name)
+      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+      ~priv:ptype_private
+      ~cstrs:(List.map
+                (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+                ptype_cstrs)
+      ~kind:(sub.type_kind sub ptype_kind)
+      ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+      ~loc:(sub.location sub ptype_loc)
+      ~attrs:(sub.attributes sub ptype_attributes)
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l ->
+        Ptype_variant (List.map (sub.constructor_declaration sub) l)
+    | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+    | Ptype_open -> Ptype_open
+
+  let map_constructor_arguments sub = function
+    | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+    | Pcstr_record l ->
+        Pcstr_record (List.map (sub.label_declaration sub) l)
+
+  let map_type_extension sub
+      {ptyext_path; ptyext_params;
+       ptyext_constructors;
+       ptyext_private;
+       ptyext_attributes} =
+    Te.mk
+      (map_loc sub ptyext_path)
+      (List.map (sub.extension_constructor sub) ptyext_constructors)
+      ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+      ~priv:ptyext_private
+      ~attrs:(sub.attributes sub ptyext_attributes)
+
+  let map_extension_constructor_kind sub = function
+      Pext_decl(ctl, cto) ->
+        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
+    | Pext_rebind li ->
+        Pext_rebind (map_loc sub li)
+
+  let map_extension_constructor sub
+      {pext_name;
+       pext_kind;
+       pext_loc;
+       pext_attributes} =
+    Te.constructor
+      (map_loc sub pext_name)
+      (map_extension_constructor_kind sub pext_kind)
+      ~loc:(sub.location sub pext_loc)
+      ~attrs:(sub.attributes sub pext_attributes)
+
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+    let open Cty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+    | Pcty_arrow (lab, t, ct) ->
+        arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+    | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+    =
+    let open Ctf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+    | Pctf_val (s, m, v, t) ->
+        val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
+    | Pctf_method (s, p, v, t) ->
+        method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
+    | Pctf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_signature sub {pcsig_self; pcsig_fields} =
+    Csig.mk
+      (sub.typ sub pcsig_self)
+      (List.map (sub.class_type_field sub) pcsig_fields)
+end
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+    let open Mty in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+    | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+    | Pmty_functor (s, mt1, mt2) ->
+        functor_ ~loc ~attrs (map_loc sub s)
+          (Misc.may_map (sub.module_type sub) mt1)
+          (sub.module_type sub mt2)
+    | Pmty_with (mt, l) ->
+        with_ ~loc ~attrs (sub.module_type sub mt)
+          (List.map (sub.with_constraint sub) l)
+    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+    | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_with_constraint sub = function
+    | Pwith_type (lid, d) ->
+        Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+    | Pwith_module (lid, lid2) ->
+        Pwith_module (map_loc sub lid, map_loc sub lid2)
+    | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
+    | Pwith_modsubst (s, lid) ->
+        Pwith_modsubst (map_loc sub s, map_loc sub lid)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    let open Sig in
+    let loc = sub.location sub loc in
+    match desc with
+    | Psig_value vd -> value ~loc (sub.value_description sub vd)
+    | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+    | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+    | Psig_recmodule l ->
+        rec_module ~loc (List.map (sub.module_declaration sub) l)
+    | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Psig_open x -> open_ ~loc (sub.open_description sub x)
+    | Psig_include x -> include_ ~loc (sub.include_description sub x)
+    | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+    | Psig_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Psig_extension (x, attrs) ->
+        extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+    | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+    let open Mod in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+    | Pmod_functor (arg, arg_ty, body) ->
+        functor_ ~loc ~attrs (map_loc sub arg)
+          (Misc.may_map (sub.module_type sub) arg_ty)
+          (sub.module_expr sub body)
+    | Pmod_apply (m1, m2) ->
+        apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+    | Pmod_constraint (m, mty) ->
+        constraint_ ~loc ~attrs (sub.module_expr sub m)
+                    (sub.module_type sub mty)
+    | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+    | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    let open Str in
+    let loc = sub.location sub loc in
+    match desc with
+    | Pstr_eval (x, attrs) ->
+        eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
+    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
+    | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
+    | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+    | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+    | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+    | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+    | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Pstr_open x -> open_ ~loc (sub.open_description sub x)
+    | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+    | Pstr_class_type l ->
+        class_type ~loc (List.map (sub.class_type_declaration sub) l)
+    | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+    | Pstr_extension (x, attrs) ->
+        extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+    | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+    let open Exp in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+    | Pexp_constant x -> constant ~loc ~attrs x
+    | Pexp_let (r, vbs, e) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.expr sub e)
+    | Pexp_fun (lab, def, p, e) ->
+        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+          (sub.expr sub e)
+    | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+    | Pexp_apply (e, l) ->
+        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+    | Pexp_match (e, pel) ->
+        match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_construct (lid, arg) ->
+        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+    | Pexp_variant (lab, eo) ->
+        variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+    | Pexp_record (l, eo) ->
+        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+          (map_opt (sub.expr sub) eo)
+    | Pexp_field (e, lid) ->
+        field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+    | Pexp_setfield (e1, lid, e2) ->
+        setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+          (sub.expr sub e2)
+    | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_ifthenelse (e1, e2, e3) ->
+        ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+          (map_opt (sub.expr sub) e3)
+    | Pexp_sequence (e1, e2) ->
+        sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_while (e1, e2) ->
+        while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+    | Pexp_for (p, e1, e2, d, e3) ->
+        for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+          (sub.expr sub e3)
+    | Pexp_coerce (e, t1, t2) ->
+        coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+          (sub.typ sub t2)
+    | Pexp_constraint (e, t) ->
+        constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+    | Pexp_send (e, s) ->
+        send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
+    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+    | Pexp_setinstvar (s, e) ->
+        setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_override sel ->
+        override ~loc ~attrs
+          (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+    | Pexp_letmodule (s, me, e) ->
+        letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+          (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
+    | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+    | Pexp_poly (e, t) ->
+        poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+    | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+    | Pexp_newtype (s, e) ->
+        newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+    | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+    | Pexp_open (ovf, lid, e) ->
+        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
+    | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pexp_unreachable -> unreachable ~loc ~attrs ()
+end
+
+module P = struct
+  (* Patterns *)
+
+  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+    let open Pat in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Ppat_any -> any ~loc ~attrs ()
+    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+    | Ppat_constant c -> constant ~loc ~attrs c
+    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_construct (l, p) ->
+        construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
+    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+    | Ppat_record (lpl, cf) ->
+        record ~loc ~attrs
+               (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+    | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+    | Ppat_constraint (p, t) ->
+        constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
+    | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+    let open Cl in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcl_constr (lid, tys) ->
+        constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+    | Pcl_structure s ->
+        structure ~loc ~attrs (sub.class_structure sub s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc ~attrs lab
+          (map_opt (sub.expr sub) e)
+          (sub.pat sub p)
+          (sub.class_expr sub ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc ~attrs (sub.class_expr sub ce)
+          (List.map (map_snd (sub.expr sub)) l)
+    | Pcl_let (r, vbs, ce) ->
+        let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+          (sub.class_expr sub ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+    | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_kind sub = function
+    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+    | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+    let open Cf in
+    let loc = sub.location sub loc in
+    let attrs = sub.attributes sub attrs in
+    match desc with
+    | Pcf_inherit (o, ce, s) ->
+        inherit_ ~loc ~attrs o (sub.class_expr sub ce)
+          (map_opt (map_loc sub) s)
+    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+    | Pcf_method (s, p, k) ->
+        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+    | Pcf_constraint (t1, t2) ->
+        constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+    | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+
+  let map_structure sub {pcstr_self; pcstr_fields} =
+    {
+      pcstr_self = sub.pat sub pcstr_self;
+      pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+    }
+
+  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+                         pci_loc; pci_attributes} =
+    Ci.mk
+     ~virt:pci_virt
+     ~params:(List.map (map_fst (sub.typ sub)) pl)
+      (map_loc sub pci_name)
+      (f pci_expr)
+      ~loc:(sub.location sub pci_loc)
+      ~attrs:(sub.attributes sub pci_attributes)
+end
+
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+   cases of the OCaml grammar.  The default behavior of the mapper is
+   the identity. *)
+
+let default_mapper =
+  {
+    structure = (fun this l -> List.map (this.structure_item this) l);
+    structure_item = M.map_structure_item;
+    module_expr = M.map;
+    signature = (fun this l -> List.map (this.signature_item this) l);
+    signature_item = MT.map_signature_item;
+    module_type = MT.map;
+    with_constraint = MT.map_with_constraint;
+    class_declaration =
+      (fun this -> CE.class_infos this (this.class_expr this));
+    class_expr = CE.map;
+    class_field = CE.map_field;
+    class_structure = CE.map_structure;
+    class_type = CT.map;
+    class_type_field = CT.map_field;
+    class_signature = CT.map_signature;
+    class_type_declaration =
+      (fun this -> CE.class_infos this (this.class_type this));
+    class_description =
+      (fun this -> CE.class_infos this (this.class_type this));
+    type_declaration = T.map_type_declaration;
+    type_kind = T.map_type_kind;
+    typ = T.map;
+    type_extension = T.map_type_extension;
+    extension_constructor = T.map_extension_constructor;
+    value_description =
+      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+                 pval_attributes} ->
+        Val.mk
+          (map_loc this pval_name)
+          (this.typ this pval_type)
+          ~attrs:(this.attributes this pval_attributes)
+          ~loc:(this.location this pval_loc)
+          ~prim:pval_prim
+      );
+
+    pat = P.map;
+    expr = E.map;
+
+    module_declaration =
+      (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+         Md.mk
+           (map_loc this pmd_name)
+           (this.module_type this pmd_type)
+           ~attrs:(this.attributes this pmd_attributes)
+           ~loc:(this.location this pmd_loc)
+      );
+
+    module_type_declaration =
+      (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+         Mtd.mk
+           (map_loc this pmtd_name)
+           ?typ:(map_opt (this.module_type this) pmtd_type)
+           ~attrs:(this.attributes this pmtd_attributes)
+           ~loc:(this.location this pmtd_loc)
+      );
+
+    module_binding =
+      (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+         Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+           ~attrs:(this.attributes this pmb_attributes)
+           ~loc:(this.location this pmb_loc)
+      );
+
+
+    open_description =
+      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (map_loc this popen_lid)
+           ~override:popen_override
+           ~loc:(this.location this popen_loc)
+           ~attrs:(this.attributes this popen_attributes)
+      );
+
+
+    include_description =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_type this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+    include_declaration =
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+         Incl.mk (this.module_expr this pincl_mod)
+           ~loc:(this.location this pincl_loc)
+           ~attrs:(this.attributes this pincl_attributes)
+      );
+
+
+    value_binding =
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+         Vb.mk
+           (this.pat this pvb_pat)
+           (this.expr this pvb_expr)
+           ~loc:(this.location this pvb_loc)
+           ~attrs:(this.attributes this pvb_attributes)
+      );
+
+
+    constructor_declaration =
+      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+        Type.constructor
+          (map_loc this pcd_name)
+          ~args:(T.map_constructor_arguments this pcd_args)
+          ?res:(map_opt (this.typ this) pcd_res)
+          ~loc:(this.location this pcd_loc)
+          ~attrs:(this.attributes this pcd_attributes)
+      );
+
+    label_declaration =
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+         Type.field
+           (map_loc this pld_name)
+           (this.typ this pld_type)
+           ~mut:pld_mutable
+           ~loc:(this.location this pld_loc)
+           ~attrs:(this.attributes this pld_attributes)
+      );
+
+    cases = (fun this l -> List.map (this.case this) l);
+    case =
+      (fun this {pc_lhs; pc_guard; pc_rhs} ->
+         {
+           pc_lhs = this.pat this pc_lhs;
+           pc_guard = map_opt (this.expr this) pc_guard;
+           pc_rhs = this.expr this pc_rhs;
+         }
+      );
+
+
+
+    location = (fun _this l -> l);
+
+    extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+    attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
+    attributes = (fun this l -> List.map (this.attribute this) l);
+    payload =
+      (fun this -> function
+         | PStr x -> PStr (this.structure this x)
+         | PSig x -> PSig (this.signature this x)
+         | PTyp x -> PTyp (this.typ this x)
+         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+      );
+  }
+
+let rec extension_of_error {loc; msg; if_highlight; sub} =
+  { loc; txt = "ocaml.error" },
+  PStr ([Str.eval (Exp.constant (Pconst_string (msg, None)));
+         Str.eval (Exp.constant (Pconst_string (if_highlight, None)))] @
+        (List.map (fun ext -> Str.extension (extension_of_error ext)) sub))
+
+let attribute_of_warning loc s =
+  { loc; txt = "ocaml.ppwarning" },
+  PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))])
+
+module StringMap = Map.Make(struct
+    type t = string
+    let compare = compare
+end)
+
+let cookies = ref StringMap.empty
+
+let get_cookie k =
+  try Some (StringMap.find k !cookies)
+  with Not_found -> None
+
+let set_cookie k v =
+  cookies := StringMap.add k v !cookies
+
+let tool_name_ref = ref "_none_"
+
+let tool_name () = !tool_name_ref
+
+
+module PpxContext = struct
+  open Longident
+  open Asttypes
+  open Ast_helper
+
+  let lid name = { txt = Lident name; loc = Location.none }
+
+  let make_string x = Exp.constant (Pconst_string (x, None))
+
+  let make_bool x =
+    if x
+    then Exp.construct (lid "true") None
+    else Exp.construct (lid "false") None
+
+  let rec make_list f lst =
+    match lst with
+    | x :: rest ->
+      Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+    | [] ->
+      Exp.construct (lid "[]") None
+
+  let make_pair f1 f2 (x1, x2) =
+    Exp.tuple [f1 x1; f2 x2]
+
+  let make_option f opt =
+    match opt with
+    | Some x -> Exp.construct (lid "Some") (Some (f x))
+    | None   -> Exp.construct (lid "None") None
+
+  let get_cookies () =
+    lid "cookies",
+    make_list (make_pair make_string (fun x -> x))
+      (StringMap.bindings !cookies)
+
+  let mk fields =
+    { txt = "ocaml.ppx.context"; loc = Location.none },
+    Parsetree.PStr [Str.eval (Exp.record fields None)]
+
+  let make ~tool_name () =
+    let fields =
+      [
+        lid "tool_name",    make_string tool_name;
+        lid "include_dirs", make_list make_string !Clflags.include_dirs;
+        lid "load_path",    make_list make_string !Config.load_path;
+        lid "open_modules", make_list make_string !Clflags.open_modules;
+        lid "for_package",  make_option make_string !Clflags.for_package;
+        lid "debug",        make_bool !Clflags.debug;
+        get_cookies ()
+      ]
+    in
+    mk fields
+
+  let get_fields = function
+    | PStr [{pstr_desc = Pstr_eval
+                 ({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
+        fields
+    | _ ->
+        raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
+
+  let restore fields =
+    let field name payload =
+      let rec get_string = function
+        | { pexp_desc = Pexp_constant (Pconst_string (str, None)) } -> str
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] string syntax" name
+      and get_bool pexp =
+        match pexp with
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"},
+                                       None)} ->
+            true
+        | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"},
+                                       None)} ->
+            false
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] bool syntax" name
+      and get_list elem = function
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "::"},
+                             Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+            elem exp :: get_list elem rest
+        | {pexp_desc =
+             Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+            []
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] list syntax" name
+      and get_pair f1 f2 = function
+        | {pexp_desc = Pexp_tuple [e1; e2]} ->
+            (f1 e1, f2 e2)
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] pair syntax" name
+      and get_option elem = function
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+            Some (elem exp)
+        | { pexp_desc =
+              Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+            None
+        | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
+                             { %s }] option syntax" name
+      in
+      match name with
+      | "tool_name" ->
+          tool_name_ref := get_string payload
+      | "include_dirs" ->
+          Clflags.include_dirs := get_list get_string payload
+      | "load_path" ->
+          Config.load_path := get_list get_string payload
+      | "open_modules" ->
+          Clflags.open_modules := get_list get_string payload
+      | "for_package" ->
+          Clflags.for_package := get_option get_string payload
+      | "debug" ->
+          Clflags.debug := get_bool payload
+      | "cookies" ->
+          let l = get_list (get_pair get_string (fun x -> x)) payload in
+          cookies :=
+            List.fold_left
+              (fun s (k, v) -> StringMap.add k v s) StringMap.empty
+              l
+      | _ ->
+          ()
+    in
+    List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
+
+  let update_cookies fields =
+    let fields =
+      List.filter
+        (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
+        fields
+    in
+    fields @ [get_cookies ()]
+end
+
+let ppx_context = PpxContext.make
+
+let ext_of_exn exn =
+  match error_of_exn exn with
+  | Some error -> extension_of_error error
+  | None -> raise exn
+
+
+let apply_lazy ~source ~target mapper =
+  let implem ast =
+    let fields, ast =
+      match ast with
+      | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.structure mapper ast
+      with exn ->
+        [{pstr_desc = Pstr_extension (ext_of_exn exn, []);
+          pstr_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Str.attribute (PpxContext.mk fields) :: ast
+  in
+  let iface ast =
+    let fields, ast =
+      match ast with
+      | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
+          PpxContext.get_fields x, l
+      | _ -> [], ast
+    in
+    PpxContext.restore fields;
+    let ast =
+      try
+        let mapper = mapper () in
+        mapper.signature mapper ast
+      with exn ->
+        [{psig_desc = Psig_extension (ext_of_exn exn, []);
+          psig_loc  = Location.none}]
+    in
+    let fields = PpxContext.update_cookies fields in
+    Sig.attribute (PpxContext.mk fields) :: ast
+  in
+
+  let ic = open_in_bin source in
+  let magic =
+    really_input_string ic (String.length Config.ast_impl_magic_number)
+  in
+
+  let rewrite transform =
+    Location.input_name := input_value ic;
+    let ast = input_value ic in
+    close_in ic;
+    let ast = transform ast in
+    let oc = open_out_bin target in
+    output_string oc magic;
+    output_value oc !Location.input_name;
+    output_value oc ast;
+    close_out oc
+  and fail () =
+    close_in ic;
+    failwith "Ast_mapper: OCaml version mismatch or malformed input";
+  in
+
+  if magic = Config.ast_impl_magic_number then
+    rewrite (implem : structure -> structure)
+  else if magic = Config.ast_intf_magic_number then
+    rewrite (iface : signature -> signature)
+  else fail ()
+
+let drop_ppx_context_str ~restore = function
+  | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let drop_ppx_context_sig ~restore = function
+  | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)}
+    :: items ->
+      if restore then
+        PpxContext.restore (PpxContext.get_fields a);
+      items
+  | items -> items
+
+let add_ppx_context_str ~tool_name ast =
+  Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast
+
+let add_ppx_context_sig ~tool_name ast =
+  Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast
+
+
+let apply ~source ~target mapper =
+  apply_lazy ~source ~target (fun () -> mapper)
+
+let run_main mapper =
+  try
+    let a = Sys.argv in
+    let n = Array.length a in
+    if n > 2 then
+      let mapper () =
+        try mapper (Array.to_list (Array.sub a 1 (n - 3)))
+        with exn ->
+          (* PR #6463 *)
+          let f _ _ = raise exn in
+          {default_mapper with structure = f; signature = f}
+      in
+      apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
+    else begin
+      Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
+                     Sys.executable_name;
+      exit 2
+    end
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name f
diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
new file mode 100644
index 00000000..8889d2f3
--- /dev/null
+++ b/parsing/ast_mapper.mli
@@ -0,0 +1,200 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The interface of a -ppx rewriter
+
+  A -ppx rewriter is a program that accepts a serialized abstract syntax
+  tree and outputs another, possibly modified, abstract syntax tree.
+  This module encapsulates the interface between the compiler and
+  the -ppx rewriters, handling such details as the serialization format,
+  forwarding of command-line flags, and storing state.
+
+  {!mapper} allows to implement AST rewriting using open recursion.
+  A typical mapper would be based on {!default_mapper}, a deep
+  identity mapper, and will fall back on it for handling the syntax it
+  does not modify. For example:
+
+  {[
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let test_mapper argv =
+  { default_mapper with
+    expr = fun mapper expr ->
+      match expr with
+      | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+        Ast_helper.Exp.constant (Const_int 42)
+      | other -> default_mapper.expr mapper other; }
+
+let () =
+  register "ppx_test" test_mapper]}
+
+  This -ppx rewriter, which replaces [[%test]] in expressions with
+  the constant [42], can be compiled using
+  [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+
+  *)
+
+open Parsetree
+
+(** {2 A generic Parsetree mapper} *)
+
+type mapper = {
+  attribute: mapper -> attribute -> attribute;
+  attributes: mapper -> attribute list -> attribute list;
+  case: mapper -> case -> case;
+  cases: mapper -> case list -> case list;
+  class_declaration: mapper -> class_declaration -> class_declaration;
+  class_description: mapper -> class_description -> class_description;
+  class_expr: mapper -> class_expr -> class_expr;
+  class_field: mapper -> class_field -> class_field;
+  class_signature: mapper -> class_signature -> class_signature;
+  class_structure: mapper -> class_structure -> class_structure;
+  class_type: mapper -> class_type -> class_type;
+  class_type_declaration: mapper -> class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> class_type_field -> class_type_field;
+  constructor_declaration: mapper -> constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> expression -> expression;
+  extension: mapper -> extension -> extension;
+  extension_constructor: mapper -> extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> include_declaration -> include_declaration;
+  include_description: mapper -> include_description -> include_description;
+  label_declaration: mapper -> label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> module_binding -> module_binding;
+  module_declaration: mapper -> module_declaration -> module_declaration;
+  module_expr: mapper -> module_expr -> module_expr;
+  module_type: mapper -> module_type -> module_type;
+  module_type_declaration: mapper -> module_type_declaration
+                           -> module_type_declaration;
+  open_description: mapper -> open_description -> open_description;
+  pat: mapper -> pattern -> pattern;
+  payload: mapper -> payload -> payload;
+  signature: mapper -> signature -> signature;
+  signature_item: mapper -> signature_item -> signature_item;
+  structure: mapper -> structure -> structure;
+  structure_item: mapper -> structure_item -> structure_item;
+  typ: mapper -> core_type -> core_type;
+  type_declaration: mapper -> type_declaration -> type_declaration;
+  type_extension: mapper -> type_extension -> type_extension;
+  type_kind: mapper -> type_kind -> type_kind;
+  value_binding: mapper -> value_binding -> value_binding;
+  value_description: mapper -> value_description -> value_description;
+  with_constraint: mapper -> with_constraint -> with_constraint;
+}
+(** A mapper record implements one "method" per syntactic category,
+    using an open recursion style: each method takes as its first
+    argument the mapper to be applied to children in the syntax
+    tree. *)
+
+val default_mapper: mapper
+(** A default mapper, which implements a "deep identity" mapping. *)
+
+(** {2 Apply mappers to compilation units} *)
+
+val tool_name: unit -> string
+(** Can be used within a ppx preprocessor to know which tool is
+    calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
+    ["ocaml"], ...  Some global variables that reflect command-line
+    options are automatically synchronized between the calling tool
+    and the ppx preprocessor: {!Clflags.include_dirs},
+    {!Config.load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
+    {!Clflags.debug}. *)
+
+
+val apply: source:string -> target:string -> mapper -> unit
+(** Apply a mapper (parametrized by the unit name) to a dumped
+    parsetree found in the [source] file and put the result in the
+    [target] file. The [structure] or [signature] field of the mapper
+    is applied to the implementation or interface.  *)
+
+val run_main: (string list -> mapper) -> unit
+(** Entry point to call to implement a standalone -ppx rewriter from a
+    mapper, parametrized by the command line arguments.  The current
+    unit name can be obtained from {!Location.input_name}.  This
+    function implements proper error reporting for uncaught
+    exceptions. *)
+
+(** {2 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> mapper) -> unit
+(** Apply the [register_function].  The default behavior is to run the
+    mapper immediately, taking arguments from the process command
+    line.  This is to support a scenario where a mapper is linked as a
+    stand-alone executable.
+
+    It is possible to overwrite the [register_function] to define
+    "-ppx drivers", which combine several mappers in a single process.
+    Typically, a driver starts by defining [register_function] to a
+    custom implementation, then lets ppx rewriters (linked statically
+    or dynamically) register themselves, and then run all or some of
+    them.  It is also possible to have -ppx drivers apply rewriters to
+    only specific parts of an AST.
+
+    The first argument to [register] is a symbolic name to be used by
+    the ppx driver.  *)
+
+
+(** {2 Convenience functions to write mappers} *)
+
+val map_opt: ('a -> 'b) -> 'a option -> 'b option
+
+val extension_of_error: Location.error -> extension
+(** Encode an error into an 'ocaml.error' extension node which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the error. *)
+
+val attribute_of_warning: Location.t -> string -> attribute
+(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be
+    inserted in a generated Parsetree.  The compiler will be
+    responsible for reporting the warning. *)
+
+(** {2 Helper functions to call external mappers} *)
+
+val add_ppx_context_str:
+    tool_name:string -> Parsetree.structure -> Parsetree.structure
+(** Extract information from the current environment and encode it
+    into an attribute which is prepended to the list of structure
+    items in order to pass the information to an external
+    processor. *)
+
+val add_ppx_context_sig:
+    tool_name:string -> Parsetree.signature -> Parsetree.signature
+(** Same as [add_ppx_context_str], but for signatures. *)
+
+val drop_ppx_context_str:
+    restore:bool -> Parsetree.structure -> Parsetree.structure
+(** Drop the ocaml.ppx.context attribute from a structure.  If
+    [restore] is true, also restore the associated data in the current
+    process. *)
+
+val drop_ppx_context_sig:
+    restore:bool -> Parsetree.signature -> Parsetree.signature
+(** Same as [drop_ppx_context_str], but for signatures. *)
+
+(** {2 Cookies} *)
+
+(** Cookies are used to pass information from a ppx processor to
+    a further invocation of itself, when called from the OCaml
+    toplevel (or other tools that support cookies). *)
+
+val set_cookie: string -> Parsetree.expression -> unit
+val get_cookie: string -> Parsetree.expression option
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
new file mode 100644
index 00000000..8cab1c6b
--- /dev/null
+++ b/parsing/asttypes.mli
@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary AST types used by parsetree and typedtree. *)
+
+type constant =
+    Const_int of int
+  | Const_char of char
+  | Const_string of string * string option
+  | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+
+type rec_flag = Nonrecursive | Recursive
+
+type direction_flag = Upto | Downto
+
+(* Order matters, used in polymorphic comparison *)
+type private_flag = Private | Public
+
+type mutable_flag = Immutable | Mutable
+
+type virtual_flag = Virtual | Concrete
+
+type override_flag = Override | Fresh
+
+type closed_flag = Closed | Open
+
+type label = string
+
+type arg_label =
+    Nolabel
+  | Labelled of string (*  label:T -> ... *)
+  | Optional of string (* ?label:T -> ... *)
+
+type 'a loc = 'a Location.loc = {
+  txt : 'a;
+  loc : Location.t;
+}
+
+
+type variance =
+  | Covariant
+  | Contravariant
+  | Invariant
diff --git a/parsing/attr_helper.ml b/parsing/attr_helper.ml
new file mode 100644
index 00000000..ecf87787
--- /dev/null
+++ b/parsing/attr_helper.ml
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+exception Error of Location.t * error
+
+let get_no_payload_attribute alt_names attrs =
+  match List.filter (fun (n, _) -> List.mem n.txt alt_names) attrs with
+  | [] -> None
+  | [ (name, PStr []) ] -> Some name
+  | [ (name, _) ] ->
+    raise (Error (name.loc, No_payload_expected name.txt))
+  | _ :: (name, _) :: _ ->
+    raise (Error (name.loc, Multiple_attributes name.txt))
+
+let has_no_payload_attribute alt_names attrs =
+  match get_no_payload_attribute alt_names attrs with
+  | None   -> false
+  | Some _ -> true
+
+open Format
+
+let report_error ppf = function
+  | Multiple_attributes name ->
+    fprintf ppf "Too many `%s' attributes" name
+  | No_payload_expected name ->
+    fprintf ppf "Attribute `%s' does not accept a payload" name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/parsing/attr_helper.mli b/parsing/attr_helper.mli
new file mode 100644
index 00000000..3d7145c3
--- /dev/null
+++ b/parsing/attr_helper.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Helpers for attributes *)
+
+open Asttypes
+open Parsetree
+
+type error =
+  | Multiple_attributes of string
+  | No_payload_expected of string
+
+(** The [string list] argument of the following functions is a list of
+    alternative names for the attribute we are looking for. For instance:
+
+    {[
+      ["foo"; "ocaml.foo"]
+    ]} *)
+val get_no_payload_attribute : string list -> attributes -> string loc option
+val has_no_payload_attribute : string list -> attributes -> bool
+
+exception Error of Location.t * error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
new file mode 100755
index 00000000..bdbefcdf
--- /dev/null
+++ b/parsing/builtin_attributes.ml
@@ -0,0 +1,213 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Parsetree
+
+let string_of_cst = function
+  | Pconst_string(s, _) -> Some s
+  | _ -> None
+
+let string_of_payload = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
+      string_of_cst c
+  | _ -> None
+
+let rec error_of_extension ext =
+  match ext with
+  | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
+    let rec sub_from inner =
+      match inner with
+      | {pstr_desc=Pstr_extension (ext, _)} :: rest ->
+          error_of_extension ext :: sub_from rest
+      | _ :: rest ->
+          (Location.errorf ~loc
+             "Invalid syntax for sub-error of extension '%s'." txt) ::
+            sub_from rest
+      | [] -> []
+    in
+    begin match p with
+    | PStr({pstr_desc=Pstr_eval
+              ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::
+           {pstr_desc=Pstr_eval
+              ({pexp_desc=Pexp_constant(Pconst_string(if_highlight,_))}, _)}::
+           inner) ->
+        Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg
+    | PStr({pstr_desc=Pstr_eval
+              ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::inner) ->
+        Location.error ~loc ~sub:(sub_from inner) msg
+    | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt
+    end
+  | ({txt; loc}, _) ->
+      Location.errorf ~loc "Uninterpreted extension '%s'." txt
+
+let rec deprecated_of_attrs = function
+  | [] -> None
+  | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ ->
+      begin match string_of_payload p with
+      | Some txt ->  Some txt
+      | None -> Some ""
+      end
+  | _ :: tl -> deprecated_of_attrs tl
+
+let check_deprecated loc attrs s =
+  match deprecated_of_attrs attrs with
+  | None -> ()
+  | Some "" -> Location.prerr_warning loc (Warnings.Deprecated s)
+  | Some txt ->
+      Location.prerr_warning loc (Warnings.Deprecated (s ^ "\n" ^ txt))
+
+let rec check_deprecated_mutable loc attrs s =
+  match attrs with
+  | [] -> ()
+  | ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ ->
+      let txt =
+        match string_of_payload p with
+        | Some txt -> "\n" ^ txt
+        | None -> ""
+      in
+      Location.prerr_warning loc
+        (Warnings.Deprecated (Printf.sprintf "mutating field %s%s"
+           s txt))
+  | _ :: tl -> check_deprecated_mutable loc tl s
+
+let rec deprecated_of_sig = function
+  | {psig_desc = Psig_attribute a} :: tl ->
+      begin match deprecated_of_attrs [a] with
+      | None -> deprecated_of_sig tl
+      | Some _ as r -> r
+      end
+  | _ -> None
+
+
+let rec deprecated_of_str = function
+  | {pstr_desc = Pstr_attribute a} :: tl ->
+      begin match deprecated_of_attrs [a] with
+      | None -> deprecated_of_str tl
+      | Some _ as r -> r
+      end
+  | _ -> None
+
+
+let emit_external_warnings =
+  (* Note: this is run as a preliminary pass when type-checking an
+     interface or implementation.  This allows to cover all kinds of
+     attributes, but the drawback is that it doesn't take local
+     configuration of warnings (with '@@warning'/'@@warnerror'
+     attributes) into account.  We should rather check for
+     'ppwarning' attributes during the actual type-checking, making
+     sure to cover all contexts (easier and more ugly alternative:
+     duplicate here the logic which control warnings locally). *)
+  let open Ast_iterator in
+  {
+    default_iterator with
+    attribute = (fun _ a ->
+        match a with
+        | {txt="ocaml.ppwarning"|"ppwarning"},
+          PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
+                                         (Pconst_string (s, _))},_);
+                pstr_loc}] ->
+            Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+        | _ -> ()
+      )
+  }
+
+
+let warning_scope = ref []
+
+let warning_enter_scope () =
+  warning_scope := (Warnings.backup ()) :: !warning_scope
+let warning_leave_scope () =
+  match !warning_scope with
+  | [] -> assert false
+  | hd :: tl ->
+      Warnings.restore hd;
+      warning_scope := tl
+
+let warning_attribute attrs =
+  let process loc txt errflag payload =
+    match string_of_payload payload with
+    | Some s ->
+        begin try Warnings.parse_options errflag s
+        with Arg.Bad _ ->
+          Location.prerr_warning loc
+            (Warnings.Attribute_payload
+               (txt, "Ill-formed list of warnings"))
+        end
+    | None ->
+        Location.prerr_warning loc
+          (Warnings.Attribute_payload
+             (txt, "A single string literal is expected"))
+  in
+  List.iter
+    (function
+      | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) ->
+          process loc txt false payload
+      | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
+          process loc txt true payload
+      | _ ->
+          ()
+    )
+    attrs
+
+let with_warning_attribute attrs f =
+  try
+    warning_enter_scope ();
+    warning_attribute attrs;
+    let ret = f () in
+    warning_leave_scope ();
+    ret
+  with exn ->
+    warning_leave_scope ();
+    raise exn
+
+
+let warn_on_literal_pattern =
+  List.exists
+    (function
+      | ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _)
+        -> true
+      | _ -> false
+    )
+
+let explicit_arity =
+  List.exists
+    (function
+      | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
+      | _ -> false
+    )
+
+let immediate =
+  List.exists
+    (function
+      | ({txt="ocaml.immediate"|"immediate"; _}, _) -> true
+      | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l (x, _) = List.mem x.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr
diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
new file mode 100755
index 00000000..9add6373
--- /dev/null
+++ b/parsing/builtin_attributes.mli
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                         Alain Frisch, LexiFi                           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Support for some of the builtin attributes:
+
+   ocaml.deprecated
+   ocaml.error
+   ocaml.ppwarning
+   ocaml.warning
+   ocaml.warnerror
+   ocaml.explicit_arity (for camlp4/camlp5)
+   ocaml.warn_on_literal_pattern
+   ocaml.deprecated_mutable
+   ocaml.immediate
+   ocaml.boxed / ocaml.unboxed
+*)
+
+
+val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
+val deprecated_of_attrs: Parsetree.attributes -> string option
+val deprecated_of_sig: Parsetree.signature -> string option
+val deprecated_of_str: Parsetree.structure -> string option
+
+val check_deprecated_mutable:
+    Location.t -> Parsetree.attributes -> string -> unit
+
+val error_of_extension: Parsetree.extension -> Location.error
+
+val warning_enter_scope: unit -> unit
+val warning_leave_scope: unit -> unit
+val warning_attribute: Parsetree.attributes -> unit
+val with_warning_attribute: Parsetree.attributes -> (unit -> 'a) -> 'a
+
+val emit_external_warnings: Ast_iterator.iterator
+
+val warn_on_literal_pattern: Parsetree.attributes -> bool
+val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool
diff --git a/parsing/depend.ml b/parsing/depend.ml
new file mode 100644
index 00000000..8703ffe0
--- /dev/null
+++ b/parsing/depend.ml
@@ -0,0 +1,517 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Location
+open Longident
+open Parsetree
+
+module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringMap = Map.Make(String)
+
+(* Module resolution map *)
+(* Node (set of imports for this path, map for submodules) *)
+type map_tree = Node of StringSet.t * bound_map
+and  bound_map = map_tree StringMap.t
+let bound = Node (StringSet.empty, StringMap.empty)
+
+(*let get_free (Node (s, _m)) = s*)
+let get_map (Node (_s, m)) = m
+let make_leaf s = Node (StringSet.singleton s, StringMap.empty)
+let make_node m =  Node (StringSet.empty, m)
+let rec weaken_map s (Node(s0,m0)) =
+  Node (StringSet.union s s0, StringMap.map (weaken_map s) m0)
+let rec collect_free (Node (s, m)) =
+  StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s
+
+(* Returns the imports required to access the structure at path p *)
+(* Only raises Not_found if the head of p is not in the toplevel map *)
+let rec lookup_free p m =
+  match p with
+    [] -> raise Not_found
+  | s::p ->
+      let Node (f, m') = StringMap.find s m  in
+      try lookup_free p m' with Not_found -> f
+
+(* Returns the node corresponding to the structure at path p *)
+let rec lookup_map lid m =
+  match lid with
+    Lident s    -> StringMap.find s m
+  | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m))
+  | Lapply _    -> raise Not_found
+
+(* Collect free module identifiers in the a.s.t. *)
+
+let free_structure_names = ref StringSet.empty
+
+let add_names s =
+  free_structure_names := StringSet.union s !free_structure_names
+
+let rec add_path bv ?(p=[]) = function
+  | Lident s ->
+      let free =
+        try lookup_free (s::p) bv with Not_found -> StringSet.singleton s
+      in
+      (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free;
+        prerr_endline "";*)
+      add_names free
+  | Ldot(l, s) -> add_path bv ~p:(s::p) l
+  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
+
+let open_module bv lid =
+  match lookup_map lid bv with
+  | Node (s, m) ->
+      add_names s;
+      StringMap.fold StringMap.add m bv
+  | exception Not_found ->
+      add_path bv lid; bv
+
+let add_parent bv lid =
+  match lid.txt with
+    Ldot(l, _s) -> add_path bv l
+  | _ -> ()
+
+let add = add_parent
+
+let addmodule bv lid = add_path bv lid.txt
+
+let handle_extension ext =
+  match (fst ext).txt with
+  | "error" | "ocaml.error" ->
+    raise (Location.Error
+             (Builtin_attributes.error_of_extension ext))
+  | _ ->
+    ()
+
+let rec add_type bv ty =
+  match ty.ptyp_desc with
+    Ptyp_any -> ()
+  | Ptyp_var _ -> ()
+  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
+  | Ptyp_tuple tl -> List.iter (add_type bv) tl
+  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
+  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_alias(t, _) -> add_type bv t
+  | Ptyp_variant(fl, _, _) ->
+      List.iter
+        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
+          | Rinherit sty -> add_type bv sty)
+        fl
+  | Ptyp_poly(_, t) -> add_type bv t
+  | Ptyp_package pt -> add_package_type bv pt
+  | Ptyp_extension e -> handle_extension e
+
+and add_package_type bv (lid, l) =
+  add bv lid;
+  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
+
+let add_opt add_fn bv = function
+    None -> ()
+  | Some x -> add_fn bv x
+
+let add_constructor_arguments bv = function
+  | Pcstr_tuple l -> List.iter (add_type bv) l
+  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
+
+let add_constructor_decl bv pcd =
+  add_constructor_arguments bv pcd.pcd_args;
+  Misc.may (add_type bv) pcd.pcd_res
+
+let add_type_declaration bv td =
+  List.iter
+    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
+    td.ptype_cstrs;
+  add_opt add_type bv td.ptype_manifest;
+  let add_tkind = function
+    Ptype_abstract -> ()
+  | Ptype_variant cstrs ->
+      List.iter (add_constructor_decl bv) cstrs
+  | Ptype_record lbls ->
+      List.iter (fun pld -> add_type bv pld.pld_type) lbls
+  | Ptype_open -> () in
+  add_tkind td.ptype_kind
+
+let add_extension_constructor bv ext =
+  match ext.pext_kind with
+    Pext_decl(args, rty) ->
+      add_constructor_arguments bv args;
+      Misc.may (add_type bv) rty
+  | Pext_rebind lid -> add bv lid
+
+let add_type_extension bv te =
+  add bv te.ptyext_path;
+  List.iter (add_extension_constructor bv) te.ptyext_constructors
+
+let rec add_class_type bv cty =
+  match cty.pcty_desc with
+    Pcty_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
+      add_type bv ty;
+      List.iter (add_class_type_field bv) fieldl
+  | Pcty_arrow(_, ty1, cty2) ->
+      add_type bv ty1; add_class_type bv cty2
+  | Pcty_extension e -> handle_extension e
+
+and add_class_type_field bv pctf =
+  match pctf.pctf_desc with
+    Pctf_inherit cty -> add_class_type bv cty
+  | Pctf_val(_, _, _, ty) -> add_type bv ty
+  | Pctf_method(_, _, _, ty) -> add_type bv ty
+  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pctf_attribute _ -> ()
+  | Pctf_extension e -> handle_extension e
+
+let add_class_description bv infos =
+  add_class_type bv infos.pci_expr
+
+let add_class_type_declaration = add_class_description
+
+let pattern_bv = ref StringMap.empty
+
+let rec add_pattern bv pat =
+  match pat.ppat_desc with
+    Ppat_any -> ()
+  | Ppat_var _ -> ()
+  | Ppat_alias(p, _) -> add_pattern bv p
+  | Ppat_interval _
+  | Ppat_constant _ -> ()
+  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
+  | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
+  | Ppat_record(pl, _) ->
+      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
+  | Ppat_array pl -> List.iter (add_pattern bv) pl
+  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
+  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
+  | Ppat_variant(_, op) -> add_opt add_pattern bv op
+  | Ppat_type li -> add bv li
+  | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv
+  | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
+  | Ppat_exception p -> add_pattern bv p
+  | Ppat_extension e -> handle_extension e
+
+let add_pattern bv pat =
+  pattern_bv := bv;
+  add_pattern bv pat;
+  !pattern_bv
+
+let rec add_expr bv exp =
+  match exp.pexp_desc with
+    Pexp_ident l -> add bv l
+  | Pexp_constant _ -> ()
+  | Pexp_let(rf, pel, e) ->
+      let bv = add_bindings rf bv pel in add_expr bv e
+  | Pexp_fun (_, opte, p, e) ->
+      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
+  | Pexp_function pel ->
+      add_cases bv pel
+  | Pexp_apply(e, el) ->
+      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
+  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_tuple el -> List.iter (add_expr bv) el
+  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
+  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
+  | Pexp_record(lblel, opte) ->
+      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
+      add_opt add_expr bv opte
+  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
+  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
+  | Pexp_array el -> List.iter (add_expr bv) el
+  | Pexp_ifthenelse(e1, e2, opte3) ->
+      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
+  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_for( _, e1, e2, _, e3) ->
+      add_expr bv e1; add_expr bv e2; add_expr bv e3
+  | Pexp_coerce(e1, oty2, ty3) ->
+      add_expr bv e1;
+      add_opt add_type bv oty2;
+      add_type bv ty3
+  | Pexp_constraint(e1, ty2) ->
+      add_expr bv e1;
+      add_type bv ty2
+  | Pexp_send(e, _m) -> add_expr bv e
+  | Pexp_new li -> add bv li
+  | Pexp_setinstvar(_v, e) -> add_expr bv e
+  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
+  | Pexp_letmodule(id, m, e) ->
+      let b = add_module_binding bv m in
+      add_expr (StringMap.add id.txt b bv) e
+  | Pexp_letexception(_, e) -> add_expr bv e
+  | Pexp_assert (e) -> add_expr bv e
+  | Pexp_lazy (e) -> add_expr bv e
+  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
+  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pexp_newtype (_, e) -> add_expr bv e
+  | Pexp_pack m -> add_module bv m
+  | Pexp_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_expr bv e
+  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
+                              "extension_constructor"); _ },
+                     PStr [item]) as e) ->
+      begin match item.pstr_desc with
+      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
+      | _ -> handle_extension e
+      end
+  | Pexp_extension e -> handle_extension e
+  | Pexp_unreachable -> ()
+
+and add_cases bv cases =
+  List.iter (add_case bv) cases
+
+and add_case bv {pc_lhs; pc_guard; pc_rhs} =
+  let bv = add_pattern bv pc_lhs in
+  add_opt add_expr bv pc_guard;
+  add_expr bv pc_rhs
+
+and add_bindings recf bv pel =
+  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
+  let bv = if recf = Recursive then bv' else bv in
+  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
+  bv'
+
+and add_modtype bv mty =
+  match mty.pmty_desc with
+    Pmty_ident l -> add bv l
+  | Pmty_alias l -> addmodule bv l
+  | Pmty_signature s -> add_signature bv s
+  | Pmty_functor(id, mty1, mty2) ->
+      Misc.may (add_modtype bv) mty1;
+      add_modtype (StringMap.add id.txt bound bv) mty2
+  | Pmty_with(mty, cstrl) ->
+      add_modtype bv mty;
+      List.iter
+        (function
+          | Pwith_type (_, td) -> add_type_declaration bv td
+          | Pwith_module (_, lid) -> addmodule bv lid
+          | Pwith_typesubst td -> add_type_declaration bv td
+          | Pwith_modsubst (_, lid) -> addmodule bv lid
+        )
+        cstrl
+  | Pmty_typeof m -> add_module bv m
+  | Pmty_extension e -> handle_extension e
+
+and add_module_alias bv l =
+  try
+    add_parent bv l;
+    lookup_map l.txt bv
+  with Not_found ->
+    match l.txt with
+      Lident s -> make_leaf s
+    | _ -> addmodule bv l; bound (* cannot delay *)
+
+and add_modtype_binding bv mty =
+  if not !Clflags.transparent_modules then add_modtype bv mty;
+  match mty.pmty_desc with
+    Pmty_alias l ->
+      add_module_alias bv l
+  | Pmty_signature s ->
+      make_node (add_signature_binding bv s)
+  | Pmty_typeof modl ->
+      add_module_binding bv modl
+  | _ ->
+      if !Clflags.transparent_modules then add_modtype bv mty; bound
+
+and add_signature bv sg =
+  ignore (add_signature_binding bv sg)
+
+and add_signature_binding bv sg =
+  snd (List.fold_left add_sig_item (bv, StringMap.empty) sg)
+
+and add_sig_item (bv, m) item =
+  match item.psig_desc with
+    Psig_value vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Psig_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Psig_typext te ->
+      add_type_extension bv te; (bv, m)
+  | Psig_exception pext ->
+      add_extension_constructor bv pext; (bv, m)
+  | Psig_module pmd ->
+      let m' = add_modtype_binding bv pmd.pmd_type in
+      let add = StringMap.add pmd.pmd_name.txt m' in
+      (add bv, add m)
+  | Psig_recmodule decls ->
+      let add =
+        List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound)
+                        decls
+      in
+      let bv' = add bv and m' = add m in
+      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
+      (bv', m')
+  | Psig_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Psig_open od ->
+      (open_module bv od.popen_lid.txt, m)
+  | Psig_include incl ->
+      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
+  | Psig_class cdl ->
+      List.iter (add_class_description bv) cdl; (bv, m)
+  | Psig_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Psig_attribute _ -> (bv, m)
+  | Psig_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_module_binding bv modl =
+  if not !Clflags.transparent_modules then add_module bv modl;
+  match modl.pmod_desc with
+    Pmod_ident l ->
+      begin try
+        add_parent bv l;
+        lookup_map l.txt bv
+      with Not_found ->
+        match l.txt with
+          Lident s -> make_leaf s
+        | _ ->  addmodule bv l; bound
+      end
+  | Pmod_structure s ->
+      make_node (snd (add_structure_binding bv s))
+  | _ ->
+      if !Clflags.transparent_modules then add_module bv modl; bound
+
+and add_module bv modl =
+  match modl.pmod_desc with
+    Pmod_ident l -> addmodule bv l
+  | Pmod_structure s -> ignore (add_structure bv s)
+  | Pmod_functor(id, mty, modl) ->
+      Misc.may (add_modtype bv) mty;
+      add_module (StringMap.add id.txt bound bv) modl
+  | Pmod_apply(mod1, mod2) ->
+      add_module bv mod1; add_module bv mod2
+  | Pmod_constraint(modl, mty) ->
+      add_module bv modl; add_modtype bv mty
+  | Pmod_unpack(e) ->
+      add_expr bv e
+  | Pmod_extension e ->
+      handle_extension e
+
+and add_structure bv item_list =
+  let (bv, m) = add_structure_binding bv item_list in
+  add_names (collect_free (make_node m));
+  bv
+
+and add_structure_binding bv item_list =
+  List.fold_left add_struct_item (bv, StringMap.empty) item_list
+
+and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
+  match item.pstr_desc with
+    Pstr_eval (e, _attrs) ->
+      add_expr bv e; (bv, m)
+  | Pstr_value(rf, pel) ->
+      let bv = add_bindings rf bv pel in (bv, m)
+  | Pstr_primitive vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Pstr_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Pstr_typext te ->
+      add_type_extension bv te;
+      (bv, m)
+  | Pstr_exception pext ->
+      add_extension_constructor bv pext; (bv, m)
+  | Pstr_module x ->
+      let b = add_module_binding bv x.pmb_expr in
+      let add = StringMap.add x.pmb_name.txt b in
+      (add bv, add m)
+  | Pstr_recmodule bindings ->
+      let add =
+        List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings
+      in
+      let bv' = add bv and m = add m in
+      List.iter
+        (fun x -> add_module bv' x.pmb_expr)
+        bindings;
+      (bv', m)
+  | Pstr_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Pstr_open od ->
+      (open_module bv od.popen_lid.txt, m)
+  | Pstr_class cdl ->
+      List.iter (add_class_declaration bv) cdl; (bv, m)
+  | Pstr_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Pstr_include incl ->
+      let Node (s, m') = add_module_binding bv incl.pincl_mod in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
+  | Pstr_attribute _ -> (bv, m)
+  | Pstr_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_use_file bv top_phrs =
+  ignore (List.fold_left add_top_phrase bv top_phrs)
+
+and add_implementation bv l =
+  if !Clflags.transparent_modules then
+    ignore (add_structure_binding bv l)
+  else ignore (add_structure bv l)
+
+and add_implementation_binding bv l =
+  snd (add_structure_binding bv l)
+
+and add_top_phrase bv = function
+  | Ptop_def str -> add_structure bv str
+  | Ptop_dir (_, _) -> bv
+
+and add_class_expr bv ce =
+  match ce.pcl_desc with
+    Pcl_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pcl_fun(_, opte, pat, ce) ->
+      add_opt add_expr bv opte;
+      let bv = add_pattern bv pat in add_class_expr bv ce
+  | Pcl_apply(ce, exprl) ->
+      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
+  | Pcl_let(rf, pel, ce) ->
+      let bv = add_bindings rf bv pel in add_class_expr bv ce
+  | Pcl_constraint(ce, ct) ->
+      add_class_expr bv ce; add_class_type bv ct
+  | Pcl_extension e -> handle_extension e
+
+and add_class_field bv pcf =
+  match pcf.pcf_desc with
+    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
+  | Pcf_val(_, _, Cfk_concrete (_, e))
+  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
+  | Pcf_val(_, _, Cfk_virtual ty)
+  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
+  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pcf_initializer e -> add_expr bv e
+  | Pcf_attribute _ -> ()
+  | Pcf_extension e -> handle_extension e
+
+and add_class_declaration bv decl =
+  add_class_expr bv decl.pci_expr
diff --git a/parsing/depend.mli b/parsing/depend.mli
new file mode 100644
index 00000000..e34abbe7
--- /dev/null
+++ b/parsing/depend.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Module dependencies. *)
+
+module StringSet : Set.S with type elt = string
+module StringMap : Map.S with type key = string
+
+type map_tree = Node of StringSet.t * bound_map
+and  bound_map = map_tree StringMap.t
+val make_leaf : string -> map_tree
+val make_node : bound_map -> map_tree
+val weaken_map : StringSet.t -> map_tree -> map_tree
+
+val free_structure_names : StringSet.t ref
+
+val open_module : bound_map -> Longident.t -> bound_map
+
+val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit
+
+val add_signature : bound_map -> Parsetree.signature -> unit
+
+val add_implementation : bound_map -> Parsetree.structure -> unit
+
+val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
+val add_signature_binding : bound_map -> Parsetree.signature -> bound_map
diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml
new file mode 100644
index 00000000..5524aea2
--- /dev/null
+++ b/parsing/docstrings.ml
@@ -0,0 +1,343 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Location
+
+(* Docstrings *)
+
+(* A docstring is "attached" if it has been inserted in the AST. This
+   is used for generating unexpected docstring warnings. *)
+type ds_attached =
+  | Unattached   (* Not yet attached anything.*)
+  | Info         (* Attached to a field or constructor. *)
+  | Docs         (* Attached to an item or as floating text. *)
+
+(* A docstring is "associated" with an item if there are no blank lines between
+   them. This is used for generating docstring ambiguity warnings. *)
+type ds_associated =
+  | Zero             (* Not associated with an item *)
+  | One              (* Associated with one item *)
+  | Many             (* Associated with multiple items (ambiguity) *)
+
+type docstring =
+  { ds_body: string;
+    ds_loc: Location.t;
+    mutable ds_attached: ds_attached;
+    mutable ds_associated: ds_associated; }
+
+(* List of docstrings *)
+
+let docstrings : docstring list ref = ref []
+
+(* Warn for unused and ambiguous docstrings *)
+
+let warn_bad_docstrings () =
+  if Warnings.is_active (Warnings.Bad_docstring true) then begin
+    List.iter
+      (fun ds ->
+         match ds.ds_attached with
+         | Info -> ()
+         | Unattached ->
+           prerr_warning ds.ds_loc (Warnings.Bad_docstring true)
+         | Docs ->
+             match ds.ds_associated with
+             | Zero | One -> ()
+             | Many ->
+               prerr_warning ds.ds_loc (Warnings.Bad_docstring false))
+      (List.rev !docstrings)
+end
+
+(* Docstring constructors and destructors *)
+
+let docstring body loc =
+  let ds =
+    { ds_body = body;
+      ds_loc = loc;
+      ds_attached = Unattached;
+      ds_associated = Zero; }
+  in
+  ds
+
+let register ds =
+  docstrings := ds :: !docstrings
+
+let docstring_body ds = ds.ds_body
+
+let docstring_loc ds = ds.ds_loc
+
+(* Docstrings attached to items *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+let empty_docs = { docs_pre = None; docs_post = None }
+
+let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
+
+let docs_attr ds =
+  let open Parsetree in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
+      pexp_loc = ds.ds_loc;
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
+  in
+    (doc_loc, PStr [item])
+
+let add_docs_attrs docs attrs =
+  let attrs =
+    match docs.docs_pre with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> docs_attr ds :: attrs
+  in
+  let attrs =
+    match docs.docs_post with
+    | None | Some { ds_body=""; _ } -> attrs
+    | Some ds -> attrs @ [docs_attr ds]
+  in
+  attrs
+
+(* Docstrings attached to constructors or fields *)
+
+type info = docstring option
+
+let empty_info = None
+
+let info_attr = docs_attr
+
+let add_info_attrs info attrs =
+  match info with
+  | None | Some {ds_body=""; _} -> attrs
+  | Some ds -> attrs @ [info_attr ds]
+
+(* Docstrings not attached to a specifc item *)
+
+type text = docstring list
+
+let empty_text = []
+let empty_text_lazy = lazy []
+
+let text_loc = {txt = "ocaml.text"; loc = Location.none}
+
+let text_attr ds =
+  let open Parsetree in
+  let exp =
+    { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
+      pexp_loc = ds.ds_loc;
+      pexp_attributes = []; }
+  in
+  let item =
+    { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
+  in
+    (text_loc, PStr [item])
+
+let add_text_attrs dsl attrs =
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
+
+(* Find the first non-info docstring in a list, attach it and return it *)
+let get_docstring ~info dsl =
+  let rec loop = function
+    | [] -> None
+    | {ds_attached = Info; _} :: rest -> loop rest
+    | ds :: _ ->
+        ds.ds_attached <- if info then Info else Docs;
+        Some ds
+  in
+  loop dsl
+
+(* Find all the non-info docstrings in a list, attach them and return them *)
+let get_docstrings dsl =
+  let rec loop acc = function
+    | [] -> List.rev acc
+    | {ds_attached = Info; _} :: rest -> loop acc rest
+    | ds :: rest ->
+        ds.ds_attached <- Docs;
+        loop (ds :: acc) rest
+  in
+    loop [] dsl
+
+(* "Associate" all the docstrings in a list *)
+let associate_docstrings dsl =
+  List.iter
+    (fun ds ->
+       match ds.ds_associated with
+       | Zero -> ds.ds_associated <- One
+       | (One | Many) -> ds.ds_associated <- Many)
+    dsl
+
+(* Map from positions to pre docstrings *)
+
+let pre_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_table pos dsl
+
+let get_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_pre_docs pos =
+  try
+    let dsl = Hashtbl.find pre_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+(* Map from positions to post docstrings *)
+
+let post_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_table pos dsl
+
+let get_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl;
+      get_docstring ~info:false dsl
+  with Not_found -> None
+
+let mark_post_docs pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      associate_docstrings dsl
+  with Not_found -> ()
+
+let get_info pos =
+  try
+    let dsl = Hashtbl.find post_table pos in
+      get_docstring ~info:true dsl
+  with Not_found -> None
+
+(* Map from positions to floating docstrings *)
+
+let floating_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_floating_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add floating_table pos dsl
+
+let get_text pos =
+  try
+    let dsl = Hashtbl.find floating_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Maps from positions to extra docstrings *)
+
+let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_pre_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
+
+let get_pre_extra_text pos =
+  try
+    let dsl = Hashtbl.find pre_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
+  Hashtbl.create 50
+
+let set_post_extra_docstrings pos dsl =
+  if dsl <> [] then Hashtbl.add post_extra_table pos dsl
+
+let get_post_extra_text pos =
+  try
+    let dsl = Hashtbl.find post_extra_table pos in
+      get_docstrings dsl
+  with Not_found -> []
+
+(* Docstrings from parser actions *)
+
+let symbol_docs () =
+  { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
+    docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
+
+let symbol_docs_lazy () =
+  let p1 = Parsing.symbol_start_pos () in
+  let p2 = Parsing.symbol_end_pos () in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let rhs_docs pos1 pos2 =
+  { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
+    docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
+
+let rhs_docs_lazy pos1 pos2 =
+  let p1 = Parsing.rhs_start_pos pos1 in
+  let p2 = Parsing.rhs_end_pos pos2 in
+    lazy { docs_pre = get_pre_docs p1;
+           docs_post = get_post_docs p2; }
+
+let mark_symbol_docs () =
+  mark_pre_docs (Parsing.symbol_start_pos ());
+  mark_post_docs (Parsing.symbol_end_pos ())
+
+let mark_rhs_docs pos1 pos2 =
+  mark_pre_docs (Parsing.rhs_start_pos pos1);
+  mark_post_docs (Parsing.rhs_end_pos pos2)
+
+let symbol_info () =
+  get_info (Parsing.symbol_end_pos ())
+
+let rhs_info pos =
+  get_info (Parsing.rhs_end_pos pos)
+
+let symbol_text () =
+  get_text (Parsing.symbol_start_pos ())
+
+let symbol_text_lazy () =
+  let pos = Parsing.symbol_start_pos () in
+    lazy (get_text pos)
+
+let rhs_text pos =
+  get_text (Parsing.rhs_start_pos pos)
+
+let rhs_text_lazy pos =
+  let pos = Parsing.rhs_start_pos pos in
+    lazy (get_text pos)
+
+let symbol_pre_extra_text () =
+  get_pre_extra_text (Parsing.symbol_start_pos ())
+
+let symbol_post_extra_text () =
+  get_post_extra_text (Parsing.symbol_end_pos ())
+
+let rhs_pre_extra_text pos =
+  get_pre_extra_text (Parsing.rhs_start_pos pos)
+
+let rhs_post_extra_text pos =
+  get_post_extra_text (Parsing.rhs_end_pos pos)
+
+
+(* (Re)Initialise all comment state *)
+
+let init () =
+  docstrings := [];
+  Hashtbl.reset pre_table;
+  Hashtbl.reset post_table;
+  Hashtbl.reset floating_table;
+  Hashtbl.reset pre_extra_table;
+  Hashtbl.reset post_extra_table
diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli
new file mode 100644
index 00000000..500ecbf0
--- /dev/null
+++ b/parsing/docstrings.mli
@@ -0,0 +1,157 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Documentation comments *)
+
+(** (Re)Initialise all docstring state *)
+val init : unit -> unit
+
+(** Emit warnings for unattached and ambiguous docstrings *)
+val warn_bad_docstrings : unit -> unit
+
+(** {3 Docstrings} *)
+
+(** Documentation comments *)
+type docstring
+
+(** Create a docstring *)
+val docstring : string -> Location.t -> docstring
+
+(** Register a docstring *)
+val register : docstring -> unit
+
+(** Get the text of a docstring *)
+val docstring_body : docstring -> string
+
+(** Get the location of a docstring *)
+val docstring_loc : docstring -> Location.t
+
+(** {3 Set functions}
+
+   These functions are used by the lexer to associate docstrings to
+   the locations of tokens. *)
+
+(** Docstrings immediately preceding a token *)
+val set_pre_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following a token *)
+val set_post_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings not immediately adjacent to a token *)
+val set_floating_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following the token which precedes this one *)
+val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately preceding the token which follows this one *)
+val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** {3 Items}
+
+    The {!docs} type represents documentation attached to an item. *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+val empty_docs : docs
+
+val docs_attr : docstring -> Parsetree.attribute
+
+(** Convert item documentation to attributes and add them to an
+    attribute list *)
+val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : unit -> docs
+val symbol_docs_lazy : unit -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : int -> int -> docs
+val rhs_docs_lazy : int -> int -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : unit -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : int -> int -> unit
+
+(** {3 Fields and constructors}
+
+    The {!info} type represents documentation attached to a field or
+    constructor. *)
+
+type info = docstring option
+
+val empty_info : info
+
+val info_attr : docstring -> Parsetree.attribute
+
+(** Convert field info to attributes and add them to an
+    attribute list *)
+val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : unit -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : int -> info
+
+(** {3 Unattached comments}
+
+    The {!text} type represents documentation which is not attached to
+    anything. *)
+
+type text = docstring list
+
+val empty_text : text
+val empty_text_lazy : text Lazy.t
+
+val text_attr : docstring -> Parsetree.attribute
+
+(** Convert text to attributes and add them to an attribute list *)
+val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : unit -> text
+val symbol_text_lazy : unit -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : int -> text
+val rhs_text_lazy : int -> text Lazy.t
+
+(** {3 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : unit -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : unit -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : int -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : int -> text
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
new file mode 100644
index 00000000..63617b48
--- /dev/null
+++ b/parsing/lexer.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexical analyzer *)
+
+val init : unit -> unit
+val token: Lexing.lexbuf -> Parser.token
+val skip_hash_bang: Lexing.lexbuf -> unit
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t
+
+open Format
+
+val report_error: formatter -> error -> unit
+ (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
+
+val in_comment : unit -> bool;;
+val in_string : unit -> bool;;
+
+
+val print_warnings : bool ref
+val handle_docstrings: bool ref
+val comments : unit -> (string * Location.t) list
+val token_with_comments : Lexing.lexbuf -> Parser.token
+
+(*
+  [set_preprocessor init preprocessor] registers [init] as the function
+to call to initialize the preprocessor when the lexer is initialized,
+and [preprocessor] a function that is called when a new token is needed
+by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
+lexing function.
+
+When a preprocessor is configured by calling [set_preprocessor], the lexer
+changes its behavior to accept backslash-newline as a token-separating blank.
+*)
+
+val set_preprocessor :
+  (unit -> unit) ->
+  ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) ->
+  unit
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
new file mode 100644
index 00000000..a485f3ed
--- /dev/null
+++ b/parsing/lexer.mll
@@ -0,0 +1,793 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexer definition *)
+
+{
+open Lexing
+open Misc
+open Parser
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t * Location.t
+  | Keyword_as_label of string
+  | Invalid_literal of string
+  | Invalid_directive of string * string option
+;;
+
+exception Error of error * Location.t;;
+
+(* The table of keywords *)
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "nonrec", NONREC;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+(*  "parser", PARSER; *)
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
+    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr")
+]
+
+(* To buffer string literals *)
+
+let initial_string_buffer = Bytes.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 >= Bytes.length !string_buff then begin
+    let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in
+    Bytes.blit !string_buff 0 new_buff 0 (Bytes.length !string_buff);
+    string_buff := new_buff
+  end;
+  Bytes.unsafe_set !string_buff !string_index c;
+  incr string_index
+
+let store_string s =
+  for i = 0 to String.length s - 1 do
+    store_string_char s.[i];
+  done
+
+let store_lexeme lexbuf =
+  store_string (Lexing.lexeme lexbuf)
+
+let get_stored_string () =
+  let s = Bytes.sub_string !string_buff 0 !string_index in
+  string_buff := initial_string_buffer;
+  s
+
+(* To store the position of the beginning of a string and comment *)
+let string_start_loc = ref Location.none;;
+let comment_start_loc = ref [];;
+let in_comment () = !comment_start_loc <> [];;
+let is_in_string = ref false
+let in_string () = !is_in_string
+let print_warnings = ref true
+
+(* Escaped chars are interpreted in strings unless they are in comments. *)
+let store_escaped_char lexbuf c =
+  if in_comment () then store_lexeme lexbuf else store_string_char c
+
+let with_comment_buffer comment lexbuf =
+  let start_loc = Location.curr lexbuf  in
+  comment_start_loc := [start_loc];
+  reset_string_buffer ();
+  let end_loc = comment lexbuf in
+  let s = get_stored_string () in
+  reset_string_buffer ();
+  let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in
+  s, loc
+
+(* 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 =
+  let c = 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) in
+  if (c < 0 || c > 255) then
+    if in_comment ()
+    then 'x'
+    else raise (Error(Illegal_escape (Lexing.lexeme lexbuf),
+                      Location.curr lexbuf))
+  else Char.chr c
+
+let char_for_octal_code lexbuf i =
+  let c = 64 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
+           8 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
+               (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in
+  Char.chr c
+
+let char_for_hexadecimal_code lexbuf i =
+  let d1 = Char.code (Lexing.lexeme_char lexbuf i) in
+  let val1 = if d1 >= 97 then d1 - 87
+             else if d1 >= 65 then d1 - 55
+             else d1 - 48
+  in
+  let d2 = Char.code (Lexing.lexeme_char lexbuf (i+1)) in
+  let val2 = if d2 >= 97 then d2 - 87
+             else if d2 >= 65 then d2 - 55
+             else d2 - 48
+  in
+  Char.chr (val1 * 16 + val2)
+
+(* recover the name from a LABEL or OPTLABEL token *)
+
+let get_label_name lexbuf =
+  let s = Lexing.lexeme lexbuf in
+  let name = String.sub s 1 (String.length s - 2) in
+  if Hashtbl.mem keyword_table name then
+    raise (Error(Keyword_as_label name, Location.curr lexbuf));
+  name
+;;
+
+(* Update the current location with file name and line number. *)
+
+let update_loc lexbuf file line absolute chars =
+  let pos = lexbuf.lex_curr_p in
+  let new_file = match file with
+                 | None -> pos.pos_fname
+                 | Some s -> s
+  in
+  lexbuf.lex_curr_p <- { pos with
+    pos_fname = new_file;
+    pos_lnum = if absolute then line else pos.pos_lnum + line;
+    pos_bol = pos.pos_cnum - chars;
+  }
+;;
+
+let preprocessor = ref None
+
+let escaped_newlines = ref false
+
+(* Warn about Latin-1 characters used in idents *)
+
+let warn_latin1 lexbuf =
+  Location.prerr_warning (Location.curr lexbuf)
+    (Warnings.Deprecated "ISO-Latin1 characters in identifiers")
+;;
+
+let handle_docstrings = ref true
+let comment_list = ref []
+
+let add_comment com =
+  comment_list := com :: !comment_list
+
+let add_docstring_comment ds =
+  let com =
+    ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds)
+  in
+    add_comment com
+
+let comments () = List.rev !comment_list
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Illegal_character c ->
+      fprintf ppf "Illegal character (%s)" (Char.escaped c)
+  | Illegal_escape s ->
+      fprintf ppf "Illegal backslash escape in string or character (%s)" s
+  | Unterminated_comment _ ->
+      fprintf ppf "Comment not terminated"
+  | Unterminated_string ->
+      fprintf ppf "String literal not terminated"
+  | Unterminated_string_in_comment (_, loc) ->
+      fprintf ppf "This comment contains an unterminated string literal@.\
+                   %aString literal begins here"
+              Location.print_error loc
+  | Keyword_as_label kwd ->
+      fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
+  | Invalid_literal s ->
+      fprintf ppf "Invalid literal %s" s
+  | Invalid_directive (dir, explanation) ->
+      fprintf ppf "Invalid lexer directive %S" dir;
+      begin match explanation with
+        | None -> ()
+        | Some expl -> fprintf ppf ": %s" expl
+      end
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (err, loc) ->
+          Some (Location.error_of_printer loc report_error err)
+      | _ ->
+          None
+    )
+
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let decimal_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+let hex_literal =
+  '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
+let oct_literal =
+  '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
+let bin_literal =
+  '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
+let float_literal =
+  ['0'-'9'] ['0'-'9' '_']*
+  ('.' ['0'-'9' '_']* )?
+  (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let hex_float_literal =
+  '0' ['x' 'X']
+  ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
+  ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
+  (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
+let literal_modifier = ['G'-'Z' 'g'-'z']
+
+rule token = parse
+  | "\\" newline {
+      if not !escaped_newlines then
+        raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
+                     Location.curr lexbuf));
+      update_loc lexbuf None 1 false 0;
+      token lexbuf }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        EOL }
+  | blank +
+      { token lexbuf }
+  | "_"
+      { UNDERSCORE }
+  | "~"
+      { TILDE }
+  | "~" lowercase identchar * ':'
+      { LABEL (get_label_name lexbuf) }
+  | "~" lowercase_latin1 identchar_latin1 * ':'
+      { warn_latin1 lexbuf; LABEL (get_label_name lexbuf) }
+  | "?"
+      { QUESTION }
+  | "?" lowercase identchar * ':'
+      { OPTLABEL (get_label_name lexbuf) }
+  | "?" lowercase_latin1 identchar_latin1 * ':'
+      { warn_latin1 lexbuf; OPTLABEL (get_label_name lexbuf) }
+  | lowercase identchar *
+      { let s = Lexing.lexeme lexbuf in
+        try Hashtbl.find keyword_table s
+        with Not_found -> LIDENT s }
+  | lowercase_latin1 identchar_latin1 *
+      { warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) }
+  | uppercase identchar *
+      { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
+  | uppercase_latin1 identchar_latin1 *
+      { warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) }
+  | int_literal { INT (Lexing.lexeme lexbuf, None) }
+  | (int_literal as lit) (literal_modifier as modif)
+      { INT (lit, Some modif) }
+  | float_literal | hex_float_literal
+      { FLOAT (Lexing.lexeme lexbuf, None) }
+  | ((float_literal | hex_float_literal) as lit) (literal_modifier as modif)
+      { FLOAT (lit, Some modif) }
+  | (float_literal | hex_float_literal | int_literal) identchar+
+      { raise (Error(Invalid_literal (Lexing.lexeme lexbuf),
+                     Location.curr lexbuf)) }
+  | "\""
+      { reset_string_buffer();
+        is_in_string := true;
+        let string_start = lexbuf.lex_start_p in
+        string_start_loc := Location.curr lexbuf;
+        string lexbuf;
+        is_in_string := false;
+        lexbuf.lex_start_p <- string_start;
+        STRING (get_stored_string(), None) }
+  | "{" lowercase* "|"
+      { reset_string_buffer();
+        let delim = Lexing.lexeme lexbuf in
+        let delim = String.sub delim 1 (String.length delim - 2) in
+        is_in_string := true;
+        let string_start = lexbuf.lex_start_p in
+        string_start_loc := Location.curr lexbuf;
+        quoted_string delim lexbuf;
+        is_in_string := false;
+        lexbuf.lex_start_p <- string_start;
+        STRING (get_stored_string(), Some delim) }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        CHAR (Lexing.lexeme_char lexbuf 1) }
+  | "\'" [^ '\\' '\'' '\010' '\013'] "\'"
+      { CHAR(Lexing.lexeme_char lexbuf 1) }
+  | "\'\\" ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] "\'"
+      { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'"
+      { CHAR(char_for_octal_code lexbuf 3) }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { CHAR(char_for_hexadecimal_code lexbuf 3) }
+  | "\'\\" _
+      { let l = Lexing.lexeme lexbuf in
+        let esc = String.sub l 1 (String.length l - 1) in
+        raise (Error(Illegal_escape esc, Location.curr lexbuf))
+      }
+  | "(*"
+      { let s, loc = with_comment_buffer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(**"
+      { let s, loc = with_comment_buffer comment lexbuf in
+        if !handle_docstrings then
+          DOCSTRING (Docstrings.docstring s loc)
+        else
+          COMMENT ("*" ^ s, loc)
+      }
+  | "(**" (('*'+) as stars)
+      { let s, loc =
+          with_comment_buffer
+            (fun lexbuf ->
+               store_string ("*" ^ stars);
+               comment lexbuf)
+            lexbuf
+        in
+        COMMENT (s, loc) }
+  | "(*)"
+      { if !print_warnings then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
+        let s, loc = with_comment_buffer comment lexbuf in
+        COMMENT (s, loc) }
+  | "(*" (('*'*) as stars) "*)"
+      { if !handle_docstrings && stars="" then
+         (* (**) is an empty docstring *)
+          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
+        else
+          COMMENT (stars, Location.curr lexbuf) }
+  | "*)"
+      { let loc = Location.curr lexbuf in
+        Location.prerr_warning loc Warnings.Comment_not_end;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        let curpos = lexbuf.lex_curr_p in
+        lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
+        STAR
+      }
+  | ("#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?) as directive
+        [^ '\010' '\013'] * newline
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let loc = Location.curr lexbuf in
+            let explanation = "line number out of range" in
+            let error = Invalid_directive (directive, Some explanation) in
+            raise (Error (error, loc))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf name line_num true 0;
+            token lexbuf
+      }
+  | "#"  { HASH }
+  | "&"  { AMPERSAND }
+  | "&&" { AMPERAMPER }
+  | "`"  { BACKQUOTE }
+  | "\'" { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "*"  { STAR }
+  | ","  { COMMA }
+  | "->" { MINUSGREATER }
+  | "."  { DOT }
+  | ".." { DOTDOT }
+  | ":"  { COLON }
+  | "::" { COLONCOLON }
+  | ":=" { COLONEQUAL }
+  | ":>" { COLONGREATER }
+  | ";"  { SEMI }
+  | ";;" { SEMISEMI }
+  | "<"  { LESS }
+  | "<-" { LESSMINUS }
+  | "="  { EQUAL }
+  | "["  { LBRACKET }
+  | "[|" { LBRACKETBAR }
+  | "[<" { LBRACKETLESS }
+  | "[>" { LBRACKETGREATER }
+  | "]"  { RBRACKET }
+  | "{"  { LBRACE }
+  | "{<" { LBRACELESS }
+  | "|"  { BAR }
+  | "||" { BARBAR }
+  | "|]" { BARRBRACKET }
+  | ">"  { GREATER }
+  | ">]" { GREATERRBRACKET }
+  | "}"  { RBRACE }
+  | ">}" { GREATERRBRACE }
+  | "[@" { LBRACKETAT }
+  | "[@@"  { LBRACKETATAT }
+  | "[@@@" { LBRACKETATATAT }
+  | "[%"   { LBRACKETPERCENT }
+  | "[%%"  { LBRACKETPERCENTPERCENT }
+  | "!"  { BANG }
+  | "!=" { INFIXOP0 "!=" }
+  | "+"  { PLUS }
+  | "+." { PLUSDOT }
+  | "+=" { PLUSEQ }
+  | "-"  { MINUS }
+  | "-." { MINUSDOT }
+
+  | "!" symbolchar +
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['~' '?'] symbolchar +
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar *
+            { INFIXOP0(Lexing.lexeme lexbuf) }
+  | ['@' '^'] symbolchar *
+            { INFIXOP1(Lexing.lexeme lexbuf) }
+  | ['+' '-'] symbolchar *
+            { INFIXOP2(Lexing.lexeme lexbuf) }
+  | "**" symbolchar *
+            { INFIXOP4(Lexing.lexeme lexbuf) }
+  | '%'     { PERCENT }
+  | ['*' '/' '%'] symbolchar *
+            { INFIXOP3(Lexing.lexeme lexbuf) }
+  | '#' (symbolchar | '#') +
+            { HASHOP(Lexing.lexeme lexbuf) }
+  | eof { EOF }
+  | _
+      { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
+                     Location.curr lexbuf))
+      }
+
+and comment = parse
+    "(*"
+      { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
+        store_lexeme lexbuf;
+        comment lexbuf;
+      }
+  | "*)"
+      { match !comment_start_loc with
+        | [] -> assert false
+        | [_] -> comment_start_loc := []; Location.curr lexbuf
+        | _ :: l -> comment_start_loc := l;
+                  store_lexeme lexbuf;
+                  comment lexbuf;
+       }
+  | "\""
+      {
+        string_start_loc := Location.curr lexbuf;
+        store_string_char '\"';
+        is_in_string := true;
+        begin try string lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            raise (Error (Unterminated_string_in_comment (start, str_start),
+                          loc))
+        end;
+        is_in_string := false;
+        store_string_char '\"';
+        comment lexbuf }
+  | "{" lowercase* "|"
+      {
+        let delim = Lexing.lexeme lexbuf in
+        let delim = String.sub delim 1 (String.length delim - 2) in
+        string_start_loc := Location.curr lexbuf;
+        store_lexeme lexbuf;
+        is_in_string := true;
+        begin try quoted_string delim lexbuf
+        with Error (Unterminated_string, str_start) ->
+          match !comment_start_loc with
+          | [] -> assert false
+          | loc :: _ ->
+            let start = List.hd (List.rev !comment_start_loc) in
+            comment_start_loc := [];
+            raise (Error (Unterminated_string_in_comment (start, str_start),
+                          loc))
+        end;
+        is_in_string := false;
+        store_string_char '|';
+        store_string delim;
+        store_string_char '}';
+        comment lexbuf }
+
+  | "\'\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'" newline "\'"
+      { update_loc lexbuf None 1 false 1;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | "\'" [^ '\\' '\'' '\010' '\013' ] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'"
+      { store_lexeme lexbuf; comment lexbuf }
+  | eof
+      { match !comment_start_loc with
+        | [] -> assert false
+        | loc :: _ ->
+          let start = List.hd (List.rev !comment_start_loc) in
+          comment_start_loc := [];
+          raise (Error (Unterminated_comment start, loc))
+      }
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        comment lexbuf
+      }
+  | _
+      { store_lexeme lexbuf; comment lexbuf }
+
+and string = parse
+    '\"'
+      { () }
+  | '\\' newline ([' ' '\t'] * as space)
+      { update_loc lexbuf None 1 false (String.length space);
+        if in_comment () then store_lexeme lexbuf;
+        string lexbuf
+      }
+  | '\\' ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' ']
+      { store_escaped_char lexbuf
+                           (char_for_backslash(Lexing.lexeme_char lexbuf 1));
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1);
+         string lexbuf }
+  | '\\' 'o' ['0'-'3'] ['0'-'7'] ['0'-'7']
+      { store_escaped_char lexbuf (char_for_octal_code lexbuf 2);
+         string lexbuf }
+  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
+      { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2);
+         string lexbuf }
+  | '\\' _
+      { if not (in_comment ()) then begin
+(*  Should be an error, but we are very lax.
+          raise (Error (Illegal_escape (Lexing.lexeme lexbuf),
+                        Location.curr lexbuf))
+*)
+          let loc = Location.curr lexbuf in
+          Location.prerr_warning loc Warnings.Illegal_backslash;
+        end;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | newline
+      { if not (in_comment ()) then
+          Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
+        update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        string lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        raise (Error (Unterminated_string, !string_start_loc)) }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        string lexbuf }
+
+and quoted_string delim = parse
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        quoted_string delim lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        raise (Error (Unterminated_string, !string_start_loc)) }
+  | "|" lowercase* "}"
+      {
+        let edelim = Lexing.lexeme lexbuf in
+        let edelim = String.sub edelim 1 (String.length edelim - 2) in
+        if delim = edelim then ()
+        else (store_lexeme lexbuf; quoted_string delim lexbuf)
+      }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        quoted_string delim lexbuf }
+
+and skip_hash_bang = parse
+  | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
+       { update_loc lexbuf None 3 false 0 }
+  | "#!" [^ '\n']* '\n'
+       { update_loc lexbuf None 1 false 0 }
+  | "" { () }
+
+{
+
+  let token_with_comments lexbuf =
+    match !preprocessor with
+    | None -> token lexbuf
+    | Some (_init, preprocess) -> preprocess token lexbuf
+
+  type newline_state =
+    | NoLine (* There have been no blank lines yet. *)
+    | NewLine
+        (* There have been no blank lines, and the previous
+           token was a newline. *)
+    | BlankLine (* There have been blank lines. *)
+
+  type doc_state =
+    | Initial  (* There have been no docstrings yet *)
+    | After of docstring list
+        (* There have been docstrings, none of which were
+           preceeded by a blank line *)
+    | Before of docstring list * docstring list * docstring list
+        (* There have been docstrings, some of which were
+           preceeded by a blank line *)
+
+  and docstring = Docstrings.docstring
+
+  let token lexbuf =
+    let post_pos = lexeme_end_p lexbuf in
+    let attach lines docs pre_pos =
+      let open Docstrings in
+        match docs, lines with
+        | Initial, _ -> ()
+        | After a, (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_docstrings pre_pos a;
+        | After a, BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_pre_extra_docstrings pre_pos (List.rev a)
+        | Before(a, f, b), (NoLine | NewLine) ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos (List.rev f);
+            set_pre_extra_docstrings pre_pos (List.rev a);
+            set_pre_docstrings pre_pos b
+        | Before(a, f, b), BlankLine ->
+            set_post_docstrings post_pos (List.rev a);
+            set_post_extra_docstrings post_pos
+              (List.rev_append f (List.rev b));
+            set_floating_docstrings pre_pos
+              (List.rev_append f (List.rev b));
+            set_pre_extra_docstrings pre_pos (List.rev a)
+    in
+    let rec loop lines docs lexbuf =
+      match token_with_comments lexbuf with
+      | COMMENT (s, loc) ->
+          add_comment (s, loc);
+          let lines' =
+            match lines with
+            | NoLine -> NoLine
+            | NewLine -> NoLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | EOL ->
+          let lines' =
+            match lines with
+            | NoLine -> NewLine
+            | NewLine -> BlankLine
+            | BlankLine -> BlankLine
+          in
+          loop lines' docs lexbuf
+      | DOCSTRING doc ->
+          Docstrings.register doc;
+          add_docstring_comment doc;
+          let docs' =
+            if Docstrings.docstring_body doc = "/*" then
+              match docs with
+              | Initial -> Before([], [doc], [])
+              | After a -> Before (a, [doc], [])
+              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
+            else
+              match docs, lines with
+              | Initial, (NoLine | NewLine) -> After [doc]
+              | Initial, BlankLine -> Before([], [], [doc])
+              | After a, (NoLine | NewLine) -> After (doc :: a)
+              | After a, BlankLine -> Before (a, [], [doc])
+              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
+              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
+          in
+          loop NoLine docs' lexbuf
+      | tok ->
+          attach lines docs (lexeme_start_p lexbuf);
+          tok
+    in
+      loop NoLine Initial lexbuf
+
+  let init () =
+    is_in_string := false;
+    comment_start_loc := [];
+    comment_list := [];
+    match !preprocessor with
+    | None -> ()
+    | Some (init, _preprocess) -> init ()
+
+  let set_preprocessor init preprocess =
+    escaped_newlines := true;
+    preprocessor := Some (init, preprocess)
+
+}
diff --git a/parsing/location.ml b/parsing/location.ml
new file mode 100644
index 00000000..abe47ef0
--- /dev/null
+++ b/parsing/location.ml
@@ -0,0 +1,469 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexing
+
+let absname = ref false
+    (* This reference should be in Clflags, but it would create an additional
+       dependency and make bootstrapping Camlp4 more difficult. *)
+
+type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
+
+let in_file name =
+  let loc = {
+    pos_fname = name;
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = -1;
+  } in
+  { loc_start = loc; loc_end = loc; loc_ghost = true }
+;;
+
+let none = in_file "_none_";;
+
+let curr lexbuf = {
+  loc_start = lexbuf.lex_start_p;
+  loc_end = lexbuf.lex_curr_p;
+  loc_ghost = false
+};;
+
+let init lexbuf fname =
+  lexbuf.lex_curr_p <- {
+    pos_fname = fname;
+    pos_lnum = 1;
+    pos_bol = 0;
+    pos_cnum = 0;
+  }
+;;
+
+let symbol_rloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = false;
+};;
+
+let symbol_gloc () = {
+  loc_start = Parsing.symbol_start_pos ();
+  loc_end = Parsing.symbol_end_pos ();
+  loc_ghost = true;
+};;
+
+let rhs_loc n = {
+  loc_start = Parsing.rhs_start_pos n;
+  loc_end = Parsing.rhs_end_pos n;
+  loc_ghost = false;
+};;
+
+let input_name = ref "_none_"
+let input_lexbuf = ref (None : lexbuf option)
+
+(* Terminal info *)
+
+let status = ref Terminfo.Uninitialised
+
+let num_loc_lines = ref 0 (* number of lines already printed after input *)
+
+let print_updating_num_loc_lines ppf f arg =
+  let open Format in
+  let out_functions = pp_get_formatter_out_functions ppf () in
+  let out_string str start len =
+    let rec count i c =
+      if i = start + len then c
+      else if String.get str i = '\n' then count (succ i) (succ c)
+      else count (succ i) c in
+    num_loc_lines := !num_loc_lines + count start 0 ;
+    out_functions.out_string str start len in
+  pp_set_formatter_out_functions ppf
+    { out_functions with out_string } ;
+  f ppf arg ;
+  pp_print_flush ppf ();
+  pp_set_formatter_out_functions ppf out_functions
+
+(* Highlight the locations using standout mode. *)
+
+let highlight_terminfo ppf num_lines lb locs =
+  Format.pp_print_flush ppf ();  (* avoid mixing Format and normal output *)
+  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
+  let pos0 = -lb.lex_abs_pos in
+  (* Do nothing if the buffer does not contain the whole phrase. *)
+  if pos0 < 0 then raise Exit;
+  (* Count number of lines in phrase *)
+  let lines = ref !num_loc_lines in
+  for i = pos0 to lb.lex_buffer_len - 1 do
+    if Bytes.get lb.lex_buffer i = '\n' then incr lines
+  done;
+  (* If too many lines, give up *)
+  if !lines >= num_lines - 2 then raise Exit;
+  (* Move cursor up that number of lines *)
+  flush stdout; Terminfo.backup !lines;
+  (* Print the input, switching to standout for the location *)
+  let bol = ref false in
+  print_string "# ";
+  for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
+    if !bol then (print_string "  "; bol := false);
+    if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
+      Terminfo.standout true;
+    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
+      Terminfo.standout false;
+    let c = Bytes.get lb.lex_buffer (pos + pos0) in
+    print_char c;
+    bol := (c = '\n')
+  done;
+  (* Make sure standout mode is over *)
+  Terminfo.standout false;
+  (* Position cursor back to original location *)
+  Terminfo.resume !num_loc_lines;
+  flush stdout
+
+(* Highlight the location by printing it again. *)
+
+let highlight_dumb ppf lb loc =
+  (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
+  let pos0 = -lb.lex_abs_pos in
+  (* Do nothing if the buffer does not contain the whole phrase. *)
+  if pos0 < 0 then raise Exit;
+  let end_pos = lb.lex_buffer_len - pos0 - 1 in
+  (* Determine line numbers for the start and end points *)
+  let line_start = ref 0 and line_end = ref 0 in
+  for pos = 0 to end_pos do
+    if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin
+      if loc.loc_start.pos_cnum > pos then incr line_start;
+      if loc.loc_end.pos_cnum   > pos then incr line_end;
+    end
+  done;
+  (* Print character location (useful for Emacs) *)
+  Format.fprintf ppf "Characters %i-%i:@."
+                 loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
+  (* Print the input, underlining the location *)
+  Format.pp_print_string ppf "  ";
+  let line = ref 0 in
+  let pos_at_bol = ref 0 in
+  for pos = 0 to end_pos do
+    match Bytes.get lb.lex_buffer (pos + pos0) with
+    | '\n' ->
+      if !line = !line_start && !line = !line_end then begin
+        (* loc is on one line: underline location *)
+        Format.fprintf ppf "@.  ";
+        for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
+          Format.pp_print_char ppf ' '
+        done;
+        for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
+          Format.pp_print_char ppf '^'
+        done
+      end;
+      if !line >= !line_start && !line <= !line_end then begin
+        Format.fprintf ppf "@.";
+        if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf "  "
+      end;
+      incr line;
+      pos_at_bol := pos + 1
+    | '\r' -> () (* discard *)
+    | c ->
+      if !line = !line_start && !line = !line_end then
+        (* loc is on one line: print whole line *)
+        Format.pp_print_char ppf c
+      else if !line = !line_start then
+        (* first line of multiline loc:
+           print a dot for each char before loc_start *)
+        if pos < loc.loc_start.pos_cnum then
+          Format.pp_print_char ppf '.'
+        else
+          Format.pp_print_char ppf c
+      else if !line = !line_end then
+        (* last line of multiline loc: print a dot for each char
+           after loc_end, even whitespaces *)
+        if pos < loc.loc_end.pos_cnum then
+          Format.pp_print_char ppf c
+        else
+          Format.pp_print_char ppf '.'
+      else if !line > !line_start && !line < !line_end then
+        (* intermediate line of multiline loc: print whole line *)
+        Format.pp_print_char ppf c
+  done
+
+(* Highlight the location using one of the supported modes. *)
+
+let rec highlight_locations ppf locs =
+  match !status with
+    Terminfo.Uninitialised ->
+      status := Terminfo.setup stdout; highlight_locations ppf locs
+  | Terminfo.Bad_term ->
+      begin match !input_lexbuf with
+        None -> false
+      | Some lb ->
+          let norepeat =
+            try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
+          if norepeat then false else
+            let loc1 = List.hd locs in
+            try highlight_dumb ppf lb loc1; true
+            with Exit -> false
+      end
+  | Terminfo.Good_term num_lines ->
+      begin match !input_lexbuf with
+        None -> false
+      | Some lb ->
+          try highlight_terminfo ppf num_lines lb locs; true
+          with Exit -> false
+      end
+
+(* Print the location in some way or another *)
+
+open Format
+
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s = if is_relative s then concat (Sys.getcwd ()) s else s in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  if !absname then absolute_path file else file
+
+let print_filename ppf file =
+  Format.fprintf ppf "%s" (show_filename file)
+
+let reset () =
+  num_loc_lines := 0
+
+let (msg_file, msg_line, msg_chars, msg_to, msg_colon) =
+  ("File \"", "\", line ", ", characters ", "-", ":")
+
+(* return file, line, char from the given position *)
+let get_pos_info pos =
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
+;;
+
+let setup_colors () =
+  Misc.Color.setup !Clflags.color
+
+let print_loc ppf loc =
+  setup_colors ();
+  let (file, line, startchar) = get_pos_info loc.loc_start in
+  let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+  if file = "//toplevel//" then begin
+    if highlight_locations ppf [loc] then () else
+      fprintf ppf "Characters %i-%i"
+              loc.loc_start.pos_cnum loc.loc_end.pos_cnum
+  end else begin
+    fprintf ppf "%s@{<loc>%a%s%i" msg_file print_filename file msg_line line;
+    if startchar >= 0 then
+      fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar;
+    fprintf ppf "@}"
+  end
+;;
+
+let print ppf loc =
+  setup_colors ();
+  if loc.loc_start.pos_fname = "//toplevel//"
+  && highlight_locations ppf [loc] then ()
+  else fprintf ppf "@{<loc>%a@}%s@." print_loc loc msg_colon
+;;
+
+let error_prefix = "Error"
+let warning_prefix = "Warning"
+
+let print_error_prefix ppf () =
+  setup_colors ();
+  fprintf ppf "@{<error>%s@}:" error_prefix;
+  ()
+;;
+
+let print_compact ppf loc =
+  if loc.loc_start.pos_fname = "//toplevel//"
+  && highlight_locations ppf [loc] then ()
+  else begin
+    let (file, line, startchar) = get_pos_info loc.loc_start in
+    let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+    fprintf ppf "%a:%i" print_filename file line;
+    if startchar >= 0 then fprintf ppf ",%i--%i" startchar endchar
+  end
+;;
+
+let print_error ppf loc =
+  print ppf loc;
+  print_error_prefix ppf ()
+;;
+
+let print_error_cur_file ppf () = print_error ppf (in_file !input_name);;
+
+let default_warning_printer loc ppf w =
+  if Warnings.is_active w then begin
+    setup_colors ();
+    print ppf loc;
+    fprintf ppf "@{<warning>%s@} %a@." warning_prefix Warnings.print w
+  end
+;;
+
+let warning_printer = ref default_warning_printer ;;
+
+let print_warning loc ppf w =
+  print_updating_num_loc_lines ppf (!warning_printer loc) w
+;;
+
+let formatter_for_warnings = ref err_formatter;;
+let prerr_warning loc w = print_warning loc !formatter_for_warnings w;;
+
+let echo_eof () =
+  print_newline ();
+  incr num_loc_lines
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+let mkloc txt loc = { txt ; loc }
+let mknoloc txt = mkloc txt none
+
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+    if_highlight: string; (* alternative message if locations are highlighted *)
+  }
+
+let pp_ksprintf ?before k fmt =
+  let buf = Buffer.create 64 in
+  let ppf = Format.formatter_of_buffer buf in
+  Misc.Color.set_color_tag_handling ppf;
+  begin match before with
+    | None -> ()
+    | Some f -> f ppf
+  end;
+  kfprintf
+    (fun _ ->
+      pp_print_flush ppf ();
+      let msg = Buffer.contents buf in
+      k msg)
+    ppf fmt
+
+(* Shift the formatter's offset by the length of the error prefix, which
+   is always added by the compiler after the message has been formatted *)
+let print_phanton_error_prefix ppf =
+  Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
+
+let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
+  pp_ksprintf
+    ~before:print_phanton_error_prefix
+    (fun msg -> {loc; msg; sub; if_highlight})
+    fmt
+
+let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
+  {loc; msg; sub; if_highlight}
+
+let error_of_exn : (exn -> error option) list ref = ref []
+
+let register_error_of_exn f = error_of_exn := f :: !error_of_exn
+
+let error_of_exn exn =
+  let rec loop = function
+    | [] -> None
+    | f :: rest ->
+        match f exn with
+        | Some _ as r -> r
+        | None -> loop rest
+  in
+  loop !error_of_exn
+
+let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
+  let highlighted =
+    if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then
+      let rec collect_locs locs {loc; sub; _} =
+        List.fold_left collect_locs (loc :: locs) sub
+      in
+      let locs = collect_locs [] err in
+      highlight_locations ppf locs
+    else
+      false
+  in
+  if highlighted then
+    Format.pp_print_string ppf if_highlight
+  else begin
+    fprintf ppf "%a%a %s" print loc print_error_prefix () msg;
+    List.iter (Format.fprintf ppf "@\n@[<2>%a@]" default_error_reporter) sub
+  end
+
+let error_reporter = ref default_error_reporter
+
+let report_error ppf err =
+  print_updating_num_loc_lines ppf !error_reporter err
+;;
+
+let error_of_printer loc print x =
+  errorf ~loc "%a@?" print x
+
+let error_of_printer_file print x =
+  error_of_printer (in_file !input_name) print x
+
+let () =
+  register_error_of_exn
+    (function
+      | Sys_error msg ->
+          Some (errorf ~loc:(in_file !input_name)
+                "I/O error: %s" msg)
+      | Warnings.Errors n ->
+          Some
+            (errorf ~loc:(in_file !input_name)
+             "Some fatal warnings were triggered (%d occurrences)" n)
+
+      | Misc.HookExnWrapper {error = e; hook_name;
+                             hook_info={Misc.sourcefile}} ->
+          let sub = match error_of_exn e with
+            | None -> error (Printexc.to_string e)
+            | Some err -> err
+          in
+          Some
+            (errorf ~loc:(in_file sourcefile)
+               "In hook %S:" hook_name
+               ~sub:[sub])
+      | _ -> None
+    )
+
+external reraise : exn -> 'a = "%reraise"
+
+let rec report_exception_rec n ppf exn =
+  try match error_of_exn exn with
+  | Some err ->
+      fprintf ppf "@[%a@]@." report_error err
+  | None -> reraise exn
+  with exn when n > 0 ->
+    report_exception_rec (n-1) ppf exn
+
+let report_exception ppf exn = report_exception_rec 5 ppf exn
+
+
+exception Error of error
+
+let () =
+  register_error_of_exn
+    (function
+      | Error e -> Some e
+      | _ -> None
+    )
+
+let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
+  pp_ksprintf
+    ~before:print_phanton_error_prefix
+    (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
diff --git a/parsing/location.mli b/parsing/location.mli
new file mode 100644
index 00000000..4a7ac959
--- /dev/null
+++ b/parsing/location.mli
@@ -0,0 +1,141 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Source code locations (ranges of positions), used in parsetree. *)
+
+open Format
+
+type t = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
+(** Note on the use of Lexing.position in this module.
+   If [pos_fname = ""], then use [!input_name] instead.
+   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
+     re-parse the file to get the line and character numbers.
+   Else all fields are correct.
+*)
+
+val none : t
+(** An arbitrary value of type [t]; describes an empty ghost range. *)
+
+val in_file : string -> t
+(** Return an empty ghost range located in a given file. *)
+
+val init : Lexing.lexbuf -> string -> unit
+(** Set the file name and line number of the [lexbuf] to be the start
+    of the named file. *)
+
+val curr : Lexing.lexbuf -> t
+(** Get the location of the current token from the [lexbuf]. *)
+
+val symbol_rloc: unit -> t
+val symbol_gloc: unit -> t
+
+(** [rhs_loc n] returns the location of the symbol at position [n], starting
+  at 1, in the current parser rule. *)
+val rhs_loc: int -> t
+
+val input_name: string ref
+val input_lexbuf: Lexing.lexbuf option ref
+
+val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
+val print_loc: formatter -> t -> unit
+val print_error: formatter -> t -> unit
+val print_error_cur_file: formatter -> unit -> unit
+val print_warning: t -> formatter -> Warnings.t -> unit
+val formatter_for_warnings : formatter ref
+val prerr_warning: t -> Warnings.t -> unit
+val echo_eof: unit -> unit
+val reset: unit -> unit
+
+val warning_printer : (t -> formatter -> Warnings.t -> unit) ref
+(** Hook for intercepting warnings. *)
+
+val default_warning_printer : t -> formatter -> Warnings.t -> unit
+(** Original warning printer for use in hooks. *)
+
+val highlight_locations: formatter -> t list -> bool
+
+type 'a loc = {
+  txt : 'a;
+  loc : t;
+}
+
+val mknoloc : 'a -> 'a loc
+val mkloc : 'a -> t -> 'a loc
+
+val print: formatter -> t -> unit
+val print_compact: formatter -> t -> unit
+val print_filename: formatter -> string -> unit
+
+val absolute_path: string -> string
+
+val show_filename: string -> string
+    (** In -absname mode, return the absolute path for this filename.
+        Otherwise, returns the filename unchanged. *)
+
+
+val absname: bool ref
+
+(* Support for located errors *)
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+    if_highlight: string; (* alternative message if locations are highlighted *)
+  }
+
+exception Error of error
+
+val print_error_prefix: formatter -> unit -> unit
+  (* print the prefix "Error:" possibly with style *)
+
+val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
+
+val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
+            -> ('a, Format.formatter, unit, error) format4 -> 'a
+
+val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
+            -> ('a, Format.formatter, unit, 'b) format4 -> 'a
+
+val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
+
+val error_of_exn: exn -> error option
+
+val register_error_of_exn: (exn -> error option) -> unit
+  (* Each compiler module which defines a custom type of exception
+     which can surface as a user-visible error should register
+     a "printer" for this exception using [register_error_of_exn].
+     The result of the printer is an [error] value containing
+     a location, a message, and optionally sub-messages (each of them
+     being located as well). *)
+
+val report_error: formatter -> error -> unit
+
+val error_reporter : (formatter -> error -> unit) ref
+(** Hook for intercepting error reports. *)
+
+val default_error_reporter : formatter -> error -> unit
+(** Original error reporter for use in hooks. *)
+
+val report_exception: formatter -> exn -> unit
+  (* Reraise the exception if it is unknown. *)
diff --git a/parsing/longident.ml b/parsing/longident.ml
new file mode 100644
index 00000000..04677ca0
--- /dev/null
+++ b/parsing/longident.ml
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+let rec flat accu = function
+    Lident s -> s :: accu
+  | Ldot(lid, s) -> flat (s :: accu) lid
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
+
+let flatten lid = flat [] lid
+
+let last = function
+    Lident s -> s
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
+
+let rec split_at_dots s pos =
+  try
+    let dot = String.index_from s pos '.' in
+    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
+  with Not_found ->
+    [String.sub s pos (String.length s - pos)]
+
+let parse s =
+  match split_at_dots s 0 with
+    [] -> Lident ""  (* should not happen, but don't put assert false
+                        so as not to crash the toplevel (see Genprintval) *)
+  | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl
diff --git a/parsing/longident.mli b/parsing/longident.mli
new file mode 100644
index 00000000..c7e7f3d2
--- /dev/null
+++ b/parsing/longident.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Long identifiers, used in parsetree. *)
+
+type t =
+    Lident of string
+  | Ldot of t * string
+  | Lapply of t * t
+
+val flatten: t -> string list
+val last: t -> string
+val parse: string -> t
diff --git a/parsing/parse.ml b/parsing/parse.ml
new file mode 100644
index 00000000..ba89f0e2
--- /dev/null
+++ b/parsing/parse.ml
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Entry points in the parser *)
+
+(* Skip tokens to the end of the phrase *)
+
+let rec skip_phrase lexbuf =
+  try
+    match Lexer.token lexbuf with
+      Parser.SEMISEMI | Parser.EOF -> ()
+    | _ -> skip_phrase lexbuf
+  with
+    | Lexer.Error (Lexer.Unterminated_comment _, _)
+    | Lexer.Error (Lexer.Unterminated_string, _)
+    | Lexer.Error (Lexer.Unterminated_string_in_comment _, _)
+    | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf
+;;
+
+let maybe_skip_phrase lexbuf =
+  if Parsing.is_current_lookahead Parser.SEMISEMI
+  || Parsing.is_current_lookahead Parser.EOF
+  then ()
+  else skip_phrase lexbuf
+
+let wrap parsing_fun lexbuf =
+  try
+    Docstrings.init ();
+    Lexer.init ();
+    let ast = parsing_fun Lexer.token lexbuf in
+    Parsing.clear_parser();
+    Docstrings.warn_bad_docstrings ();
+    ast
+  with
+  | Lexer.Error(Lexer.Illegal_character _, _) as err
+    when !Location.input_name = "//toplevel//"->
+      skip_phrase lexbuf;
+      raise err
+  | Syntaxerr.Error _ as err
+    when !Location.input_name = "//toplevel//" ->
+      maybe_skip_phrase lexbuf;
+      raise err
+  | Parsing.Parse_error | Syntaxerr.Escape_error ->
+      let loc = Location.curr lexbuf in
+      if !Location.input_name = "//toplevel//"
+      then maybe_skip_phrase lexbuf;
+      raise(Syntaxerr.Error(Syntaxerr.Other loc))
+
+let implementation = wrap Parser.implementation
+and interface = wrap Parser.interface
+and toplevel_phrase = wrap Parser.toplevel_phrase
+and use_file = wrap Parser.use_file
+and core_type = wrap Parser.parse_core_type
+and expression = wrap Parser.parse_expression
+and pattern = wrap Parser.parse_pattern
diff --git a/parsing/parse.mli b/parsing/parse.mli
new file mode 100644
index 00000000..8e6eb454
--- /dev/null
+++ b/parsing/parse.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Entry points in the parser *)
+
+val implementation : Lexing.lexbuf -> Parsetree.structure
+val interface : Lexing.lexbuf -> Parsetree.signature
+val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
+val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
+val core_type : Lexing.lexbuf -> Parsetree.core_type
+val expression : Lexing.lexbuf -> Parsetree.expression
+val pattern : Lexing.lexbuf -> Parsetree.pattern
diff --git a/parsing/parser.mly b/parsing/parser.mly
new file mode 100644
index 00000000..f444810e
--- /dev/null
+++ b/parsing/parser.mly
@@ -0,0 +1,2582 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* The parser definition */
+
+%{
+open Location
+open Asttypes
+open Longident
+open Parsetree
+open Ast_helper
+open Docstrings
+
+let mktyp d = Typ.mk ~loc:(symbol_rloc()) d
+let mkpat d = Pat.mk ~loc:(symbol_rloc()) d
+let mkexp d = Exp.mk ~loc:(symbol_rloc()) d
+let mkmty ?attrs d = Mty.mk ~loc:(symbol_rloc()) ?attrs d
+let mksig d = Sig.mk ~loc:(symbol_rloc()) d
+let mkmod ?attrs d = Mod.mk ~loc:(symbol_rloc()) ?attrs d
+let mkstr d = Str.mk ~loc:(symbol_rloc()) d
+let mkclass ?attrs d = Cl.mk ~loc:(symbol_rloc()) ?attrs d
+let mkcty ?attrs d = Cty.mk ~loc:(symbol_rloc()) ?attrs d
+let mkctf ?attrs ?docs d =
+  Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
+let mkcf ?attrs ?docs d =
+  Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
+
+let mkrhs rhs pos = mkloc rhs (rhs_loc pos)
+
+let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
+let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
+
+let mkoperator name pos =
+  let loc = rhs_loc pos in
+  Exp.mk ~loc (Pexp_ident(mkloc (Lident name) loc))
+
+let mkpatvar name pos =
+  Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos))
+
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitly in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -annot option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
+*)
+let ghexp d = Exp.mk ~loc:(symbol_gloc ()) d
+let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d
+let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d
+let ghloc d = { txt = d; loc = symbol_gloc () }
+let ghstr d = Str.mk ~loc:(symbol_gloc()) d
+let ghsig d = Sig.mk ~loc:(symbol_gloc()) d
+
+let mkinfix arg1 name arg2 =
+  mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2]))
+
+let neg_string f =
+  if String.length f > 0 && f.[0] = '-'
+  then String.sub f 1 (String.length f - 1)
+  else "-" ^ f
+
+let mkuminus name arg =
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Pconst_integer (n,m)) ->
+      mkexp(Pexp_constant(Pconst_integer(neg_string n,m)))
+  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
+      mkexp(Pexp_constant(Pconst_float(neg_string f, m)))
+  | _ ->
+      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
+
+let mkuplus name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Pconst_integer _)
+  | ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc
+  | _ ->
+      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
+
+let mkexp_cons consloc args loc =
+  Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args))
+
+let mkpat_cons consloc args loc =
+  Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args))
+
+let rec mktailexp nilloc = function
+    [] ->
+      let loc = { nilloc with loc_ghost = true } in
+      let nil = { txt = Lident "[]"; loc = loc } in
+      Exp.mk ~loc (Pexp_construct (nil, None))
+  | e1 :: el ->
+      let exp_el = mktailexp nilloc el in
+      let loc = {loc_start = e1.pexp_loc.loc_start;
+               loc_end = exp_el.pexp_loc.loc_end;
+               loc_ghost = true}
+      in
+      let arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in
+      mkexp_cons {loc with loc_ghost = true} arg loc
+
+let rec mktailpat nilloc = function
+    [] ->
+      let loc = { nilloc with loc_ghost = true } in
+      let nil = { txt = Lident "[]"; loc = loc } in
+      Pat.mk ~loc (Ppat_construct (nil, None))
+  | p1 :: pl ->
+      let pat_pl = mktailpat nilloc pl in
+      let loc = {loc_start = p1.ppat_loc.loc_start;
+               loc_end = pat_pl.ppat_loc.loc_end;
+               loc_ghost = true}
+      in
+      let arg = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in
+      mkpat_cons {loc with loc_ghost = true} arg loc
+
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
+
+let mkexp_constraint e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp(Pexp_constraint(e, t))
+  | _, Some t -> ghexp(Pexp_coerce(e, t1, t))
+  | None, None -> assert false
+
+let mkexp_opt_constraint e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint e constraint_
+
+let mkpat_opt_constraint p = function
+  | None -> p
+  | Some typ -> mkpat (Ppat_constraint(p, typ))
+
+let array_function str name =
+  ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
+
+let syntax_error () =
+  raise Syntaxerr.Escape_error
+
+let unclosed opening_name opening_num closing_name closing_num =
+  raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name,
+                                           rhs_loc closing_num, closing_name)))
+
+let expecting pos nonterm =
+    raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))
+
+let not_expecting pos nonterm =
+    raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm)))
+
+let bigarray_function str name =
+  ghloc (Ldot(Ldot(Lident "Bigarray", str), name))
+
+let bigarray_untuplify = function
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
+  | exp -> [exp]
+
+let bigarray_get arr arg =
+  let get = if !Clflags.fast then "unsafe_get" else "get" in
+  match bigarray_untuplify arg with
+    [c1] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
+                       [Nolabel, arr; Nolabel, c1]))
+  | [c1;c2] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
+  | [c1;c2;c3] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
+  | coords ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
+                       [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
+
+let bigarray_set arr arg newval =
+  let set = if !Clflags.fast then "unsafe_set" else "set" in
+  match bigarray_untuplify arg with
+    [c1] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
+  | [c1;c2] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),
+                       [Nolabel, arr; Nolabel, c1;
+                        Nolabel, c2; Nolabel, newval]))
+  | [c1;c2;c3] ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),
+                       [Nolabel, arr; Nolabel, c1;
+                        Nolabel, c2; Nolabel, c3; Nolabel, newval]))
+  | coords ->
+      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
+                       [Nolabel, arr;
+                        Nolabel, ghexp(Pexp_array coords);
+                        Nolabel, newval]))
+
+let lapply p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc())))
+
+let exp_of_label lbl pos =
+  mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos))
+
+let pat_of_label lbl pos =
+  mkpat (Ppat_var (mkrhs (Longident.last lbl) pos))
+
+let mk_newtypes newtypes exp =
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation newtypes core_type body =
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs body (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+  match ext with
+  | None -> body
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
+
+let mkexp_attrs d attrs =
+  wrap_exp_attrs (mkexp d) attrs
+
+let wrap_typ_attrs typ (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
+  match ext with
+  | None -> typ
+  | Some id -> ghtyp(Ptyp_extension (id, PTyp typ))
+
+let mktyp_attrs d attrs =
+  wrap_typ_attrs (mktyp d) attrs
+
+let wrap_pat_attrs pat (ext, attrs) =
+  (* todo: keep exact location for the entire attribute *)
+  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
+  match ext with
+  | None -> pat
+  | Some id -> ghpat(Ppat_extension (id, PPat (pat, None)))
+
+let mkpat_attrs d attrs =
+  wrap_pat_attrs (mkpat d) attrs
+
+let wrap_class_attrs body attrs =
+  {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_mod_attrs body attrs =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs body attrs =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+
+let wrap_str_ext body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghstr(Pstr_extension ((id, PStr [body]), []))
+
+let mkstr_ext d ext =
+  wrap_str_ext (mkstr d) ext
+
+let wrap_sig_ext body ext =
+  match ext with
+  | None -> body
+  | Some id -> ghsig(Psig_extension ((id, PSig [body]), []))
+
+let mksig_ext d ext =
+  wrap_sig_ext (mksig d) ext
+
+let text_str pos = Str.text (rhs_text pos)
+let text_sig pos = Sig.text (rhs_text pos)
+let text_cstr pos = Cf.text (rhs_text pos)
+let text_csig pos = Ctf.text (rhs_text pos)
+let text_def pos = [Ptop_def (Str.text (rhs_text pos))]
+
+let extra_text text pos items =
+  let pre_extras = rhs_pre_extra_text pos in
+  let post_extras = rhs_post_extra_text pos in
+    text pre_extras @ items @ text post_extras
+
+let extra_str pos items = extra_text Str.text pos items
+let extra_sig pos items = extra_text Sig.text pos items
+let extra_cstr pos items = extra_text Cf.text pos items
+let extra_csig pos items = extra_text Ctf.text pos items
+let extra_def pos items =
+  extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items
+
+let extra_rhs_core_type ct ~pos =
+  let docs = rhs_info pos in
+  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
+
+type let_binding =
+  { lb_pattern: pattern;
+    lb_expression: expression;
+    lb_attributes: attributes;
+    lb_docs: docs Lazy.t;
+    lb_text: text Lazy.t;
+    lb_loc: Location.t; }
+
+type let_bindings =
+  { lbs_bindings: let_binding list;
+    lbs_rec: rec_flag;
+    lbs_extension: string Asttypes.loc option;
+    lbs_loc: Location.t }
+
+let mklb first (p, e) attrs =
+  { lb_pattern = p;
+    lb_expression = e;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy ();
+    lb_text = if first then empty_text_lazy
+              else symbol_text_lazy ();
+    lb_loc = symbol_rloc (); }
+
+let mklbs ext rf lb =
+  { lbs_bindings = [lb];
+    lbs_rec = rf;
+    lbs_extension = ext ;
+    lbs_loc = symbol_rloc (); }
+
+let addlb lbs lb =
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let val_of_let_bindings lbs =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           ~docs:(Lazy.force lb.lb_docs)
+           ~text:(Lazy.force lb.lb_text)
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+  let str = mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings)) in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, [])
+
+let class_of_let_bindings lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
+           lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    if lbs.lbs_extension <> None then
+      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension")));
+    mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
+
+(* Alternatively, we could keep the generic module type in the Parsetree
+   and extract the package type during type-checking. In that case,
+   the assertions below should be turned into explicit checks. *)
+let package_type_of_module_type pmty =
+  let err loc s =
+    raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
+  in
+  let map_cstr = function
+    | Pwith_type (lid, ptyp) ->
+        let loc = ptyp.ptype_loc in
+        if ptyp.ptype_params <> [] then
+          err loc "parametrized types are not supported";
+        if ptyp.ptype_cstrs <> [] then
+          err loc "constrained types are not supported";
+        if ptyp.ptype_private <> Public then
+          err loc "private types are not supported";
+
+        (* restrictions below are checked by the 'with_constraint' rule *)
+        assert (ptyp.ptype_kind = Ptype_abstract);
+        assert (ptyp.ptype_attributes = []);
+        let ty =
+          match ptyp.ptype_manifest with
+          | Some ty -> ty
+          | None -> assert false
+        in
+        (lid, ty)
+    | _ ->
+        err pmty.pmty_loc "only 'with type t =' constraints are supported"
+  in
+  match pmty with
+  | {pmty_desc = Pmty_ident lid} -> (lid, [])
+  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
+      (lid, List.map map_cstr cstrs)
+  | _ ->
+      err pmty.pmty_loc
+        "only module type identifier and 'with type' constraints are supported"
+
+
+%}
+
+/* Tokens */
+
+%token AMPERAMPER
+%token AMPERSAND
+%token AND
+%token AS
+%token ASSERT
+%token BACKQUOTE
+%token BANG
+%token BAR
+%token BARBAR
+%token BARRBRACKET
+%token BEGIN
+%token <char> CHAR
+%token CLASS
+%token COLON
+%token COLONCOLON
+%token COLONEQUAL
+%token COLONGREATER
+%token COMMA
+%token CONSTRAINT
+%token DO
+%token DONE
+%token DOT
+%token DOTDOT
+%token DOWNTO
+%token ELSE
+%token END
+%token EOF
+%token EQUAL
+%token EXCEPTION
+%token EXTERNAL
+%token FALSE
+%token <string * char option> FLOAT
+%token FOR
+%token FUN
+%token FUNCTION
+%token FUNCTOR
+%token GREATER
+%token GREATERRBRACE
+%token GREATERRBRACKET
+%token IF
+%token IN
+%token INCLUDE
+%token <string> INFIXOP0
+%token <string> INFIXOP1
+%token <string> INFIXOP2
+%token <string> INFIXOP3
+%token <string> INFIXOP4
+%token INHERIT
+%token INITIALIZER
+%token <string * char option> INT
+%token <string> LABEL
+%token LAZY
+%token LBRACE
+%token LBRACELESS
+%token LBRACKET
+%token LBRACKETBAR
+%token LBRACKETLESS
+%token LBRACKETGREATER
+%token LBRACKETPERCENT
+%token LBRACKETPERCENTPERCENT
+%token LESS
+%token LESSMINUS
+%token LET
+%token <string> LIDENT
+%token LPAREN
+%token LBRACKETAT
+%token LBRACKETATAT
+%token LBRACKETATATAT
+%token MATCH
+%token METHOD
+%token MINUS
+%token MINUSDOT
+%token MINUSGREATER
+%token MODULE
+%token MUTABLE
+%token NEW
+%token NONREC
+%token OBJECT
+%token OF
+%token OPEN
+%token <string> OPTLABEL
+%token OR
+/* %token PARSER */
+%token PERCENT
+%token PLUS
+%token PLUSDOT
+%token PLUSEQ
+%token <string> PREFIXOP
+%token PRIVATE
+%token QUESTION
+%token QUOTE
+%token RBRACE
+%token RBRACKET
+%token REC
+%token RPAREN
+%token SEMI
+%token SEMISEMI
+%token HASH
+%token <string> HASHOP
+%token SIG
+%token STAR
+%token <string * string option> STRING
+%token STRUCT
+%token THEN
+%token TILDE
+%token TO
+%token TRUE
+%token TRY
+%token TYPE
+%token <string> UIDENT
+%token UNDERSCORE
+%token VAL
+%token VIRTUAL
+%token WHEN
+%token WHILE
+%token WITH
+%token <string * Location.t> COMMENT
+%token <Docstrings.docstring> DOCSTRING
+
+%token EOL
+
+/* Precedences and associativities.
+
+Tokens and rules have precedences.  A reduce/reduce conflict is resolved
+in favor of the first rule (in source file order).  A shift/reduce conflict
+is resolved by comparing the precedence and associativity of the token to
+be shifted with those of the rule to be reduced.
+
+By default, a rule has the precedence of its rightmost terminal (if any).
+
+When there is a shift/reduce conflict between a rule and a token that
+have the same precedence, it is resolved using the associativity:
+if the token is left-associative, the parser will reduce; if
+right-associative, the parser will shift; if non-associative,
+the parser will declare a syntax error.
+
+We will only use associativities with operators of the kind  x * x -> x
+for example, in the rules of the form    expr: expr BINOP expr
+in all other cases, we define two precedences if needed to resolve
+conflicts.
+
+The precedences must be listed from low to high.
+*/
+
+%nonassoc IN
+%nonassoc below_SEMI
+%nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+%nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
+%nonassoc below_WITH
+%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
+%nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+%nonassoc THEN                          /* below ELSE (if ... then ...) */
+%nonassoc ELSE                          /* (if ... then ... else ...) */
+%nonassoc LESSMINUS                     /* below COLONEQUAL (lbl <- x := e) */
+%right    COLONEQUAL                    /* expr (e := e := e) */
+%nonassoc AS
+%left     BAR                           /* pattern (p|p|p) */
+%nonassoc below_COMMA
+%left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+%right    MINUSGREATER                  /* core_type2 (t -> t -> t) */
+%right    OR BARBAR                     /* expr (e || e || e) */
+%right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
+%nonassoc below_EQUAL
+%left     INFIXOP0 EQUAL LESS GREATER   /* expr (e OP e OP e) */
+%right    INFIXOP1                      /* expr (e OP e OP e) */
+%nonassoc below_LBRACKETAT
+%nonassoc LBRACKETAT
+%nonassoc LBRACKETATAT
+%right    COLONCOLON                    /* expr (e :: e :: e) */
+%left     INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */
+%left     PERCENT INFIXOP3 STAR                 /* expr (e OP e OP e) */
+%right    INFIXOP4                      /* expr (e OP e OP e) */
+%nonassoc prec_unary_minus prec_unary_plus /* unary - */
+%nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
+%nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
+%nonassoc below_HASH
+%nonassoc HASH                         /* simple_expr/toplevel_directive */
+%left     HASHOP
+%nonassoc below_DOT
+%nonassoc DOT
+/* Finally, the first tokens of simple_expr are above everything else. */
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
+          LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+          NEW PREFIXOP STRING TRUE UIDENT
+          LBRACKETPERCENT LBRACKETPERCENTPERCENT
+
+
+/* Entry points */
+
+%start implementation                   /* for implementation files */
+%type <Parsetree.structure> implementation
+%start interface                        /* for interface files */
+%type <Parsetree.signature> interface
+%start toplevel_phrase                  /* for interactive use */
+%type <Parsetree.toplevel_phrase> toplevel_phrase
+%start use_file                         /* for the #use directive */
+%type <Parsetree.toplevel_phrase list> use_file
+%start parse_core_type
+%type <Parsetree.core_type> parse_core_type
+%start parse_expression
+%type <Parsetree.expression> parse_expression
+%start parse_pattern
+%type <Parsetree.pattern> parse_pattern
+%%
+
+/* Entry points */
+
+implementation:
+    structure EOF                        { extra_str 1 $1 }
+;
+interface:
+    signature EOF                        { extra_sig 1 $1 }
+;
+toplevel_phrase:
+    top_structure SEMISEMI               { Ptop_def (extra_str 1 $1) }
+  | toplevel_directive SEMISEMI          { $1 }
+  | EOF                                  { raise End_of_file }
+;
+top_structure:
+    seq_expr post_item_attributes
+      { (text_str 1) @ [mkstrexp $1 $2] }
+  | top_structure_tail
+      { $1 }
+;
+top_structure_tail:
+    /* empty */                          { [] }
+  | structure_item top_structure_tail    { (text_str 1) @ $1 :: $2 }
+;
+use_file:
+    use_file_body                        { extra_def 1 $1 }
+;
+use_file_body:
+    use_file_tail                        { $1 }
+  | seq_expr post_item_attributes use_file_tail
+      { (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 }
+;
+use_file_tail:
+    EOF
+      { [] }
+  | SEMISEMI EOF
+      { text_def 1 }
+  | SEMISEMI seq_expr post_item_attributes use_file_tail
+      {  mark_rhs_docs 2 3;
+        (text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp $2 $3] :: $4 }
+  | SEMISEMI structure_item use_file_tail
+      { (text_def 1) @ (text_def 2) @ Ptop_def[$2] :: $3 }
+  | SEMISEMI toplevel_directive use_file_tail
+      {  mark_rhs_docs 2 3;
+        (text_def 1) @ (text_def 2) @ $2 :: $3 }
+  | structure_item use_file_tail
+      { (text_def 1) @ Ptop_def[$1] :: $2 }
+  | toplevel_directive use_file_tail
+      { mark_rhs_docs 1 1;
+        (text_def 1) @ $1 :: $2 }
+;
+parse_core_type:
+    core_type EOF { $1 }
+;
+parse_expression:
+    seq_expr EOF { $1 }
+;
+parse_pattern:
+    pattern EOF { $1 }
+;
+
+/* Module expressions */
+
+functor_arg:
+    LPAREN RPAREN
+      { mkrhs "*" 2, None }
+  | LPAREN functor_arg_name COLON module_type RPAREN
+      { mkrhs $2 2, Some $4 }
+;
+
+functor_arg_name:
+    UIDENT     { $1 }
+  | UNDERSCORE { "_" }
+;
+
+functor_args:
+    functor_args functor_arg
+      { $2 :: $1 }
+  | functor_arg
+      { [ $1 ] }
+;
+
+module_expr:
+    mod_longident
+      { mkmod(Pmod_ident (mkrhs $1 1)) }
+  | STRUCT attributes structure END
+      { mkmod ~attrs:$2 (Pmod_structure(extra_str 3 $3)) }
+  | STRUCT attributes structure error
+      { unclosed "struct" 1 "end" 4 }
+  | FUNCTOR attributes functor_args MINUSGREATER module_expr
+      { let modexp =
+          List.fold_left
+            (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc)))
+            $5 $3
+        in wrap_mod_attrs modexp $2 }
+  | module_expr paren_module_expr
+      { mkmod(Pmod_apply($1, $2)) }
+  | module_expr LPAREN RPAREN
+      { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) }
+  | paren_module_expr
+      { $1 }
+  | module_expr attribute
+      { Mod.attr $1 $2 }
+  | extension
+      { mkmod(Pmod_extension $1) }
+;
+
+paren_module_expr:
+    LPAREN module_expr COLON module_type RPAREN
+      { mkmod(Pmod_constraint($2, $4)) }
+  | LPAREN module_expr COLON module_type error
+      { unclosed "(" 1 ")" 5 }
+  | LPAREN module_expr RPAREN
+      { $2 }
+  | LPAREN module_expr error
+      { unclosed "(" 1 ")" 3 }
+  | LPAREN VAL attributes expr RPAREN
+      { mkmod ~attrs:$3 (Pmod_unpack $4)}
+  | LPAREN VAL attributes expr COLON package_type RPAREN
+      { mkmod ~attrs:$3
+          (Pmod_unpack(
+               ghexp(Pexp_constraint($4, ghtyp(Ptyp_package $6))))) }
+  | LPAREN VAL attributes expr COLON package_type COLONGREATER package_type
+    RPAREN
+      { mkmod ~attrs:$3
+          (Pmod_unpack(
+               ghexp(Pexp_coerce($4, Some(ghtyp(Ptyp_package $6)),
+                                 ghtyp(Ptyp_package $8))))) }
+  | LPAREN VAL attributes expr COLONGREATER package_type RPAREN
+      { mkmod ~attrs:$3
+          (Pmod_unpack(
+               ghexp(Pexp_coerce($4, None, ghtyp(Ptyp_package $6))))) }
+  | LPAREN VAL attributes expr COLON error
+      { unclosed "(" 1 ")" 6 }
+  | LPAREN VAL attributes expr COLONGREATER error
+      { unclosed "(" 1 ")" 6 }
+  | LPAREN VAL attributes expr error
+      { unclosed "(" 1 ")" 5 }
+;
+
+structure:
+    seq_expr post_item_attributes structure_tail
+      { mark_rhs_docs 1 2;
+        (text_str 1) @ mkstrexp $1 $2 :: $3 }
+  | structure_tail { $1 }
+;
+structure_tail:
+    /* empty */          { [] }
+  | SEMISEMI structure   { (text_str 1) @ $2 }
+  | structure_item structure_tail { (text_str 1) @ $1 :: $2 }
+;
+structure_item:
+    let_bindings
+      { val_of_let_bindings $1 }
+  | primitive_declaration
+      { let (body, ext) = $1 in mkstr_ext (Pstr_primitive body) ext }
+  | value_description
+      { let (body, ext) = $1 in mkstr_ext (Pstr_primitive body) ext }
+  | type_declarations
+      { let (nr, l, ext ) = $1 in mkstr_ext (Pstr_type (nr, List.rev l)) ext }
+  | str_type_extension
+      { let (l, ext) = $1 in mkstr_ext (Pstr_typext l) ext }
+  | str_exception_declaration
+      { let (l, ext) = $1 in mkstr_ext (Pstr_exception l) ext }
+  | module_binding
+      { let (body, ext) = $1 in mkstr_ext (Pstr_module body) ext }
+  | rec_module_bindings
+      { let (l, ext) = $1 in mkstr_ext (Pstr_recmodule(List.rev l)) ext }
+  | module_type_declaration
+      { let (body, ext) = $1 in mkstr_ext (Pstr_modtype body) ext }
+  | open_statement
+      { let (body, ext) = $1 in mkstr_ext (Pstr_open body) ext }
+  | class_declarations
+      { let (l, ext) = $1 in mkstr_ext (Pstr_class (List.rev l)) ext }
+  | class_type_declarations
+      { let (l, ext) = $1 in mkstr_ext (Pstr_class_type (List.rev l)) ext }
+  | str_include_statement
+      { let (body, ext) = $1 in mkstr_ext (Pstr_include body) ext }
+  | item_extension post_item_attributes
+      { mkstr(Pstr_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) }
+  | floating_attribute
+      { mark_symbol_docs ();
+        mkstr(Pstr_attribute $1) }
+;
+str_include_statement:
+    INCLUDE ext_attributes module_expr post_item_attributes
+      { let (ext, attrs) = $2 in
+        Incl.mk $3 ~attrs:(attrs@$4)
+            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext }
+;
+module_binding_body:
+    EQUAL module_expr
+      { $2 }
+  | COLON module_type EQUAL module_expr
+      { mkmod(Pmod_constraint($4, $2)) }
+  | functor_arg module_binding_body
+      { mkmod(Pmod_functor(fst $1, snd $1, $2)) }
+;
+module_binding:
+    MODULE ext_attributes UIDENT module_binding_body post_item_attributes
+      { let (ext, attrs) = $2 in
+        Mb.mk (mkrhs $3 3) $4 ~attrs:(attrs@$5)
+            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+      , ext }
+;
+rec_module_bindings:
+    rec_module_binding                     { let (b, ext) = $1 in ([b], ext) }
+  | rec_module_bindings and_module_binding
+      { let (l, ext) = $1 in ($2 :: l, ext) }
+;
+rec_module_binding:
+    MODULE ext_attributes REC UIDENT module_binding_body post_item_attributes
+      { let (ext, attrs) = $2 in
+        Mb.mk (mkrhs $4 4) $5 ~attrs:(attrs@$6)
+            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+      , ext }
+;
+and_module_binding:
+    AND attributes UIDENT module_binding_body post_item_attributes
+      { Mb.mk (mkrhs $3 3) $4 ~attrs:($2@$5) ~loc:(symbol_rloc ())
+               ~text:(symbol_text ()) ~docs:(symbol_docs ()) }
+;
+
+/* Module types */
+
+module_type:
+    mty_longident
+      { mkmty(Pmty_ident (mkrhs $1 1)) }
+  | SIG attributes signature END
+      { mkmty ~attrs:$2 (Pmty_signature (extra_sig 3 $3)) }
+  | SIG attributes signature error
+      { unclosed "sig" 1 "end" 4 }
+  | FUNCTOR attributes functor_args MINUSGREATER module_type
+      %prec below_WITH
+      { let mty =
+          List.fold_left
+            (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc)))
+            $5 $3
+        in wrap_mty_attrs mty $2 }
+  | module_type MINUSGREATER module_type
+      %prec below_WITH
+      { mkmty(Pmty_functor(mknoloc "_", Some $1, $3)) }
+  | module_type WITH with_constraints
+      { mkmty(Pmty_with($1, List.rev $3)) }
+  | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
+      { mkmty ~attrs:$4 (Pmty_typeof $5) }
+/*  | LPAREN MODULE mod_longident RPAREN
+      { mkmty (Pmty_alias (mkrhs $3 3)) } */
+  | LPAREN module_type RPAREN
+      { $2 }
+  | LPAREN module_type error
+      { unclosed "(" 1 ")" 3 }
+  | extension
+      { mkmty(Pmty_extension $1) }
+  | module_type attribute
+      { Mty.attr $1 $2 }
+;
+signature:
+    /* empty */          { [] }
+  | SEMISEMI signature   { (text_sig 1) @ $2 }
+  | signature_item signature { (text_sig 1) @ $1 :: $2 }
+;
+signature_item:
+    value_description
+      { let (body, ext) = $1 in mksig_ext (Psig_value body) ext }
+  | primitive_declaration
+      { let (body, ext) = $1 in mksig_ext (Psig_value body) ext}
+  | type_declarations
+      { let (nr, l, ext) = $1 in mksig_ext (Psig_type (nr, List.rev l)) ext }
+  | sig_type_extension
+      { let (l, ext) = $1 in mksig_ext (Psig_typext l) ext }
+  | sig_exception_declaration
+      { let (l, ext) = $1 in mksig_ext (Psig_exception l) ext }
+  | module_declaration
+      { let (body, ext) = $1 in mksig_ext (Psig_module body) ext }
+  | module_alias
+      { let (body, ext) = $1 in mksig_ext (Psig_module body) ext }
+  | rec_module_declarations
+      { let (l, ext) = $1 in mksig_ext (Psig_recmodule (List.rev l)) ext }
+  | module_type_declaration
+      { let (body, ext) = $1 in mksig_ext (Psig_modtype body) ext }
+  | open_statement
+      { let (body, ext) = $1 in mksig_ext (Psig_open body) ext }
+  | sig_include_statement
+      { let (body, ext) = $1 in mksig_ext (Psig_include body) ext }
+  | class_descriptions
+      { let (l, ext) = $1 in mksig_ext (Psig_class (List.rev l)) ext }
+  | class_type_declarations
+      { let (l, ext) = $1 in mksig_ext (Psig_class_type (List.rev l)) ext }
+  | item_extension post_item_attributes
+      { mksig(Psig_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) }
+  | floating_attribute
+      { mark_symbol_docs ();
+        mksig(Psig_attribute $1) }
+;
+open_statement:
+  | OPEN override_flag ext_attributes mod_longident post_item_attributes
+      { let (ext, attrs) = $3 in
+        Opn.mk (mkrhs $4 4) ~override:$2 ~attrs:(attrs@$5)
+          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext}
+;
+sig_include_statement:
+    INCLUDE ext_attributes module_type post_item_attributes %prec below_WITH
+      { let (ext, attrs) = $2 in
+        Incl.mk $3 ~attrs:(attrs@$4)
+            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext}
+;
+module_declaration_body:
+    COLON module_type
+      { $2 }
+  | LPAREN UIDENT COLON module_type RPAREN module_declaration_body
+      { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) }
+  | LPAREN RPAREN module_declaration_body
+      { mkmty(Pmty_functor(mkrhs "*" 1, None, $3)) }
+;
+module_declaration:
+    MODULE ext_attributes UIDENT module_declaration_body post_item_attributes
+      { let (ext, attrs) = $2 in
+        Md.mk (mkrhs $3 3) $4 ~attrs:(attrs@$5)
+          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext }
+;
+module_alias:
+    MODULE ext_attributes UIDENT EQUAL mod_longident post_item_attributes
+      { let (ext, attrs) = $2 in
+        Md.mk (mkrhs $3 3)
+          (Mty.alias ~loc:(rhs_loc 5) (mkrhs $5 5)) ~attrs:(attrs@$6)
+             ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext }
+;
+rec_module_declarations:
+    rec_module_declaration
+      { let (body, ext) = $1 in ([body], ext) }
+  | rec_module_declarations and_module_declaration
+      { let (l, ext) = $1 in ($2 :: l, ext) }
+;
+rec_module_declaration:
+    MODULE ext_attributes REC UIDENT COLON module_type post_item_attributes
+      { let (ext, attrs) = $2 in
+        Md.mk (mkrhs $4 4) $6 ~attrs:(attrs@$7)
+            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext}
+;
+and_module_declaration:
+    AND attributes UIDENT COLON module_type post_item_attributes
+      { Md.mk (mkrhs $3 3) $5 ~attrs:($2@$6) ~loc:(symbol_rloc())
+              ~text:(symbol_text()) ~docs:(symbol_docs()) }
+;
+module_type_declaration_body:
+    /* empty */               { None }
+  | EQUAL module_type         { Some $2 }
+;
+module_type_declaration:
+    MODULE TYPE ext_attributes ident module_type_declaration_body
+    post_item_attributes
+      { let (ext, attrs) = $3 in
+        Mtd.mk (mkrhs $4 4) ?typ:$5 ~attrs:(attrs@$6)
+          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext }
+;
+/* Class expressions */
+
+class_declarations:
+    class_declaration
+      { let (body, ext) = $1 in ([body], ext) }
+  | class_declarations and_class_declaration
+      { let (l, ext) = $1 in ($2 :: l, ext) }
+;
+class_declaration:
+    CLASS ext_attributes virtual_flag class_type_parameters LIDENT
+    class_fun_binding post_item_attributes
+      { let (ext, attrs) = $2 in
+        Ci.mk (mkrhs $5 5) $6 ~virt:$3 ~params:$4 ~attrs:(attrs@$7)
+            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+      , ext }
+;
+and_class_declaration:
+    AND attributes virtual_flag class_type_parameters LIDENT class_fun_binding
+    post_item_attributes
+      { Ci.mk (mkrhs $5 5) $6 ~virt:$3 ~params:$4
+         ~attrs:($2@$7) ~loc:(symbol_rloc ())
+         ~text:(symbol_text ()) ~docs:(symbol_docs ()) }
+;
+class_fun_binding:
+    EQUAL class_expr
+      { $2 }
+  | COLON class_type EQUAL class_expr
+      { mkclass(Pcl_constraint($4, $2)) }
+  | labeled_simple_pattern class_fun_binding
+      { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
+;
+class_type_parameters:
+    /*empty*/                                   { [] }
+  | LBRACKET type_parameter_list RBRACKET       { List.rev $2 }
+;
+class_fun_def:
+    labeled_simple_pattern MINUSGREATER class_expr
+      { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $3)) }
+  | labeled_simple_pattern class_fun_def
+      { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
+;
+class_expr:
+    class_simple_expr
+      { $1 }
+  | FUN attributes class_fun_def
+      { wrap_class_attrs $3 $2 }
+  | class_simple_expr simple_labeled_expr_list
+      { mkclass(Pcl_apply($1, List.rev $2)) }
+  | let_bindings IN class_expr
+      { class_of_let_bindings $1 $3 }
+  | class_expr attribute
+      { Cl.attr $1 $2 }
+  | extension
+      { mkclass(Pcl_extension $1) }
+;
+class_simple_expr:
+    LBRACKET core_type_comma_list RBRACKET class_longident
+      { mkclass(Pcl_constr(mkloc $4 (rhs_loc 4), List.rev $2)) }
+  | class_longident
+      { mkclass(Pcl_constr(mkrhs $1 1, [])) }
+  | OBJECT attributes class_structure END
+      { mkclass ~attrs:$2 (Pcl_structure $3) }
+  | OBJECT attributes class_structure error
+      { unclosed "object" 1 "end" 4 }
+  | LPAREN class_expr COLON class_type RPAREN
+      { mkclass(Pcl_constraint($2, $4)) }
+  | LPAREN class_expr COLON class_type error
+      { unclosed "(" 1 ")" 5 }
+  | LPAREN class_expr RPAREN
+      { $2 }
+  | LPAREN class_expr error
+      { unclosed "(" 1 ")" 3 }
+;
+class_structure:
+  |  class_self_pattern class_fields
+       { Cstr.mk $1 (extra_cstr 2 (List.rev $2)) }
+;
+class_self_pattern:
+    LPAREN pattern RPAREN
+      { reloc_pat $2 }
+  | LPAREN pattern COLON core_type RPAREN
+      { mkpat(Ppat_constraint($2, $4)) }
+  | /* empty */
+      { ghpat(Ppat_any) }
+;
+class_fields:
+    /* empty */
+      { [] }
+  | class_fields class_field
+      { $2 :: (text_cstr 2) @ $1 }
+;
+class_field:
+  | INHERIT override_flag attributes class_expr parent_binder
+    post_item_attributes
+      { mkcf (Pcf_inherit ($2, $4, $5)) ~attrs:($3@$6) ~docs:(symbol_docs ()) }
+  | VAL value post_item_attributes
+      { let v, attrs = $2 in
+        mkcf (Pcf_val v) ~attrs:(attrs@$3) ~docs:(symbol_docs ()) }
+  | METHOD method_ post_item_attributes
+      { let meth, attrs = $2 in
+        mkcf (Pcf_method meth) ~attrs:(attrs@$3) ~docs:(symbol_docs ()) }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { mkcf (Pcf_constraint $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) }
+  | INITIALIZER attributes seq_expr post_item_attributes
+      { mkcf (Pcf_initializer $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) }
+  | item_extension post_item_attributes
+      { mkcf (Pcf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) }
+  | floating_attribute
+      { mark_symbol_docs ();
+        mkcf (Pcf_attribute $1) }
+;
+parent_binder:
+    AS LIDENT
+          { Some (mkrhs $2 2) }
+  | /* empty */
+          { None }
+;
+value:
+/* TODO: factorize these rules (also with method): */
+    override_flag attributes MUTABLE VIRTUAL label COLON core_type
+      { if $1 = Override then syntax_error ();
+        (mkloc $5 (rhs_loc 5), Mutable, Cfk_virtual $7), $2 }
+  | override_flag attributes VIRTUAL mutable_flag label COLON core_type
+      { if $1 = Override then syntax_error ();
+        (mkrhs $5 5, $4, Cfk_virtual $7), $2 }
+  | override_flag attributes mutable_flag label EQUAL seq_expr
+      { (mkrhs $4 4, $3, Cfk_concrete ($1, $6)), $2 }
+  | override_flag attributes mutable_flag label type_constraint EQUAL seq_expr
+      {
+       let e = mkexp_constraint $7 $5 in
+       (mkrhs $4 4, $3, Cfk_concrete ($1, e)), $2
+      }
+;
+method_:
+/* TODO: factorize those rules... */
+    override_flag attributes PRIVATE VIRTUAL label COLON poly_type
+      { if $1 = Override then syntax_error ();
+        (mkloc $5 (rhs_loc 5), Private, Cfk_virtual $7), $2 }
+  | override_flag attributes VIRTUAL private_flag label COLON poly_type
+      { if $1 = Override then syntax_error ();
+        (mkloc $5 (rhs_loc 5), $4, Cfk_virtual $7), $2 }
+  | override_flag attributes private_flag label strict_binding
+      { (mkloc $4 (rhs_loc 4), $3,
+        Cfk_concrete ($1, ghexp(Pexp_poly ($5, None)))), $2 }
+  | override_flag attributes private_flag label COLON poly_type EQUAL seq_expr
+      { (mkloc $4 (rhs_loc 4), $3,
+        Cfk_concrete ($1, ghexp(Pexp_poly($8, Some $6)))), $2 }
+  | override_flag attributes private_flag label COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let exp, poly = wrap_type_annotation $7 $9 $11 in
+        (mkloc $4 (rhs_loc 4), $3,
+        Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly)))), $2 }
+;
+
+/* Class types */
+
+class_type:
+    class_signature
+      { $1 }
+  | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER
+    class_type
+      { mkcty(Pcty_arrow(Optional $2 , $4, $6)) }
+  | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type
+      { mkcty(Pcty_arrow(Optional $1, $2, $4)) }
+  | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
+      { mkcty(Pcty_arrow(Labelled $1, $3, $5)) }
+  | simple_core_type_or_tuple MINUSGREATER class_type
+      { mkcty(Pcty_arrow(Nolabel, $1, $3)) }
+ ;
+class_signature:
+    LBRACKET core_type_comma_list RBRACKET clty_longident
+      { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) }
+  | clty_longident
+      { mkcty(Pcty_constr (mkrhs $1 1, [])) }
+  | OBJECT attributes class_sig_body END
+      { mkcty ~attrs:$2 (Pcty_signature $3) }
+  | OBJECT attributes class_sig_body error
+      { unclosed "object" 1 "end" 4 }
+  | class_signature attribute
+      { Cty.attr $1 $2 }
+  | extension
+      { mkcty(Pcty_extension $1) }
+;
+class_sig_body:
+    class_self_type class_sig_fields
+      { Csig.mk $1 (extra_csig 2 (List.rev $2)) }
+;
+class_self_type:
+    LPAREN core_type RPAREN
+      { $2 }
+  | /* empty */
+      { mktyp(Ptyp_any) }
+;
+class_sig_fields:
+    /* empty */                                 { [] }
+| class_sig_fields class_sig_field     { $2 :: (text_csig 2) @ $1 }
+;
+class_sig_field:
+    INHERIT attributes class_signature post_item_attributes
+      { mkctf (Pctf_inherit $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) }
+  | VAL attributes value_type post_item_attributes
+      { mkctf (Pctf_val $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) }
+  | METHOD attributes private_virtual_flags label COLON poly_type
+    post_item_attributes
+      {
+       let (p, v) = $3 in
+       mkctf (Pctf_method (mkrhs $4 4, p, v, $6)) ~attrs:($2@$7) ~docs:(symbol_docs ())
+      }
+  | CONSTRAINT attributes constrain_field post_item_attributes
+      { mkctf (Pctf_constraint $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) }
+  | item_extension post_item_attributes
+      { mkctf (Pctf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) }
+  | floating_attribute
+      { mark_symbol_docs ();
+        mkctf(Pctf_attribute $1) }
+;
+value_type:
+    VIRTUAL mutable_flag label COLON core_type
+      { mkrhs $3 3, $2, Virtual, $5 }
+  | MUTABLE virtual_flag label COLON core_type
+      { mkrhs $3 3, Mutable, $2, $5 }
+  | label COLON core_type
+      { mkrhs $1 1, Immutable, Concrete, $3 }
+;
+constrain:
+        core_type EQUAL core_type          { $1, $3, symbol_rloc() }
+;
+constrain_field:
+        core_type EQUAL core_type          { $1, $3 }
+;
+class_descriptions:
+    class_description
+      { let (body, ext) = $1 in ([body],ext) }
+  | class_descriptions and_class_description
+      { let (l, ext) = $1 in ($2 :: l, ext) }
+;
+class_description:
+    CLASS ext_attributes virtual_flag class_type_parameters LIDENT COLON
+    class_type post_item_attributes
+      { let (ext, attrs) = $2 in
+        Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs @ $8)
+            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+      , ext }
+;
+and_class_description:
+    AND attributes virtual_flag class_type_parameters LIDENT COLON class_type
+    post_item_attributes
+      { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4
+              ~attrs:($2@$8) ~loc:(symbol_rloc ())
+              ~text:(symbol_text ()) ~docs:(symbol_docs ()) }
+;
+class_type_declarations:
+    class_type_declaration
+      { let (body, ext) = $1 in ([body],ext) }
+  | class_type_declarations and_class_type_declaration
+      { let (l, ext) = $1 in ($2 :: l, ext) }
+;
+class_type_declaration:
+    CLASS TYPE ext_attributes virtual_flag class_type_parameters LIDENT EQUAL
+    class_signature post_item_attributes
+      { let (ext, attrs) = $3 in
+        Ci.mk (mkrhs $6 6) $8 ~virt:$4 ~params:$5 ~attrs:(attrs@$9)
+            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+      , ext}
+;
+and_class_type_declaration:
+    AND attributes virtual_flag class_type_parameters LIDENT EQUAL
+    class_signature post_item_attributes
+      { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4
+         ~attrs:($2@$8) ~loc:(symbol_rloc ())
+         ~text:(symbol_text ()) ~docs:(symbol_docs ()) }
+;
+
+/* Core expressions */
+
+seq_expr:
+  | expr        %prec below_SEMI  { $1 }
+  | expr SEMI                     { reloc_exp $1 }
+  | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
+  | expr SEMI PERCENT attr_id seq_expr
+      { let seq = mkexp(Pexp_sequence ($1, $5)) in
+        let payload = PStr [mkstrexp seq []] in
+        mkexp (Pexp_extension ($4, payload)) }
+;
+labeled_simple_pattern:
+    QUESTION LPAREN label_let_pattern opt_default RPAREN
+      { (Optional (fst $3), $4, snd $3) }
+  | QUESTION label_var
+      { (Optional (fst $2), None, snd $2) }
+  | OPTLABEL LPAREN let_pattern opt_default RPAREN
+      { (Optional $1, $4, $3) }
+  | OPTLABEL pattern_var
+      { (Optional $1, None, $2) }
+  | TILDE LPAREN label_let_pattern RPAREN
+      { (Labelled (fst $3), None, snd $3) }
+  | TILDE label_var
+      { (Labelled (fst $2), None, snd $2) }
+  | LABEL simple_pattern
+      { (Labelled $1, None, $2) }
+  | simple_pattern
+      { (Nolabel, None, $1) }
+;
+pattern_var:
+    LIDENT            { mkpat(Ppat_var (mkrhs $1 1)) }
+  | UNDERSCORE        { mkpat Ppat_any }
+;
+opt_default:
+    /* empty */                         { None }
+  | EQUAL seq_expr                      { Some $2 }
+;
+label_let_pattern:
+    label_var
+      { $1 }
+  | label_var COLON core_type
+      { let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) }
+;
+label_var:
+    LIDENT    { ($1, mkpat(Ppat_var (mkrhs $1 1))) }
+;
+let_pattern:
+    pattern
+      { $1 }
+  | pattern COLON core_type
+      { mkpat(Ppat_constraint($1, $3)) }
+;
+expr:
+    simple_expr %prec below_HASH
+      { $1 }
+  | simple_expr simple_labeled_expr_list
+      { mkexp(Pexp_apply($1, List.rev $2)) }
+  | let_bindings IN seq_expr
+      { expr_of_let_bindings $1 $3 }
+  | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr
+      { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { mkexp_attrs (Pexp_letexception($4, $6)) $3 }
+  | LET OPEN override_flag ext_attributes mod_longident IN seq_expr
+      { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 }
+  | FUNCTION ext_attributes opt_bar match_cases
+      { mkexp_attrs (Pexp_function(List.rev $4)) $2 }
+  | FUN ext_attributes labeled_simple_pattern fun_def
+      { let (l,o,p) = $3 in
+        mkexp_attrs (Pexp_fun(l, o, p, $4)) $2 }
+  | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
+      { mkexp_attrs (mk_newtypes $5 $7).pexp_desc $2 }
+  | MATCH ext_attributes seq_expr WITH opt_bar match_cases
+      { mkexp_attrs (Pexp_match($3, List.rev $6)) $2 }
+  | TRY ext_attributes seq_expr WITH opt_bar match_cases
+      { mkexp_attrs (Pexp_try($3, List.rev $6)) $2 }
+  | TRY ext_attributes seq_expr WITH error
+      { syntax_error() }
+  | expr_comma_list %prec below_COMMA
+      { mkexp(Pexp_tuple(List.rev $1)) }
+  | constr_longident simple_expr %prec below_HASH
+      { mkexp(Pexp_construct(mkrhs $1 1, Some $2)) }
+  | name_tag simple_expr %prec below_HASH
+      { mkexp(Pexp_variant($1, Some $2)) }
+  | IF ext_attributes seq_expr THEN expr ELSE expr
+      { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 }
+  | IF ext_attributes seq_expr THEN expr
+      { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 }
+  | WHILE ext_attributes seq_expr DO seq_expr DONE
+      { mkexp_attrs (Pexp_while($3, $5)) $2 }
+  | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
+    seq_expr DONE
+      { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
+  | expr COLONCOLON expr
+      { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
+  | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
+      { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
+  | expr INFIXOP0 expr
+      { mkinfix $1 $2 $3 }
+  | expr INFIXOP1 expr
+      { mkinfix $1 $2 $3 }
+  | expr INFIXOP2 expr
+      { mkinfix $1 $2 $3 }
+  | expr INFIXOP3 expr
+      { mkinfix $1 $2 $3 }
+  | expr INFIXOP4 expr
+      { mkinfix $1 $2 $3 }
+  | expr PLUS expr
+      { mkinfix $1 "+" $3 }
+  | expr PLUSDOT expr
+      { mkinfix $1 "+." $3 }
+  | expr PLUSEQ expr
+      { mkinfix $1 "+=" $3 }
+  | expr MINUS expr
+      { mkinfix $1 "-" $3 }
+  | expr MINUSDOT expr
+      { mkinfix $1 "-." $3 }
+  | expr STAR expr
+      { mkinfix $1 "*" $3 }
+  | expr PERCENT expr
+      { mkinfix $1 "%" $3 }
+  | expr EQUAL expr
+      { mkinfix $1 "=" $3 }
+  | expr LESS expr
+    { mkinfix $1 "<" $3 }
+  | expr GREATER expr
+      { mkinfix $1 ">" $3 }
+  | expr OR expr
+      { mkinfix $1 "or" $3 }
+  | expr BARBAR expr
+      { mkinfix $1 "||" $3 }
+  | expr AMPERSAND expr
+      { mkinfix $1 "&" $3 }
+  | expr AMPERAMPER expr
+      { mkinfix $1 "&&" $3 }
+  | expr COLONEQUAL expr
+      { mkinfix $1 ":=" $3 }
+  | subtractive expr %prec prec_unary_minus
+      { mkuminus $1 $2 }
+  | additive expr %prec prec_unary_plus
+      { mkuplus $1 $2 }
+  | simple_expr DOT label_longident LESSMINUS expr
+      { mkexp(Pexp_setfield($1, mkrhs $3 3, $5)) }
+  | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
+      { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")),
+                         [Nolabel,$1; Nolabel,$4; Nolabel,$7])) }
+  | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
+      { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")),
+                         [Nolabel,$1; Nolabel,$4; Nolabel,$7])) }
+  | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
+      { bigarray_set $1 $4 $7 }
+  | label LESSMINUS expr
+      { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
+  | ASSERT ext_attributes simple_expr %prec below_HASH
+      { mkexp_attrs (Pexp_assert $3) $2 }
+  | LAZY ext_attributes simple_expr %prec below_HASH
+      { mkexp_attrs (Pexp_lazy $3) $2 }
+  | OBJECT ext_attributes class_structure END
+      { mkexp_attrs (Pexp_object $3) $2 }
+  | OBJECT ext_attributes class_structure error
+      { unclosed "object" 1 "end" 4 }
+  | expr attribute
+      { Exp.attr $1 $2 }
+  | UNDERSCORE
+     { not_expecting 1 "wildcard \"_\"" }
+;
+simple_expr:
+    val_longident
+      { mkexp(Pexp_ident (mkrhs $1 1)) }
+  | constant
+      { mkexp(Pexp_constant $1) }
+  | constr_longident %prec prec_constant_constructor
+      { mkexp(Pexp_construct(mkrhs $1 1, None)) }
+  | name_tag %prec prec_constant_constructor
+      { mkexp(Pexp_variant($1, None)) }
+  | LPAREN seq_expr RPAREN
+      { reloc_exp $2 }
+  | LPAREN seq_expr error
+      { unclosed "(" 1 ")" 3 }
+  | BEGIN ext_attributes seq_expr END
+      { wrap_exp_attrs (reloc_exp $3) $2 (* check location *) }
+  | BEGIN ext_attributes END
+      { mkexp_attrs (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()),
+                               None)) $2 }
+  | BEGIN ext_attributes seq_expr error
+      { unclosed "begin" 1 "end" 4 }
+  | LPAREN seq_expr type_constraint RPAREN
+      { mkexp_constraint $2 $3 }
+  | simple_expr DOT label_longident
+      { mkexp(Pexp_field($1, mkrhs $3 3)) }
+  | mod_longident DOT LPAREN seq_expr RPAREN
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) }
+  | mod_longident DOT LPAREN RPAREN
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1,
+                        mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) }
+  | mod_longident DOT LPAREN seq_expr error
+      { unclosed "(" 3 ")" 5 }
+  | simple_expr DOT LPAREN seq_expr RPAREN
+      { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")),
+                         [Nolabel,$1; Nolabel,$4])) }
+  | simple_expr DOT LPAREN seq_expr error
+      { unclosed "(" 3 ")" 5 }
+  | simple_expr DOT LBRACKET seq_expr RBRACKET
+      { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")),
+                         [Nolabel,$1; Nolabel,$4])) }
+  | simple_expr DOT LBRACKET seq_expr error
+      { unclosed "[" 3 "]" 5 }
+  | simple_expr DOT LBRACE expr RBRACE
+      { bigarray_get $1 $4 }
+  | simple_expr DOT LBRACE expr_comma_list error
+      { unclosed "{" 3 "}" 5 }
+  | LBRACE record_expr RBRACE
+      { let (exten, fields) = $2 in mkexp (Pexp_record(fields, exten)) }
+  | LBRACE record_expr error
+      { unclosed "{" 1 "}" 3 }
+  | mod_longident DOT LBRACE record_expr RBRACE
+      { let (exten, fields) = $4 in
+        let rec_exp = mkexp(Pexp_record(fields, exten)) in
+        mkexp(Pexp_open(Fresh, mkrhs $1 1, rec_exp)) }
+  | mod_longident DOT LBRACE record_expr error
+      { unclosed "{" 3 "}" 5 }
+  | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET
+      { mkexp (Pexp_array(List.rev $2)) }
+  | LBRACKETBAR expr_semi_list opt_semi error
+      { unclosed "[|" 1 "|]" 4 }
+  | LBRACKETBAR BARRBRACKET
+      { mkexp (Pexp_array []) }
+  | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi BARRBRACKET
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array(List.rev $4)))) }
+  | mod_longident DOT LBRACKETBAR BARRBRACKET
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array []))) }
+  | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi error
+      { unclosed "[|" 3 "|]" 6 }
+  | LBRACKET expr_semi_list opt_semi RBRACKET
+      { reloc_exp (mktailexp (rhs_loc 4) (List.rev $2)) }
+  | LBRACKET expr_semi_list opt_semi error
+      { unclosed "[" 1 "]" 4 }
+  | mod_longident DOT LBRACKET expr_semi_list opt_semi RBRACKET
+      { let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev $4)) in
+        mkexp(Pexp_open(Fresh, mkrhs $1 1, list_exp)) }
+  | mod_longident DOT LBRACKET RBRACKET
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1,
+                        mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) }
+  | mod_longident DOT LBRACKET expr_semi_list opt_semi error
+      { unclosed "[" 3 "]" 6 }
+  | PREFIXOP simple_expr
+      { mkexp(Pexp_apply(mkoperator $1 1, [Nolabel,$2])) }
+  | BANG simple_expr
+      { mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,$2])) }
+  | NEW ext_attributes class_longident
+      { mkexp_attrs (Pexp_new(mkrhs $3 3)) $2 }
+  | LBRACELESS field_expr_list GREATERRBRACE
+      { mkexp (Pexp_override $2) }
+  | LBRACELESS field_expr_list error
+      { unclosed "{<" 1 ">}" 3 }
+  | LBRACELESS GREATERRBRACE
+      { mkexp (Pexp_override [])}
+  | mod_longident DOT LBRACELESS field_expr_list GREATERRBRACE
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override $4)))}
+  | mod_longident DOT LBRACELESS GREATERRBRACE
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))}
+  | mod_longident DOT LBRACELESS field_expr_list error
+      { unclosed "{<" 3 ">}" 5 }
+  | simple_expr HASH label
+      { mkexp(Pexp_send($1, mkrhs $3 3)) }
+  | simple_expr HASHOP simple_expr
+      { mkinfix $1 $2 $3 }
+  | LPAREN MODULE ext_attributes module_expr RPAREN
+      { mkexp_attrs (Pexp_pack $4) $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN
+      { mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $4),
+                                      ghtyp (Ptyp_package $6)))
+                    $3 }
+  | LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" 1 ")" 6 }
+  | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON
+    package_type RPAREN
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1,
+        mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $6),
+                                ghtyp (Ptyp_package $8)))
+                    $5 )) }
+  | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON error
+      { unclosed "(" 3 ")" 8 }
+  | extension
+      { mkexp (Pexp_extension $1) }
+;
+simple_labeled_expr_list:
+    labeled_simple_expr
+      { [$1] }
+  | simple_labeled_expr_list labeled_simple_expr
+      { $2 :: $1 }
+;
+labeled_simple_expr:
+    simple_expr %prec below_HASH
+      { (Nolabel, $1) }
+  | label_expr
+      { $1 }
+;
+label_expr:
+    LABEL simple_expr %prec below_HASH
+      { (Labelled $1, $2) }
+  | TILDE label_ident
+      { (Labelled (fst $2), snd $2) }
+  | QUESTION label_ident
+      { (Optional (fst $2), snd $2) }
+  | OPTLABEL simple_expr %prec below_HASH
+      { (Optional $1, $2) }
+;
+label_ident:
+    LIDENT   { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) }
+;
+lident_list:
+    LIDENT                            { [mkrhs $1 1] }
+  | LIDENT lident_list                { mkrhs $1 1 :: $2 }
+;
+let_binding_body:
+    val_ident fun_binding
+      { (mkpatvar $1 1, $2) }
+  | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
+      { (ghpat(Ppat_constraint(mkpatvar $1 1,
+                               ghtyp(Ptyp_poly(List.rev $3,$5)))),
+         $7) }
+  | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+      { let exp, poly = wrap_type_annotation $4 $6 $8 in
+        (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
+  | pattern_no_exn EQUAL seq_expr
+      { ($1, $3) }
+  | simple_pattern_not_ident COLON core_type EQUAL seq_expr
+      { (ghpat(Ppat_constraint($1, $3)), $5) }
+;
+let_bindings:
+    let_binding                                 { $1 }
+  | let_bindings and_let_binding                { addlb $1 $2 }
+;
+let_binding:
+    LET ext_attributes rec_flag let_binding_body post_item_attributes
+      { let (ext, attr) = $2 in
+        mklbs ext $3 (mklb true $4 (attr@$5)) }
+;
+and_let_binding:
+    AND attributes let_binding_body post_item_attributes
+      { mklb false $3 ($2@$4) }
+;
+fun_binding:
+    strict_binding
+      { $1 }
+  | type_constraint EQUAL seq_expr
+      { mkexp_constraint $3 $1 }
+;
+strict_binding:
+    EQUAL seq_expr
+      { $2 }
+  | labeled_simple_pattern fun_binding
+      { let (l, o, p) = $1 in ghexp(Pexp_fun(l, o, p, $2)) }
+  | LPAREN TYPE lident_list RPAREN fun_binding
+      { mk_newtypes $3 $5 }
+;
+match_cases:
+    match_case { [$1] }
+  | match_cases BAR match_case { $3 :: $1 }
+;
+match_case:
+    pattern MINUSGREATER seq_expr
+      { Exp.case $1 $3 }
+  | pattern WHEN seq_expr MINUSGREATER seq_expr
+      { Exp.case $1 ~guard:$3 $5 }
+  | pattern MINUSGREATER DOT
+      { Exp.case $1 (Exp.unreachable ~loc:(rhs_loc 3) ())}
+;
+fun_def:
+    MINUSGREATER seq_expr
+      { $2 }
+  | COLON simple_core_type MINUSGREATER seq_expr
+      { mkexp (Pexp_constraint ($4, $2)) }
+/* Cf #5939: we used to accept (fun p when e0 -> e) */
+  | labeled_simple_pattern fun_def
+      {
+       let (l,o,p) = $1 in
+       ghexp(Pexp_fun(l, o, p, $2))
+      }
+  | LPAREN TYPE lident_list RPAREN fun_def
+      { mk_newtypes $3 $5 }
+;
+expr_comma_list:
+    expr_comma_list COMMA expr                  { $3 :: $1 }
+  | expr COMMA expr                             { [$3; $1] }
+;
+record_expr:
+    simple_expr WITH lbl_expr_list              { (Some $1, $3) }
+  | lbl_expr_list                               { (None, $1) }
+;
+lbl_expr_list:
+     lbl_expr { [$1] }
+  |  lbl_expr SEMI lbl_expr_list { $1 :: $3 }
+  |  lbl_expr SEMI { [$1] }
+;
+lbl_expr:
+    label_longident opt_type_constraint EQUAL expr
+      { (mkrhs $1 1, mkexp_opt_constraint $4 $2) }
+  | label_longident opt_type_constraint
+      { (mkrhs $1 1, mkexp_opt_constraint (exp_of_label $1 1) $2) }
+;
+field_expr_list:
+    field_expr opt_semi { [$1] }
+  | field_expr SEMI field_expr_list { $1 :: $3 }
+;
+field_expr:
+    label EQUAL expr
+      { (mkrhs $1 1, $3) }
+  | label
+      { (mkrhs $1 1, exp_of_label (Lident $1) 1) }
+;
+expr_semi_list:
+    expr                                        { [$1] }
+  | expr_semi_list SEMI expr                    { $3 :: $1 }
+;
+type_constraint:
+    COLON core_type                             { (Some $2, None) }
+  | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
+  | COLONGREATER core_type                      { (None, Some $2) }
+  | COLON error                                 { syntax_error() }
+  | COLONGREATER error                          { syntax_error() }
+;
+opt_type_constraint:
+    type_constraint { Some $1 }
+  | /* empty */ { None }
+;
+
+/* Patterns */
+
+pattern:
+  | pattern AS val_ident
+      { mkpat(Ppat_alias($1, mkrhs $3 3)) }
+  | pattern AS error
+      { expecting 3 "identifier" }
+  | pattern_comma_list  %prec below_COMMA
+      { mkpat(Ppat_tuple(List.rev $1)) }
+  | pattern COLONCOLON pattern
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
+  | pattern COLONCOLON error
+      { expecting 3 "pattern" }
+  | pattern BAR pattern
+      { mkpat(Ppat_or($1, $3)) }
+  | pattern BAR error
+      { expecting 3 "pattern" }
+  | EXCEPTION ext_attributes pattern %prec prec_constr_appl
+      { mkpat_attrs (Ppat_exception $3) $2}
+  | pattern attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen { $1 }
+;
+pattern_no_exn:
+  | pattern_no_exn AS val_ident
+      { mkpat(Ppat_alias($1, mkrhs $3 3)) }
+  | pattern_no_exn AS error
+      { expecting 3 "identifier" }
+  | pattern_no_exn_comma_list  %prec below_COMMA
+      { mkpat(Ppat_tuple(List.rev $1)) }
+  | pattern_no_exn COLONCOLON pattern
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
+  | pattern_no_exn COLONCOLON error
+      { expecting 3 "pattern" }
+  | pattern_no_exn BAR pattern
+      { mkpat(Ppat_or($1, $3)) }
+  | pattern_no_exn BAR error
+      { expecting 3 "pattern" }
+  | pattern_no_exn attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen { $1 }
+;
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | constr_longident pattern %prec prec_constr_appl
+      { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
+  | name_tag pattern %prec prec_constr_appl
+      { mkpat(Ppat_variant($1, Some $2)) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
+      { unclosed "(" 4 ")" 8 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs (Ppat_lazy $3) $2}
+;
+simple_pattern:
+    val_ident %prec below_EQUAL
+      { mkpat(Ppat_var (mkrhs $1 1)) }
+  | simple_pattern_not_ident { $1 }
+;
+simple_pattern_not_ident:
+  | UNDERSCORE
+      { mkpat(Ppat_any) }
+  | signed_constant
+      { mkpat(Ppat_constant $1) }
+  | signed_constant DOTDOT signed_constant
+      { mkpat(Ppat_interval ($1, $3)) }
+  | constr_longident
+      { mkpat(Ppat_construct(mkrhs $1 1, None)) }
+  | name_tag
+      { mkpat(Ppat_variant($1, None)) }
+  | HASH type_longident
+      { mkpat(Ppat_type (mkrhs $2 2)) }
+  | simple_delimited_pattern
+      { $1 }
+  | mod_longident DOT simple_delimited_pattern
+      { mkpat @@ Ppat_open(mkrhs $1 1, $3) }
+  | mod_longident DOT LBRACKET RBRACKET
+    { mkpat @@ Ppat_open(mkrhs $1 1, mkpat @@
+               Ppat_construct ( mkrhs (Lident "[]") 4, None)) }
+  | mod_longident DOT LPAREN RPAREN
+      { mkpat @@ Ppat_open( mkrhs $1 1, mkpat @@
+                 Ppat_construct ( mkrhs (Lident "()") 4, None) ) }
+  | mod_longident DOT LPAREN pattern RPAREN
+      { mkpat @@ Ppat_open (mkrhs $1 1, $4)}
+  | mod_longident DOT LPAREN pattern error
+      {unclosed "(" 3 ")" 5  }
+  | mod_longident DOT LPAREN error
+      { expecting 4 "pattern" }
+  | LPAREN pattern RPAREN
+      { reloc_pat $2 }
+  | LPAREN pattern error
+      { unclosed "(" 1 ")" 3 }
+  | LPAREN pattern COLON core_type RPAREN
+      { mkpat(Ppat_constraint($2, $4)) }
+  | LPAREN pattern COLON core_type error
+      { unclosed "(" 1 ")" 5 }
+  | LPAREN pattern COLON error
+      { expecting 4 "type" }
+  | LPAREN MODULE ext_attributes UIDENT RPAREN
+      { mkpat_attrs (Ppat_unpack (mkrhs $4 4)) $3 }
+  | LPAREN MODULE ext_attributes UIDENT COLON package_type RPAREN
+      { mkpat_attrs
+          (Ppat_constraint(mkpat(Ppat_unpack (mkrhs $4 4)),
+                           ghtyp(Ptyp_package $6)))
+          $3 }
+  | LPAREN MODULE ext_attributes UIDENT COLON package_type error
+      { unclosed "(" 1 ")" 7 }
+  | extension
+      { mkpat(Ppat_extension $1) }
+;
+
+simple_delimited_pattern:
+  | LBRACE lbl_pattern_list RBRACE
+    { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
+  | LBRACE lbl_pattern_list error
+    { unclosed "{" 1 "}" 3 }
+  | LBRACKET pattern_semi_list opt_semi RBRACKET
+    { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
+  | LBRACKET pattern_semi_list opt_semi error
+    { unclosed "[" 1 "]" 4 }
+  | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
+    { mkpat(Ppat_array(List.rev $2)) }
+  | LBRACKETBAR BARRBRACKET
+    { mkpat(Ppat_array []) }
+  | LBRACKETBAR pattern_semi_list opt_semi error
+    { unclosed "[|" 1 "|]" 4 }
+
+pattern_comma_list:
+    pattern_comma_list COMMA pattern            { $3 :: $1 }
+  | pattern COMMA pattern                       { [$3; $1] }
+  | pattern COMMA error                         { expecting 3 "pattern" }
+;
+pattern_no_exn_comma_list:
+    pattern_no_exn_comma_list COMMA pattern     { $3 :: $1 }
+  | pattern_no_exn COMMA pattern                { [$3; $1] }
+  | pattern_no_exn COMMA error                  { expecting 3 "pattern" }
+;
+pattern_semi_list:
+    pattern                                     { [$1] }
+  | pattern_semi_list SEMI pattern              { $3 :: $1 }
+;
+lbl_pattern_list:
+    lbl_pattern { [$1], Closed }
+  | lbl_pattern SEMI { [$1], Closed }
+  | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open }
+  | lbl_pattern SEMI lbl_pattern_list
+      { let (fields, closed) = $3 in $1 :: fields, closed }
+;
+lbl_pattern:
+    label_longident opt_pattern_type_constraint EQUAL pattern
+     { (mkrhs $1 1, mkpat_opt_constraint $4 $2) }
+  | label_longident opt_pattern_type_constraint
+     { (mkrhs $1 1, mkpat_opt_constraint (pat_of_label $1 1) $2) }
+;
+opt_pattern_type_constraint:
+    COLON core_type { Some $2 }
+  | /* empty */ { None }
+;
+
+/* Value descriptions */
+
+value_description:
+    VAL ext_attributes val_ident COLON core_type post_item_attributes
+      { let (ext, attrs) = $2 in
+        Val.mk (mkrhs $3 3) $5 ~attrs:(attrs@$6)
+              ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+      , ext }
+;
+
+/* Primitive declarations */
+
+primitive_declaration_body:
+    STRING                                      { [fst $1] }
+  | STRING primitive_declaration_body           { fst $1 :: $2 }
+;
+primitive_declaration:
+    EXTERNAL ext_attributes val_ident COLON core_type EQUAL
+    primitive_declaration_body post_item_attributes
+      { let (ext, attrs) = $2 in
+        Val.mk (mkrhs $3 3) $5 ~prim:$7 ~attrs:(attrs@$8)
+              ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+      , ext }
+;
+
+/* Type declarations */
+
+type_declarations:
+    type_declaration
+      { let (nonrec_flag, ty, ext) = $1 in (nonrec_flag, [ty], ext) }
+  | type_declarations and_type_declaration
+      { let (nonrec_flag, tys, ext) = $1 in (nonrec_flag, $2 :: tys, ext) }
+;
+
+type_declaration:
+    TYPE ext_attributes nonrec_flag optional_type_parameters LIDENT
+    type_kind constraints post_item_attributes
+      { let (kind, priv, manifest) = $6 in
+        let (ext, attrs) = $2 in
+        let ty =
+          Type.mk (mkrhs $5 5) ~params:$4 ~cstrs:(List.rev $7) ~kind
+            ~priv ?manifest ~attrs:(attrs@$8)
+            ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
+        in
+          ($3, ty, ext) }
+;
+and_type_declaration:
+    AND attributes optional_type_parameters LIDENT type_kind constraints
+    post_item_attributes
+      { let (kind, priv, manifest) = $5 in
+          Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6)
+            ~kind ~priv ?manifest ~attrs:($2@$7) ~loc:(symbol_rloc ())
+            ~text:(symbol_text ()) ~docs:(symbol_docs ()) }
+;
+constraints:
+        constraints CONSTRAINT constrain        { $3 :: $1 }
+      | /* empty */                             { [] }
+;
+type_kind:
+    /*empty*/
+      { (Ptype_abstract, Public, None) }
+  | EQUAL core_type
+      { (Ptype_abstract, Public, Some $2) }
+  | EQUAL PRIVATE core_type
+      { (Ptype_abstract, Private, Some $3) }
+  | EQUAL constructor_declarations
+      { (Ptype_variant(List.rev $2), Public, None) }
+  | EQUAL PRIVATE constructor_declarations
+      { (Ptype_variant(List.rev $3), Private, None) }
+  | EQUAL DOTDOT
+      { (Ptype_open, Public, None) }
+  | EQUAL private_flag LBRACE label_declarations RBRACE
+      { (Ptype_record $4, $2, None) }
+  | EQUAL core_type EQUAL private_flag constructor_declarations
+      { (Ptype_variant(List.rev $5), $4, Some $2) }
+  | EQUAL core_type EQUAL DOTDOT
+      { (Ptype_open, Public, Some $2) }
+  | EQUAL core_type EQUAL private_flag LBRACE label_declarations RBRACE
+      { (Ptype_record $6, $4, Some $2) }
+;
+optional_type_parameters:
+    /*empty*/                                   { [] }
+  | optional_type_parameter                     { [$1] }
+  | LPAREN optional_type_parameter_list RPAREN  { List.rev $2 }
+;
+optional_type_parameter:
+    type_variance optional_type_variable        { $2, $1 }
+;
+optional_type_parameter_list:
+    optional_type_parameter                              { [$1] }
+  | optional_type_parameter_list COMMA optional_type_parameter    { $3 :: $1 }
+;
+optional_type_variable:
+    QUOTE ident                                 { mktyp(Ptyp_var $2) }
+  | UNDERSCORE                                  { mktyp(Ptyp_any) }
+;
+
+
+type_parameters:
+    /*empty*/                                   { [] }
+  | type_parameter                              { [$1] }
+  | LPAREN type_parameter_list RPAREN           { List.rev $2 }
+;
+type_parameter:
+    type_variance type_variable                   { $2, $1 }
+;
+type_variance:
+    /* empty */                                 { Invariant }
+  | PLUS                                        { Covariant }
+  | MINUS                                       { Contravariant }
+;
+type_variable:
+    QUOTE ident                                 { mktyp(Ptyp_var $2) }
+;
+type_parameter_list:
+    type_parameter                              { [$1] }
+  | type_parameter_list COMMA type_parameter    { $3 :: $1 }
+;
+constructor_declarations:
+    constructor_declaration                              { [$1] }
+  | bar_constructor_declaration                          { [$1] }
+  | constructor_declarations bar_constructor_declaration { $2 :: $1 }
+;
+constructor_declaration:
+  | constr_ident generalized_constructor_arguments attributes
+      {
+       let args,res = $2 in
+       Type.constructor (mkrhs $1 1) ~args ?res ~attrs:$3
+         ~loc:(symbol_rloc()) ~info:(symbol_info ())
+      }
+;
+bar_constructor_declaration:
+  | BAR constr_ident generalized_constructor_arguments attributes
+      {
+       let args,res = $3 in
+       Type.constructor (mkrhs $2 2) ~args ?res ~attrs:$4
+         ~loc:(symbol_rloc()) ~info:(symbol_info ())
+      }
+;
+str_exception_declaration:
+  | sig_exception_declaration                    { $1 }
+  | EXCEPTION ext_attributes constr_ident EQUAL constr_longident attributes
+    post_item_attributes
+      { let (ext,attrs) = $2 in
+        Te.rebind (mkrhs $3 3) (mkrhs $5 5) ~attrs:(attrs @ $6 @ $7)
+          ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+        , ext }
+;
+sig_exception_declaration:
+  | EXCEPTION ext_attributes constr_ident generalized_constructor_arguments
+    attributes post_item_attributes
+      { let args, res = $4 in
+        let (ext,attrs) = $2 in
+          Te.decl (mkrhs $3 3) ~args ?res ~attrs:(attrs @ $5 @ $6)
+            ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
+        , ext }
+;
+let_exception_declaration:
+    constr_ident generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 ~loc:(symbol_rloc()) }
+;
+generalized_constructor_arguments:
+    /*empty*/                     { (Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ($2,None) }
+  | COLON constructor_arguments MINUSGREATER simple_core_type
+                                  { ($2,Some $4) }
+  | COLON simple_core_type
+                                  { (Pcstr_tuple [],Some $2) }
+;
+
+constructor_arguments:
+  | core_type_list                   { Pcstr_tuple (List.rev $1) }
+  | LBRACE label_declarations RBRACE { Pcstr_record $2 }
+;
+label_declarations:
+    label_declaration                           { [$1] }
+  | label_declaration_semi                      { [$1] }
+  | label_declaration_semi label_declarations   { $1 :: $2 }
+;
+label_declaration:
+    mutable_flag label COLON poly_type_no_attr attributes
+      {
+       Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5
+         ~loc:(symbol_rloc()) ~info:(symbol_info ())
+      }
+;
+label_declaration_semi:
+    mutable_flag label COLON poly_type_no_attr attributes SEMI attributes
+      {
+       let info =
+         match rhs_info 5 with
+         | Some _ as info_before_semi -> info_before_semi
+         | None -> symbol_info ()
+       in
+       Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7)
+         ~loc:(symbol_rloc()) ~info
+      }
+;
+
+/* Type Extensions */
+
+str_type_extension:
+  TYPE ext_attributes nonrec_flag optional_type_parameters type_longident
+  PLUSEQ private_flag str_extension_constructors post_item_attributes
+      { let (ext, attrs) = $2 in
+        if $3 <> Recursive then not_expecting 3 "nonrec flag";
+        Te.mk (mkrhs $5 5) (List.rev $8) ~params:$4 ~priv:$7
+          ~attrs:(attrs@$9) ~docs:(symbol_docs ())
+        , ext }
+;
+sig_type_extension:
+  TYPE ext_attributes nonrec_flag optional_type_parameters type_longident
+  PLUSEQ private_flag sig_extension_constructors post_item_attributes
+      { let (ext, attrs) = $2 in
+        if $3 <> Recursive then not_expecting 3 "nonrec flag";
+        Te.mk (mkrhs $5 5) (List.rev $8) ~params:$4 ~priv:$7
+          ~attrs:(attrs @ $9) ~docs:(symbol_docs ())
+        , ext }
+;
+str_extension_constructors:
+    extension_constructor_declaration                     { [$1] }
+  | bar_extension_constructor_declaration                 { [$1] }
+  | extension_constructor_rebind                          { [$1] }
+  | bar_extension_constructor_rebind                      { [$1] }
+  | str_extension_constructors bar_extension_constructor_declaration
+      { $2 :: $1 }
+  | str_extension_constructors bar_extension_constructor_rebind
+      { $2 :: $1 }
+;
+sig_extension_constructors:
+    extension_constructor_declaration                     { [$1] }
+  | bar_extension_constructor_declaration                 { [$1] }
+  | sig_extension_constructors bar_extension_constructor_declaration
+      { $2 :: $1 }
+;
+extension_constructor_declaration:
+  | constr_ident generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3
+          ~loc:(symbol_rloc()) ~info:(symbol_info ()) }
+;
+bar_extension_constructor_declaration:
+  | BAR constr_ident generalized_constructor_arguments attributes
+      { let args, res = $3 in
+        Te.decl (mkrhs $2 2) ~args ?res ~attrs:$4
+           ~loc:(symbol_rloc()) ~info:(symbol_info ()) }
+;
+extension_constructor_rebind:
+  | constr_ident EQUAL constr_longident attributes
+      { Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~attrs:$4
+          ~loc:(symbol_rloc()) ~info:(symbol_info ()) }
+;
+bar_extension_constructor_rebind:
+  | BAR constr_ident EQUAL constr_longident attributes
+      { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:$5
+          ~loc:(symbol_rloc()) ~info:(symbol_info ()) }
+;
+
+/* "with" constraints (additional type equations over signature components) */
+
+with_constraints:
+    with_constraint                             { [$1] }
+  | with_constraints AND with_constraint        { $3 :: $1 }
+;
+with_constraint:
+    TYPE type_parameters label_longident with_type_binder core_type_no_attr
+    constraints
+      { Pwith_type
+          (mkrhs $3 3,
+           (Type.mk (mkrhs (Longident.last $3) 3)
+              ~params:$2
+              ~cstrs:(List.rev $6)
+              ~manifest:$5
+              ~priv:$4
+              ~loc:(symbol_rloc()))) }
+    /* used label_longident instead of type_longident to disallow
+       functor applications in type path */
+  | TYPE type_parameters label COLONEQUAL core_type_no_attr
+      { Pwith_typesubst
+          (Type.mk (mkrhs $3 3)
+             ~params:$2
+             ~manifest:$5
+             ~loc:(symbol_rloc())) }
+  | MODULE mod_longident EQUAL mod_ext_longident
+      { Pwith_module (mkrhs $2 2, mkrhs $4 4) }
+  | MODULE UIDENT COLONEQUAL mod_ext_longident
+      { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) }
+;
+with_type_binder:
+    EQUAL          { Public }
+  | EQUAL PRIVATE  { Private }
+;
+
+/* Polymorphic types */
+
+typevar_list:
+        QUOTE ident                             { [mkrhs $2 2] }
+      | typevar_list QUOTE ident                { mkrhs $3 3 :: $1 }
+;
+poly_type:
+        core_type
+          { $1 }
+      | typevar_list DOT core_type
+          { mktyp(Ptyp_poly(List.rev $1, $3)) }
+;
+poly_type_no_attr:
+        core_type_no_attr
+          { $1 }
+      | typevar_list DOT core_type_no_attr
+          { mktyp(Ptyp_poly(List.rev $1, $3)) }
+;
+
+/* Core types */
+
+core_type:
+    core_type_no_attr
+      { $1 }
+  | core_type attribute
+      { Typ.attr $1 $2 }
+;
+core_type_no_attr:
+    core_type2 %prec MINUSGREATER
+      { $1 }
+  | core_type2 AS QUOTE ident
+      { mktyp(Ptyp_alias($1, $4)) }
+;
+core_type2:
+    simple_core_type_or_tuple
+      { $1 }
+  | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2
+      { let param = extra_rhs_core_type $4 ~pos:4 in
+        mktyp (Ptyp_arrow(Optional $2 , param, $6)) }
+  | OPTLABEL core_type2 MINUSGREATER core_type2
+      { let param = extra_rhs_core_type $2 ~pos:2 in
+        mktyp(Ptyp_arrow(Optional $1 , param, $4))
+      }
+  | LIDENT COLON core_type2 MINUSGREATER core_type2
+      { let param = extra_rhs_core_type $3 ~pos:3 in
+        mktyp(Ptyp_arrow(Labelled $1, param, $5)) }
+  | core_type2 MINUSGREATER core_type2
+      { let param = extra_rhs_core_type $1 ~pos:1 in
+        mktyp(Ptyp_arrow(Nolabel, param, $3)) }
+;
+
+simple_core_type:
+    simple_core_type2  %prec below_HASH
+      { $1 }
+  | LPAREN core_type_comma_list RPAREN %prec below_HASH
+      { match $2 with [sty] -> sty | _ -> raise Parse_error }
+;
+
+simple_core_type2:
+    QUOTE ident
+      { mktyp(Ptyp_var $2) }
+  | UNDERSCORE
+      { mktyp(Ptyp_any) }
+  | type_longident
+      { mktyp(Ptyp_constr(mkrhs $1 1, [])) }
+  | simple_core_type2 type_longident
+      { mktyp(Ptyp_constr(mkrhs $2 2, [$1])) }
+  | LPAREN core_type_comma_list RPAREN type_longident
+      { mktyp(Ptyp_constr(mkrhs $4 4, List.rev $2)) }
+  | LESS meth_list GREATER
+      { let (f, c) = $2 in mktyp(Ptyp_object (f, c)) }
+  | LESS GREATER
+      { mktyp(Ptyp_object ([], Closed)) }
+  | HASH class_longident
+      { mktyp(Ptyp_class(mkrhs $2 2, [])) }
+  | simple_core_type2 HASH class_longident
+      { mktyp(Ptyp_class(mkrhs $3 3, [$1])) }
+  | LPAREN core_type_comma_list RPAREN HASH class_longident
+      { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2)) }
+  | LBRACKET tag_field RBRACKET
+      { mktyp(Ptyp_variant([$2], Closed, None)) }
+/* PR#3835: this is not LR(1), would need lookahead=2
+  | LBRACKET simple_core_type RBRACKET
+      { mktyp(Ptyp_variant([$2], Closed, None)) }
+*/
+  | LBRACKET BAR row_field_list RBRACKET
+      { mktyp(Ptyp_variant(List.rev $3, Closed, None)) }
+  | LBRACKET row_field BAR row_field_list RBRACKET
+      { mktyp(Ptyp_variant($2 :: List.rev $4, Closed, None)) }
+  | LBRACKETGREATER opt_bar row_field_list RBRACKET
+      { mktyp(Ptyp_variant(List.rev $3, Open, None)) }
+  | LBRACKETGREATER RBRACKET
+      { mktyp(Ptyp_variant([], Open, None)) }
+  | LBRACKETLESS opt_bar row_field_list RBRACKET
+      { mktyp(Ptyp_variant(List.rev $3, Closed, Some [])) }
+  | LBRACKETLESS opt_bar row_field_list GREATER name_tag_list RBRACKET
+      { mktyp(Ptyp_variant(List.rev $3, Closed, Some (List.rev $5))) }
+  | LPAREN MODULE ext_attributes package_type RPAREN
+      { mktyp_attrs (Ptyp_package $4) $3 }
+  | extension
+      { mktyp (Ptyp_extension $1) }
+;
+package_type:
+    module_type { package_type_of_module_type $1 }
+;
+row_field_list:
+    row_field                                   { [$1] }
+  | row_field_list BAR row_field                { $3 :: $1 }
+;
+row_field:
+    tag_field                                   { $1 }
+  | simple_core_type                            { Rinherit $1 }
+;
+tag_field:
+    name_tag OF opt_ampersand amper_type_list attributes
+      { Rtag ($1, add_info_attrs (symbol_info ()) $5, $3, List.rev $4) }
+  | name_tag attributes
+      { Rtag ($1, add_info_attrs (symbol_info ()) $2, true, []) }
+;
+opt_ampersand:
+    AMPERSAND                                   { true }
+  | /* empty */                                 { false }
+;
+amper_type_list:
+    core_type_no_attr                           { [$1] }
+  | amper_type_list AMPERSAND core_type_no_attr { $3 :: $1 }
+;
+name_tag_list:
+    name_tag                                    { [$1] }
+  | name_tag_list name_tag                      { $2 :: $1 }
+;
+simple_core_type_or_tuple:
+    simple_core_type { $1 }
+  | simple_core_type STAR core_type_list
+      { mktyp(Ptyp_tuple($1 :: List.rev $3)) }
+;
+core_type_comma_list:
+    core_type                                   { [$1] }
+  | core_type_comma_list COMMA core_type        { $3 :: $1 }
+;
+core_type_list:
+    simple_core_type                            { [$1] }
+  | core_type_list STAR simple_core_type        { $3 :: $1 }
+;
+meth_list:
+    field_semi meth_list                     { let (f, c) = $2 in ($1 :: f, c) }
+  | field_semi                                  { [$1], Closed }
+  | field                                       { [$1], Closed }
+  | DOTDOT                                      { [], Open }
+;
+field:
+  label COLON poly_type_no_attr attributes
+    { (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) }
+;
+
+field_semi:
+  label COLON poly_type_no_attr attributes SEMI attributes
+    { let info =
+        match rhs_info 4 with
+        | Some _ as info_before_semi -> info_before_semi
+        | None -> symbol_info ()
+      in
+      (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3) }
+;
+
+label:
+    LIDENT                                      { $1 }
+;
+
+/* Constants */
+
+constant:
+  | INT          { let (n, m) = $1 in Pconst_integer (n, m) }
+  | CHAR         { Pconst_char $1 }
+  | STRING       { let (s, d) = $1 in Pconst_string (s, d) }
+  | FLOAT        { let (f, m) = $1 in Pconst_float (f, m) }
+;
+signed_constant:
+    constant     { $1 }
+  | MINUS INT    { let (n, m) = $2 in Pconst_integer("-" ^ n, m) }
+  | MINUS FLOAT  { let (f, m) = $2 in Pconst_float("-" ^ f, m) }
+  | PLUS INT     { let (n, m) = $2 in Pconst_integer (n, m) }
+  | PLUS FLOAT   { let (f, m) = $2 in Pconst_float(f, m) }
+;
+
+/* Identifiers and long identifiers */
+
+ident:
+    UIDENT                                      { $1 }
+  | LIDENT                                      { $1 }
+;
+val_ident:
+    LIDENT                                      { $1 }
+  | LPAREN operator RPAREN                      { $2 }
+  | LPAREN operator error                       { unclosed "(" 1 ")" 3 }
+  | LPAREN error                                { expecting 2 "operator" }
+  | LPAREN MODULE error                         { expecting 3 "module-expr" }
+;
+operator:
+    PREFIXOP                                    { $1 }
+  | INFIXOP0                                    { $1 }
+  | INFIXOP1                                    { $1 }
+  | INFIXOP2                                    { $1 }
+  | INFIXOP3                                    { $1 }
+  | INFIXOP4                                    { $1 }
+  | HASHOP                                     { $1 }
+  | BANG                                        { "!" }
+  | PLUS                                        { "+" }
+  | PLUSDOT                                     { "+." }
+  | MINUS                                       { "-" }
+  | MINUSDOT                                    { "-." }
+  | STAR                                        { "*" }
+  | EQUAL                                       { "=" }
+  | LESS                                        { "<" }
+  | GREATER                                     { ">" }
+  | OR                                          { "or" }
+  | BARBAR                                      { "||" }
+  | AMPERSAND                                   { "&" }
+  | AMPERAMPER                                  { "&&" }
+  | COLONEQUAL                                  { ":=" }
+  | PLUSEQ                                      { "+=" }
+  | PERCENT                                     { "%" }
+;
+constr_ident:
+    UIDENT                                      { $1 }
+  | LBRACKET RBRACKET                           { "[]" }
+  | LPAREN RPAREN                               { "()" }
+  /* | COLONCOLON                               { "::" } */
+  | LPAREN COLONCOLON RPAREN                    { "::" }
+  | FALSE                                       { "false" }
+  | TRUE                                        { "true" }
+;
+
+val_longident:
+    val_ident                                   { Lident $1 }
+  | mod_longident DOT val_ident                 { Ldot($1, $3) }
+;
+constr_longident:
+    mod_longident       %prec below_DOT         { $1 }
+  | LBRACKET RBRACKET                           { Lident "[]" }
+  | LPAREN RPAREN                               { Lident "()" }
+  | FALSE                                       { Lident "false" }
+  | TRUE                                        { Lident "true" }
+;
+label_longident:
+    LIDENT                                      { Lident $1 }
+  | mod_longident DOT LIDENT                    { Ldot($1, $3) }
+;
+type_longident:
+    LIDENT                                      { Lident $1 }
+  | mod_ext_longident DOT LIDENT                { Ldot($1, $3) }
+;
+mod_longident:
+    UIDENT                                      { Lident $1 }
+  | mod_longident DOT UIDENT                    { Ldot($1, $3) }
+;
+mod_ext_longident:
+    UIDENT                                      { Lident $1 }
+  | mod_ext_longident DOT UIDENT                { Ldot($1, $3) }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN { lapply $1 $3 }
+;
+mty_longident:
+    ident                                       { Lident $1 }
+  | mod_ext_longident DOT ident                 { Ldot($1, $3) }
+;
+clty_longident:
+    LIDENT                                      { Lident $1 }
+  | mod_ext_longident DOT LIDENT                { Ldot($1, $3) }
+;
+class_longident:
+    LIDENT                                      { Lident $1 }
+  | mod_longident DOT LIDENT                    { Ldot($1, $3) }
+;
+
+/* Toplevel directives */
+
+toplevel_directive:
+    HASH ident                 { Ptop_dir($2, Pdir_none) }
+  | HASH ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
+  | HASH ident INT             { let (n, m) = $3 in
+                                  Ptop_dir($2, Pdir_int (n ,m)) }
+  | HASH ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | HASH ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | HASH ident FALSE           { Ptop_dir($2, Pdir_bool false) }
+  | HASH ident TRUE            { Ptop_dir($2, Pdir_bool true) }
+;
+
+/* Miscellaneous */
+
+name_tag:
+    BACKQUOTE ident                             { $2 }
+;
+rec_flag:
+    /* empty */                                 { Nonrecursive }
+  | REC                                         { Recursive }
+;
+nonrec_flag:
+    /* empty */                                 { Recursive }
+  | NONREC                                      { Nonrecursive }
+;
+direction_flag:
+    TO                                          { Upto }
+  | DOWNTO                                      { Downto }
+;
+private_flag:
+    /* empty */                                 { Public }
+  | PRIVATE                                     { Private }
+;
+mutable_flag:
+    /* empty */                                 { Immutable }
+  | MUTABLE                                     { Mutable }
+;
+virtual_flag:
+    /* empty */                                 { Concrete }
+  | VIRTUAL                                     { Virtual }
+;
+private_virtual_flags:
+    /* empty */  { Public, Concrete }
+  | PRIVATE { Private, Concrete }
+  | VIRTUAL { Public, Virtual }
+  | PRIVATE VIRTUAL { Private, Virtual }
+  | VIRTUAL PRIVATE { Private, Virtual }
+;
+override_flag:
+    /* empty */                                 { Fresh }
+  | BANG                                        { Override }
+;
+opt_bar:
+    /* empty */                                 { () }
+  | BAR                                         { () }
+;
+opt_semi:
+  | /* empty */                                 { () }
+  | SEMI                                        { () }
+;
+subtractive:
+  | MINUS                                       { "-" }
+  | MINUSDOT                                    { "-." }
+;
+additive:
+  | PLUS                                        { "+" }
+  | PLUSDOT                                     { "+." }
+;
+
+/* Attributes and extensions */
+
+single_attr_id:
+    LIDENT { $1 }
+  | UIDENT { $1 }
+  | AND { "and" }
+  | AS { "as" }
+  | ASSERT { "assert" }
+  | BEGIN { "begin" }
+  | CLASS { "class" }
+  | CONSTRAINT { "constraint" }
+  | DO { "do" }
+  | DONE { "done" }
+  | DOWNTO { "downto" }
+  | ELSE { "else" }
+  | END { "end" }
+  | EXCEPTION { "exception" }
+  | EXTERNAL { "external" }
+  | FALSE { "false" }
+  | FOR { "for" }
+  | FUN { "fun" }
+  | FUNCTION { "function" }
+  | FUNCTOR { "functor" }
+  | IF { "if" }
+  | IN { "in" }
+  | INCLUDE { "include" }
+  | INHERIT { "inherit" }
+  | INITIALIZER { "initializer" }
+  | LAZY { "lazy" }
+  | LET { "let" }
+  | MATCH { "match" }
+  | METHOD { "method" }
+  | MODULE { "module" }
+  | MUTABLE { "mutable" }
+  | NEW { "new" }
+  | NONREC { "nonrec" }
+  | OBJECT { "object" }
+  | OF { "of" }
+  | OPEN { "open" }
+  | OR { "or" }
+  | PRIVATE { "private" }
+  | REC { "rec" }
+  | SIG { "sig" }
+  | STRUCT { "struct" }
+  | THEN { "then" }
+  | TO { "to" }
+  | TRUE { "true" }
+  | TRY { "try" }
+  | TYPE { "type" }
+  | VAL { "val" }
+  | VIRTUAL { "virtual" }
+  | WHEN { "when" }
+  | WHILE { "while" }
+  | WITH { "with" }
+/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
+;
+
+attr_id:
+    single_attr_id { mkloc $1 (symbol_rloc()) }
+  | single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())}
+;
+attribute:
+  LBRACKETAT attr_id payload RBRACKET { ($2, $3) }
+;
+post_item_attribute:
+  LBRACKETATAT attr_id payload RBRACKET { ($2, $3) }
+;
+floating_attribute:
+  LBRACKETATATAT attr_id payload RBRACKET { ($2, $3) }
+;
+post_item_attributes:
+    /* empty */  { [] }
+  | post_item_attribute post_item_attributes { $1 :: $2 }
+;
+attributes:
+    /* empty */{ [] }
+  | attribute attributes { $1 :: $2 }
+;
+ext_attributes:
+    /* empty */  { None, [] }
+  | attribute attributes { None, $1 :: $2 }
+  | PERCENT attr_id attributes { Some $2, $3 }
+;
+extension:
+  LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
+;
+item_extension:
+  LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
+;
+payload:
+    structure { PStr $1 }
+  | COLON signature { PSig $2 }
+  | COLON core_type { PTyp $2 }
+  | QUESTION pattern { PPat ($2, None) }
+  | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
+;
+%%
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
new file mode 100644
index 00000000..1155ddc9
--- /dev/null
+++ b/parsing/parsetree.mli
@@ -0,0 +1,866 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree produced by parsing *)
+
+open Asttypes
+
+type constant =
+    Pconst_integer of string * char option
+  (* 3 3l 3L 3n
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
+  *)
+  | Pconst_char of char
+  (* 'c' *)
+  | Pconst_string of string * string option
+  (* "constant"
+     {delim|other constant|delim}
+  *)
+  | Pconst_float of string * char option
+  (* 3.4 2e5 1.4e-4
+
+     Suffixes [g-z][G-Z] are accepted by the parser.
+     Suffixes are rejected by the typechecker.
+  *)
+
+(** {2 Extension points} *)
+
+type attribute = string loc * payload
+       (* [@id ARG]
+          [@@id ARG]
+
+          Metadata containers passed around within the AST.
+          The compiler ignores unknown attributes.
+       *)
+
+and extension = string loc * payload
+      (* [%id ARG]
+         [%%id ARG]
+
+         Sub-language placeholder -- rejected by the typechecker.
+      *)
+
+and attributes = attribute list
+
+and payload =
+  | PStr of structure
+  | PSig of signature (* : SIG *)
+  | PTyp of core_type  (* : T *)
+  | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+
+(** {2 Core language} *)
+
+(* Type expressions *)
+
+and core_type =
+    {
+     ptyp_desc: core_type_desc;
+     ptyp_loc: Location.t;
+     ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and core_type_desc =
+  | Ptyp_any
+        (*  _ *)
+  | Ptyp_var of string
+        (* 'a *)
+  | Ptyp_arrow of arg_label * core_type * core_type
+        (* T1 -> T2       Simple
+           ~l:T1 -> T2    Labelled
+           ?l:T1 -> T2    Otional
+         *)
+  | Ptyp_tuple of core_type list
+        (* T1 * ... * Tn
+
+           Invariant: n >= 2
+        *)
+  | Ptyp_constr of Longident.t loc * core_type list
+        (* tconstr
+           T tconstr
+           (T1, ..., Tn) tconstr
+         *)
+  | Ptyp_object of (string loc * attributes * core_type) list * closed_flag
+        (* < l1:T1; ...; ln:Tn >     (flag = Closed)
+           < l1:T1; ...; ln:Tn; .. > (flag = Open)
+         *)
+  | Ptyp_class of Longident.t loc * core_type list
+        (* #tconstr
+           T #tconstr
+           (T1, ..., Tn) #tconstr
+         *)
+  | Ptyp_alias of core_type * string
+        (* T as 'a *)
+  | Ptyp_variant of row_field list * closed_flag * label list option
+        (* [ `A|`B ]         (flag = Closed; labels = None)
+           [> `A|`B ]        (flag = Open;   labels = None)
+           [< `A|`B ]        (flag = Closed; labels = Some [])
+           [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
+         *)
+  | Ptyp_poly of string loc list * core_type
+        (* 'a1 ... 'an. T
+
+           Can only appear in the following context:
+
+           - As the core_type of a Ppat_constraint node corresponding
+             to a constraint on a let-binding: let x : 'a1 ... 'an. T
+             = e ...
+
+           - Under Cfk_virtual for methods (not values).
+
+           - As the core_type of a Pctf_method node.
+
+           - As the core_type of a Pexp_poly node.
+
+           - As the pld_type field of a label_declaration.
+
+           - As a core_type of a Ptyp_object node.
+         *)
+
+  | Ptyp_package of package_type
+        (* (module S) *)
+  | Ptyp_extension of extension
+        (* [%id] *)
+
+and package_type = Longident.t loc * (Longident.t loc * core_type) list
+      (*
+        (module S)
+        (module S with type t1 = T1 and ... and tn = Tn)
+       *)
+
+and row_field =
+  | Rtag of label * attributes * bool * core_type list
+        (* [`A]                   ( true,  [] )
+           [`A of T]              ( false, [T] )
+           [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
+           [`A of & T1 & .. & Tn] ( true,  [T1;...Tn] )
+
+          - The 2nd field is true if the tag contains a
+            constant (empty) constructor.
+          - '&' occurs when several types are used for the same constructor
+            (see 4.2 in the manual)
+
+          - TODO: switch to a record representation, and keep location
+        *)
+  | Rinherit of core_type
+        (* [ T ] *)
+
+(* Patterns *)
+
+and pattern =
+    {
+     ppat_desc: pattern_desc;
+     ppat_loc: Location.t;
+     ppat_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and pattern_desc =
+  | Ppat_any
+        (* _ *)
+  | Ppat_var of string loc
+        (* x *)
+  | Ppat_alias of pattern * string loc
+        (* P as 'a *)
+  | Ppat_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Ppat_interval of constant * constant
+        (* 'a'..'z'
+
+           Other forms of interval are recognized by the parser
+           but rejected by the type-checker. *)
+  | Ppat_tuple of pattern list
+        (* (P1, ..., Pn)
+
+           Invariant: n >= 2
+        *)
+  | Ppat_construct of Longident.t loc * pattern option
+        (* C                None
+           C P              Some P
+           C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn])
+         *)
+  | Ppat_variant of label * pattern option
+        (* `A             (None)
+           `A P           (Some P)
+         *)
+  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
+        (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+           { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+           Invariant: n > 0
+         *)
+  | Ppat_array of pattern list
+        (* [| P1; ...; Pn |] *)
+  | Ppat_or of pattern * pattern
+        (* P1 | P2 *)
+  | Ppat_constraint of pattern * core_type
+        (* (P : T) *)
+  | Ppat_type of Longident.t loc
+        (* #tconst *)
+  | Ppat_lazy of pattern
+        (* lazy P *)
+  | Ppat_unpack of string loc
+        (* (module P)
+           Note: (module P : S) is represented as
+           Ppat_constraint(Ppat_unpack, Ptyp_package)
+         *)
+  | Ppat_exception of pattern
+        (* exception P *)
+  | Ppat_extension of extension
+        (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
+        (* M.(P) *)
+
+(* Value expressions *)
+
+and expression =
+    {
+     pexp_desc: expression_desc;
+     pexp_loc: Location.t;
+     pexp_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and expression_desc =
+  | Pexp_ident of Longident.t loc
+        (* x
+           M.x
+         *)
+  | Pexp_constant of constant
+        (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Pexp_let of rec_flag * value_binding list * expression
+        (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Pexp_function of case list
+        (* function P1 -> E1 | ... | Pn -> En *)
+  | Pexp_fun of arg_label * expression option * pattern * expression
+        (* fun P -> E1                          (Simple, None)
+           fun ~l:P -> E1                       (Labelled l, None)
+           fun ?l:P -> E1                       (Optional l, None)
+           fun ?l:(P = E0) -> E1                (Optional l, Some E0)
+
+           Notes:
+           - If E0 is provided, only Optional is allowed.
+           - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
+           - "let f P = E" is represented using Pexp_fun.
+         *)
+  | Pexp_apply of expression * (arg_label * expression) list
+        (* E0 ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pexp_match of expression * case list
+        (* match E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_try of expression * case list
+        (* try E0 with P1 -> E1 | ... | Pn -> En *)
+  | Pexp_tuple of expression list
+        (* (E1, ..., En)
+
+           Invariant: n >= 2
+        *)
+  | Pexp_construct of Longident.t loc * expression option
+        (* C                None
+           C E              Some E
+           C (E1, ..., En)  Some (Pexp_tuple[E1;...;En])
+        *)
+  | Pexp_variant of label * expression option
+        (* `A             (None)
+           `A E           (Some E)
+         *)
+  | Pexp_record of (Longident.t loc * expression) list * expression option
+        (* { l1=P1; ...; ln=Pn }     (None)
+           { E0 with l1=P1; ...; ln=Pn }   (Some E0)
+
+           Invariant: n > 0
+         *)
+  | Pexp_field of expression * Longident.t loc
+        (* E.l *)
+  | Pexp_setfield of expression * Longident.t loc * expression
+        (* E1.l <- E2 *)
+  | Pexp_array of expression list
+        (* [| E1; ...; En |] *)
+  | Pexp_ifthenelse of expression * expression * expression option
+        (* if E1 then E2 else E3 *)
+  | Pexp_sequence of expression * expression
+        (* E1; E2 *)
+  | Pexp_while of expression * expression
+        (* while E1 do E2 done *)
+  | Pexp_for of
+      pattern *  expression * expression * direction_flag * expression
+        (* for i = E1 to E2 do E3 done      (flag = Upto)
+           for i = E1 downto E2 do E3 done  (flag = Downto)
+         *)
+  | Pexp_constraint of expression * core_type
+        (* (E : T) *)
+  | Pexp_coerce of expression * core_type option * core_type
+        (* (E :> T)        (None, T)
+           (E : T0 :> T)   (Some T0, T)
+         *)
+  | Pexp_send of expression * string loc
+        (*  E # m *)
+  | Pexp_new of Longident.t loc
+        (* new M.c *)
+  | Pexp_setinstvar of string loc * expression
+        (* x <- 2 *)
+  | Pexp_override of (string loc * expression) list
+        (* {< x1 = E1; ...; Xn = En >} *)
+  | Pexp_letmodule of string loc * module_expr * expression
+        (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
+  | Pexp_assert of expression
+        (* assert E
+           Note: "assert false" is treated in a special way by the
+           type-checker. *)
+  | Pexp_lazy of expression
+        (* lazy E *)
+  | Pexp_poly of expression * core_type option
+        (* Used for method bodies.
+
+           Can only be used as the expression under Cfk_concrete
+           for methods (not values). *)
+  | Pexp_object of class_structure
+        (* object ... end *)
+  | Pexp_newtype of string loc * expression
+        (* fun (type t) -> E *)
+  | Pexp_pack of module_expr
+        (* (module ME)
+
+           (module ME : S) is represented as
+           Pexp_constraint(Pexp_pack, Ptyp_package S) *)
+  | Pexp_open of override_flag * Longident.t loc * expression
+        (* M.(E)
+           let open M in E
+           let! open M in E *)
+  | Pexp_extension of extension
+        (* [%id] *)
+  | Pexp_unreachable
+        (* . *)
+
+and case =   (* (P -> E) or (P when E0 -> E) *)
+    {
+     pc_lhs: pattern;
+     pc_guard: expression option;
+     pc_rhs: expression;
+    }
+
+(* Value descriptions *)
+
+and value_description =
+    {
+     pval_name: string loc;
+     pval_type: core_type;
+     pval_prim: string list;
+     pval_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+     pval_loc: Location.t;
+    }
+
+(*
+  val x: T                            (prim = [])
+  external x: T = "s1" ... "sn"       (prim = ["s1";..."sn"])
+*)
+
+(* Type declarations *)
+
+and type_declaration =
+    {
+     ptype_name: string loc;
+     ptype_params: (core_type * variance) list;
+           (* ('a1,...'an) t; None represents  _*)
+     ptype_cstrs: (core_type * core_type * Location.t) list;
+           (* ... constraint T1=T1'  ... constraint Tn=Tn' *)
+     ptype_kind: type_kind;
+     ptype_private: private_flag;   (* = private ... *)
+     ptype_manifest: core_type option;  (* = T *)
+     ptype_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+     ptype_loc: Location.t;
+    }
+
+(*
+  type t                     (abstract, no manifest)
+  type t = T0                (abstract, manifest=T0)
+  type t = C of T | ...      (variant,  no manifest)
+  type t = T0 = C of T | ... (variant,  manifest=T0)
+  type t = {l: T; ...}       (record,   no manifest)
+  type t = T0 = {l : T; ...} (record,   manifest=T0)
+  type t = ..                (open,     no manifest)
+*)
+
+and type_kind =
+  | Ptype_abstract
+  | Ptype_variant of constructor_declaration list
+        (* Invariant: non-empty list *)
+  | Ptype_record of label_declaration list
+        (* Invariant: non-empty list *)
+  | Ptype_open
+
+and label_declaration =
+    {
+     pld_name: string loc;
+     pld_mutable: mutable_flag;
+     pld_type: core_type;
+     pld_loc: Location.t;
+     pld_attributes: attributes; (* l [@id1] [@id2] : T *)
+    }
+
+(*  { ...; l: T; ... }            (mutable=Immutable)
+    { ...; mutable l: T; ... }    (mutable=Mutable)
+
+    Note: T can be a Ptyp_poly.
+*)
+
+and constructor_declaration =
+    {
+     pcd_name: string loc;
+     pcd_args: constructor_arguments;
+     pcd_res: core_type option;
+     pcd_loc: Location.t;
+     pcd_attributes: attributes; (* C [@id1] [@id2] of ... *)
+    }
+
+and constructor_arguments =
+  | Pcstr_tuple of core_type list
+  | Pcstr_record of label_declaration list
+
+(*
+  | C of T1 * ... * Tn     (res = None,    args = Pcstr_tuple [])
+  | C: T0                  (res = Some T0, args = [])
+  | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple)
+  | C of {...}             (res = None,    args = Pcstr_record)
+  | C: {...} -> T0         (res = Some T0, args = Pcstr_record)
+  | C of {...} as t        (res = None,    args = Pcstr_record)
+*)
+
+and type_extension =
+    {
+     ptyext_path: Longident.t loc;
+     ptyext_params: (core_type * variance) list;
+     ptyext_constructors: extension_constructor list;
+     ptyext_private: private_flag;
+     ptyext_attributes: attributes;   (* ... [@@id1] [@@id2] *)
+    }
+(*
+  type t += ...
+*)
+
+and extension_constructor =
+    {
+     pext_name: string loc;
+     pext_kind : extension_constructor_kind;
+     pext_loc : Location.t;
+     pext_attributes: attributes; (* C [@id1] [@id2] of ... *)
+    }
+
+and extension_constructor_kind =
+    Pext_decl of constructor_arguments * core_type option
+      (*
+         | C of T1 * ... * Tn     ([T1; ...; Tn], None)
+         | C: T0                  ([], Some T0)
+         | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0)
+       *)
+  | Pext_rebind of Longident.t loc
+      (*
+         | C = D
+       *)
+
+(** {2 Class language} *)
+
+(* Type expressions for the class language *)
+
+and class_type =
+    {
+     pcty_desc: class_type_desc;
+     pcty_loc: Location.t;
+     pcty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_type_desc =
+  | Pcty_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcty_signature of class_signature
+        (* object ... end *)
+  | Pcty_arrow of arg_label * core_type * class_type
+        (* T -> CT       Simple
+           ~l:T -> CT    Labelled l
+           ?l:T -> CT    Optional l
+         *)
+  | Pcty_extension of extension
+        (* [%id] *)
+
+and class_signature =
+    {
+     pcsig_self: core_type;
+     pcsig_fields: class_type_field list;
+    }
+(* object('selfpat) ... end
+   object ... end             (self = Ptyp_any)
+ *)
+
+and class_type_field =
+    {
+     pctf_desc: class_type_field_desc;
+     pctf_loc: Location.t;
+     pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_type_field_desc =
+  | Pctf_inherit of class_type
+        (* inherit CT *)
+  | Pctf_val of (string loc * mutable_flag * virtual_flag * core_type)
+        (* val x: T *)
+  | Pctf_method  of (string loc * private_flag * virtual_flag * core_type)
+        (* method x: T
+
+           Note: T can be a Ptyp_poly.
+         *)
+  | Pctf_constraint  of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pctf_attribute of attribute
+        (* [@@@id] *)
+  | Pctf_extension of extension
+        (* [%%id] *)
+
+and 'a class_infos =
+    {
+     pci_virt: virtual_flag;
+     pci_params: (core_type * variance) list;
+     pci_name: string loc;
+     pci_expr: 'a;
+     pci_loc: Location.t;
+     pci_attributes: attributes;  (* ... [@@id1] [@@id2] *)
+    }
+(* class c = ...
+   class ['a1,...,'an] c = ...
+   class virtual c = ...
+
+   Also used for "class type" declaration.
+*)
+
+and class_description = class_type class_infos
+
+and class_type_declaration = class_type class_infos
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     pcl_desc: class_expr_desc;
+     pcl_loc: Location.t;
+     pcl_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and class_expr_desc =
+  | Pcl_constr of Longident.t loc * core_type list
+        (* c
+           ['a1, ..., 'an] c *)
+  | Pcl_structure of class_structure
+        (* object ... end *)
+  | Pcl_fun of arg_label * expression option * pattern * class_expr
+        (* fun P -> CE                          (Simple, None)
+           fun ~l:P -> CE                       (Labelled l, None)
+           fun ?l:P -> CE                       (Optional l, None)
+           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
+         *)
+  | Pcl_apply of class_expr * (arg_label * expression) list
+        (* CE ~l1:E1 ... ~ln:En
+           li can be empty (non labeled argument) or start with '?'
+           (optional argument).
+
+           Invariant: n > 0
+         *)
+  | Pcl_let of rec_flag * value_binding list * class_expr
+        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
+         *)
+  | Pcl_constraint of class_expr * class_type
+        (* (CE : CT) *)
+  | Pcl_extension of extension
+        (* [%id] *)
+
+and class_structure =
+    {
+     pcstr_self: pattern;
+     pcstr_fields: class_field list;
+    }
+(* object(selfpat) ... end
+   object ... end           (self = Ppat_any)
+ *)
+
+and class_field =
+    {
+     pcf_desc: class_field_desc;
+     pcf_loc: Location.t;
+     pcf_attributes: attributes; (* ... [@@id1] [@@id2] *)
+    }
+
+and class_field_desc =
+  | Pcf_inherit of override_flag * class_expr * string loc option
+        (* inherit CE
+           inherit CE as x
+           inherit! CE
+           inherit! CE as x
+         *)
+  | Pcf_val of (string loc * mutable_flag * class_field_kind)
+        (* val x = E
+           val virtual x: T
+         *)
+  | Pcf_method of (string loc * private_flag * class_field_kind)
+        (* method x = E            (E can be a Pexp_poly)
+           method virtual x: T     (T can be a Ptyp_poly)
+         *)
+  | Pcf_constraint of (core_type * core_type)
+        (* constraint T1 = T2 *)
+  | Pcf_initializer of expression
+        (* initializer E *)
+  | Pcf_attribute of attribute
+        (* [@@@id] *)
+  | Pcf_extension of extension
+        (* [%%id] *)
+
+and class_field_kind =
+  | Cfk_virtual of core_type
+  | Cfk_concrete of override_flag * expression
+
+and class_declaration = class_expr class_infos
+
+(** {2 Module language} *)
+
+(* Type expressions for the module language *)
+
+and module_type =
+    {
+     pmty_desc: module_type_desc;
+     pmty_loc: Location.t;
+     pmty_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_type_desc =
+  | Pmty_ident of Longident.t loc
+        (* S *)
+  | Pmty_signature of signature
+        (* sig ... end *)
+  | Pmty_functor of string loc * module_type option * module_type
+        (* functor(X : MT1) -> MT2 *)
+  | Pmty_with of module_type * with_constraint list
+        (* MT with ... *)
+  | Pmty_typeof of module_expr
+        (* module type of ME *)
+  | Pmty_extension of extension
+        (* [%id] *)
+  | Pmty_alias of Longident.t loc
+        (* (module M) *)
+
+and signature = signature_item list
+
+and signature_item =
+    {
+     psig_desc: signature_item_desc;
+     psig_loc: Location.t;
+    }
+
+and signature_item_desc =
+  | Psig_value of value_description
+        (*
+          val x: T
+          external x: T = "s1" ... "sn"
+         *)
+  | Psig_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn = ... *)
+  | Psig_typext of type_extension
+        (* type t1 += ... *)
+  | Psig_exception of extension_constructor
+        (* exception C of T *)
+  | Psig_module of module_declaration
+        (* module X : MT *)
+  | Psig_recmodule of module_declaration list
+        (* module rec X1 : MT1 and ... and Xn : MTn *)
+  | Psig_modtype of module_type_declaration
+        (* module type S = MT
+           module type S *)
+  | Psig_open of open_description
+        (* open X *)
+  | Psig_include of include_description
+        (* include MT *)
+  | Psig_class of class_description list
+        (* class c1 : ... and ... and cn : ... *)
+  | Psig_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Psig_attribute of attribute
+        (* [@@@id] *)
+  | Psig_extension of extension * attributes
+        (* [%%id] *)
+
+and module_declaration =
+    {
+     pmd_name: string loc;
+     pmd_type: module_type;
+     pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmd_loc: Location.t;
+    }
+(* S : MT *)
+
+and module_type_declaration =
+    {
+     pmtd_name: string loc;
+     pmtd_type: module_type option;
+     pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
+     pmtd_loc: Location.t;
+    }
+(* S = MT
+   S       (abstract module type declaration, pmtd_type = None)
+*)
+
+and open_description =
+    {
+     popen_lid: Longident.t loc;
+     popen_override: override_flag;
+     popen_loc: Location.t;
+     popen_attributes: attributes;
+    }
+(* open! X - popen_override = Override (silences the 'used identifier
+                              shadowing' warning)
+   open  X - popen_override = Fresh
+ *)
+
+and 'a include_infos =
+    {
+     pincl_mod: 'a;
+     pincl_loc: Location.t;
+     pincl_attributes: attributes;
+    }
+
+and include_description = module_type include_infos
+(* include MT *)
+
+and include_declaration = module_expr include_infos
+(* include ME *)
+
+and with_constraint =
+  | Pwith_type of Longident.t loc * type_declaration
+        (* with type X.t = ...
+
+           Note: the last component of the longident must match
+           the name of the type_declaration. *)
+  | Pwith_module of Longident.t loc * Longident.t loc
+        (* with module X.Y = Z *)
+  | Pwith_typesubst of type_declaration
+        (* with type t := ... *)
+  | Pwith_modsubst of string loc * Longident.t loc
+        (* with module X := Z *)
+
+(* Value expressions for the module language *)
+
+and module_expr =
+    {
+     pmod_desc: module_expr_desc;
+     pmod_loc: Location.t;
+     pmod_attributes: attributes; (* ... [@id1] [@id2] *)
+    }
+
+and module_expr_desc =
+  | Pmod_ident of Longident.t loc
+        (* X *)
+  | Pmod_structure of structure
+        (* struct ... end *)
+  | Pmod_functor of string loc * module_type option * module_expr
+        (* functor(X : MT1) -> ME *)
+  | Pmod_apply of module_expr * module_expr
+        (* ME1(ME2) *)
+  | Pmod_constraint of module_expr * module_type
+        (* (ME : MT) *)
+  | Pmod_unpack of expression
+        (* (val E) *)
+  | Pmod_extension of extension
+        (* [%id] *)
+
+and structure = structure_item list
+
+and structure_item =
+    {
+     pstr_desc: structure_item_desc;
+     pstr_loc: Location.t;
+    }
+
+and structure_item_desc =
+  | Pstr_eval of expression * attributes
+        (* E *)
+  | Pstr_value of rec_flag * value_binding list
+        (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
+           let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
+         *)
+  | Pstr_primitive of value_description
+        (*  val x: T
+            external x: T = "s1" ... "sn" *)
+  | Pstr_type of rec_flag * type_declaration list
+        (* type t1 = ... and ... and tn = ... *)
+  | Pstr_typext of type_extension
+        (* type t1 += ... *)
+  | Pstr_exception of extension_constructor
+        (* exception C of T
+           exception C = M.X *)
+  | Pstr_module of module_binding
+        (* module X = ME *)
+  | Pstr_recmodule of module_binding list
+        (* module rec X1 = ME1 and ... and Xn = MEn *)
+  | Pstr_modtype of module_type_declaration
+        (* module type S = MT *)
+  | Pstr_open of open_description
+        (* open X *)
+  | Pstr_class of class_declaration list
+        (* class c1 = ... and ... and cn = ... *)
+  | Pstr_class_type of class_type_declaration list
+        (* class type ct1 = ... and ... and ctn = ... *)
+  | Pstr_include of include_declaration
+        (* include ME *)
+  | Pstr_attribute of attribute
+        (* [@@@id] *)
+  | Pstr_extension of extension * attributes
+        (* [%%id] *)
+
+and value_binding =
+  {
+    pvb_pat: pattern;
+    pvb_expr: expression;
+    pvb_attributes: attributes;
+    pvb_loc: Location.t;
+  }
+
+and module_binding =
+    {
+     pmb_name: string loc;
+     pmb_expr: module_expr;
+     pmb_attributes: attributes;
+     pmb_loc: Location.t;
+    }
+(* X = ME *)
+
+(** {2 Toplevel} *)
+
+(* Toplevel phrases *)
+
+type toplevel_phrase =
+  | Ptop_def of structure
+  | Ptop_dir of string * directive_argument
+     (* #use, #load ... *)
+
+and directive_argument =
+  | Pdir_none
+  | Pdir_string of string
+  | Pdir_int of string * char option
+  | Pdir_ident of Longident.t
+  | Pdir_bool of bool
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
new file mode 100644
index 00000000..c6f48d16
--- /dev/null
+++ b/parsing/pprintast.ml
@@ -0,0 +1,1474 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Thomas Gazagnaire, OCamlPro                       *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*               Hongbo Zhang, University of Pennsylvania                 *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+open Ast_helper
+
+let prefix_symbols  = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+                      '$'; '%' ]
+(* type fixity = Infix| Prefix  *)
+let special_infix_strings =
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ]
+
+(* determines if the string is an infix string.
+   checks backwards, first allowing a renaming postfix ("_102") which
+   may have resulted from Pexp -> Texp -> Pexp translation, then checking
+   if all the characters in the beginning of the string are valid infix
+   characters. *)
+let fixity_of_string  = function
+  | s when List.mem s special_infix_strings -> `Infix s
+  | s when List.mem s.[0] infix_symbols -> `Infix s
+  | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | _ -> `Normal
+
+let view_fixity_of_exp = function
+  | {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
+  | _ -> `Normal
+
+let is_infix  = function  | `Infix _ -> true | _  -> false
+
+(* which identifiers are in fact operators needing parentheses *)
+let needs_parens txt =
+  is_infix (fixity_of_string txt)
+  || List.mem txt.[0] prefix_symbols
+
+(* some infixes need spaces around parens to avoid clashes with comment
+   syntax *)
+let needs_spaces txt =
+  txt.[0]='*' || txt.[String.length txt - 1] = '*'
+
+(* add parentheses to binders when they are in fact infix or prefix operators *)
+let protect_ident ppf txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%s"
+    else if needs_spaces txt then "(@;%s@;)"
+    else "(%s)"
+  in fprintf ppf format txt
+
+let protect_longident ppf print_longident longprefix txt =
+  let format : (_, _, _) format =
+    if not (needs_parens txt) then "%a.%s"
+    else if needs_spaces txt then  "%a.(@;%s@;)"
+    else "%a.(%s)" in
+  fprintf ppf format print_longident longprefix txt
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+  | Override -> "!"
+  | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+  | Invariant -> ""
+  | Covariant -> "+"
+  | Contravariant -> "-"
+
+type construct =
+  [ `cons of expression list
+  | `list of expression list
+  | `nil
+  | `normal
+  | `simple of Longident.t
+  | `tuple ]
+
+let view_expr x =
+  match x.pexp_desc with
+  | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple
+  | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
+  | Pexp_construct ( {txt= Lident"::";_},Some _) ->
+      let rec loop exp acc = match exp with
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);_} ->
+              (List.rev acc,true)
+          | {pexp_desc=
+             Pexp_construct ({txt=Lident "::";_},
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);_}));_} ->
+              loop e2 (e1::acc)
+          | e -> (List.rev (e::acc),false) in
+      let (ls,b) = loop x []  in
+      if b then
+        `list ls
+      else `cons ls
+  | Pexp_construct (x,None) -> `simple (x.txt)
+  | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+  | `nil | `tuple | `list _ | `simple _  -> true
+  | `cons _ | `normal -> false
+
+let pp = fprintf
+
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
+            | [x] -> fu f x
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let constant f = function
+  | Pconst_char i -> pp f "%C"  i
+  | Pconst_string (i, None) -> pp f "%S" i
+  | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
+  | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+    paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) ->
+      pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let constant_string f s = pp f "%S" s
+let tyvar f str = pp f "'%s" str
+let tyvar_loc f str = pp f "'%s" str.txt
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
+    | Ptyp_arrow (l, ct1, ct2) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
+    | Ptyp_alias (ct, s) ->
+        pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
+    | Ptyp_poly (sl, ct) ->
+        pp f "@[<2>%a%a@]"
+          (fun f l ->
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar_loc ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
+    | Ptyp_any -> pp f "_";
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
+    | Ptyp_constr (li, l) ->
+        pp f (* "%a%a@;" *) "%a%a"
+          (fun f l -> match l with
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:"," f l)
+          l longident_loc li
+    | Ptyp_variant (l, closed, low) ->
+        let type_variant_helper f x =
+          match x with
+          | Rtag (l, attrs, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" string_quot l
+                (fun f l -> match l with
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) attrs
+          | Rinherit ct -> core_type ctxt f ct in
+        pp f "@[<2>[%a%a]@]"
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
+    | Ptyp_object (l, o) ->
+        let core_field_type f (s, attrs, ct) =
+          pp f "@[<hov2>%s: %a@ %a@ @]" s.txt
+            (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
+        in
+        let field_var f = function
+          | Asttypes.Closed -> ()
+          | Asttypes.Open ->
+              match l with
+              | [] -> pp f ".."
+              | _ -> pp f " ;.."
+        in
+        pp f "@[<hov2><@ %a%a@ > @]" (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
+    | Ptyp_class (li, l) ->   (*FIXME*)
+        pp f "@[<hov2>%a#%a@]"
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
+    | Ptyp_package (lid, cstrs) ->
+        let aux f (s, ct) =
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
+        (match cstrs with
+         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
+    | {ppat_desc= Ppat_or (p1,p2);_} ->
+        list_of_pattern  (p2::acc) p1
+    | x -> x::acc
+  in
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*)
+    | Ppat_or _ -> (* *)
+        pp f "@[<hov0>%a@]" (list ~sep:"@,|" (pattern ctxt))
+          (list_of_pattern [] x)
+    | _ -> pattern1 ctxt f x
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
+         Ppat_construct
+           ({ txt = Lident("::") ;_},
+            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); _}
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x
+    | Ppat_construct (({txt;_} as li), po) ->
+        (* FIXME The third field always false *)
+        if txt = Lident "::" then
+          pp f "%a" pattern_list_helper x
+        else
+          (match po with
+           | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | None -> pp f "%a@;"longident_loc li )
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f  "%s" x
+    | Ppat_any -> pp f "_";
+    | Ppat_var ({txt = txt;_}) -> protect_ident f txt
+    | Ppat_array l ->
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
+    | Ppat_unpack (s) ->
+        pp f "(module@ %s)@ " s.txt
+    | Ppat_type li ->
+        pp f "#%a" longident_loc li
+    | Ppat_record (l, closed) ->
+        let longident_x_pattern f (li, p) =
+          match (li,p.ppat_desc) with
+          | ({txt=Lident s;_ },Ppat_var {txt;_} ) when s = txt ->
+              pp f "@[<2>%a@]"  longident_loc li
+          | _ ->
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
+        | _ ->
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:"," (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
+    | Ppat_variant (l,None) ->  pp f "`%s" l
+    | Ppat_constraint (p, ct) ->
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
+    | Ppat_lazy p ->
+        pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p
+    | Ppat_exception p ->
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p.ppat_desc with
+      | Ppat_var {txt;_} when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
+      end
+  | Labelled l -> match p.ppat_desc with
+    | Ppat_var {txt;_} when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let print left right print_index indexes rem_args =
+            match func, rem_args with
+            | "get", [] ->
+              pp f "@[%a.%s%a%s@]"
+                (simple_expr ctxt) a
+                left (list ~sep:"," print_index) indexes right; true
+            | "set", [v] ->
+              pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a
+                left (list ~sep:"," print_index) indexes right
+                (simple_expr ctxt) v; true
+            | _ -> false
+          in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print "(" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print "[" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+            print "{" "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | _ -> false
+    end
+  | _ -> false
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
+    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_fun (l, e0, p, e) ->
+        pp f "@[<2>fun@;%a@;->@;%a@]"
+          (label_exp ctxt) (l, e0, p)
+          (expression ctxt) e
+    | Pexp_function l ->
+        pp f "@[<hv>function%a@]" (case_list ctxt) l
+    | Pexp_match (e, l) ->
+        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
+
+    | Pexp_try (e, l) ->
+        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
+    | Pexp_let (rf, l, e) ->
+        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
+           (*no identation here, a new line*) *)
+        (*   rec_flag rf *)
+        pp f "@[<2>%a in@;<1 -2>%a@]"
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
+    | Pexp_apply (e, l) ->
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, x)] ->
+                  pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
+            | _ ->
+                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
+
+    | Pexp_construct (li, Some eo)
+      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+        (match view_expr x with
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
+    | Pexp_setfield (e1, li, e2) ->
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        (* @;@[<2>else@ %a@]@] *)
+        let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
+          (fun f eo -> match eo with
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
+    | Pexp_sequence _ ->
+        let rec sequence_helper acc = function
+          | {pexp_desc=Pexp_sequence(e1,e2);_} ->
+              sequence_helper (e1::acc) e2
+          | v -> List.rev (v::acc) in
+        let lst = sequence_helper [] x in
+        pp f "@[<hv>%a@]"
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
+    | Pexp_new (li) ->
+        pp f "@[<hov2>new@ %a@]" longident_loc li;
+    | Pexp_setinstvar (s, e) ->
+        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
+    | Pexp_override l -> (* FIXME *)
+        let string_x_expression f (s, e) =
+          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
+        pp f "@[<hov2>{<%a>}@]"
+          (list string_x_expression  ~sep:";"  )  l;
+    | Pexp_letmodule (s, me, e) ->
+        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
+    | Pexp_assert e ->
+        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
+    | Pexp_lazy (e) ->
+        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
+    | Pexp_poly (e, None) ->
+        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
+    | Pexp_poly (e, Some ct) ->
+        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
+    | Pexp_open (ovf, lid, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+          (expression ctxt) e
+    | Pexp_variant (l,Some eo) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_field (e, li) ->
+        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
+
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_construct _  when is_simple_construct (view_expr x) ->
+        (match view_expr x with
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[<hv0>[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
+    | Pexp_ident li ->
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
+    | Pexp_pack me ->
+        pp f "(module@;%a)" (module_expr ctxt) me
+    | Pexp_newtype (lid, e) ->
+        pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e
+    | Pexp_tuple l ->
+        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
+    | Pexp_constraint (e, ct) ->
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
+    | Pexp_coerce (e, cto1, ct) ->
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
+    | Pexp_variant (l, None) -> pp f "`%s" l
+    | Pexp_record (l, eo) ->
+        let longident_x_expression f ( li, e) =
+          match e.pexp_desc with
+          |  Pexp_ident {txt;_} when li.txt = txt ->
+              pp f "@[<hov2>%a@]" longident_loc li
+          | _ ->
+              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
+        in
+        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
+    | Pexp_array (l) ->
+        pp f "@[<0>@[<2>[|%a|]@]@]"
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
+    | Pexp_while (e1, e2) ->
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
+    | Pexp_for (s, e1, e2, df, e3) ->
+        let fmt:(_,_,_)format =
+          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f (s, e) =
+  pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_attribute ctxt f (s, e) =
+  pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and floating_attribute ctxt f (s, e) =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f ext =
+  pp f "@[<hov2>exception@ %a@]" (extension_constructor ctxt) ext
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
+    (fun f ct -> match ct.ptyp_desc with
+       | Ptyp_any -> ()
+       | _ -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[<v>%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s.txt ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f e -> match e.pexp_desc with
+           | Pexp_poly (e, Some ct) ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | Pexp_poly (e,None) -> bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
+    match x.pcl_desc with
+    | Pcl_structure (cs) -> class_structure ctxt f cs
+    | Pcl_fun (l, eo, p, e) ->
+        pp f "fun@ %a@ ->@ %a"
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
+    | Pcl_let (rf, l, ce) ->
+        pp f "%a@ in@ %a"
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
+    | Pcl_apply (ce, l) ->
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
+    | Pcl_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l-> if l <>[] then
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
+    | Pcl_constraint (ce, ct) ->
+        pp f "(%a@ :@ %a)"
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
+    match x.pmty_desc with
+    | Pmty_ident li ->
+        pp f "%a" longident_loc li;
+    | Pmty_alias li ->
+        pp f "(module %a)" longident_loc li;
+    | Pmty_signature (s) ->
+        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
+    | Pmty_functor (_, None, mt2) ->
+        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
+    | Pmty_functor (s, Some mt1, mt2) ->
+        if s.txt = "_" then
+          pp f "@[<hov2>%a@ ->@ %a@]"
+            (module_type ctxt) mt1 (module_type ctxt) mt2
+        else
+          pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
+            (module_type ctxt) mt1 (module_type ctxt) mt2
+    | Pmty_with (mt, l) ->
+        let with_constraint f = function
+          | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
+              let ls = List.map fst ls in
+              pp f "type@ %a %a =@ %a"
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li (type_declaration ctxt) td
+          | Pwith_module (li, li2) ->
+              pp f "module %a =@ %a" longident_loc li longident_loc li2;
+          | Pwith_typesubst ({ptype_params=ls;_} as td) ->
+              let ls = List.map fst ls in
+              pp f "type@ %a %s :=@ %a"
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls td.ptype_name.txt
+                (type_declaration ctxt) td
+          | Pwith_modsubst (s, li2) ->
+              pp f "module %s :=@ %a" s.txt longident_loc li2 in
+        (match l with
+         | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
+         | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
+                  (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l)
+    | Pmty_typeof me ->
+        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) ->
+      pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[<hov>module@ %s@ :@ %a@]%a"
+        pmd.pmd_name.txt
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_open od ->
+      pp f "@[<hov2>open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_lid
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
+                (module_type ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
+                (module_type ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
+    | Pmod_structure (s) ->
+        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
+          (list (structure_item ctxt) ~sep:"@\n") s;
+    | Pmod_constraint (me, mt) ->
+        pp f "@[<hov2>(%a@ :@ %a)@]"
+          (module_expr ctxt) me
+          (module_type ctxt) mt
+    | Pmod_ident (li) ->
+        pp f "%a" longident_loc li;
+    | Pmod_functor (_, None, me) ->
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
+    | Pmod_functor (s, Some mt, me) ->
+        pp f "functor@ (%s@ :@ %a)@;->@;%a"
+          s.txt (module_type ctxt) mt (module_expr ctxt) me
+    | Pmod_apply (me1, me2) ->
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
+    | Pmod_unpack e ->
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":"; core_type ctxt f x
+  | PSig x -> pp f ":"; signature ctxt f x
+  | PPat (x, None) -> pp f "?"; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?"; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
+      | Pexp_fun (label, eo, p, e) ->
+          if label=Nolabel then
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
+          else
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
+      | Pexp_newtype (str,e) ->
+          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
+  let is_desugared_gadt p e =
+    let gadt_pattern =
+      match p.ppat_desc with
+      | Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+                        {ptyp_desc=Ptyp_poly (args_tyvars, rt)}) ->
+        Some (pat, args_tyvars, rt)
+      | _ -> None in
+    let rec gadt_exp tyvars e =
+      match e.pexp_desc with
+      | Pexp_newtype (tyvar, e) -> gadt_exp (tyvar :: tyvars) e
+      | Pexp_constraint (e, ct) -> Some (List.rev tyvars, e, ct)
+      | _ -> None in
+    let gadt_exp = gadt_exp [] e in
+    match gadt_pattern, gadt_exp with
+    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
+      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
+      let ety = Typ.varify_constructors e_tyvars e_ct in
+      if ety = pt_ct then
+      Some (p, pt_tyvars, e_ct, e) else None
+    | _ -> None in
+  if x.pexp_attributes <> []
+  then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
+  match is_desugared_gadt p x with
+  | Some (p, tyvars, ct, e) -> begin
+    pp f "%a@;: type@;%a.%a@;=@;%a"
+    (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
+    (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
+    end
+  | None -> begin
+      match (x.pexp_desc,p.ppat_desc) with
+      | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
+          begin match ty.ptyp_desc with
+          | Ptyp_poly _ ->
+              pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          | _ ->
+              pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+                (core_type ctxt) ty (expression ctxt) x
+          end
+      | (_, Ppat_var _) ->
+          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+      | _ ->
+          pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+    end
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]@ %a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[<v>%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[<hov2>;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper me =
+        match me.pmod_desc with
+        | Pmod_functor(s,mt,me') when me.pmod_attributes = [] ->
+            if mt = None then pp f "()"
+            else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
+            module_helper me'
+        | _ -> me
+      in
+      pp f "@[<hov2>module %s%a@]%a"
+        x.pmb_name.txt
+        (fun f me ->
+           let me = module_helper me in
+           match me.pmod_desc with
+           | Pmod_constraint
+               (me',
+                ({pmty_desc=(Pmty_ident (_)
+                            | Pmty_signature (_));_} as mt))
+             when me.pmod_attributes = [] ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_lid
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc cl =
+          match cl.pcl_desc with
+          | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] ->
+              loop ((l,eo,p) :: acc) cl'
+          | _ -> List.rev acc, cl
+        in
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl.pcl_desc with
+          | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] ->
+              Some ct, cl'
+          | _ -> None, cl
+        in
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
+        | _ -> assert false
+      in
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            pmb.pmb_name.txt
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, a) =
+  pp f "%s%a" (type_variance a) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l
+
+and type_def_list ctxt f (rf, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else " ="
+    in
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[<v>%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
+        if x.ptype_kind = Ptype_abstract then
+          pp f "%t@;%a" priv (core_type ctxt) y
+        else
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
+    in
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+        pp f "%t%t@\n%a" intro priv
+          (list ~sep:"@\n" constructor_declaration) xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s%a@;=@;%a" x.pext_name.txt
+        (attributes ctxt) x.pext_attributes
+        longident_loc li
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e.pexp_desc with
+    | Pexp_ident {txt=Lident l;_} -> Some l
+    | _ -> None
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x with
+  | Pdir_none -> ()
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
+
+let toplevel_phrase f x =
+  match x with
+  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
+   (* pp_open_hvbox f 0; *)
+   (* pp_print_list structure_item f s ; *)
+   (* pp_close_box f (); *)
+  | Ptop_dir (s, da) ->
+   pp f "@[<hov2>#%s@ %a@]" s directive_argument da
+   (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)
+
+let expression f x =
+  pp f "@[%a@]" (expression reset_ctxt) x
+
+let string_of_expression x =
+  ignore (flush_str_formatter ()) ;
+  let f = str_formatter in
+  expression f x;
+  flush_str_formatter ()
+
+let string_of_structure x =
+  ignore (flush_str_formatter ());
+  let f = str_formatter in
+  structure reset_ctxt f x;
+  flush_str_formatter ()
+
+let top_phrase f x =
+  pp_print_newline f ();
+  toplevel_phrase f x;
+  pp f ";;";
+  pp_print_newline f ()
+
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
new file mode 100644
index 00000000..60f57cf4
--- /dev/null
+++ b/parsing/pprintast.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Hongbo Zhang (University of Pennsylvania)                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
diff --git a/parsing/printast.ml b/parsing/printast.ml
new file mode 100644
index 00000000..6e167b3e
--- /dev/null
+++ b/parsing/printast.ml
@@ -0,0 +1,912 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Parsetree;;
+
+let fmt_position with_name f l =
+  let fname = if with_name then l.pos_fname else "" in
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+  fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+                       (fmt_position p_2nd_name) loc.loc_end;
+  if loc.loc_ghost then fprintf f " ghost";
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f (x : Longident.t loc) =
+  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f (x : string loc) =
+  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
+
+let fmt_char_option f = function
+  | None -> fprintf f "None"
+  | Some c -> fprintf f "Some %c" c
+
+let fmt_constant f x =
+  match x with
+  | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
+  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
+  | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s;
+  | Pconst_string (s, Some delim) ->
+      fprintf f "PConst_string (%S,Some %S)" s delim;
+  | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
+  attributes i ppf x.ptyp_attributes;
+  let i = i+1 in
+  match x.ptyp_desc with
+  | Ptyp_any -> line i ppf "Ptyp_any\n";
+  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
+  | Ptyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ptyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ptyp_tuple l ->
+      line i ppf "Ptyp_tuple\n";
+      list i core_type ppf l;
+  | Ptyp_constr (li, l) ->
+      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Ptyp_variant (l, closed, low) ->
+      line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ptyp_object (l, c) ->
+      line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter
+        (fun (s, attrs, t) ->
+          line i ppf "method %s\n" s.txt;
+          attributes i ppf attrs;
+          core_type (i + 1) ppf t
+        )
+        l
+  | Ptyp_class (li, l) ->
+      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
+      list i core_type ppf l
+  | Ptyp_alias (ct, s) ->
+      line i ppf "Ptyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ptyp_poly (sl, ct) ->
+      line i ppf "Ptyp_poly%a\n"
+        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl;
+      core_type i ppf ct;
+  | Ptyp_package (s, l) ->
+      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
+      list i package_with ppf l;
+  | Ptyp_extension (s, arg) ->
+      line i ppf "Ptyp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident_loc s;
+  core_type i ppf t
+
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
+  attributes i ppf x.ppat_attributes;
+  let i = i+1 in
+  match x.ppat_desc with
+  | Ppat_any -> line i ppf "Ppat_any\n";
+  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
+  | Ppat_alias (p, s) ->
+      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
+      pattern i ppf p;
+  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
+  | Ppat_interval (c1, c2) ->
+      line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
+  | Ppat_tuple (l) ->
+      line i ppf "Ppat_tuple\n";
+      list i pattern ppf l;
+  | Ppat_construct (li, po) ->
+      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
+      option i pattern ppf po;
+  | Ppat_variant (l, po) ->
+      line i ppf "Ppat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Ppat_record (l, c) ->
+      line i ppf "Ppat_record %a\n" fmt_closed_flag c;
+      list i longident_x_pattern ppf l;
+  | Ppat_array (l) ->
+      line i ppf "Ppat_array\n";
+      list i pattern ppf l;
+  | Ppat_or (p1, p2) ->
+      line i ppf "Ppat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+  | Ppat_lazy p ->
+      line i ppf "Ppat_lazy\n";
+      pattern i ppf p;
+  | Ppat_constraint (p, ct) ->
+      line i ppf "Ppat_constraint\n";
+      pattern i ppf p;
+      core_type i ppf ct;
+  | Ppat_type (li) ->
+      line i ppf "Ppat_type\n";
+      longident_loc i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
+  | Ppat_exception p ->
+      line i ppf "Ppat_exception\n";
+      pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
+  | Ppat_extension (s, arg) ->
+      line i ppf "Ppat_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.pexp_loc;
+  attributes i ppf x.pexp_attributes;
+  let i = i+1 in
+  match x.pexp_desc with
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
+  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
+  | Pexp_let (rf, l, e) ->
+      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Pexp_function l ->
+      line i ppf "Pexp_function\n";
+      list i case ppf l;
+  | Pexp_fun (l, eo, p, e) ->
+      line i ppf "Pexp_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      expression i ppf e;
+  | Pexp_apply (e, l) ->
+      line i ppf "Pexp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Pexp_match (e, l) ->
+      line i ppf "Pexp_match\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_try (e, l) ->
+      line i ppf "Pexp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Pexp_tuple (l) ->
+      line i ppf "Pexp_tuple\n";
+      list i expression ppf l;
+  | Pexp_construct (li, eo) ->
+      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
+      option i expression ppf eo;
+  | Pexp_variant (l, eo) ->
+      line i ppf "Pexp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Pexp_record (l, eo) ->
+      line i ppf "Pexp_record\n";
+      list i longident_x_expression ppf l;
+      option i expression ppf eo;
+  | Pexp_field (e, li) ->
+      line i ppf "Pexp_field\n";
+      expression i ppf e;
+      longident_loc i ppf li;
+  | Pexp_setfield (e1, li, e2) ->
+      line i ppf "Pexp_setfield\n";
+      expression i ppf e1;
+      longident_loc i ppf li;
+      expression i ppf e2;
+  | Pexp_array (l) ->
+      line i ppf "Pexp_array\n";
+      list i expression ppf l;
+  | Pexp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Pexp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Pexp_sequence (e1, e2) ->
+      line i ppf "Pexp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_while (e1, e2) ->
+      line i ppf "Pexp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Pexp_for (p, e1, e2, df, e3) ->
+      line i ppf "Pexp_for %a\n" fmt_direction_flag df;
+      pattern i ppf p;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Pexp_constraint (e, ct) ->
+      line i ppf "Pexp_constraint\n";
+      expression i ppf e;
+      core_type i ppf ct;
+  | Pexp_coerce (e, cto1, cto2) ->
+      line i ppf "Pexp_coerce\n";
+      expression i ppf e;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Pexp_send (e, s) ->
+      line i ppf "Pexp_send \"%s\"\n" s.txt;
+      expression i ppf e;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
+  | Pexp_setinstvar (s, e) ->
+      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
+      expression i ppf e;
+  | Pexp_override (l) ->
+      line i ppf "Pexp_override\n";
+      list i string_x_expression ppf l;
+  | Pexp_letmodule (s, me, e) ->
+      line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Pexp_assert (e) ->
+      line i ppf "Pexp_assert\n";
+      expression i ppf e;
+  | Pexp_lazy (e) ->
+      line i ppf "Pexp_lazy\n";
+      expression i ppf e;
+  | Pexp_poly (e, cto) ->
+      line i ppf "Pexp_poly\n";
+      expression i ppf e;
+      option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object\n";
+      class_structure i ppf s
+  | Pexp_newtype (s, e) ->
+      line i ppf "Pexp_newtype \"%s\"\n" s.txt;
+      expression i ppf e
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack\n";
+      module_expr i ppf me
+  | Pexp_open (ovf, m, e) ->
+      line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf
+        fmt_longident_loc m;
+      expression i ppf e
+  | Pexp_extension (s, arg) ->
+      line i ppf "Pexp_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pexp_unreachable ->
+      line i ppf "Pexp_unreachable"
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_string_loc
+       x.pval_name fmt_location x.pval_loc;
+  attributes i ppf x.pval_attributes;
+  core_type (i+1) ppf x.pval_type;
+  list (i+1) string ppf x.pval_prim
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
+       fmt_location x.ptype_loc;
+  attributes i ppf x.ptype_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.ptype_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.ptype_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.ptype_manifest
+
+and attributes i ppf l =
+  let i = i + 1 in
+  List.iter
+    (fun (s, arg) ->
+      line i ppf "attribute \"%s\"\n" s.txt;
+      payload (i + 1) ppf arg;
+    )
+    l
+
+and payload i ppf = function
+  | PStr x -> structure i ppf x
+  | PSig x -> signature i ppf x
+  | PTyp x -> core_type i ppf x
+  | PPat (x, None) -> pattern i ppf x
+  | PPat (x, Some g) ->
+    pattern i ppf x;
+    line i ppf "<when>\n";
+    expression (i + 1) ppf g
+
+
+and type_kind i ppf x =
+  match x with
+  | Ptype_abstract ->
+      line i ppf "Ptype_abstract\n"
+  | Ptype_variant l ->
+      line i ppf "Ptype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ptype_record l ->
+      line i ppf "Ptype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ptype_open ->
+      line i ppf "Ptype_open\n";
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.ptyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.ptyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.ptyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
+  attributes i ppf x.pext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.pext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Pext_decl(a, r) ->
+        line i ppf "Pext_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Pext_rebind li ->
+        line i ppf "Pext_rebind\n";
+        line (i+1) ppf "%a\n" fmt_longident_loc li;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+  attributes i ppf x.pcty_attributes;
+  let i = i+1 in
+  match x.pcty_desc with
+  | Pcty_constr (li, l) ->
+      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcty_signature (cs) ->
+      line i ppf "Pcty_signature\n";
+      class_signature i ppf cs;
+  | Pcty_arrow (l, co, cl) ->
+      line i ppf "Pcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+  | Pcty_extension (s, arg) ->
+      line i ppf "Pcty_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_signature i ppf cs =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf cs.pcsig_self;
+  list (i+1) class_type_field ppf cs.pcsig_fields;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+  let i = i+1 in
+  attributes i ppf x.pctf_attributes;
+  match x.pctf_desc with
+  | Pctf_inherit (ct) ->
+      line i ppf "Pctf_inherit\n";
+      class_type i ppf ct;
+  | Pctf_val (s, mf, vf, ct) ->
+      line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_method (s, pf, vf, ct) ->
+      line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Pctf_constraint (ct1, ct2) ->
+      line i ppf "Pctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pctf_attribute (s, arg) ->
+      line i ppf "Pctf_attribute \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pctf_extension (s, arg) ->
+      line i ppf "Pctf_extension \"%s\"\n" s.txt;
+     payload i ppf arg
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
+  attributes i ppf x.pcl_attributes;
+  let i = i+1 in
+  match x.pcl_desc with
+  | Pcl_constr (li, l) ->
+      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
+      list i core_type ppf l;
+  | Pcl_structure (cs) ->
+      line i ppf "Pcl_structure\n";
+      class_structure i ppf cs;
+  | Pcl_fun (l, eo, p, e) ->
+      line i ppf "Pcl_fun\n";
+      arg_label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      class_expr i ppf e;
+  | Pcl_apply (ce, l) ->
+      line i ppf "Pcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Pcl_let (rf, l, ce) ->
+      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      class_expr i ppf ce;
+  | Pcl_constraint (ce, ct) ->
+      line i ppf "Pcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct;
+  | Pcl_extension (s, arg) ->
+      line i ppf "Pcl_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+  let i = i + 1 in
+  attributes i ppf x.pcf_attributes;
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string_loc ppf so;
+  | Pcf_val (s, mf, k) ->
+      line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_method (s, pf, k) ->
+      line i ppf "Pcf_method %a\n" fmt_private_flag pf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      class_field_kind (i+1) ppf k
+  | Pcf_constraint (ct1, ct2) ->
+      line i ppf "Pcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Pcf_initializer (e) ->
+      line i ppf "Pcf_initializer\n";
+      expression (i+1) ppf e;
+  | Pcf_attribute (s, arg) ->
+      line i ppf "Pcf_attribute \"%s\"\n" s.txt;
+      payload i ppf arg
+  | Pcf_extension (s, arg) ->
+      line i ppf "Pcf_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and class_field_kind i ppf = function
+  | Cfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Cfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
+  attributes i ppf x.pci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.pci_params;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.pci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
+  attributes i ppf x.pmty_attributes;
+  let i = i+1 in
+  match x.pmty_desc with
+  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
+  | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
+  | Pmty_signature (s) ->
+      line i ppf "Pmty_signature\n";
+      signature i ppf s;
+  | Pmty_functor (s, mt1, mt2) ->
+      line i ppf "Pmty_functor %a\n" fmt_string_loc s;
+      Misc.may (module_type i ppf) mt1;
+      module_type i ppf mt2;
+  | Pmty_with (mt, l) ->
+      line i ppf "Pmty_with\n";
+      module_type i ppf mt;
+      list i with_constraint ppf l;
+  | Pmty_typeof m ->
+      line i ppf "Pmty_typeof\n";
+      module_expr i ppf m;
+  | Pmty_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and signature i ppf x = list i signature_item ppf x
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
+  let i = i+1 in
+  match x.psig_desc with
+  | Psig_value vd ->
+      line i ppf "Psig_value\n";
+      value_description i ppf vd;
+  | Psig_type (rf, l) ->
+      line i ppf "Psig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Psig_typext te ->
+      line i ppf "Psig_typext\n";
+      type_extension i ppf te
+  | Psig_exception ext ->
+      line i ppf "Psig_exception\n";
+      extension_constructor i ppf ext;
+  | Psig_module pmd ->
+      line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name;
+      attributes i ppf pmd.pmd_attributes;
+      module_type i ppf pmd.pmd_type
+  | Psig_recmodule decls ->
+      line i ppf "Psig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Psig_modtype x ->
+      line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Psig_open od ->
+      line i ppf "Psig_open %a %a\n"
+        fmt_override_flag od.popen_override
+        fmt_longident_loc od.popen_lid;
+      attributes i ppf od.popen_attributes
+  | Psig_include incl ->
+      line i ppf "Psig_include\n";
+      module_type i ppf incl.pincl_mod;
+      attributes i ppf incl.pincl_attributes
+  | Psig_class (l) ->
+      line i ppf "Psig_class\n";
+      list i class_description ppf l;
+  | Psig_class_type (l) ->
+      line i ppf "Psig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Psig_extension ((s, arg), attrs) ->
+      line i ppf "Psig_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Psig_attribute (s, arg) ->
+      line i ppf "Psig_attribute \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i+1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Pwith_type (lid, td) ->
+      line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
+      type_declaration (i+1) ppf td;
+  | Pwith_typesubst (td) ->
+      line i ppf "Pwith_typesubst\n";
+      type_declaration (i+1) ppf td;
+  | Pwith_module (lid1, lid2) ->
+      line i ppf "Pwith_module %a = %a\n"
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
+  | Pwith_modsubst (s, li) ->
+      line i ppf "Pwith_modsubst %a = %a\n"
+        fmt_string_loc s
+        fmt_longident_loc li;
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+  attributes i ppf x.pmod_attributes;
+  let i = i+1 in
+  match x.pmod_desc with
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
+  | Pmod_structure (s) ->
+      line i ppf "Pmod_structure\n";
+      structure i ppf s;
+  | Pmod_functor (s, mt, me) ->
+      line i ppf "Pmod_functor %a\n" fmt_string_loc s;
+      Misc.may (module_type i ppf) mt;
+      module_expr i ppf me;
+  | Pmod_apply (me1, me2) ->
+      line i ppf "Pmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Pmod_constraint (me, mt) ->
+      line i ppf "Pmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
+      expression i ppf e;
+  | Pmod_extension (s, arg) ->
+      line i ppf "Pmod_extension \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and structure i ppf x = list i structure_item ppf x
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
+  let i = i+1 in
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      line i ppf "Pstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Pstr_value (rf, l) ->
+      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Pstr_primitive vd ->
+      line i ppf "Pstr_primitive\n";
+      value_description i ppf vd;
+  | Pstr_type (rf, l) ->
+      line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Pstr_typext te ->
+      line i ppf "Pstr_typext\n";
+      type_extension i ppf te
+  | Pstr_exception ext ->
+      line i ppf "Pstr_exception\n";
+      extension_constructor i ppf ext;
+  | Pstr_module x ->
+      line i ppf "Pstr_module\n";
+      module_binding i ppf x
+  | Pstr_recmodule bindings ->
+      line i ppf "Pstr_recmodule\n";
+      list i module_binding ppf bindings;
+  | Pstr_modtype x ->
+      line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
+  | Pstr_open od ->
+      line i ppf "Pstr_open %a %a\n"
+        fmt_override_flag od.popen_override
+        fmt_longident_loc od.popen_lid;
+      attributes i ppf od.popen_attributes
+  | Pstr_class (l) ->
+      line i ppf "Pstr_class\n";
+      list i class_declaration ppf l;
+  | Pstr_class_type (l) ->
+      line i ppf "Pstr_class_type\n";
+      list i class_type_declaration ppf l;
+  | Pstr_include incl ->
+      line i ppf "Pstr_include";
+      attributes i ppf incl.pincl_attributes;
+      module_expr i ppf incl.pincl_mod
+  | Pstr_extension ((s, arg), attrs) ->
+      line i ppf "Pstr_extension \"%s\"\n" s.txt;
+      attributes i ppf attrs;
+      payload i ppf arg
+  | Pstr_attribute (s, arg) ->
+      line i ppf "Pstr_attribute \"%s\"\n" s.txt;
+      payload i ppf arg
+
+and module_declaration i ppf pmd =
+  string_loc i ppf pmd.pmd_name;
+  attributes i ppf pmd.pmd_attributes;
+  module_type (i+1) ppf pmd.pmd_type;
+
+and module_binding i ppf x =
+  string_loc i ppf x.pmb_name;
+  attributes i ppf x.pmb_attributes;
+  module_expr (i+1) ppf x.pmb_expr
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf
+                     {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
+  line i ppf "%a\n" fmt_location pcd_loc;
+  line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
+  attributes i ppf pcd_attributes;
+  constructor_arguments (i+1) ppf pcd_args;
+  option (i+1) core_type ppf pcd_res
+
+and constructor_arguments i ppf = function
+  | Pcstr_tuple l -> list i core_type ppf l
+  | Pcstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
+  line i ppf "%a\n" fmt_location pld_loc;
+  attributes i ppf pld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
+  line (i+1) ppf "%a" fmt_string_loc pld_name;
+  core_type (i+1) ppf pld_type
+
+and longident_x_pattern i ppf (li, p) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  pattern (i+1) ppf p;
+
+and case i ppf {pc_lhs; pc_guard; pc_rhs} =
+  line i ppf "<case>\n";
+  pattern (i+1) ppf pc_lhs;
+  begin match pc_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf pc_rhs;
+
+and value_binding i ppf x =
+  line i ppf "<def>\n";
+  attributes (i+1) ppf x.pvb_attributes;
+  pattern (i+1) ppf x.pvb_pat;
+  expression (i+1) ppf x.pvb_expr
+
+and string_x_expression i ppf (s, e) =
+  line i ppf "<override> %a\n" fmt_string_loc s;
+  expression (i+1) ppf e;
+
+and longident_x_expression i ppf (li, e) =
+  line i ppf "%a\n" fmt_longident_loc li;
+  expression (i+1) ppf e;
+
+and label_x_expression i ppf (l,e) =
+  line i ppf "<arg>\n";
+  arg_label i ppf l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x with
+    Rtag (l, attrs, b, ctl) ->
+      line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+      attributes (i+1) ppf attrs;
+      list (i+1) core_type ppf ctl
+  | Rinherit (ct) ->
+      line i ppf "Rinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let rec toplevel_phrase i ppf x =
+  match x with
+  | Ptop_def (s) ->
+      line i ppf "Ptop_def\n";
+      structure (i+1) ppf s;
+  | Ptop_dir (s, da) ->
+      line i ppf "Ptop_dir \"%s\"\n" s;
+      directive_argument i ppf da;
+
+and directive_argument i ppf x =
+  match x with
+  | Pdir_none -> line i ppf "Pdir_none\n"
+  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
+  | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
+  | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
+;;
+
+let interface ppf x = list 0 signature_item ppf x;;
+
+let implementation ppf x = list 0 structure_item ppf x;;
+
+let top_phrase ppf x = toplevel_phrase 0 ppf x;;
diff --git a/parsing/printast.mli b/parsing/printast.mli
new file mode 100644
index 00000000..b77a2ca5
--- /dev/null
+++ b/parsing/printast.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree;;
+open Format;;
+
+val interface : formatter -> signature_item list -> unit;;
+val implementation : formatter -> structure_item list -> unit;;
+val top_phrase : formatter -> toplevel_phrase -> unit;;
+
+val expression: int -> formatter -> expression -> unit
+val structure: int -> formatter -> structure -> unit
+val payload: int -> formatter -> payload -> unit
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
new file mode 100644
index 00000000..0bb55ab6
--- /dev/null
+++ b/parsing/syntaxerr.ml
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliary type for reporting syntax errors *)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+let prepare_error = function
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
+      Location.errorf ~loc:closing_loc
+        ~sub:[
+          Location.errorf ~loc:opening_loc
+            "This '%s' might be unmatched" opening
+        ]
+        ~if_highlight:
+          (Printf.sprintf "Syntax error: '%s' expected, \
+                           the highlighted '%s' might be unmatched"
+             closing opening)
+        "Syntax error: '%s' expected" closing
+
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      Location.errorf ~loc
+        "Syntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~loc
+        "In this scoped type, variable '%s \
+         is reserved for the local type %s."
+         var var
+  | Other loc ->
+      Location.errorf ~loc "Syntax error"
+  | Ill_formed_ast (loc, s) ->
+      Location.errorf ~loc "broken invariant in parsetree: %s" s
+  | Invalid_package_type (loc, s) ->
+      Location.errorf ~loc "invalid package type: %s" s
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (prepare_error err)
+      | _ -> None
+    )
+
+
+let report_error ppf err =
+  Location.report_error ppf (prepare_error err)
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Not_expecting (l, _)
+  | Ill_formed_ast (l, _)
+  | Invalid_package_type (l, _)
+  | Expecting (l, _) -> l
+
+
+let ill_formed_ast loc s =
+  raise (Error (Ill_formed_ast (loc, s)))
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
new file mode 100644
index 00000000..319eb579
--- /dev/null
+++ b/parsing/syntaxerr.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary type for reporting syntax errors *)
+
+open Format
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+
+exception Error of error
+exception Escape_error
+
+val report_error: formatter -> error -> unit
+ (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *)
+
+val location_of_error: error -> Location.t
+val ill_formed_ast: Location.t -> string -> 'a
diff --git a/stdlib/.depend b/stdlib/.depend
new file mode 100644
index 00000000..961b1fd7
--- /dev/null
+++ b/stdlib/.depend
@@ -0,0 +1,320 @@
+arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
+    arg.cmi
+arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
+    arg.cmi
+arg.cmi :
+array.cmo : array.cmi
+array.cmx : array.cmi
+array.cmi :
+arrayLabels.cmo : array.cmi arrayLabels.cmi
+arrayLabels.cmx : array.cmx arrayLabels.cmi
+arrayLabels.cmi :
+buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
+buffer.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
+buffer.cmi :
+bytes.cmo : pervasives.cmi char.cmi bytes.cmi
+bytes.cmx : pervasives.cmx char.cmx bytes.cmi
+bytes.cmi :
+bytesLabels.cmo : bytes.cmi bytesLabels.cmi
+bytesLabels.cmx : bytes.cmx bytesLabels.cmi
+bytesLabels.cmi :
+callback.cmo : obj.cmi callback.cmi
+callback.cmx : obj.cmx callback.cmi
+callback.cmi :
+camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
+    camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
+camlinternalFormat.cmx : sys.cmx string.cmx char.cmx \
+    camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi
+camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
+camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi
+camlinternalFormatBasics.cmx : camlinternalFormatBasics.cmi
+camlinternalFormatBasics.cmi :
+camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
+camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalLazy.cmi :
+camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+    camlinternalMod.cmi
+camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \
+    camlinternalMod.cmi
+camlinternalMod.cmi : obj.cmi
+camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
+    array.cmi camlinternalOO.cmi
+camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
+    array.cmx camlinternalOO.cmi
+camlinternalOO.cmi : obj.cmi
+char.cmo : char.cmi
+char.cmx : char.cmi
+char.cmi :
+complex.cmo : complex.cmi
+complex.cmx : complex.cmi
+complex.cmi :
+digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi
+digest.cmx : string.cmx char.cmx bytes.cmx digest.cmi
+digest.cmi :
+ephemeron.cmo : sys.cmi random.cmi obj.cmi lazy.cmi hashtbl.cmi array.cmi \
+    ephemeron.cmi
+ephemeron.cmx : sys.cmx random.cmx obj.cmx lazy.cmx hashtbl.cmx array.cmx \
+    ephemeron.cmi
+ephemeron.cmi : hashtbl.cmi
+filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
+    filename.cmi
+filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
+    filename.cmi
+filename.cmi :
+format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \
+    camlinternalFormat.cmi buffer.cmi format.cmi
+format.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \
+    camlinternalFormat.cmx buffer.cmx format.cmi
+format.cmi : pervasives.cmi buffer.cmi
+gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
+gc.cmx : sys.cmx string.cmx printf.cmx gc.cmi
+gc.cmi :
+genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \
+    genlex.cmi
+genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \
+    genlex.cmi
+genlex.cmi : stream.cmi
+hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \
+    hashtbl.cmi
+hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \
+    hashtbl.cmi
+hashtbl.cmi :
+int32.cmo : pervasives.cmi int32.cmi
+int32.cmx : pervasives.cmx int32.cmi
+int32.cmi :
+int64.cmo : pervasives.cmi int64.cmi
+int64.cmx : pervasives.cmx int64.cmi
+int64.cmi :
+lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
+lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
+lazy.cmi :
+lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi
+lexing.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi
+lexing.cmi :
+list.cmo : list.cmi
+list.cmx : list.cmi
+list.cmi :
+listLabels.cmo : list.cmi listLabels.cmi
+listLabels.cmx : list.cmx listLabels.cmi
+listLabels.cmi :
+map.cmo : map.cmi
+map.cmx : map.cmi
+map.cmi :
+marshal.cmo : bytes.cmi marshal.cmi
+marshal.cmx : bytes.cmx marshal.cmi
+marshal.cmi :
+moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
+moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
+moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
+nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
+nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi
+nativeint.cmi :
+obj.cmo : marshal.cmi int32.cmi obj.cmi
+obj.cmx : marshal.cmx int32.cmx obj.cmi
+obj.cmi : int32.cmi
+oo.cmo : camlinternalOO.cmi oo.cmi
+oo.cmx : camlinternalOO.cmx oo.cmi
+oo.cmi : camlinternalOO.cmi
+parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
+parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
+parsing.cmi : obj.cmi lexing.cmi
+pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi
+pervasives.cmx : camlinternalFormatBasics.cmx pervasives.cmi
+pervasives.cmi : camlinternalFormatBasics.cmi
+printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \
+    printexc.cmi
+printexc.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \
+    printexc.cmi
+printexc.cmi :
+printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \
+    printf.cmi
+printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \
+    printf.cmi
+printf.cmi : buffer.cmi
+queue.cmo : queue.cmi
+queue.cmx : queue.cmi
+queue.cmi :
+random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
+    digest.cmi char.cmi array.cmi random.cmi
+random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
+    digest.cmx char.cmx array.cmx random.cmi
+random.cmi : nativeint.cmi int64.cmi int32.cmi
+scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \
+    camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \
+    scanf.cmi
+scanf.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \
+    camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \
+    scanf.cmi
+scanf.cmi : pervasives.cmi
+set.cmo : list.cmi set.cmi
+set.cmx : list.cmx set.cmi
+set.cmi :
+sort.cmo : array.cmi sort.cmi
+sort.cmx : array.cmx sort.cmi
+sort.cmi :
+spacetime.cmo : gc.cmi spacetime.cmi
+spacetime.cmx : gc.cmx spacetime.cmi
+spacetime.cmi :
+stack.cmo : list.cmi stack.cmi
+stack.cmx : list.cmx stack.cmi
+stack.cmi :
+stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
+    arrayLabels.cmi stdLabels.cmi
+stdLabels.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \
+    arrayLabels.cmx stdLabels.cmi
+stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
+    arrayLabels.cmi
+std_exit.cmo :
+std_exit.cmx :
+stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
+stream.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
+stream.cmi :
+string.cmo : pervasives.cmi bytes.cmi string.cmi
+string.cmx : pervasives.cmx bytes.cmx string.cmi
+string.cmi :
+stringLabels.cmo : string.cmi stringLabels.cmi
+stringLabels.cmx : string.cmx stringLabels.cmi
+stringLabels.cmi :
+sys.cmo : sys.cmi
+sys.cmx : sys.cmi
+sys.cmi :
+uchar.cmo : pervasives.cmi char.cmi uchar.cmi
+uchar.cmx : pervasives.cmx char.cmx uchar.cmi
+uchar.cmi :
+weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
+weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+weak.cmi : hashtbl.cmi
+arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
+    arg.cmi
+arg.p.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
+    arg.cmi
+array.cmo : array.cmi
+array.p.cmx : array.cmi
+arrayLabels.cmo : array.cmi arrayLabels.cmi
+arrayLabels.p.cmx : array.cmx arrayLabels.cmi
+buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
+buffer.p.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
+bytes.cmo : pervasives.cmi char.cmi bytes.cmi
+bytes.p.cmx : pervasives.cmx char.cmx bytes.cmi
+bytesLabels.cmo : bytes.cmi bytesLabels.cmi
+bytesLabels.p.cmx : bytes.cmx bytesLabels.cmi
+callback.cmo : obj.cmi callback.cmi
+callback.p.cmx : obj.cmx callback.cmi
+camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
+    camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
+camlinternalFormat.p.cmx : sys.cmx string.cmx char.cmx \
+    camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi
+camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi
+camlinternalFormatBasics.p.cmx : camlinternalFormatBasics.cmi
+camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
+camlinternalLazy.p.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+    camlinternalMod.cmi
+camlinternalMod.p.cmx : obj.cmx camlinternalOO.cmx array.cmx \
+    camlinternalMod.cmi
+camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
+    array.cmi camlinternalOO.cmi
+camlinternalOO.p.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
+    array.cmx camlinternalOO.cmi
+char.cmo : char.cmi
+char.p.cmx : char.cmi
+complex.cmo : complex.cmi
+complex.p.cmx : complex.cmi
+digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi
+digest.p.cmx : string.cmx char.cmx bytes.cmx digest.cmi
+ephemeron.cmo : sys.cmi random.cmi obj.cmi lazy.cmi hashtbl.cmi array.cmi \
+    ephemeron.cmi
+ephemeron.p.cmx : sys.cmx random.cmx obj.cmx lazy.cmx hashtbl.cmx array.cmx \
+    ephemeron.cmi
+filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
+    filename.cmi
+filename.p.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
+    filename.cmi
+format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \
+    camlinternalFormat.cmi buffer.cmi format.cmi
+format.p.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \
+    camlinternalFormat.cmx buffer.cmx format.cmi
+gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
+gc.p.cmx : sys.cmx string.cmx printf.cmx gc.cmi
+genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \
+    genlex.cmi
+genlex.p.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \
+    genlex.cmi
+hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \
+    hashtbl.cmi
+hashtbl.p.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \
+    hashtbl.cmi
+int32.cmo : pervasives.cmi int32.cmi
+int32.p.cmx : pervasives.cmx int32.cmi
+int64.cmo : pervasives.cmi int64.cmi
+int64.p.cmx : pervasives.cmx int64.cmi
+lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
+lazy.p.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
+lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi
+lexing.p.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi
+list.cmo : list.cmi
+list.p.cmx : list.cmi
+listLabels.cmo : list.cmi listLabels.cmi
+listLabels.p.cmx : list.cmx listLabels.cmi
+map.cmo : map.cmi
+map.p.cmx : map.cmi
+marshal.cmo : bytes.cmi marshal.cmi
+marshal.p.cmx : bytes.cmx marshal.cmi
+moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
+moreLabels.p.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
+nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
+nativeint.p.cmx : sys.cmx pervasives.cmx nativeint.cmi
+obj.cmo : marshal.cmi int32.cmi obj.cmi
+obj.p.cmx : marshal.cmx int32.cmx obj.cmi
+oo.cmo : camlinternalOO.cmi oo.cmi
+oo.p.cmx : camlinternalOO.cmx oo.cmi
+parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
+parsing.p.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
+pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi
+pervasives.p.cmx : camlinternalFormatBasics.cmx pervasives.cmi
+printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \
+    printexc.cmi
+printexc.p.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \
+    printexc.cmi
+printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \
+    printf.cmi
+printf.p.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \
+    printf.cmi
+queue.cmo : queue.cmi
+queue.p.cmx : queue.cmi
+random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
+    digest.cmi char.cmi array.cmi random.cmi
+random.p.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
+    digest.cmx char.cmx array.cmx random.cmi
+scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \
+    camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \
+    scanf.cmi
+scanf.p.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \
+    camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \
+    scanf.cmi
+set.cmo : list.cmi set.cmi
+set.p.cmx : list.cmx set.cmi
+sort.cmo : array.cmi sort.cmi
+sort.p.cmx : array.cmx sort.cmi
+spacetime.cmo : gc.cmi spacetime.cmi
+spacetime.p.cmx : gc.cmx spacetime.cmi
+stack.cmo : list.cmi stack.cmi
+stack.p.cmx : list.cmx stack.cmi
+stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
+    arrayLabels.cmi stdLabels.cmi
+stdLabels.p.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \
+    arrayLabels.cmx stdLabels.cmi
+std_exit.cmo :
+std_exit.cmx :
+stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
+stream.p.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
+string.cmo : pervasives.cmi bytes.cmi string.cmi
+string.p.cmx : pervasives.cmx bytes.cmx string.cmi
+stringLabels.cmo : string.cmi stringLabels.cmi
+stringLabels.p.cmx : string.cmx stringLabels.cmi
+sys.cmo : sys.cmi
+sys.p.cmx : sys.cmi
+uchar.cmo : pervasives.cmi char.cmi uchar.cmi
+uchar.p.cmx : pervasives.cmx char.cmx uchar.cmi
+weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
+weak.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
diff --git a/stdlib/Compflags b/stdlib/Compflags
new file mode 100755
index 00000000..0f7b922a
--- /dev/null
+++ b/stdlib/Compflags
@@ -0,0 +1,30 @@
+#!/bin/sh
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+case $1 in
+  pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
+  camlinternalOO.cmi) echo ' -nopervasives';;
+  camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  buffer.cmx|buffer.p.cmx) echo ' -inline 3';;
+                           # make sure add_char is inlined (PR#5872)
+  buffer.cm[io]) echo ' -w A';;
+  camlinternalFormat.cm[io]) echo ' -w Ae';;
+  camlinternalFormatBasics*.cm[iox]) echo ' -nopervasives';;
+  printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w Ae';;
+  scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
+  *Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -no-alias-deps';;
+  *) echo ' ';;
+esac
diff --git a/stdlib/Makefile b/stdlib/Makefile
new file mode 100644
index 00000000..004329a7
--- /dev/null
+++ b/stdlib/Makefile
@@ -0,0 +1,250 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include ../config/Makefile
+CAMLRUN ?= ../boot/ocamlrun
+CAMLYACC ?= ../boot/ocamlyacc
+TARGET_BINDIR ?= $(BINDIR)
+
+COMPILER=../ocamlc
+CAMLC=$(CAMLRUN) $(COMPILER)
+COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \
+          -g -warn-error A -bin-annot -nostdlib \
+          -safe-string -strict-formats
+ifeq "$(FLAMBDA)" "true"
+OPTCOMPFLAGS=-O3
+else
+OPTCOMPFLAGS=
+endif
+OPTCOMPILER=../ocamlopt
+CAMLOPT=$(CAMLRUN) $(OPTCOMPILER)
+CAMLDEP=$(CAMLRUN) ../tools/ocamldep
+
+OBJS=camlinternalFormatBasics.cmo pervasives.cmo $(OTHERS)
+OTHERS=list.cmo char.cmo uchar.cmo bytes.cmo string.cmo sys.cmo \
+  sort.cmo marshal.cmo obj.cmo array.cmo \
+  int32.cmo int64.cmo nativeint.cmo \
+  lexing.cmo parsing.cmo \
+  set.cmo map.cmo stack.cmo queue.cmo \
+  camlinternalLazy.cmo lazy.cmo stream.cmo \
+  buffer.cmo camlinternalFormat.cmo printf.cmo \
+  arg.cmo printexc.cmo gc.cmo \
+  digest.cmo random.cmo hashtbl.cmo weak.cmo \
+  format.cmo scanf.cmo callback.cmo \
+  camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
+  genlex.cmo ephemeron.cmo \
+  filename.cmo complex.cmo \
+  arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
+  stringLabels.cmo moreLabels.cmo stdLabels.cmo \
+  spacetime.cmo
+
+.PHONY: all
+all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
+
+ifeq "$(RUNTIMED)" "true"
+all: camlheaderd
+endif
+
+ifeq "$(RUNTIMEI)" "true"
+all: camlheaderi
+endif
+
+ifeq "$(PROFILING)" "true"
+PROFILINGTARGET = prof
+else
+PROFILINGTARGET = noprof
+endif
+
+.PHONY: allopt
+allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILINGTARGET)
+
+.PHONY: allopt-noprof
+allopt-noprof:
+
+.PHONY: allopt-prof
+allopt-prof: stdlib.p.cmxa std_exit.p.cmx
+	rm -f std_exit.p.cmi
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+.PHONY: install
+install::
+	cp stdlib.cma std_exit.cmo *.cmi *.cmt *.cmti *.mli *.ml \
+	  camlheader_ur \
+	  "$(INSTALL_LIBDIR)"
+	cp target_camlheader "$(INSTALL_LIBDIR)/camlheader"
+
+ifeq "$(RUNTIMED)" "true"
+install::
+	cp target_camlheaderd $(INSTALL_LIBDIR)
+endif
+
+ifeq "$(RUNTIMEI)" "true"
+install::
+	cp target_camlheaderi $(INSTALL_LIBDIR)
+endif
+
+.PHONY: installopt
+installopt: installopt-default installopt-$(PROFILINGTARGET)
+
+.PHONY: installopt-default
+installopt-default:
+	cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx "$(INSTALL_LIBDIR)"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.$(A)
+
+.PHONY: installopt-noprof
+installopt-noprof:
+
+.PHONY: installopt-prof
+installopt-prof:
+	cp stdlib.p.cmxa stdlib.p.$(A) std_exit.p.cmx std_exit.p.$(O) \
+	  "$(INSTALL_LIBDIR)"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.p.$(A)
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+HEADERPROGRAM = header.c
+else # Windows
+HEADERPROGRAM = headernt.c
+endif
+
+CAMLHEADERS =\
+  camlheader target_camlheader camlheader_ur \
+  camlheaderd target_camlheaderd \
+  camlheaderi target_camlheaderi
+
+ifeq "$(HASHBANGSCRIPTS)" "true"
+$(CAMLHEADERS): ../config/Makefile
+	for suff in '' d i; do \
+	  echo '#!$(BINDIR)/ocamlrun'$$suff > camlheader$$suff && \
+	  echo '#!$(TARGET_BINDIR)/ocamlrun'$$suff >target_camlheader$$suff; \
+	done && \
+	echo '#!' | tr -d '\012' > camlheader_ur;
+else # Hashbang scripts not supported
+
+$(CAMLHEADERS): $(HEADERPROGRAM) ../config/Makefile
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+$(CAMLHEADERS):
+	for suff in '' d i; do \
+	  $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+	            -DRUNTIME_NAME='"$(BINDIR)/ocamlrun'$$suff'"' \
+	            header.c -o tmpheader$(EXE) && \
+	  strip tmpheader$(EXE) && \
+	  mv tmpheader$(EXE) camlheader$$suff && \
+	  $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+	            -DRUNTIME_NAME='"$(TARGET_BINDIR)/ocamlrun'$$suff'"' \
+	            header.c -o tmpheader$(EXE) && \
+	  strip tmpheader$(EXE) && \
+	  mv tmpheader$(EXE) target_camlheader$$suff; \
+	done && \
+	cp camlheader camlheader_ur
+
+else # Windows
+
+# TODO: see whether there is a way to further merge the rules below
+# with those above
+
+camlheader target_camlheader camlheader_ur:
+	$(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+	          -DRUNTIME_NAME='"ocamlrun"' headernt.c
+	$(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+	rm -f camlheader.exe
+	mv tmpheader.exe camlheader
+	cp camlheader target_camlheader
+	cp camlheader camlheader_ur
+
+camlheaderd target_camlheaderd:
+	$(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+	          -DRUNTIME_NAME='"ocamlrund"' headernt.c
+	$(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+	mv tmpheader.exe camlheaderd
+	cp camlheaderd target_camlheaderd
+
+camlheaderi:
+	$(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+	          -DRUNTIME_NAME='"ocamlruni"' headernt.c
+	$(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+	mv tmpheader.exe camlheaderi
+
+# TODO: do not call flexlink to build tmpheader.exe (we don't need
+# the export table)
+
+endif # ifeq "$(UNIX_OR_WIN32)" "unix"
+
+endif # ifeq "$(HASHBANGSCRIPTS)" "true"
+
+stdlib.cma: $(OBJS)
+	$(CAMLC) -a -o $@ $^
+
+stdlib.cmxa: $(OBJS:.cmo=.cmx)
+	$(CAMLOPT) -a -o $@ $^
+
+stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
+	$(CAMLOPT) -a -o $@ $^
+
+sys.ml: sys.mlp ../VERSION
+	sed -e "s|%%VERSION%%|`sed -e 1q ../VERSION | tr -d '\r'`|" sys.mlp > $@
+
+.PHONY: clean
+clean::
+	rm -f sys.ml
+
+clean::
+	rm -f $(CAMLHEADERS)
+
+.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) `sh ./Compflags $@` -c $<
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) `sh ./Compflags $@` -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `sh ./Compflags $@` -c $<
+
+.ml.p.cmx:
+	$(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `sh ./Compflags $@` \
+	           -p -c -o $*.p.cmx $<
+
+# Dependencies on the compiler
+COMPILER_DEPS=$(filter-out -use-prims, $(COMPILER))
+$(OBJS) std_exit.cmo: $(COMPILER_DEPS)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER_DEPS)
+$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
+
+# Dependencies on Pervasives (not tracked by ocamldep)
+$(OTHERS) 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)
+	rm -f *~
+	rm -f camlheader*
+
+include .depend
+
+# Note that .p.cmx targets do not depend (for compilation) upon other
+# .p.cmx files.  When the compiler imports another compilation unit,
+# it looks for the .cmx file (not .p.cmx).
+.PHONY: depend
+depend:
+	$(CAMLDEP) -slash *.mli *.ml > .depend
+	$(CAMLDEP) -slash *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/stdlib/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
new file mode 100644
index 00000000..28207401
--- /dev/null
+++ b/stdlib/StdlibModules
@@ -0,0 +1,72 @@
+# -*- Makefile -*-
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 2002 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# This file lists all standard library modules.
+# It is used in particular to know what to expunge in toplevels.
+
+STDLIB_MODULES=\
+  spacetime \
+  arg \
+  array \
+  arrayLabels \
+  buffer \
+  bytes \
+  bytesLabels \
+  callback \
+  camlinternalFormat \
+  camlinternalFormatBasics \
+  camlinternalLazy \
+  camlinternalMod \
+  camlinternalOO \
+  char \
+  complex \
+  digest \
+  ephemeron \
+  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 \
+  uchar \
+  weak
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
new file mode 100644
index 00000000..0f9095a7
--- /dev/null
+++ b/stdlib/arg.ml
@@ -0,0 +1,394 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type key = string
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+type spec =
+  | Unit of (unit -> unit)     (* Call the function with unit argument *)
+  | Bool of (bool -> unit)     (* Call the function with a bool argument *)
+  | Set of bool ref            (* Set the reference to true *)
+  | Clear of bool ref          (* Set the reference to false *)
+  | String of (string -> unit) (* Call the function with a string argument *)
+  | Set_string of string ref   (* Set the reference to the string argument *)
+  | Int of (int -> unit)       (* Call the function with an int argument *)
+  | Set_int of int ref         (* Set the reference to the int argument *)
+  | Float of (float -> unit)   (* Call the function with a float argument *)
+  | Set_float of float ref     (* Set the reference to the float argument *)
+  | Tuple of spec list         (* Take several arguments according to the
+                                  spec list *)
+  | Symbol of string list * (string -> unit)
+                               (* Take one of the symbols as argument and
+                                  call the function with the symbol. *)
+  | Rest of (string -> unit)   (* Stop interpreting keywords and call the
+                                  function with each remaining argument *)
+  | Expand of (string -> string array) (* If the remaining arguments to process
+                                          are of the form
+                                          [["-foo"; "arg"] @ rest] where "foo" is
+                                          registered as [Expand f], then the
+                                          arguments [f "arg" @ rest] are
+                                          processed. Only allowed in
+                                          [parse_and_expand_argv_dynamic]. *)
+
+exception Bad of string
+exception Help of string
+
+type error =
+  | Unknown of string
+  | Wrong of string * string * string  (* option, actual, expected *)
+  | Missing of string
+  | Message of string
+
+exception Stop of error (* used internally *)
+
+open Printf
+
+let rec assoc3 x l =
+  match l with
+  | [] -> raise Not_found
+  | (y1, y2, _) :: _ when y1 = x -> y2
+  | _ :: t -> assoc3 x t
+
+
+let split s =
+  let i = String.index s '=' in
+  let len = String.length s in
+  String.sub s 0 i, String.sub s (i+1) (len-(i+1))
+
+
+let make_symlist prefix sep suffix l =
+  match l with
+  | [] -> "<none>"
+  | h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
+
+
+let print_spec buf (key, spec, doc) =
+  if String.length doc > 0 then
+    match spec with
+    | Symbol (l, _) ->
+        bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l) 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) (add_help speclist)
+
+
+let usage_string speclist errmsg =
+  let b = Buffer.create 200 in
+  usage_b b speclist errmsg;
+  Buffer.contents b
+
+
+let usage speclist errmsg =
+  eprintf "%s" (usage_string speclist errmsg)
+
+
+let current = ref 0
+
+let bool_of_string_opt x =
+  try Some (bool_of_string x)
+  with Invalid_argument _ -> None
+
+let int_of_string_opt x =
+  try Some (int_of_string x)
+  with Failure _ -> None
+
+let float_of_string_opt x =
+  try Some (float_of_string x)
+  with Failure _ -> None
+
+let parse_and_expand_argv_dynamic_aux allow_expand current argv speclist anonfun errmsg =
+  let initpos = !current in
+  let convert_error error =
+    (* convert an internal error to a Bad/Help exception
+       *or* add the program name as a prefix and the usage message as a suffix
+       to an user-raised Bad exception.
+    *)
+    let b = Buffer.create 200 in
+    let progname = if initpos < (Array.length !argv) then !argv.(initpos) else "(?)" in
+    begin match error with
+      | Unknown "-help" -> ()
+      | Unknown "--help" -> ()
+      | Unknown s ->
+          bprintf b "%s: unknown option '%s'.\n" progname s
+      | Missing s ->
+          bprintf b "%s: option '%s' needs an argument.\n" progname s
+      | Wrong (opt, arg, expected) ->
+          bprintf b "%s: wrong argument '%s'; option '%s' expects %s.\n"
+                  progname arg opt expected
+      | Message s -> (* user error message *)
+          bprintf b "%s: %s.\n" progname s
+    end;
+    usage_b b !speclist errmsg;
+    if error = Unknown "-help" || error = Unknown "--help"
+    then Help (Buffer.contents b)
+    else Bad (Buffer.contents b)
+  in
+  incr current;
+  while !current < (Array.length !argv) do
+    begin try
+      let s = !argv.(!current) in
+      if String.length s >= 1 && s.[0] = '-' then begin
+        let action, follow =
+          try assoc3 s !speclist, None
+          with Not_found ->
+          try
+            let keyword, arg = split s in
+            assoc3 keyword !speclist, Some arg
+          with Not_found -> raise (Stop (Unknown s))
+        in
+        let no_arg () =
+          match follow with
+          | None -> ()
+          | Some arg -> raise (Stop (Wrong (s, arg, "no argument"))) in
+        let get_arg () =
+          match follow with
+          | None ->
+              if !current + 1 < (Array.length !argv) then !argv.(!current + 1)
+              else raise (Stop (Missing s))
+          | Some arg -> arg
+        in
+        let consume_arg () =
+          match follow with
+          | None -> incr current
+          | Some _ -> ()
+        in
+        let rec treat_action = function
+        | Unit f -> f ();
+        | Bool f ->
+            let arg = get_arg () in
+            begin match bool_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "a boolean")))
+            | Some s -> f s
+            end;
+            consume_arg ();
+        | Set r -> no_arg (); r := true;
+        | Clear r -> no_arg (); r := false;
+        | String f ->
+            let arg = get_arg () in
+            f arg;
+            consume_arg ();
+        | Symbol (symb, f) ->
+            let arg = get_arg () in
+            if List.mem arg symb then begin
+              f arg;
+              consume_arg ();
+            end else begin
+              raise (Stop (Wrong (s, arg, "one of: "
+                                          ^ (make_symlist "" " " "" symb))))
+            end
+        | Set_string r ->
+            r := get_arg ();
+            consume_arg ();
+        | Int f ->
+            let arg = get_arg () in
+            begin match int_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "an integer")))
+            | Some x -> f x
+            end;
+            consume_arg ();
+        | Set_int r ->
+            let arg = get_arg () in
+            begin match int_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "an integer")))
+            | Some x -> r := x
+            end;
+            consume_arg ();
+        | Float f ->
+            let arg = get_arg () in
+            begin match float_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "a float")))
+            | Some x -> f x
+            end;
+            consume_arg ();
+        | Set_float r ->
+            let arg = get_arg () in
+            begin match float_of_string_opt arg with
+            | None -> raise (Stop (Wrong (s, arg, "a float")))
+            | Some x -> r := x
+            end;
+            consume_arg ();
+        | Tuple specs ->
+            List.iter treat_action specs;
+        | Rest f ->
+            while !current < (Array.length !argv) - 1 do
+              f !argv.(!current + 1);
+              consume_arg ();
+            done;
+        | Expand f ->
+            if not allow_expand then
+              raise (Invalid_argument "Arg.Expand is is only allowed with Arg.parse_and_expand_argv_dynamic");
+            let arg = get_arg () in
+            let newarg = f arg in
+            consume_arg ();
+            let before = Array.sub !argv 0 (!current + 1)
+            and after = Array.sub !argv (!current + 1) ((Array.length !argv) - !current - 1) in
+            argv:= Array.concat [before;newarg;after];
+        in
+        treat_action action end
+      else anonfun s
+    with | Bad m -> raise (convert_error (Message m));
+         | Stop e -> raise (convert_error e);
+    end;
+    incr current
+  done
+
+let parse_and_expand_argv_dynamic current argv speclist anonfun errmsg =
+  parse_and_expand_argv_dynamic_aux true current argv speclist anonfun errmsg
+
+let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
+  parse_and_expand_argv_dynamic_aux false current (ref argv) speclist anonfun errmsg
+
+
+let parse_argv ?(current=current) argv speclist anonfun errmsg =
+  parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg
+
+
+let parse l f msg =
+  try
+    parse_argv Sys.argv l f msg
+  with
+  | Bad msg -> eprintf "%s" msg; exit 2
+  | Help msg -> printf "%s" msg; exit 0
+
+
+let parse_dynamic l f msg =
+  try
+    parse_argv_dynamic Sys.argv l f msg
+  with
+  | Bad msg -> eprintf "%s" msg; exit 2
+  | Help msg -> printf "%s" msg; exit 0
+
+let parse_expand l f msg =
+  try
+    let argv = ref Sys.argv in
+    let spec = ref l in
+    let current = ref (!current) in
+    parse_and_expand_argv_dynamic current argv spec f msg
+  with
+  | Bad msg -> eprintf "%s" msg; exit 2
+  | Help msg -> printf "%s" msg; exit 0
+
+
+let 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, spec, doc) =
+  match spec with
+  | Symbol _ -> max cur (String.length kwd)
+  | _ -> max cur (String.length kwd + second_word doc)
+
+
+let add_padding len ksd =
+  match ksd with
+  | (_, _, "") ->
+      (* Do not pad undocumented options, so that they still don't show up when
+       * run through [usage] or [parse]. *)
+      ksd
+  | (kwd, (Symbol _ as spec), msg) ->
+      let cutcol = second_word msg in
+      let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in
+      (kwd, spec, "\n" ^ spaces ^ msg)
+  | (kwd, spec, msg) ->
+      let cutcol = second_word msg in
+      let kwd_len = String.length kwd in
+      let diff = len - kwd_len - cutcol in
+      if diff <= 0 then
+        (kwd, spec, msg)
+      else
+        let spaces = String.make diff ' ' 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 ?(limit=max_int) speclist =
+  let completed = add_help speclist in
+  let len = List.fold_left max_arg_len 0 completed in
+  let len = min len limit in
+  List.map (add_padding len) completed
+
+let trim_cr s =
+  let len = String.length s in
+  if len > 0 && String.get s (len - 1) = '\r' then
+    String.sub s 0 (len - 1)
+  else
+    s
+
+let read_aux trim sep file =
+  let ic = open_in_bin file in
+  let buf = Buffer.create 200 in
+  let words = ref [] in
+  let stash () =
+    let word =  (Buffer.contents buf) in
+    let word = if trim then trim_cr word else word in
+    words := word :: !words;
+    Buffer.clear buf
+  in
+  let rec read () =
+    try
+      let c = input_char ic in
+      if c = sep then begin
+        stash (); read ()
+      end else begin
+        Buffer.add_char buf c; read ()
+      end
+    with End_of_file ->
+      if Buffer.length buf > 0 then
+        stash () in
+  read ();
+  close_in ic;
+  Array.of_list (List.rev !words)
+
+let read_arg = read_aux true '\n'
+
+let read_arg0 = read_aux false '\x00'
+
+let write_aux sep file args =
+  let oc = open_out_bin file in
+  Array.iter (fun s -> fprintf oc "%s%c" s sep) args;
+  close_out oc
+
+let write_arg = write_aux '\n'
+
+let write_arg0 = write_aux '\x00'
diff --git a/stdlib/arg.mli b/stdlib/arg.mli
new file mode 100644
index 00000000..e7d942ed
--- /dev/null
+++ b/stdlib/arg.mli
@@ -0,0 +1,207 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Parsing of command line arguments.
+
+   This module provides a general mechanism for extracting options and
+   arguments from the command line to the program.
+
+   Syntax of command lines:
+    A keyword is a character string starting with a [-].
+    An option is a keyword alone or followed by an argument.
+    The types of keywords are: [Unit], [Bool], [Set], [Clear],
+    [String], [Set_string], [Int], [Set_int], [Float], [Set_float],
+    [Tuple], [Symbol], and [Rest].
+    [Unit], [Set] and [Clear] keywords take no argument. A [Rest]
+    keyword takes the remaining of the command line as arguments.
+    Every other keyword takes the following word on the command line
+    as argument.  For compatibility with GNU getopt_long, [keyword=arg]
+    is also allowed.
+    Arguments not preceded by a keyword are called anonymous arguments.
+
+   Examples ([cmd] is assumed to be the command name):
+-   [cmd -flag           ](a unit option)
+-   [cmd -int 1          ](an int option with argument [1])
+-   [cmd -string foobar  ](a string option with argument ["foobar"])
+-   [cmd -float 12.34    ](a float option with argument [12.34])
+-   [cmd a b c           ](three anonymous arguments: ["a"], ["b"], and ["c"])
+-   [cmd a b -- c d      ](two anonymous arguments and a rest option with
+                           two arguments)
+*)
+
+type spec =
+  | Unit of (unit -> unit)     (** Call the function with unit argument *)
+  | Bool of (bool -> unit)     (** Call the function with a bool argument *)
+  | Set of bool ref            (** Set the reference to true *)
+  | Clear of bool ref          (** Set the reference to false *)
+  | String of (string -> unit) (** Call the function with a string argument *)
+  | Set_string of string ref   (** Set the reference to the string argument *)
+  | Int of (int -> unit)       (** Call the function with an int argument *)
+  | Set_int of int ref         (** Set the reference to the int argument *)
+  | Float of (float -> unit)   (** Call the function with a float argument *)
+  | Set_float of float ref     (** Set the reference to the float argument *)
+  | Tuple of spec list         (** Take several arguments according to the
+                                   spec list *)
+  | Symbol of string list * (string -> unit)
+                               (** Take one of the symbols as argument and
+                                   call the function with the symbol *)
+  | Rest of (string -> unit)   (** Stop interpreting keywords and call the
+                                   function with each remaining argument *)
+  | Expand of (string -> string array) (** If the remaining arguments to process
+                                           are of the form
+                                           [["-foo"; "arg"] @ rest] where "foo" is
+                                           registered as [Expand f], then the
+                                           arguments [f "arg" @ rest] are
+                                           processed. Only allowed in
+                                           [parse_and_expand_argv_dynamic]. *)
+(** The concrete type describing the behavior associated
+   with a keyword. *)
+
+type key = string
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+val parse :
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** [Arg.parse speclist anon_fun usage_msg] parses the command line.
+    [speclist] is a list of triples [(key, spec, doc)].
+    [key] is the option keyword, it must start with a ['-'] character.
+    [spec] gives the option type and the function to call when this option
+    is found on the command line.
+    [doc] is a one-line description of this option.
+    [anon_fun] is called on anonymous arguments.
+    The functions in [spec] and [anon_fun] are called in the same order
+    as their arguments appear on the command line.
+
+    If an error occurs, [Arg.parse] exits the program, after printing
+    to standard error an error message as follows:
+-   The reason for the error: unknown option, invalid or missing argument, etc.
+-   [usage_msg]
+-   The list of options, each followed by the corresponding [doc] string.
+    Beware: options that have an empty [doc] string will not be included in the
+    list.
+
+    For the user to be able to specify anonymous arguments starting with a
+    [-], include for example [("-", String anon_fun, doc)] in [speclist].
+
+    By default, [parse] recognizes two unit options, [-help] and [--help],
+    which will print to standard output [usage_msg] and the list of
+    options, and exit the program.  You can override this behaviour
+    by specifying your own [-help] and [--help] options in [speclist].
+*)
+
+val parse_dynamic :
+  (key * spec * doc) list ref -> anon_fun -> usage_msg -> unit
+(** Same as {!Arg.parse}, except that the [speclist] argument is a reference
+    and may be updated during the parsing. A typical use for this feature
+    is to parse command lines of the form:
+-     command subcommand [options]
+    where the list of options depends on the value of the subcommand argument.
+    @since 4.01.0
+*)
+
+val parse_argv : ?current: int ref -> string array ->
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses
+  the array [args] as if it were the command line.  It uses and updates
+  the value of [~current] (if given), or {!Arg.current}.  You must set
+  it before calling [parse_argv].  The initial value of [current]
+  is the index of the program name (argument 0) in the array.
+  If an error occurs, [Arg.parse_argv] raises {!Arg.Bad} with
+  the error message as argument.  If option [-help] or [--help] is
+  given, [Arg.parse_argv] raises {!Arg.Help} with the help message
+  as argument.
+*)
+
+val parse_argv_dynamic : ?current:int ref -> string array ->
+  (key * spec * doc) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv}, except that the [speclist] argument is a
+    reference and may be updated during the parsing.
+    See {!Arg.parse_dynamic}.
+    @since 4.01.0
+*)
+
+val parse_and_expand_argv_dynamic : int ref -> string array ref ->
+  (key * spec * doc) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv_dynamic}, except that the [argv] argument is a
+    reference and may be updated during the parsing of [Expand] arguments.
+    See {!Arg.parse_argv_dynamic}.
+    @since 4.05.0
+*)
+
+val parse_expand:
+  (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** Same as {!Arg.parse}, except that the [Expand] arguments are allowed and
+    the {!current} reference is not updated.
+    @since 4.05.0
+*)
+
+exception Help of string
+(** Raised by [Arg.parse_argv] when the user asks for help. *)
+
+exception Bad of string
+(** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error
+    message to reject invalid arguments.
+    [Arg.Bad] is also raised by {!Arg.parse_argv} in case of an error. *)
+
+val usage : (key * spec * doc) list -> usage_msg -> unit
+(** [Arg.usage speclist usage_msg] prints to standard error
+    an error message that includes the list of valid options.  This is
+    the same message that {!Arg.parse} prints in case of error.
+    [speclist] and [usage_msg] are the same as for {!Arg.parse}. *)
+
+val usage_string : (key * spec * doc) list -> usage_msg -> string
+(** Returns the message that would have been printed by {!Arg.usage},
+    if provided with the same parameters. *)
+
+val align: ?limit: int -> (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 aligned on the next line.
+    @param limit options with keyword and message longer than
+    [limit] will not be used to compute the alignement.
+*)
+
+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.
+    {!Arg.parse} uses the initial value of {!Arg.current} as the index of
+    argument 0 (the program name) and starts parsing arguments
+    at the next element. *)
+
+val read_arg: string -> string array
+(** [Arg.read_arg file] reads newline-terminated command line arguments from
+    file [file].
+    @since 4.05.0 *)
+
+val read_arg0: string -> string array
+(** Identical to {!Arg.read_arg} but assumes null character terminated command line
+    arguments.
+    @since 4.05.0 *)
+
+
+val write_arg: string -> string array -> unit
+(** [Arg.write_arg file args] writes the arguments [args] newline-terminated
+    into the file [file]. If the any of the arguments in [args] contains a
+    newline, use {!Arg.write_arg0} instead.
+    @since 4.05.0 *)
+
+val write_arg0: string -> string array -> unit
+(** Identical to {!Arg.write_arg} but uses the null character for terminator
+    instead of newline.
+    @since 4.05.0 *)
diff --git a/stdlib/array.ml b/stdlib/array.ml
new file mode 100644
index 00000000..a4270f27
--- /dev/null
+++ b/stdlib/array.ml
@@ -0,0 +1,294 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Array operations *)
+
+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 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 = "caml_make_vect"
+external create: int -> 'a -> 'a array = "caml_make_vect"
+external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
+external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
+external concat : 'a array list -> 'a array = "caml_array_concat"
+external unsafe_blit :
+  'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
+external create_float: int -> float array = "caml_make_float_vect"
+let make_float = create_float
+
+let init l f =
+  if l = 0 then [||] else
+  if l < 0 then invalid_arg "Array.init"
+  (* See #6575. We could also check for maximum array size, but this depends
+     on whether we create a float array or a regular one... *)
+  else
+   let res = create l (f 0) in
+   for i = 1 to pred l do
+     unsafe_set res i (f i)
+   done;
+   res
+
+let make_matrix sx sy init =
+  let res = create sx [||] in
+  for x = 0 to pred sx do
+    unsafe_set res x (create sy init)
+  done;
+  res
+
+let create_matrix = make_matrix
+
+let copy a =
+  let l = length a in if l = 0 then [||] else unsafe_sub a 0 l
+
+let append a1 a2 =
+  let l1 = length a1 in
+  if l1 = 0 then copy a2
+  else if length a2 = 0 then unsafe_sub a1 0 l1
+  else append_prim a1 a2
+
+let sub a ofs len =
+  if ofs < 0 || len < 0 || ofs > length a - len
+  then invalid_arg "Array.sub"
+  else unsafe_sub a ofs len
+
+let fill a ofs len v =
+  if ofs < 0 || len < 0 || ofs > length a - len
+  then invalid_arg "Array.fill"
+  else for i = ofs to ofs + len - 1 do unsafe_set a i v done
+
+let blit a1 ofs1 a2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
+             || ofs2 < 0 || ofs2 > length a2 - len
+  then invalid_arg "Array.blit"
+  else unsafe_blit a1 ofs1 a2 ofs2 len
+
+let iter f a =
+  for i = 0 to length a - 1 do f(unsafe_get a i) done
+
+let iter2 f a b =
+  if length a <> length b then
+    invalid_arg "Array.iter2: arrays must have the same length"
+  else
+    for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
+
+let map f a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let r = create l (f(unsafe_get a 0)) in
+    for i = 1 to l - 1 do
+      unsafe_set r i (f(unsafe_get a i))
+    done;
+    r
+  end
+
+let map2 f a b =
+  let la = length a in
+  let lb = length b in
+  if la <> lb then
+    invalid_arg "Array.map2: arrays must have the same length"
+  else begin
+    if la = 0 then [||] else begin
+      let r = create la (f (unsafe_get a 0) (unsafe_get b 0)) in
+      for i = 1 to la - 1 do
+        unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
+      done;
+      r
+    end
+  end
+
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
+let mapi f a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let r = create l (f 0 (unsafe_get a 0)) in
+    for i = 1 to l - 1 do
+      unsafe_set r i (f i (unsafe_get a i))
+    done;
+    r
+  end
+
+let to_list a =
+  let rec tolist i res =
+    if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
+  tolist (length a - 1) []
+
+(* Cannot use List.length here because the List module depends on Array. *)
+let rec list_length accu = function
+  | [] -> accu
+  | _::t -> list_length (succ accu) t
+
+let of_list = function
+    [] -> [||]
+  | hd::tl as l ->
+      let a = create (list_length 0 l) hd in
+      let rec fill i = function
+          [] -> a
+        | hd::tl -> unsafe_set a i hd; fill (i+1) tl in
+      fill 1 tl
+
+let fold_left f x a =
+  let r = ref x in
+  for i = 0 to length a - 1 do
+    r := f !r (unsafe_get a i)
+  done;
+  !r
+
+let fold_right f a x =
+  let r = ref x in
+  for i = length a - 1 downto 0 do
+    r := f (unsafe_get a i) !r
+  done;
+  !r
+
+let exists p a =
+  let n = length a in
+  let rec loop i =
+    if i = n then false
+    else if p (unsafe_get a i) then true
+    else loop (succ i) in
+  loop 0
+
+let for_all p a =
+  let n = length a in
+  let rec loop i =
+    if i = n then true
+    else if p (unsafe_get a i) then loop (succ i)
+    else false in
+  loop 0
+
+let mem x a =
+  let n = length a in
+  let rec loop i =
+    if i = n then false
+    else if compare (unsafe_get a i) x = 0 then true
+    else loop (succ i) in
+  loop 0
+
+let memq x a =
+  let n = length a in
+  let rec loop i =
+    if i = n then false
+    else if x == (unsafe_get a i) then true
+    else loop (succ i) in
+  loop 0
+
+exception Bottom of int
+let sort 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 (get a i31) (get a (i31+1)) < 0 then x := i31+1;
+      if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
+      !x
+    end else
+      if i31+1 < l && cmp (get a i31) (get 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 (get a j) e > 0 then begin
+      set a i (get a j);
+      trickledown l j e;
+    end else begin
+      set a i e;
+    end;
+  in
+  let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
+  let rec bubbledown l i =
+    let j = maxson l i in
+    set a i (get 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 (get a father) e < 0 then begin
+      set a i (get a father);
+      if father > 0 then trickleup father e else set a 0 e;
+    end else begin
+      set a i e;
+    end;
+  in
+  let l = length a in
+  for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
+  for i = l - 1 downto 2 do
+    let e = (get a i) in
+    set a i (get a 0);
+    trickleup (bubble i 0) e;
+  done;
+  if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
+
+
+let cutoff = 5
+let stable_sort 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
+        set dst d s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 (get a i1) i2 s2 (d + 1)
+        else
+          blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        set dst d s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 (get src2 i2) (d + 1)
+        else
+          blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = (get a (srcofs + i)) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp (get dst !j) e > 0) do
+        set dst (!j + 1) (get dst !j);
+        decr j;
+      done;
+      set 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 = 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 = make l2 (get a 0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end
+
+
+let fast_sort = stable_sort
diff --git a/stdlib/array.mli b/stdlib/array.mli
new file mode 100644
index 00000000..b89cd6b6
--- /dev/null
+++ b/stdlib/array.mli
@@ -0,0 +1,265 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Array operations. *)
+
+external length : 'a array -> int = "%array_length"
+(** Return the length (number of elements) of the given array. *)
+
+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 "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 "index out of bounds"]
+   if [n] is outside the range 0 to [Array.length a - 1]. *)
+
+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
+   physically equal to [x] (in the sense of the [==] predicate).
+   Consequently, if [x] is mutable, it is shared among all elements
+   of the array, and modifying [x] through one of the array entries
+   will modify all other entries at the same time.
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   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 = "caml_make_vect"
+  [@@ocaml.deprecated "Use Array.make instead."]
+(** @deprecated [Array.create] is an alias for {!Array.make}. *)
+
+external create_float: int -> float array = "caml_make_float_vect"
+(** [Array.create_float n] returns a fresh float array of length [n],
+    with uninitialized data.
+    @since 4.03 *)
+
+val make_float: int -> float array
+  [@@ocaml.deprecated "Use Array.create_float instead."]
+(** @deprecated [Array.make_float] is an alias for {!Array.create_float}. *)
+
+val init : int -> (int -> 'a) -> 'a array
+(** [Array.init n f] returns a fresh array of length [n],
+   with element number [i] initialized to the result of [f i].
+   In other terms, [Array.init n f] tabulates the results of [f]
+   applied to the integers [0] to [n-1].
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   If the return type of [f] is [float], then the maximum
+   size is only [Sys.max_array_length / 2].*)
+
+val make_matrix : int -> int -> 'a -> 'a array array
+(** [Array.make_matrix dimx dimy e] returns a two-dimensional array
+   (an array of arrays) with first dimension [dimx] and
+   second dimension [dimy]. All the elements of this new matrix
+   are initially physically equal to [e].
+   The element ([x,y]) of a matrix [m] is accessed
+   with the notation [m.(x).(y)].
+
+   Raise [Invalid_argument] if [dimx] or [dimy] is negative or
+   greater than {!Sys.max_array_length}.
+   If the value of [e] is a floating-point number, then the maximum
+   size is only [Sys.max_array_length / 2]. *)
+
+val create_matrix : int -> int -> 'a -> 'a array array
+  [@@ocaml.deprecated "Use Array.make_matrix instead."]
+(** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *)
+
+val append : 'a array -> 'a array -> 'a array
+(** [Array.append v1 v2] returns a fresh array containing the
+   concatenation of the arrays [v1] and [v2]. *)
+
+val concat : 'a array list -> 'a array
+(** Same as {!Array.append}, but concatenates a list of arrays. *)
+
+val sub : 'a array -> int -> int -> 'a array
+(** [Array.sub a start len] returns a fresh array of length [len],
+   containing the elements number [start] to [start + len - 1]
+   of array [a].
+
+   Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
+   designate a valid subarray of [a]; that is, if
+   [start < 0], or [len < 0], or [start + len > Array.length a]. *)
+
+val copy : 'a array -> 'a array
+(** [Array.copy a] returns a copy of [a], that is, a fresh array
+   containing the same elements as [a]. *)
+
+val fill : 'a array -> int -> int -> 'a -> unit
+(** [Array.fill a ofs len x] modifies the array [a] in place,
+   storing [x] in elements number [ofs] to [ofs + len - 1].
+
+   Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
+   designate a valid subarray of [a]. *)
+
+val blit : 'a array -> int -> 'a array -> int -> int -> unit
+(** [Array.blit v1 o1 v2 o2 len] copies [len] elements
+   from array [v1], starting at element number [o1], to array [v2],
+   starting at element number [o2]. It works correctly even if
+   [v1] and [v2] are the same array, and the source and
+   destination chunks overlap.
+
+   Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not
+   designate a valid subarray of [v1], or if [o2] and [len] do not
+   designate a valid subarray of [v2]. *)
+
+val to_list : 'a array -> 'a list
+(** [Array.to_list a] returns the list of all the elements of [a]. *)
+
+val of_list : 'a list -> 'a array
+(** [Array.of_list l] returns a fresh array containing the elements
+   of [l]. *)
+
+
+(** {6 Iterators} *)
+
+
+val iter : ('a -> unit) -> 'a array -> unit
+(** [Array.iter f a] applies function [f] in turn to all
+   the elements of [a].  It is equivalent to
+   [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
+
+val iteri : (int -> 'a -> unit) -> 'a array -> unit
+(** Same as {!Array.iter}, but the
+   function is applied with the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val map : ('a -> 'b) -> 'a array -> 'b array
+(** [Array.map f a] applies function [f] to all the elements of [a],
+   and builds an array with the results returned by [f]:
+   [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
+
+val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array
+(** Same as {!Array.map}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+(** [Array.fold_left f x a] computes
+   [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
+   where [n] is the length of the array [a]. *)
+
+val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+(** [Array.fold_right f a x] computes
+   [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
+   where [n] is the length of the array [a]. *)
+
+
+(** {6 Iterators on two arrays} *)
+
+
+val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+(** [Array.iter2 f a b] applies function [f] to all the elements of [a]
+   and [b].
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.03.0 *)
+
+val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+(** [Array.map2 f a b] applies function [f] to all the elements of [a]
+   and [b], and builds an array with the results returned by [f]:
+   [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]].
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.03.0 *)
+
+
+(** {6 Array scanning} *)
+
+
+val for_all : ('a -> bool) -> 'a array -> bool
+(** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array
+   satisfy the predicate [p]. That is, it returns
+   [(p a1) && (p a2) && ... && (p an)].
+   @since 4.03.0 *)
+
+val exists : ('a -> bool) -> 'a array -> bool
+(** [Array.exists p [|a1; ...; an|]] checks if at least one element of
+    the array satisfies the predicate [p]. That is, it returns
+    [(p a1) || (p a2) || ... || (p an)].
+    @since 4.03.0 *)
+
+val mem : 'a -> 'a array -> bool
+(** [mem a l] is true if and only if [a] is equal
+   to an element of [l].
+   @since 4.03.0 *)
+
+val memq : 'a -> 'a array -> bool
+(** Same as {!Array.mem}, but uses physical equality instead of structural
+   equality to compare array elements.
+   @since 4.03.0 *)
+
+
+(** {6 Sorting} *)
+
+
+val sort : ('a -> 'a -> int) -> 'a array -> unit
+(** Sort an array in increasing order according to a comparison
+   function.  The comparison function must return 0 if its arguments
+   compare as equal, a positive integer if the first is greater,
+   and a negative integer if the first is smaller (see below for a
+   complete specification).  For example, {!Pervasives.compare} is
+   a suitable comparison function, provided there are no floating-point
+   NaN values in the data.  After calling [Array.sort], the
+   array is sorted in place in increasing order.
+   [Array.sort] is guaranteed to run in constant heap space
+   and (at most) logarithmic stack space.
+
+   The current implementation uses Heap Sort.  It runs in constant
+   stack space.
+
+   Specification of the comparison function:
+   Let [a] be the array and [cmp] the comparison function.  The following
+   must be true for all x, y, z in a :
+-   [cmp x y] > 0 if and only if [cmp y x] < 0
+-   if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0
+
+   When [Array.sort] returns, [a] contains the same elements as before,
+   reordered in such a way that for all i and j valid indices of [a] :
+-   [cmp a.(i) a.(j)] >= 0 if and only if i >= j
+*)
+
+val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e.
+   elements that compare equal are kept in their original order) and
+   not guaranteed to run in constant heap space.
+
+   The current implementation uses Merge Sort. It uses [n/2]
+   words of heap space, where [n] is the length of the array.
+   It is usually faster than the current implementation of {!Array.sort}.
+*)
+
+val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster
+    on typical input.
+*)
+
+
+(**/**)
+(** {6 Undocumented functions} *)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
diff --git a/stdlib/arrayLabels.ml b/stdlib/arrayLabels.ml
new file mode 100644
index 00000000..f7a460a1
--- /dev/null
+++ b/stdlib/arrayLabels.ml
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [ArrayLabels]: labelled Array module *)
+
+include Array
diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
new file mode 100644
index 00000000..868f73a5
--- /dev/null
+++ b/stdlib/arrayLabels.mli
@@ -0,0 +1,266 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Array operations. *)
+
+external length : 'a array -> int = "%array_length"
+(** Return the length (number of elements) of the given array. *)
+
+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 "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 "index out of bounds"]
+   if [n] is outside the range 0 to [Array.length a - 1]. *)
+
+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
+   physically equal to [x] (in the sense of the [==] predicate).
+   Consequently, if [x] is mutable, it is shared among all elements
+   of the array, and modifying [x] through one of the array entries
+   will modify all other entries at the same time.
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   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 = "caml_make_vect"
+  [@@ocaml.deprecated "Use Array.make instead."]
+(** @deprecated [Array.create] is an alias for {!Array.make}. *)
+
+val init : int -> f:(int -> 'a) -> 'a array
+(** [Array.init n f] returns a fresh array of length [n],
+   with element number [i] initialized to the result of [f i].
+   In other terms, [Array.init n f] tabulates the results of [f]
+   applied to the integers [0] to [n-1].
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   If the return type of [f] is [float], then the maximum
+   size is only [Sys.max_array_length / 2].*)
+
+val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
+(** [Array.make_matrix dimx dimy e] returns a two-dimensional array
+   (an array of arrays) with first dimension [dimx] and
+   second dimension [dimy]. All the elements of this new matrix
+   are initially physically equal to [e].
+   The element ([x,y]) of a matrix [m] is accessed
+   with the notation [m.(x).(y)].
+
+   Raise [Invalid_argument] if [dimx] or [dimy] is negative or
+   greater than {!Sys.max_array_length}.
+   If the value of [e] is a floating-point number, then the maximum
+   size is only [Sys.max_array_length / 2]. *)
+
+val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
+  [@@ocaml.deprecated "Use Array.make_matrix instead."]
+(** @deprecated [Array.create_matrix] is an alias for
+   {!Array.make_matrix}. *)
+
+val append : 'a array -> 'a array -> 'a array
+(** [Array.append v1 v2] returns a fresh array containing the
+   concatenation of the arrays [v1] and [v2]. *)
+
+val concat : 'a array list -> 'a array
+(** Same as {!Array.append}, but concatenates a list of arrays. *)
+
+val sub : 'a array -> pos:int -> len:int -> 'a array
+(** [Array.sub a start len] returns a fresh array of length [len],
+   containing the elements number [start] to [start + len - 1]
+   of array [a].
+
+   Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
+   designate a valid subarray of [a]; that is, if
+   [start < 0], or [len < 0], or [start + len > Array.length a]. *)
+
+val copy : 'a array -> 'a array
+(** [Array.copy a] returns a copy of [a], that is, a fresh array
+   containing the same elements as [a]. *)
+
+val fill : 'a array -> pos:int -> len:int -> 'a -> unit
+(** [Array.fill a ofs len x] modifies the array [a] in place,
+   storing [x] in elements number [ofs] to [ofs + len - 1].
+
+   Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
+   designate a valid subarray of [a]. *)
+
+val blit :
+  src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int ->
+    unit
+(** [Array.blit v1 o1 v2 o2 len] copies [len] elements
+   from array [v1], starting at element number [o1], to array [v2],
+   starting at element number [o2]. It works correctly even if
+   [v1] and [v2] are the same array, and the source and
+   destination chunks overlap.
+
+   Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not
+   designate a valid subarray of [v1], or if [o2] and [len] do not
+   designate a valid subarray of [v2]. *)
+
+val to_list : 'a array -> 'a list
+(** [Array.to_list a] returns the list of all the elements of [a]. *)
+
+val of_list : 'a list -> 'a array
+(** [Array.of_list l] returns a fresh array containing the elements
+   of [l]. *)
+
+val iter : f:('a -> unit) -> 'a array -> unit
+(** [Array.iter f a] applies function [f] in turn to all
+   the elements of [a].  It is equivalent to
+   [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
+
+val map : f:('a -> 'b) -> 'a array -> 'b array
+(** [Array.map f a] applies function [f] to all the elements of [a],
+   and builds an array with the results returned by [f]:
+   [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
+
+val iteri : f:(int -> 'a -> unit) -> 'a array -> unit
+(** Same as {!Array.iter}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array
+(** Same as {!Array.map}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a
+(** [Array.fold_left f x a] computes
+   [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
+   where [n] is the length of the array [a]. *)
+
+val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a
+(** [Array.fold_right f a x] computes
+   [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
+   where [n] is the length of the array [a]. *)
+
+
+(** {6 Iterators on two arrays} *)
+
+
+val iter2 : f:('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+(** [Array.iter2 f a b] applies function [f] to all the elements of [a]
+   and [b].
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.05.0 *)
+
+val map2 : f:('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+(** [Array.map2 f a b] applies function [f] to all the elements of [a]
+   and [b], and builds an array with the results returned by [f]:
+   [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]].
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.05.0 *)
+
+
+(** {6 Array scanning} *)
+
+
+val exists : f:('a -> bool) -> 'a array -> bool
+(** [Array.exists p [|a1; ...; an|]] checks if at least one element of
+    the array satisfies the predicate [p]. That is, it returns
+    [(p a1) || (p a2) || ... || (p an)].
+    @since 4.03.0 *)
+
+val for_all : f:('a -> bool) -> 'a array -> bool
+(** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array
+   satisfy the predicate [p]. That is, it returns
+   [(p a1) && (p a2) && ... && (p an)].
+   @since 4.03.0 *)
+
+val mem : 'a -> set:'a array -> bool
+(** [mem x a] is true if and only if [x] is equal
+   to an element of [a].
+   @since 4.03.0 *)
+
+val memq : 'a -> set:'a array -> bool
+(** Same as {!Array.mem}, but uses physical equality instead of structural
+   equality to compare list elements.
+   @since 4.03.0 *)
+
+external create_float: int -> float array = "caml_make_float_vect"
+(** [Array.create_float n] returns a fresh float array of length [n],
+    with uninitialized data.
+    @since 4.03 *)
+
+val make_float: int -> float array
+  [@@ocaml.deprecated "Use Array.create_float instead."]
+(** @deprecated [Array.make_float] is an alias for
+    {!Array.create_float}. *)
+
+
+(** {6 Sorting} *)
+
+
+val sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+(** Sort an array in increasing order according to a comparison
+   function.  The comparison function must return 0 if its arguments
+   compare as equal, a positive integer if the first is greater,
+   and a negative integer if the first is smaller (see below for a
+   complete specification).  For example, {!Pervasives.compare} is
+   a suitable comparison function, provided there are no floating-point
+   NaN values in the data.  After calling [Array.sort], the
+   array is sorted in place in increasing order.
+   [Array.sort] is guaranteed to run in constant heap space
+   and (at most) logarithmic stack space.
+
+   The current implementation uses Heap Sort.  It runs in constant
+   stack space.
+
+   Specification of the comparison function:
+   Let [a] be the array and [cmp] the comparison function.  The following
+   must be true for all x, y, z in a :
+-   [cmp x y] > 0 if and only if [cmp y x] < 0
+-   if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0
+
+   When [Array.sort] returns, [a] contains the same elements as before,
+   reordered in such a way that for all i and j valid indices of [a] :
+-   [cmp a.(i) a.(j)] >= 0 if and only if i >= j
+*)
+
+val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e.
+   elements that compare equal are kept in their original order) and
+   not guaranteed to run in constant heap space.
+
+   The current implementation uses Merge Sort. It uses [n/2]
+   words of heap space, where [n] is the length of the array.
+   It is usually faster than the current implementation of {!Array.sort}.
+*)
+
+val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is
+    faster on typical input.
+*)
+
+
+(**/**)
+
+(** {6 Undocumented functions} *)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
new file mode 100644
index 00000000..908909fa
--- /dev/null
+++ b/stdlib/buffer.ml
@@ -0,0 +1,196 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Pierre Weis and 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Extensible buffers *)
+
+type t =
+ {mutable buffer : bytes;
+  mutable position : int;
+  mutable length : int;
+  initial_buffer : bytes}
+
+let create n =
+ let n = if n < 1 then 1 else n in
+ let n = if n > Sys.max_string_length then Sys.max_string_length else n in
+ let s = Bytes.create n in
+ {buffer = s; position = 0; length = n; initial_buffer = s}
+
+let contents b = Bytes.sub_string b.buffer 0 b.position
+let to_bytes b = Bytes.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 Bytes.sub_string b.buffer ofs len
+
+
+let blit src srcoff dst dstoff len =
+  if len < 0 || srcoff < 0 || srcoff > src.position - len
+             || dstoff < 0 || dstoff > (Bytes.length dst) - len
+  then invalid_arg "Buffer.blit"
+  else
+    Bytes.unsafe_blit src.buffer srcoff dst dstoff len
+
+
+let nth b ofs =
+  if ofs < 0 || ofs >= b.position then
+   invalid_arg "Buffer.nth"
+  else Bytes.unsafe_get b.buffer ofs
+
+
+let length b = b.position
+
+let clear b = b.position <- 0
+
+let reset b =
+  b.position <- 0; b.buffer <- b.initial_buffer;
+  b.length <- Bytes.length b.buffer
+
+let resize b more =
+  let len = b.length in
+  let new_len = ref len in
+  while b.position + more > !new_len do new_len := 2 * !new_len done;
+  if !new_len > Sys.max_string_length then begin
+    if b.position + more <= Sys.max_string_length
+    then new_len := Sys.max_string_length
+    else failwith "Buffer.add: cannot grow buffer"
+  end;
+  let new_buffer = Bytes.create !new_len in
+  (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in
+     this tricky function that is slow anyway. *)
+  Bytes.blit b.buffer 0 new_buffer 0 b.position;
+  b.buffer <- new_buffer;
+  b.length <- !new_len
+
+let add_char b c =
+  let pos = b.position in
+  if pos >= b.length then resize b 1;
+  Bytes.unsafe_set b.buffer pos c;
+  b.position <- pos + 1
+
+let add_substring b s offset len =
+  if offset < 0 || len < 0 || offset > String.length s - len
+  then invalid_arg "Buffer.add_substring/add_subbytes";
+  let new_position = b.position + len in
+  if new_position > b.length then resize b len;
+  Bytes.blit_string s offset b.buffer b.position len;
+  b.position <- new_position
+
+let add_subbytes b s offset len =
+  add_substring b (Bytes.unsafe_to_string s) offset len
+
+let add_string b s =
+  let len = String.length s in
+  let new_position = b.position + len in
+  if new_position > b.length then resize b len;
+  Bytes.blit_string s 0 b.buffer b.position len;
+  b.position <- new_position
+
+let add_bytes b s = add_string b (Bytes.unsafe_to_string s)
+
+let add_buffer b bs =
+  add_subbytes b bs.buffer 0 bs.position
+
+(* read up to [len] bytes from [ic] into [b]. *)
+let rec add_channel_rec b ic len =
+  if len > 0 then (
+    let n = input ic b.buffer b.position len in
+    b.position <- b.position + n;
+    if n = 0 then raise End_of_file
+    else add_channel_rec b ic (len-n)   (* n <= len *)
+  )
+
+let add_channel b ic len =
+  if len < 0 || len > Sys.max_string_length then   (* PR#5004 *)
+    invalid_arg "Buffer.add_channel";
+  if b.position + len > b.length then resize b len;
+  add_channel_rec b ic len
+
+let output_buffer oc b =
+  output oc b.buffer 0 b.position
+
+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. *)
+let advance_to_closing opening closing k s start =
+  let rec advance k i lim =
+    if i >= lim then raise Not_found else
+    if s.[i] = opening then advance (k + 1) (i + 1) lim else
+    if s.[i] = closing then
+      if k = 0 then i else advance (k - 1) (i + 1) lim
+    else advance k (i + 1) lim in
+  advance k start (String.length s)
+
+let advance_to_non_alpha s start =
+  let rec advance i lim =
+    if i >= lim then lim else
+    match s.[i] with
+    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim
+    | _ -> i in
+  advance start (String.length s)
+
+(* We are just at the beginning of an ident in s, starting at start. *)
+let find_ident s start lim =
+  if start >= lim then raise Not_found else
+  match s.[start] with
+  (* Parenthesized ident ? *)
+  | '(' | '{' as c ->
+     let new_start = start + 1 in
+     let stop = advance_to_closing c (closing c) 0 s new_start in
+     String.sub s new_start (stop - start - 1), stop + 1
+  (* Regular ident *)
+  | _ ->
+     let stop = advance_to_non_alpha s (start + 1) in
+     String.sub s start (stop - start), stop
+
+(* Substitute $ident, $(ident), or ${ident} in s,
+    according to the function mapping f. *)
+let add_substitute b f s =
+  let lim = String.length s in
+  let rec subst previous i =
+    if i < lim then begin
+      match s.[i] with
+      | '$' as current when previous = '\\' ->
+         add_char b current;
+         subst ' ' (i + 1)
+      | '$' ->
+         let j = i + 1 in
+         let ident, next_i = find_ident s j lim in
+         add_string b (f ident);
+         subst ' ' next_i
+      | current when previous == '\\' ->
+         add_char b '\\';
+         add_char b current;
+         subst ' ' (i + 1)
+      | '\\' as current ->
+         subst current (i + 1)
+      | current ->
+         add_char b current;
+         subst current (i + 1)
+    end else
+    if previous = '\\' then add_char b previous in
+  subst ' ' 0
+
+let truncate b len =
+    if len < 0 || len > length b then
+      invalid_arg "Buffer.truncate"
+    else
+      b.position <- len
diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
new file mode 100644
index 00000000..71d87970
--- /dev/null
+++ b/stdlib/buffer.mli
@@ -0,0 +1,139 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Pierre Weis and 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Extensible buffers.
+
+   This module implements buffers that automatically expand
+   as necessary.  It provides accumulative concatenation of strings
+   in quasi-linear time (instead of quadratic time when strings are
+   concatenated pairwise).
+*)
+
+type t
+(** The abstract type of buffers. *)
+
+val create : int -> t
+(** [create n] returns a fresh buffer, initially empty.
+   The [n] parameter is the initial size of the internal byte sequence
+   that holds the buffer contents. That byte sequence is automatically
+   reallocated when more than [n] characters are stored in the buffer,
+   but shrinks back to [n] characters when [reset] is called.
+   For best performance, [n] should be of the same order of magnitude
+   as the number of characters that are expected to be stored in
+   the buffer (for instance, 80 for a buffer that holds one output
+   line).  Nothing bad will happen if the buffer grows beyond that
+   limit, however. In doubt, take [n = 16] for instance.
+   If [n] is not between 1 and {!Sys.max_string_length}, it will
+   be clipped to that interval. *)
+
+val contents : t -> string
+(** Return a copy of the current contents of the buffer.
+    The buffer itself is unchanged. *)
+
+val to_bytes : t -> bytes
+(** Return a copy of the current contents of the buffer.
+    The buffer itself is unchanged.
+    @since 4.02 *)
+
+val sub : t -> int -> int -> string
+(** [Buffer.sub b off len] returns a copy of [len] bytes from the
+    current contents of the buffer [b], starting at offset [off].
+
+    Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid
+    range of [b]. *)
+
+val blit : t -> int -> bytes -> int -> int -> unit
+(** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from
+   the current contents of the buffer [src], starting at offset [srcoff]
+   to [dst], starting at character [dstoff].
+
+   Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid
+   range of [src], or if [dstoff] and [len] do not designate a valid
+   range of [dst].
+   @since 3.11.2
+*)
+
+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. *)
+
+val clear : t -> unit
+(** Empty the buffer. *)
+
+val reset : t -> unit
+(** Empty the buffer and deallocate the internal byte sequence holding the
+   buffer contents, replacing it with the initial internal byte sequence
+   of length [n] that was allocated by {!Buffer.create} [n].
+   For long-lived buffers that may have grown a lot, [reset] allows
+   faster reclamation of the space used by the buffer. *)
+
+val add_char : t -> char -> unit
+(** [add_char b c] appends the character [c] at the end of buffer [b]. *)
+
+val add_string : t -> string -> unit
+(** [add_string b s] appends the string [s] at the end of buffer [b]. *)
+
+val add_bytes : t -> bytes -> unit
+(** [add_bytes b s] appends the byte sequence [s] at the end of buffer [b].
+    @since 4.02 *)
+
+val add_substring : t -> string -> int -> int -> unit
+(** [add_substring b s ofs len] takes [len] characters from offset
+   [ofs] in string [s] and appends them at the end of buffer [b]. *)
+
+val add_subbytes : t -> bytes -> int -> int -> unit
+(** [add_subbytes b s ofs len] takes [len] characters from offset
+    [ofs] in byte sequence [s] and appends them at the end of buffer [b].
+    @since 4.02 *)
+
+val add_substitute : t -> (string -> string) -> string -> unit
+(** [add_substitute b f s] appends the string pattern [s] at the end
+   of buffer [b] with substitution.
+   The substitution process looks for variables into
+   the pattern and substitutes each variable name by its value, as
+   obtained by applying the mapping [f] to the variable name. Inside the
+   string pattern, a variable name immediately follows a non-escaped
+   [$] character and is one of the following:
+   - a non empty sequence of alphanumeric or [_] characters,
+   - an arbitrary sequence of characters enclosed by a pair of
+   matching parentheses or curly brackets.
+   An escaped [$] character is a [$] that immediately follows a backslash
+   character; it then stands for a plain [$].
+   Raise [Not_found] if the closing character of a parenthesized variable
+   cannot be found. *)
+
+val add_buffer : t -> t -> unit
+(** [add_buffer b1 b2] appends the current contents of buffer [b2]
+   at the end of buffer [b1].  [b2] is not modified. *)
+
+val add_channel : t -> in_channel -> int -> unit
+(** [add_channel b ic n] reads at most [n] characters from the
+   input channel [ic] and stores them at the end of buffer [b].
+   Raise [End_of_file] if the channel contains fewer than [n]
+   characters. In this case, the characters are still added to
+   the buffer, so as to avoid loss of data. *)
+
+val output_buffer : out_channel -> t -> unit
+(** [output_buffer oc b] writes the current contents of buffer [b]
+   on the output channel [oc]. *)
+
+val truncate : t -> int -> unit
+(** [truncate b len] truncates the length of [b] to [len]
+  Note: the internal byte sequence is not shortened.
+  Raise [Invalid_argument] if [len < 0] or [len > length b].
+  @since 4.05.0 *)
diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml
new file mode 100644
index 00000000..0783babc
--- /dev/null
+++ b/stdlib/bytes.ml
@@ -0,0 +1,329 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Byte sequence operations *)
+
+(* WARNING: Some functions in this file are duplicated in string.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in string.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
+external length : bytes -> int = "%bytes_length"
+external string_length : string -> int = "%string_length"
+external get : bytes -> int -> char = "%bytes_safe_get"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
+external create : int -> bytes = "caml_create_bytes"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
+external unsafe_fill : bytes -> int -> int -> char -> unit
+                     = "caml_fill_bytes" [@@noalloc]
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
+external unsafe_of_string : string -> bytes = "%bytes_of_string"
+
+external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_bytes" [@@noalloc]
+external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+
+let make n c =
+  let s = create n in
+  unsafe_fill s 0 n c;
+  s
+
+let init n f =
+  let s = create n in
+  for i = 0 to n - 1 do
+    unsafe_set s i (f i)
+  done;
+  s
+
+let empty = create 0
+
+let copy s =
+  let len = length s in
+  let r = create len in
+  unsafe_blit s 0 r 0 len;
+  r
+
+let to_string b = unsafe_to_string (copy b)
+let of_string s = copy (unsafe_of_string s)
+
+let sub s ofs len =
+  if ofs < 0 || len < 0 || ofs > length s - len
+  then invalid_arg "String.sub / Bytes.sub"
+  else begin
+    let r = create len in
+    unsafe_blit s ofs r 0 len;
+    r
+  end
+
+let sub_string b ofs len = unsafe_to_string (sub b ofs len)
+
+(* addition with an overflow check *)
+let (++) a b =
+  let c = a + b in
+  match a < 0, b < 0, c < 0 with
+  | true , true , false
+  | false, false, true  -> invalid_arg "Bytes.extend" (* overflow *)
+  | _ -> c
+
+let extend s left right =
+  let len = length s ++ left ++ right in
+  let r = create len in
+  let (srcoff, dstoff) = if left < 0 then -left, 0 else 0, left in
+  let cpylen = min (length s - srcoff) (len - dstoff) in
+  if cpylen > 0 then unsafe_blit s srcoff r dstoff cpylen;
+  r
+
+let fill s ofs len c =
+  if ofs < 0 || len < 0 || ofs > length s - len
+  then invalid_arg "String.fill / Bytes.fill"
+  else unsafe_fill s ofs len c
+
+let blit s1 ofs1 s2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 > length s1 - len
+             || ofs2 < 0 || ofs2 > length s2 - len
+  then invalid_arg "Bytes.blit"
+  else unsafe_blit s1 ofs1 s2 ofs2 len
+
+let blit_string s1 ofs1 s2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 > string_length s1 - len
+             || ofs2 < 0 || ofs2 > length s2 - len
+  then invalid_arg "String.blit / Bytes.blit_string"
+  else unsafe_blit_string s1 ofs1 s2 ofs2 len
+
+(* duplicated in string.ml *)
+let iter f a =
+  for i = 0 to length a - 1 do f(unsafe_get a i) done
+
+(* duplicated in string.ml *)
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
+let ensure_ge (x:int) y = if x >= y then x else invalid_arg "Bytes.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
+
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
+  | hd :: tl ->
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> empty
+  | l -> let seplen = length sep in
+          unsafe_blits
+            (create (sum_lengths 0 seplen l))
+            0 sep seplen l
+
+let cat s1 s2 =
+  let l1 = length s1 in
+  let l2 = length s2 in
+  let r = create (l1 + l2) in
+  unsafe_blit s1 0 r 0 l1;
+  unsafe_blit s2 0 r l1 l2;
+  r
+
+
+external char_code: char -> int = "%identity"
+external char_chr: int -> char = "%identity"
+
+let is_space = function
+  | ' ' | '\012' | '\n' | '\r' | '\t' -> true
+  | _ -> false
+
+let trim s =
+  let len = length s in
+  let i = ref 0 in
+  while !i < len && is_space (unsafe_get s !i) do
+    incr i
+  done;
+  let j = ref (len - 1) in
+  while !j >= !i && is_space (unsafe_get s !j) do
+    decr j
+  done;
+  if !j >= !i then
+    sub s !i (!j - !i + 1)
+  else
+    empty
+
+let escaped s =
+  let n = ref 0 in
+  for i = 0 to length s - 1 do
+    n := !n +
+      (match unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | ' ' .. '~' -> 1
+       | _ -> 4)
+  done;
+  if !n = length s then copy s else begin
+    let s' = create !n in
+    n := 0;
+    for i = 0 to length s - 1 do
+      begin match unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c
+      | '\n' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n'
+      | '\t' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't'
+      | '\r' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r'
+      | '\b' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b'
+      | (' ' .. '~') as c -> unsafe_set s' !n c
+      | c ->
+          let a = char_code c in
+          unsafe_set s' !n '\\';
+          incr n;
+          unsafe_set s' !n (char_chr (48 + a / 100));
+          incr n;
+          unsafe_set s' !n (char_chr (48 + (a / 10) mod 10));
+          incr n;
+          unsafe_set s' !n (char_chr (48 + a mod 10));
+      end;
+      incr n
+    done;
+    s'
+  end
+
+let map f s =
+  let l = length s in
+  if l = 0 then s else begin
+    let r = create l in
+    for i = 0 to l - 1 do unsafe_set r i (f (unsafe_get s i)) done;
+    r
+  end
+
+let mapi f s =
+  let l = length s in
+  if l = 0 then s else begin
+    let r = create l in
+    for i = 0 to l - 1 do unsafe_set r i (f i (unsafe_get s i)) done;
+    r
+  end
+
+let uppercase_ascii s = map Char.uppercase_ascii s
+let lowercase_ascii s = map Char.lowercase_ascii s
+
+let apply1 f s =
+  if length s = 0 then s else begin
+    let r = copy s in
+    unsafe_set r 0 (f(unsafe_get s 0));
+    r
+  end
+
+let capitalize_ascii s = apply1 Char.uppercase_ascii s
+let uncapitalize_ascii s = apply1 Char.lowercase_ascii s
+
+(* duplicated in string.ml *)
+let rec index_rec s lim i c =
+  if i >= lim then raise Not_found else
+  if unsafe_get s i = c then i else index_rec s lim (i + 1) c
+
+(* duplicated in string.ml *)
+let index s c = index_rec s (length s) 0 c
+
+(* duplicated in string.ml *)
+let rec index_rec_opt s lim i c =
+  if i >= lim then None else
+  if unsafe_get s i = c then Some i else index_rec_opt s lim (i + 1) c
+
+(* duplicated in string.ml *)
+let index_opt s c = index_rec_opt s (length s) 0 c
+
+(* duplicated in string.ml *)
+let index_from s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
+  index_rec s l i c
+
+(* duplicated in string.ml *)
+let index_from_opt s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from_opt / Bytes.index_from_opt" else
+  index_rec_opt s l i c
+
+(* duplicated in string.ml *)
+let rec rindex_rec s i c =
+  if i < 0 then raise Not_found else
+  if unsafe_get s i = c then i else rindex_rec s (i - 1) c
+
+(* duplicated in string.ml *)
+let rindex s c = rindex_rec s (length s - 1) c
+
+(* duplicated in string.ml *)
+let rindex_from s i c =
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from / Bytes.rindex_from"
+  else
+    rindex_rec s i c
+
+(* duplicated in string.ml *)
+let rec rindex_rec_opt s i c =
+  if i < 0 then None else
+  if unsafe_get s i = c then Some i else rindex_rec_opt s (i - 1) c
+
+(* duplicated in string.ml *)
+let rindex_opt s c = rindex_rec_opt s (length s - 1) c
+
+(* duplicated in string.ml *)
+let rindex_from_opt s i c =
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from_opt / Bytes.rindex_from_opt"
+  else
+    rindex_rec_opt s i c
+
+
+(* duplicated in string.ml *)
+let contains_from s i c =
+  let l = length s in
+  if i < 0 || i > l then
+    invalid_arg "String.contains_from / Bytes.contains_from"
+  else
+    try ignore (index_rec s l i c); true with Not_found -> false
+
+
+(* duplicated in string.ml *)
+let contains s c = contains_from s 0 c
+
+(* duplicated in string.ml *)
+let rcontains_from s i c =
+  if i < 0 || i >= length s then
+    invalid_arg "String.rcontains_from / Bytes.rcontains_from"
+  else
+    try ignore (rindex_rec s i c); true with Not_found -> false
+
+
+type t = bytes
+
+let compare (x: t) (y: t) = Pervasives.compare x y
+external equal : t -> t -> bool = "caml_bytes_equal"
+
+(* Deprecated functions implemented via other deprecated functions *)
+[@@@ocaml.warning "-3"]
+let uppercase s = map Char.uppercase s
+let lowercase s = map Char.lowercase s
+
+let capitalize s = apply1 Char.uppercase s
+let uncapitalize s = apply1 Char.lowercase s
diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli
new file mode 100644
index 00000000..dc530787
--- /dev/null
+++ b/stdlib/bytes.mli
@@ -0,0 +1,460 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Byte sequence operations.
+
+   A byte sequence is a mutable data structure that contains a
+   fixed-length sequence of bytes. Each byte can be indexed in
+   constant time for reading or writing.
+
+   Given a byte sequence [s] of length [l], we can access each of the
+   [l] bytes of [s] via its index in the sequence. Indexes start at
+   [0], and we will call an index valid in [s] if it falls within the
+   range [[0...l-1]] (inclusive). A position is the point between two
+   bytes or at the beginning or end of the sequence.  We call a
+   position valid in [s] if it falls within the range [[0...l]]
+   (inclusive). Note that the byte at index [n] is between positions
+   [n] and [n+1].
+
+   Two parameters [start] and [len] are said to designate a valid
+   range of [s] if [len >= 0] and [start] and [start+len] are valid
+   positions in [s].
+
+   Byte sequences can be modified in place, for instance via the [set]
+   and [blit] functions described below.  See also strings (module
+   {!String}), which are almost the same data structure, but cannot be
+   modified in place.
+
+   Bytes are represented by the OCaml type [char].
+
+   @since 4.02.0
+ *)
+
+external length : bytes -> int = "%bytes_length"
+(** Return the length (number of bytes) of the argument. *)
+
+external get : bytes -> int -> char = "%bytes_safe_get"
+(** [get s n] returns the byte at index [n] in argument [s].
+
+    Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
+
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
+(** [set s n c] modifies [s] in place, replacing the byte at index [n]
+    with [c].
+
+    Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
+
+external create : int -> bytes = "caml_create_bytes"
+(** [create n] returns a new byte sequence of length [n]. The
+    sequence is uninitialized and contains arbitrary bytes.
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val make : int -> char -> bytes
+(** [make n c] returns a new byte sequence of length [n], filled with
+    the byte [c].
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val init : int -> (int -> char) -> bytes
+(** [Bytes.init n f] returns a fresh byte sequence of length [n], with
+    character [i] initialized to the result of [f i] (in increasing
+    index order).
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val empty : bytes
+(** A byte sequence of size 0. *)
+
+val copy : bytes -> bytes
+(** Return a new byte sequence that contains the same bytes as the
+    argument. *)
+
+val of_string : string -> bytes
+(** Return a new byte sequence that contains the same bytes as the
+    given string. *)
+
+val to_string : bytes -> string
+(** Return a new string that contains the same bytes as the given byte
+    sequence. *)
+
+val sub : bytes -> int -> int -> bytes
+(** [sub s start len] returns a new byte sequence of length [len],
+    containing the subsequence of [s] that starts at position [start]
+    and has length [len].
+
+    Raise [Invalid_argument] if [start] and [len] do not designate a
+    valid range of [s]. *)
+
+val sub_string : bytes -> int -> int -> string
+(** Same as [sub] but return a string instead of a byte sequence. *)
+
+val extend : bytes -> int -> int -> bytes
+(** [extend s left right] returns a new byte sequence that contains
+    the bytes of [s], with [left] uninitialized bytes prepended and
+    [right] uninitialized bytes appended to it. If [left] or [right]
+    is negative, then bytes are removed (instead of appended) from
+    the corresponding side of [s].
+
+    Raise [Invalid_argument] if the result length is negative or
+    longer than {!Sys.max_string_length} bytes. *)
+
+val fill : bytes -> int -> int -> char -> unit
+(** [fill s start len c] modifies [s] in place, replacing [len]
+    characters with [c], starting at [start].
+
+    Raise [Invalid_argument] if [start] and [len] do not designate a
+    valid range of [s]. *)
+
+val blit : bytes -> int -> bytes -> int -> int -> unit
+(** [blit src srcoff dst dstoff len] copies [len] bytes from sequence
+    [src], starting at index [srcoff], to sequence [dst], starting at
+    index [dstoff]. It works correctly even if [src] and [dst] are the
+    same byte sequence, and the source and destination intervals
+    overlap.
+
+    Raise [Invalid_argument] if [srcoff] and [len] do not
+    designate a valid range of [src], or if [dstoff] and [len]
+    do not designate a valid range of [dst]. *)
+
+val blit_string : string -> int -> bytes -> int -> int -> unit
+(** [blit src srcoff dst dstoff len] copies [len] bytes from string
+    [src], starting at index [srcoff], to byte sequence [dst],
+    starting at index [dstoff].
+
+    Raise [Invalid_argument] if [srcoff] and [len] do not
+    designate a valid range of [src], or if [dstoff] and [len]
+    do not designate a valid range of [dst]. *)
+
+val concat : bytes -> bytes list -> bytes
+(** [concat sep sl] concatenates the list of byte sequences [sl],
+    inserting the separator byte sequence [sep] between each, and
+    returns the result as a new byte sequence.
+
+    Raise [Invalid_argument] if the result is longer than
+    {!Sys.max_string_length} bytes. *)
+
+val cat : bytes -> bytes -> bytes
+(** [cat s1 s2] concatenates [s1] and [s2] and returns the result
+     as new byte sequence.
+
+    Raise [Invalid_argument] if the result is longer than
+    {!Sys.max_string_length} bytes. *)
+
+val iter : (char -> unit) -> bytes -> unit
+(** [iter f s] applies function [f] in turn to all the bytes of [s].
+    It is equivalent to [f (get s 0); f (get s 1); ...; f (get s
+    (length s - 1)); ()]. *)
+
+val iteri : (int -> char -> unit) -> bytes -> unit
+(** Same as {!Bytes.iter}, but the function is applied to the index of
+    the byte as first argument and the byte itself as second
+    argument. *)
+
+val map : (char -> char) -> bytes -> bytes
+(** [map f s] applies function [f] in turn to all the bytes of [s]
+    (in increasing index order) and stores the resulting bytes in
+    a new sequence that is returned as the result. *)
+
+val mapi : (int -> char -> char) -> bytes -> bytes
+(** [mapi f s] calls [f] with each character of [s] and its
+    index (in increasing index order) and stores the resulting bytes
+    in a new sequence that is returned as the result. *)
+
+val trim : bytes -> bytes
+(** Return a copy of the argument, without leading and trailing
+    whitespace. The bytes regarded as whitespace are the ASCII
+    characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *)
+
+val escaped : bytes -> bytes
+(** Return a copy of the argument, with special characters represented
+    by escape sequences, following the lexical conventions of OCaml.
+    All characters outside the ASCII printable range (32..126) are
+    escaped, as well as backslash and double-quote.
+
+    Raise [Invalid_argument] if the result is longer than
+    {!Sys.max_string_length} bytes. *)
+
+val index : bytes -> char -> int
+(** [index s c] returns the index of the first occurrence of byte [c]
+    in [s].
+
+    Raise [Not_found] if [c] does not occur in [s]. *)
+
+val index_opt: bytes -> char -> int option
+(** [index_opt s c] returns the index of the first occurrence of byte [c]
+    in [s] or [None] if [c] does not occur in [s].
+    @since 4.05 *)
+
+val rindex : bytes -> char -> int
+(** [rindex s c] returns the index of the last occurrence of byte [c]
+    in [s].
+
+    Raise [Not_found] if [c] does not occur in [s]. *)
+
+val rindex_opt: bytes -> char -> int option
+(** [rindex_opt s c] returns the index of the last occurrence of byte [c]
+    in [s] or [None] if [c] does not occur in [s].
+    @since 4.05 *)
+
+val index_from : bytes -> int -> char -> int
+(** [index_from s i c] returns the index of the first occurrence of
+    byte [c] in [s] after position [i].  [Bytes.index s c] is
+    equivalent to [Bytes.index_from s 0 c].
+
+    Raise [Invalid_argument] if [i] is not a valid position in [s].
+    Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+
+val index_from_opt: bytes -> int -> char -> int option
+(** [index_from _opts i c] returns the index of the first occurrence of
+    byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i].
+    [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c].
+
+    Raise [Invalid_argument] if [i] is not a valid position in [s].
+    @since 4.05 *)
+
+val rindex_from : bytes -> int -> char -> int
+(** [rindex_from s i c] returns the index of the last occurrence of
+    byte [c] in [s] before position [i+1].  [rindex s c] is equivalent
+    to [rindex_from s (Bytes.length s - 1) c].
+
+    Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+    Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+
+val rindex_from_opt: bytes -> int -> char -> int option
+(** [rindex_from_opt s i c] returns the index of the last occurrence
+    of byte [c] in [s] before position [i+1] or [None] if [c] does not
+    occur in [s] before position [i+1].  [rindex_opt s c] is equivalent to
+    [rindex_from s (Bytes.length s - 1) c].
+
+    Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+    @since 4.05 *)
+
+val contains : bytes -> char -> bool
+(** [contains s c] tests if byte [c] appears in [s]. *)
+
+val contains_from : bytes -> int -> char -> bool
+(** [contains_from s start c] tests if byte [c] appears in [s] after
+    position [start].  [contains s c] is equivalent to [contains_from
+    s 0 c].
+
+    Raise [Invalid_argument] if [start] is not a valid position in [s]. *)
+
+val rcontains_from : bytes -> int -> char -> bool
+(** [rcontains_from s stop c] tests if byte [c] appears in [s] before
+    position [stop+1].
+
+    Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid
+    position in [s]. *)
+
+val uppercase : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.uppercase_ascii instead."]
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val lowercase : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.lowercase_ascii instead."]
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val capitalize : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.capitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uncapitalize : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.uncapitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase_ascii : bytes -> bytes
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val lowercase_ascii : bytes -> bytes
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val capitalize_ascii : bytes -> bytes
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val uncapitalize_ascii : bytes -> bytes
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the US-ASCII character set.
+   @since 4.03.0 *)
+
+type t = bytes
+(** An alias for the type of byte sequences. *)
+
+val compare: t -> t -> int
+(** The comparison function for byte sequences, with the same
+    specification as {!Pervasives.compare}.  Along with the type [t],
+    this function [compare] allows the module [Bytes] to be passed as
+    argument to the functors {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equality function for byte sequences.
+    @since 4.03.0 *)
+
+(** {4 Unsafe conversions (for advanced users)}
+
+    This section describes unsafe, low-level conversion functions
+    between [bytes] and [string]. They do not copy the internal data;
+    used improperly, they can break the immutability invariant on
+    strings provided by the [-safe-string] option. They are available for
+    expert library authors, but for most purposes you should use the
+    always-correct {!Bytes.to_string} and {!Bytes.of_string} instead.
+*)
+
+val unsafe_to_string : bytes -> string
+(** Unsafely convert a byte sequence into a string.
+
+    To reason about the use of [unsafe_to_string], it is convenient to
+    consider an "ownership" discipline. A piece of code that
+    manipulates some data "owns" it; there are several disjoint ownership
+    modes, including:
+    - Unique ownership: the data may be accessed and mutated
+    - Shared ownership: the data has several owners, that may only
+      access it, not mutate it.
+
+    Unique ownership is linear: passing the data to another piece of
+    code means giving up ownership (we cannot write the
+    data again). A unique owner may decide to make the data shared
+    (giving up mutation rights on it), but shared data may not become
+    uniquely-owned again.
+
+   [unsafe_to_string s] can only be used when the caller owns the byte
+   sequence [s] -- either uniquely or as shared immutable data. The
+   caller gives up ownership of [s], and gains ownership of the
+   returned string.
+
+   There are two valid use-cases that respect this ownership
+   discipline:
+
+   1. Creating a string by initializing and mutating a byte sequence
+   that is never changed after initialization is performed.
+
+   {[
+let string_init len f : string =
+  let s = Bytes.create len in
+  for i = 0 to len - 1 do Bytes.set s i (f i) done;
+  Bytes.unsafe_to_string s
+   ]}
+
+   This function is safe because the byte sequence [s] will never be
+   accessed or mutated after [unsafe_to_string] is called. The
+   [string_init] code gives up ownership of [s], and returns the
+   ownership of the resulting string to its caller.
+
+   Note that it would be unsafe if [s] was passed as an additional
+   parameter to the function [f] as it could escape this way and be
+   mutated in the future -- [string_init] would give up ownership of
+   [s] to pass it to [f], and could not call [unsafe_to_string]
+   safely.
+
+   We have provided the {!String.init}, {!String.map} and
+   {!String.mapi} functions to cover most cases of building
+   new strings. You should prefer those over [to_string] or
+   [unsafe_to_string] whenever applicable.
+
+   2. Temporarily giving ownership of a byte sequence to a function
+   that expects a uniquely owned string and returns ownership back, so
+   that we can mutate the sequence again after the call ended.
+
+   {[
+let bytes_length (s : bytes) =
+  String.length (Bytes.unsafe_to_string s)
+   ]}
+
+   In this use-case, we do not promise that [s] will never be mutated
+   after the call to [bytes_length s]. The {!String.length} function
+   temporarily borrows unique ownership of the byte sequence
+   (and sees it as a [string]), but returns this ownership back to
+   the caller, which may assume that [s] is still a valid byte
+   sequence after the call. Note that this is only correct because we
+   know that {!String.length} does not capture its argument -- it could
+   escape by a side-channel such as a memoization combinator.
+
+   The caller may not mutate [s] while the string is borrowed (it has
+   temporarily given up ownership). This affects concurrent programs,
+   but also higher-order functions: if {!String.length} returned
+   a closure to be called later, [s] should not be mutated until this
+   closure is fully applied and returns ownership.
+*)
+
+val unsafe_of_string : string -> bytes
+(** Unsafely convert a shared string to a byte sequence that should
+    not be mutated.
+
+    The same ownership discipline that makes [unsafe_to_string]
+    correct applies to [unsafe_of_string]: you may use it if you were
+    the owner of the [string] value, and you will own the return
+    [bytes] in the same mode.
+
+    In practice, unique ownership of string values is extremely
+    difficult to reason about correctly. You should always assume
+    strings are shared, never uniquely owned.
+
+    For example, string literals are implicitly shared by the
+    compiler, so you never uniquely own them.
+
+    {[
+let incorrect = Bytes.unsafe_of_string "hello"
+let s = Bytes.of_string "hello"
+    ]}
+
+    The first declaration is incorrect, because the string literal
+    ["hello"] could be shared by the compiler with other parts of the
+    program, and mutating [incorrect] is a bug. You must always use
+    the second version, which performs a copy and is thus correct.
+
+    Assuming unique ownership of strings that are not string
+    literals, but are (partly) built from string literals, is also
+    incorrect. For example, mutating [unsafe_of_string ("foo" ^ s)]
+    could mutate the shared string ["foo"] -- assuming a rope-like
+    representation of strings. More generally, functions operating on
+    strings will assume shared ownership, they do not preserve unique
+    ownership. It is thus incorrect to assume unique ownership of the
+    result of [unsafe_of_string].
+
+    The only case we have reasonable confidence is safe is if the
+    produced [bytes] is shared -- used as an immutable byte
+    sequence. This is possibly useful for incremental migration of
+    low-level programs that manipulate immutable sequences of bytes
+    (for example {!Marshal.from_bytes}) and previously used the
+    [string] type for this purpose.
+*)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
+external unsafe_blit :
+  bytes -> int -> bytes -> int -> int -> unit
+  = "caml_blit_bytes" [@@noalloc]
+external unsafe_fill :
+  bytes -> int -> int -> char -> unit = "caml_fill_bytes" [@@noalloc]
diff --git a/stdlib/bytesLabels.ml b/stdlib/bytesLabels.ml
new file mode 100644
index 00000000..0e984169
--- /dev/null
+++ b/stdlib/bytesLabels.ml
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [BytesLabels]: labelled Bytes module *)
+
+include Bytes
diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli
new file mode 100644
index 00000000..9848f32d
--- /dev/null
+++ b/stdlib/bytesLabels.mli
@@ -0,0 +1,307 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Byte sequence operations.
+    @since 4.02.0
+ *)
+
+external length : bytes -> int = "%bytes_length"
+(** Return the length (number of bytes) of the argument. *)
+
+external get : bytes -> int -> char = "%bytes_safe_get"
+(** [get s n] returns the byte at index [n] in argument [s].
+
+    Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
+
+
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
+(** [set s n c] modifies [s] in place, replacing the byte at index [n]
+    with [c].
+
+    Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
+
+external create : int -> bytes = "caml_create_bytes"
+(** [create n] returns a new byte sequence of length [n]. The
+    sequence is uninitialized and contains arbitrary bytes.
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val make : int -> char -> bytes
+(** [make n c] returns a new byte sequence of length [n], filled with
+    the byte [c].
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val init : int -> f:(int -> char) -> bytes
+(** [init n f] returns a fresh byte sequence of length [n],
+    with character [i] initialized to the result of [f i].
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val empty : bytes
+(** A byte sequence of size 0. *)
+
+val copy : bytes -> bytes
+(** Return a new byte sequence that contains the same bytes as the
+    argument. *)
+
+val of_string : string -> bytes
+(** Return a new byte sequence that contains the same bytes as the
+    given string. *)
+
+val to_string : bytes -> string
+(** Return a new string that contains the same bytes as the given byte
+    sequence. *)
+
+val sub : bytes -> pos:int -> len:int -> bytes
+(** [sub s start len] returns a new byte sequence of length [len],
+    containing the subsequence of [s] that starts at position [start]
+    and has length [len].
+
+    Raise [Invalid_argument] if [start] and [len] do not designate a
+    valid range of [s]. *)
+
+val sub_string : bytes -> int -> int -> string
+(** Same as [sub] but return a string instead of a byte sequence. *)
+
+val extend : bytes -> left:int -> right:int -> bytes
+(** [extend s left right] returns a new byte sequence that contains
+    the bytes of [s], with [left] uninitialized bytes prepended and
+    [right] uninitialized bytes appended to it. If [left] or [right]
+    is negative, then bytes are removed (instead of appended) from
+    the corresponding side of [s].
+
+    Raise [Invalid_argument] if the result length is negative or
+    longer than {!Sys.max_string_length} bytes.
+    @since 4.05.0 *)
+
+val fill : bytes -> pos:int -> len:int -> char -> unit
+(** [fill s start len c] modifies [s] in place, replacing [len]
+    characters with [c], starting at [start].
+
+    Raise [Invalid_argument] if [start] and [len] do not designate a
+    valid range of [s]. *)
+
+val blit :
+  src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int
+  -> unit
+(** [blit src srcoff dst dstoff len] copies [len] bytes from sequence
+    [src], starting at index [srcoff], to sequence [dst], starting at
+    index [dstoff]. It works correctly even if [src] and [dst] are the
+    same byte sequence, and the source and destination intervals
+    overlap.
+
+    Raise [Invalid_argument] if [srcoff] and [len] do not
+    designate a valid range of [src], or if [dstoff] and [len]
+    do not designate a valid range of [dst]. *)
+
+val blit_string :
+  src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int
+  -> unit
+(** [blit src srcoff dst dstoff len] copies [len] bytes from string
+    [src], starting at index [srcoff], to byte sequence [dst],
+    starting at index [dstoff].
+
+    Raise [Invalid_argument] if [srcoff] and [len] do not
+    designate a valid range of [src], or if [dstoff] and [len]
+    do not designate a valid range of [dst].
+    @since 4.05.0 *)
+
+val concat : sep:bytes -> bytes list -> bytes
+(** [concat sep sl] concatenates the list of byte sequences [sl],
+    inserting the separator byte sequence [sep] between each, and
+    returns the result as a new byte sequence. *)
+
+val cat : bytes -> bytes -> bytes
+(** [cat s1 s2] concatenates [s1] and [s2] and returns the result
+     as new byte sequence.
+
+    Raise [Invalid_argument] if the result is longer than
+    {!Sys.max_string_length} bytes.
+    @since 4.05.0 *)
+
+val iter : f:(char -> unit) -> bytes -> unit
+(** [iter f s] applies function [f] in turn to all the bytes of [s].
+    It is equivalent to [f (get s 0); f (get s 1); ...; f (get s
+    (length s - 1)); ()]. *)
+
+val iteri : f:(int -> char -> unit) -> bytes -> unit
+(** Same as {!Bytes.iter}, but the function is applied to the index of
+    the byte as first argument and the byte itself as second
+    argument. *)
+
+val map : f:(char -> char) -> bytes -> bytes
+(** [map f s] applies function [f] in turn to all the bytes of [s] and
+    stores the resulting bytes in a new sequence that is returned as
+    the result. *)
+
+val mapi : f:(int -> char -> char) -> bytes -> bytes
+(** [mapi f s] calls [f] with each character of [s] and its
+    index (in increasing index order) and stores the resulting bytes
+    in a new sequence that is returned as the result. *)
+
+val trim : bytes -> bytes
+(** Return a copy of the argument, without leading and trailing
+    whitespace. The bytes regarded as whitespace are the ASCII
+    characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *)
+
+val escaped : bytes -> bytes
+(** Return a copy of the argument, with special characters represented
+    by escape sequences, following the lexical conventions of OCaml. *)
+
+val index : bytes -> char -> int
+(** [index s c] returns the index of the first occurrence of byte [c]
+    in [s].
+
+    Raise [Not_found] if [c] does not occur in [s]. *)
+
+val index_opt: bytes -> char -> int option
+(** [index_opt s c] returns the index of the first occurrence of byte [c]
+    in [s] or [None] if [c] does not occur in [s].
+    @since 4.05 *)
+
+val rindex : bytes -> char -> int
+(** [rindex s c] returns the index of the last occurrence of byte [c]
+    in [s].
+
+    Raise [Not_found] if [c] does not occur in [s]. *)
+
+val rindex_opt: bytes -> char -> int option
+(** [rindex_opt s c] returns the index of the last occurrence of byte [c]
+    in [s] or [None] if [c] does not occur in [s].
+    @since 4.05 *)
+
+val index_from : bytes -> int -> char -> int
+(** [index_from s i c] returns the index of the first occurrence of
+    byte [c] in [s] after position [i].  [Bytes.index s c] is
+    equivalent to [Bytes.index_from s 0 c].
+
+    Raise [Invalid_argument] if [i] is not a valid position in [s].
+    Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+
+val index_from_opt: bytes -> int -> char -> int option
+(** [index_from _opts i c] returns the index of the first occurrence of
+    byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i].
+    [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c].
+
+    Raise [Invalid_argument] if [i] is not a valid position in [s].
+    @since 4.05 *)
+
+val rindex_from : bytes -> int -> char -> int
+(** [rindex_from s i c] returns the index of the last occurrence of
+    byte [c] in [s] before position [i+1].  [rindex s c] is equivalent
+    to [rindex_from s (Bytes.length s - 1) c].
+
+    Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+    Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+
+val rindex_from_opt: bytes -> int -> char -> int option
+(** [rindex_from_opt s i c] returns the index of the last occurrence
+    of byte [c] in [s] before position [i+1] or [None] if [c] does not
+    occur in [s] before position [i+1].  [rindex_opt s c] is equivalent to
+    [rindex_from s (Bytes.length s - 1) c].
+
+    Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+    @since 4.05 *)
+
+val contains : bytes -> char -> bool
+(** [contains s c] tests if byte [c] appears in [s]. *)
+
+val contains_from : bytes -> int -> char -> bool
+(** [contains_from s start c] tests if byte [c] appears in [s] after
+    position [start].  [contains s c] is equivalent to [contains_from
+    s 0 c].
+
+    Raise [Invalid_argument] if [start] is not a valid position in [s]. *)
+
+val rcontains_from : bytes -> int -> char -> bool
+(** [rcontains_from s stop c] tests if byte [c] appears in [s] before
+    position [stop+1].
+
+    Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid
+    position in [s]. *)
+
+val uppercase : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.uppercase_ascii instead."]
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val lowercase : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.lowercase_ascii instead."]
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val capitalize : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.capitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uncapitalize : bytes -> bytes
+  [@@ocaml.deprecated "Use Bytes.uncapitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase_ascii : bytes -> bytes
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, using the US-ASCII character set.
+   @since 4.05.0 *)
+
+val lowercase_ascii : bytes -> bytes
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, using the US-ASCII character set.
+   @since 4.05.0 *)
+
+val capitalize_ascii : bytes -> bytes
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the US-ASCII character set.
+   @since 4.05.0 *)
+
+val uncapitalize_ascii : bytes -> bytes
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the US-ASCII character set.
+   @since 4.05.0 *)
+
+type t = bytes
+(** An alias for the type of byte sequences. *)
+
+val compare: t -> t -> int
+(** The comparison function for byte sequences, with the same
+    specification as {!Pervasives.compare}.  Along with the type [t],
+    this function [compare] allows the module [Bytes] to be passed as
+    argument to the functors {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equality function for byte sequences.
+    @since 4.05.0 *)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
+external unsafe_blit :
+  src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int ->
+    unit = "caml_blit_bytes" [@@noalloc]
+external unsafe_fill :
+  bytes -> pos:int -> len:int -> char -> unit = "caml_fill_bytes" [@@noalloc]
+val unsafe_to_string : bytes -> string
+val unsafe_of_string : string -> bytes
diff --git a/stdlib/callback.ml b/stdlib/callback.ml
new file mode 100644
index 00000000..e0cfb655
--- /dev/null
+++ b/stdlib/callback.ml
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Registering OCaml values with the C runtime for later callbacks *)
+
+external register_named_value : string -> Obj.t -> unit
+                              = "caml_register_named_value"
+
+let register name v =
+  register_named_value name (Obj.repr v)
+
+let register_exception name (exn : exn) =
+  let exn = Obj.repr exn in
+  let slot = if Obj.tag exn = Obj.object_tag then exn else Obj.field exn 0 in
+  register_named_value name slot
diff --git a/stdlib/callback.mli b/stdlib/callback.mli
new file mode 100644
index 00000000..27c8b500
--- /dev/null
+++ b/stdlib/callback.mli
@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Registering OCaml values with the C runtime.
+
+   This module allows OCaml values to be registered with the C runtime
+   under a symbolic name, so that C code can later call back registered
+   OCaml functions, or raise registered OCaml exceptions.
+*)
+
+val register : string -> 'a -> unit
+(** [Callback.register n v] registers the value [v] under
+   the name [n]. C code can later retrieve a handle to [v]
+   by calling [caml_named_value(n)]. *)
+
+val register_exception : string -> exn -> unit
+(** [Callback.register_exception n exn] registers the
+   exception contained in the exception value [exn]
+   under the name [n]. C code can later retrieve a handle to
+   the exception by calling [caml_named_value(n)]. The exception
+   value thus obtained is suitable for passing as first argument
+   to [raise_constant] or [raise_with_arg]. *)
diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml
new file mode 100644
index 00000000..9c0574dd
--- /dev/null
+++ b/stdlib/camlinternalFormat.ml
@@ -0,0 +1,2958 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Benoit Vaugon, ENSTA                          *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open CamlinternalFormatBasics
+
+(******************************************************************************)
+           (* Tools to manipulate scanning set of chars (see %[...]) *)
+
+type mutable_char_set = bytes
+
+(* Create a fresh, empty, mutable char set. *)
+let create_char_set () = Bytes.make 32 '\000'
+
+(* Add a char in a mutable char set. *)
+let add_in_char_set char_set c =
+  let ind = int_of_char c in
+  let str_ind = ind lsr 3 and mask = 1 lsl (ind land 0b111) in
+  Bytes.set char_set str_ind
+    (char_of_int (int_of_char (Bytes.get char_set str_ind) lor mask))
+
+let freeze_char_set char_set =
+  Bytes.to_string char_set
+
+(* Compute the complement of a char set. *)
+let rev_char_set char_set =
+  let char_set' = create_char_set () in
+  for i = 0 to 31 do
+    Bytes.set char_set' i
+      (char_of_int (int_of_char (String.get char_set i) lxor 0xFF));
+  done;
+  Bytes.unsafe_to_string char_set'
+
+(* Return true if a `c' is in `char_set'. *)
+let is_in_char_set char_set c =
+  let ind = int_of_char c in
+  let str_ind = ind lsr 3 and mask = 1 lsl (ind land 0b111) in
+  (int_of_char (String.get char_set str_ind) land mask) <> 0
+
+
+(******************************************************************************)
+                         (* Ignored param conversion *)
+
+(* GADT used to abstract an existential type parameter. *)
+(* See param_format_of_ignored_format. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb = Param_format_EBB :
+    ('x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb
+
+(* Compute a padding associated to a pad_option (see "%_42d"). *)
+let pad_of_pad_opt pad_opt = match pad_opt with
+  | None -> No_padding
+  | Some width -> Lit_padding (Right, width)
+
+(* Compute a precision associated to a prec_option (see "%_.42f"). *)
+let prec_of_prec_opt prec_opt = match prec_opt with
+  | None -> No_precision
+  | Some ndec -> Lit_precision ndec
+
+(* Turn an ignored param into its equivalent not-ignored format node. *)
+(* Used for format pretty-printing and Scanf. *)
+let param_format_of_ignored_format : type a b c d e f x y .
+    (a, b, c, d, y, x) ignored -> (x, b, c, y, e, f) fmt ->
+      (a, b, c, d, e, f) param_format_ebb =
+fun ign fmt -> match ign with
+  | Ignored_char ->
+    Param_format_EBB (Char fmt)
+  | Ignored_caml_char ->
+    Param_format_EBB (Caml_char fmt)
+  | Ignored_string pad_opt ->
+    Param_format_EBB (String (pad_of_pad_opt pad_opt, fmt))
+  | Ignored_caml_string pad_opt ->
+    Param_format_EBB (Caml_string (pad_of_pad_opt pad_opt, fmt))
+  | Ignored_int (iconv, pad_opt) ->
+    Param_format_EBB (Int (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+  | Ignored_int32 (iconv, pad_opt) ->
+    Param_format_EBB
+      (Int32 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+  | Ignored_nativeint (iconv, pad_opt) ->
+    Param_format_EBB
+      (Nativeint (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+  | Ignored_int64 (iconv, pad_opt) ->
+    Param_format_EBB
+      (Int64 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+  | Ignored_float (pad_opt, prec_opt) ->
+    Param_format_EBB
+      (Float (Float_f, pad_of_pad_opt pad_opt, prec_of_prec_opt prec_opt, fmt))
+  | Ignored_bool ->
+    Param_format_EBB (Bool fmt)
+  | Ignored_format_arg (pad_opt, fmtty) ->
+    Param_format_EBB (Format_arg (pad_opt, fmtty, fmt))
+  | Ignored_format_subst (pad_opt, fmtty) ->
+    Param_format_EBB
+      (Format_subst (pad_opt, fmtty, fmt))
+  | Ignored_reader ->
+    Param_format_EBB (Reader fmt)
+  | Ignored_scan_char_set (width_opt, char_set) ->
+    Param_format_EBB (Scan_char_set (width_opt, char_set, fmt))
+  | Ignored_scan_get_counter counter ->
+    Param_format_EBB (Scan_get_counter (counter, fmt))
+  | Ignored_scan_next_char ->
+    Param_format_EBB (Scan_next_char fmt)
+
+
+(******************************************************************************)
+                                 (* Types *)
+
+type ('b, 'c) acc_formatting_gen =
+  | Acc_open_tag of ('b, 'c) acc
+  | Acc_open_box of ('b, 'c) acc
+
+(* Reversed list of printing atoms. *)
+(* Used to accumulate printf arguments. *)
+and ('b, 'c) acc =
+  | Acc_formatting_lit of ('b, 'c) acc * formatting_lit
+      (* Special fmtting (box) *)
+  | Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen
+      (* Special fmtting (box) *)
+  | Acc_string_literal of ('b, 'c) acc * string     (* Literal string *)
+  | Acc_char_literal   of ('b, 'c) acc * char       (* Literal char *)
+  | Acc_data_string    of ('b, 'c) acc * string     (* Generated string *)
+  | Acc_data_char      of ('b, 'c) acc * char       (* Generated char *)
+  | Acc_delay          of ('b, 'c) acc * ('b -> 'c)
+                                                (* Delayed printing (%a, %t) *)
+  | Acc_flush          of ('b, 'c) acc              (* Flush *)
+  | Acc_invalid_arg    of ('b, 'c) acc * string
+      (* Raise Invalid_argument msg *)
+  | End_of_acc
+
+(* List of heterogeneous values. *)
+(* Used to accumulate scanf callback arguments. *)
+type ('a, 'b) heter_list =
+  | Cons : 'c * ('a, 'b) heter_list -> ('c -> 'a, 'b) heter_list
+  | Nil : ('b, 'b) heter_list
+
+(* Existential Black Boxes. *)
+(* Used to abstract some existential type parameters. *)
+
+(* GADT type associating a padding and an fmtty. *)
+(* See the type_padding function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) padding_fmtty_ebb = Padding_fmtty_EBB :
+     ('x, 'y) padding * ('y, 'b, 'c, 'd, 'e, 'f) fmtty ->
+     ('x, 'b, 'c, 'd, 'e, 'f) padding_fmtty_ebb
+
+(* GADT type associating a padding, a precision and an fmtty. *)
+(* See the type_padprec function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb = Padprec_fmtty_EBB :
+     ('x, 'y) padding * ('y, 'z) precision * ('z, 'b, 'c, 'd, 'e, 'f) fmtty ->
+     ('x, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb
+
+(* GADT type associating a padding and an fmt. *)
+(* See make_padding_fmt_ebb and parse_format functions. *)
+type ('a, 'b, 'c, 'e, 'f) padding_fmt_ebb = Padding_fmt_EBB :
+     (_, 'x -> 'a) padding *
+     ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+     ('x, 'b, 'c, 'e, 'f) padding_fmt_ebb
+
+(* GADT type associating a precision and an fmt. *)
+(* See make_precision_fmt_ebb and parse_format functions. *)
+type ('a, 'b, 'c, 'e, 'f) precision_fmt_ebb = Precision_fmt_EBB :
+     (_, 'x -> 'a) precision *
+     ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+     ('x, 'b, 'c, 'e, 'f) precision_fmt_ebb
+
+(* GADT type associating a padding, a precision and an fmt. *)
+(* See make_padprec_fmt_ebb and parse_format functions. *)
+type ('p, 'b, 'c, 'e, 'f) padprec_fmt_ebb = Padprec_fmt_EBB :
+     ('x, 'y) padding * ('y, 'p -> 'a) precision *
+     ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+     ('p, 'b, 'c, 'e, 'f) padprec_fmt_ebb
+
+(* Abstract the 'a and 'd parameters of an fmt. *)
+(* Output type of the format parsing function. *)
+type ('b, 'c, 'e, 'f) fmt_ebb = Fmt_EBB :
+     ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+     ('b, 'c, 'e, 'f) fmt_ebb
+
+(* GADT type associating an fmtty and an fmt. *)
+(* See the type_format_gen function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) fmt_fmtty_ebb = Fmt_fmtty_EBB :
+     ('a, 'b, 'c, 'd, 'y, 'x) fmt *
+     ('x, 'b, 'c, 'y, 'e, 'f) fmtty ->
+     ('a, 'b, 'c, 'd, 'e, 'f) fmt_fmtty_ebb
+
+(* GADT type associating an fmtty and an fmt. *)
+(* See the type_ignored_format_substitution function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb = Fmtty_fmt_EBB :
+     ('a, 'b, 'c, 'd, 'y, 'x) fmtty *
+     ('x, 'b, 'c, 'y, 'e, 'f) fmt_fmtty_ebb ->
+     ('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb
+
+(* Abstract all fmtty type parameters. *)
+(* Used to compare format types. *)
+type fmtty_ebb = Fmtty_EBB : ('a, 'b, 'c, 'd, 'e, 'f) fmtty -> fmtty_ebb
+
+(* Abstract all padding type parameters. *)
+(* Used to compare paddings. *)
+type padding_ebb = Padding_EBB : ('a, 'b) padding -> padding_ebb
+
+(* Abstract all precision type parameters. *)
+(* Used to compare precisions. *)
+type precision_ebb = Precision_EBB : ('a, 'b) precision -> precision_ebb
+
+(******************************************************************************)
+                               (* Constants *)
+
+(* Default precision for float printing. *)
+let default_float_precision = -6
+  (* For %h and %H formats, a negative precision means "as many digits as
+     necessary".  For the other FP formats, we take the absolute value
+     of the precision, hence 6 digits by default. *)
+
+(******************************************************************************)
+                               (* Externals *)
+
+external format_float: string -> float -> string
+  = "caml_format_float"
+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 hexstring_of_float: float -> int -> char -> string
+  = "caml_hexstring_of_float"
+
+(******************************************************************************)
+                     (* Tools to pretty-print formats *)
+
+(* Type of extensible character buffers. *)
+type buffer = {
+  mutable ind : int;
+  mutable bytes : bytes;
+}
+
+(* Create a fresh buffer. *)
+let buffer_create init_size = { ind = 0; bytes = Bytes.create init_size }
+
+(* Check size of the buffer and grow it if needed. *)
+let buffer_check_size buf overhead =
+  let len = Bytes.length buf.bytes in
+  let min_len = buf.ind + overhead in
+  if min_len > len then (
+    let new_len = max (len * 2) min_len in
+    let new_str = Bytes.create new_len in
+    Bytes.blit buf.bytes 0 new_str 0 len;
+    buf.bytes <- new_str;
+  )
+
+(* Add the character `c' to the buffer `buf'. *)
+let buffer_add_char buf c =
+  buffer_check_size buf 1;
+  Bytes.set buf.bytes buf.ind c;
+  buf.ind <- buf.ind + 1
+
+(* Add the string `s' to the buffer `buf'. *)
+let buffer_add_string buf s =
+  let str_len = String.length s in
+  buffer_check_size buf str_len;
+  String.blit s 0 buf.bytes buf.ind str_len;
+  buf.ind <- buf.ind + str_len
+
+(* Get the content of the buffer. *)
+let buffer_contents buf =
+  Bytes.sub_string buf.bytes 0 buf.ind
+
+(***)
+
+(* Convert an integer conversion to char. *)
+let char_of_iconv iconv = match iconv with
+  | Int_d | Int_pd | Int_sd -> 'd' | Int_i | Int_pi | Int_si -> 'i'
+  | Int_x | Int_Cx -> 'x' | Int_X | Int_CX -> 'X' | Int_o | Int_Co -> 'o'
+  | Int_u -> 'u'
+
+(* Convert a float conversion to char. *)
+let char_of_fconv fconv = match fconv with
+  | Float_f | Float_pf | Float_sf -> 'f' | Float_e | Float_pe | Float_se -> 'e'
+  | Float_E | Float_pE | Float_sE -> 'E' | Float_g | Float_pg | Float_sg -> 'g'
+  | Float_G | Float_pG | Float_sG -> 'G' | Float_F -> 'F'
+  | Float_h | Float_ph | Float_sh -> 'h' | Float_H | Float_pH | Float_sH -> 'H'
+
+
+(* Convert a scanning counter to char. *)
+let char_of_counter counter = match counter with
+  | Line_counter  -> 'l'
+  | Char_counter  -> 'n'
+  | Token_counter -> 'N'
+
+(***)
+
+(* Print a char_set in a buffer with the OCaml format lexical convention. *)
+let bprint_char_set buf char_set =
+  let rec print_start set =
+    let is_alone c =
+      let before, after = Char.(chr (code c - 1), chr (code c + 1)) in
+      is_in_char_set set c
+      && not (is_in_char_set set before && is_in_char_set set after) in
+    if is_alone ']' then buffer_add_char buf ']';
+    print_out set 1;
+    if is_alone '-' then buffer_add_char buf '-';
+  and print_out set i =
+    if i < 256 then
+      if is_in_char_set set (char_of_int i) then print_first set i
+      else print_out set (i + 1)
+  and print_first set i =
+    match char_of_int i with
+    | '\255' -> print_char buf 255;
+    | ']' | '-' -> print_out set (i + 1);
+    | _ -> print_second set (i + 1);
+  and print_second set i =
+    if is_in_char_set set (char_of_int i) then
+      match char_of_int i with
+      | '\255' ->
+        print_char buf 254;
+        print_char buf 255;
+      | ']' | '-' when not (is_in_char_set set (char_of_int (i + 1))) ->
+        print_char buf (i - 1);
+        print_out set (i + 1);
+      | _ when not (is_in_char_set set (char_of_int (i + 1))) ->
+        print_char buf (i - 1);
+        print_char buf i;
+        print_out set (i + 2);
+      | _ ->
+        print_in set (i - 1) (i + 2);
+    else (
+      print_char buf (i - 1);
+      print_out set (i + 1);
+    )
+  and print_in set i j =
+    if j = 256 || not (is_in_char_set set (char_of_int j)) then (
+      print_char buf i;
+      print_char buf (int_of_char '-');
+      print_char buf (j - 1);
+      if j < 256 then print_out set (j + 1);
+    ) else
+      print_in set i (j + 1);
+  and print_char buf i = match char_of_int i with
+    | '%' -> buffer_add_char buf '%'; buffer_add_char buf '%';
+    | '@' -> buffer_add_char buf '%'; buffer_add_char buf '@';
+    | c   -> buffer_add_char buf c;
+  in
+  buffer_add_char buf '[';
+  print_start (
+    if is_in_char_set char_set '\000'
+    then ( buffer_add_char buf '^'; rev_char_set char_set )
+    else char_set
+  );
+  buffer_add_char buf ']'
+
+(***)
+
+(* Print a padty in a buffer with the format-like syntax. *)
+let bprint_padty buf padty = match padty with
+  | Left  -> buffer_add_char buf '-'
+  | Right -> ()
+  | Zeros -> buffer_add_char buf '0'
+
+(* Print the '_' of an ignored flag if needed. *)
+let bprint_ignored_flag buf ign_flag =
+  if ign_flag then buffer_add_char buf '_'
+
+(***)
+
+let bprint_pad_opt buf pad_opt = match pad_opt with
+  | None -> ()
+  | Some width -> buffer_add_string buf (string_of_int width)
+
+(***)
+
+(* Print padding in a buffer with the format-like syntax. *)
+let bprint_padding : type a b . buffer -> (a, b) padding -> unit =
+fun buf pad -> match pad with
+  | No_padding -> ()
+  | Lit_padding (padty, n) ->
+    bprint_padty buf padty;
+    buffer_add_string buf (string_of_int n);
+  | Arg_padding padty ->
+    bprint_padty buf padty;
+    buffer_add_char buf '*'
+
+(* Print precision in a buffer with the format-like syntax. *)
+let bprint_precision : type a b . buffer -> (a, b) precision -> unit =
+  fun buf prec -> match prec with
+  | No_precision -> ()
+  | Lit_precision n ->
+    buffer_add_char buf '.';
+    buffer_add_string buf (string_of_int n);
+  | Arg_precision ->
+    buffer_add_string buf ".*"
+
+(***)
+
+(* Print the optionnal '+', ' ' or '#' associated to an int conversion. *)
+let bprint_iconv_flag buf iconv = match iconv with
+  | Int_pd | Int_pi -> buffer_add_char buf '+'
+  | Int_sd | Int_si -> buffer_add_char buf ' '
+  | Int_Cx | Int_CX | Int_Co -> buffer_add_char buf '#'
+  | Int_d | Int_i | Int_x | Int_X | Int_o | Int_u -> ()
+
+(* Print an complete int format in a buffer (ex: "%3.*d"). *)
+let bprint_int_fmt buf ign_flag iconv pad prec =
+  buffer_add_char buf '%';
+  bprint_ignored_flag buf ign_flag;
+  bprint_iconv_flag buf iconv;
+  bprint_padding buf pad;
+  bprint_precision buf prec;
+  buffer_add_char buf (char_of_iconv iconv)
+
+(* Print a complete int32, nativeint or int64 format in a buffer. *)
+let bprint_altint_fmt buf ign_flag iconv pad prec c =
+  buffer_add_char buf '%';
+  bprint_ignored_flag buf ign_flag;
+  bprint_iconv_flag buf iconv;
+  bprint_padding buf pad;
+  bprint_precision buf prec;
+  buffer_add_char buf c;
+  buffer_add_char buf (char_of_iconv iconv)
+
+(***)
+
+(* Print the optionnal '+' associated to a float conversion. *)
+let bprint_fconv_flag buf fconv = match fconv with
+  | Float_pf | Float_pe | Float_pE
+  | Float_pg | Float_pG | Float_ph | Float_pH ->
+    buffer_add_char buf '+'
+  | Float_sf | Float_se | Float_sE
+  | Float_sg | Float_sG | Float_sh | Float_sH ->
+    buffer_add_char buf ' '
+  | Float_f | Float_e | Float_E
+  | Float_g | Float_G | Float_F | Float_h | Float_H ->
+    ()
+
+(* Print a complete float format in a buffer (ex: "%+*.3f"). *)
+let bprint_float_fmt buf ign_flag fconv pad prec =
+  buffer_add_char buf '%';
+  bprint_ignored_flag buf ign_flag;
+  bprint_fconv_flag buf fconv;
+  bprint_padding buf pad;
+  bprint_precision buf prec;
+  buffer_add_char buf (char_of_fconv fconv)
+
+(* Compute the literal string representation of a formatting_lit. *)
+(* Also used by Printf and Scanf where formatting is not interpreted. *)
+let string_of_formatting_lit formatting_lit = match formatting_lit with
+  | Close_box            -> "@]"
+  | Close_tag            -> "@}"
+  | Break (str, _, _)    -> str
+  | FFlush               -> "@?"
+  | Force_newline        -> "@\n"
+  | Flush_newline        -> "@."
+  | Magic_size (str, _)  -> str
+  | Escaped_at           -> "@@"
+  | Escaped_percent      -> "@%"
+  | Scan_indic c -> "@" ^ (String.make 1 c)
+
+(* Compute the literal string representation of a formatting. *)
+(* Also used by Printf and Scanf where formatting is not interpreted. *)
+let string_of_formatting_gen : type a b c d e f .
+    (a, b, c, d, e, f) formatting_gen -> string =
+  fun formatting_gen -> match formatting_gen with
+  | Open_tag (Format (_, str)) -> str
+  | Open_box (Format (_, str)) -> str
+
+(***)
+
+(* Print a literal char in a buffer, escape '%' by "%%". *)
+let bprint_char_literal buf chr = match chr with
+  | '%' -> buffer_add_string buf "%%"
+  | _ -> buffer_add_char buf chr
+
+(* Print a literal string in a buffer, escape all '%' by "%%". *)
+let bprint_string_literal buf str =
+  for i = 0 to String.length str - 1 do
+    bprint_char_literal buf str.[i]
+  done
+
+(******************************************************************************)
+                          (* Format pretty-printing *)
+
+(* Print a complete format type (an fmtty) in a buffer. *)
+let rec bprint_fmtty : type a b c d e f g h i j k l .
+    buffer -> (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> unit =
+fun buf fmtty -> match fmtty with
+  | Char_ty rest      -> buffer_add_string buf "%c";  bprint_fmtty buf rest;
+  | String_ty rest    -> buffer_add_string buf "%s";  bprint_fmtty buf rest;
+  | Int_ty rest       -> buffer_add_string buf "%i";  bprint_fmtty buf rest;
+  | Int32_ty rest     -> buffer_add_string buf "%li"; bprint_fmtty buf rest;
+  | Nativeint_ty rest -> buffer_add_string buf "%ni"; bprint_fmtty buf rest;
+  | Int64_ty rest     -> buffer_add_string buf "%Li"; bprint_fmtty buf rest;
+  | Float_ty rest     -> buffer_add_string buf "%f";  bprint_fmtty buf rest;
+  | Bool_ty rest      -> buffer_add_string buf "%B";  bprint_fmtty buf rest;
+  | Alpha_ty rest     -> buffer_add_string buf "%a";  bprint_fmtty buf rest;
+  | Theta_ty rest     -> buffer_add_string buf "%t";  bprint_fmtty buf rest;
+  | Any_ty rest       -> buffer_add_string buf "%?";  bprint_fmtty buf rest;
+  | Reader_ty rest    -> buffer_add_string buf "%r";  bprint_fmtty buf rest;
+
+  | Ignored_reader_ty rest ->
+    buffer_add_string buf "%_r";
+    bprint_fmtty buf rest;
+
+  | Format_arg_ty (sub_fmtty, rest) ->
+    buffer_add_string buf "%{"; bprint_fmtty buf sub_fmtty;
+    buffer_add_string buf "%}"; bprint_fmtty buf rest;
+  | Format_subst_ty (sub_fmtty, _, rest) ->
+    buffer_add_string buf "%("; bprint_fmtty buf sub_fmtty;
+    buffer_add_string buf "%)"; bprint_fmtty buf rest;
+
+  | End_of_fmtty -> ()
+
+(***)
+
+let rec int_of_custom_arity : type a b c .
+  (a, b, c) custom_arity -> int =
+  function
+  | Custom_zero -> 0
+  | Custom_succ x -> 1 + int_of_custom_arity x
+
+(* Print a complete format in a buffer. *)
+let bprint_fmt buf fmt =
+  let rec fmtiter : type a b c d e f .
+      (a, b, c, d, e, f) fmt -> bool -> unit =
+  fun fmt ign_flag -> match fmt with
+    | String (pad, rest) ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_padding buf pad; buffer_add_char buf 's';
+      fmtiter rest false;
+    | Caml_string (pad, rest) ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_padding buf pad; buffer_add_char buf 'S';
+      fmtiter rest false;
+
+    | Int (iconv, pad, prec, rest) ->
+      bprint_int_fmt buf ign_flag iconv pad prec;
+      fmtiter rest false;
+    | Int32 (iconv, pad, prec, rest) ->
+      bprint_altint_fmt buf ign_flag iconv pad prec 'l';
+      fmtiter rest false;
+    | Nativeint (iconv, pad, prec, rest) ->
+      bprint_altint_fmt buf ign_flag iconv pad prec 'n';
+      fmtiter rest false;
+    | Int64 (iconv, pad, prec, rest) ->
+      bprint_altint_fmt buf ign_flag iconv pad prec 'L';
+      fmtiter rest false;
+    | Float (fconv, pad, prec, rest) ->
+      bprint_float_fmt buf ign_flag fconv pad prec;
+      fmtiter rest false;
+
+    | Char rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf 'c'; fmtiter rest false;
+    | Caml_char rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf 'C'; fmtiter rest false;
+    | Bool rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf 'B'; fmtiter rest false;
+    | Alpha rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf 'a'; fmtiter rest false;
+    | Theta rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf 't'; fmtiter rest false;
+    | Custom (arity, _, rest) ->
+      for _i = 1 to int_of_custom_arity arity do
+        buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+        buffer_add_char buf '?';
+      done;
+      fmtiter rest false;
+    | Reader rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf 'r'; fmtiter rest false;
+    | Flush rest ->
+      buffer_add_string buf "%!";
+      fmtiter rest ign_flag;
+
+    | String_literal (str, rest) ->
+      bprint_string_literal buf str;
+      fmtiter rest ign_flag;
+    | Char_literal (chr, rest) ->
+      bprint_char_literal buf chr;
+      fmtiter rest ign_flag;
+
+    | Format_arg (pad_opt, fmtty, rest) ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_pad_opt buf pad_opt; buffer_add_char buf '{';
+      bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf '}';
+      fmtiter rest false;
+    | Format_subst (pad_opt, fmtty, rest) ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_pad_opt buf pad_opt; buffer_add_char buf '(';
+      bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf ')';
+      fmtiter rest false;
+
+    | Scan_char_set (width_opt, char_set, rest) ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_pad_opt buf width_opt; bprint_char_set buf char_set;
+      fmtiter rest false;
+    | Scan_get_counter (counter, rest) ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      buffer_add_char buf (char_of_counter counter);
+      fmtiter rest false;
+    | Scan_next_char rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_string_literal buf "0c"; fmtiter rest false;
+
+    | Ignored_param (ign, rest) ->
+      let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in
+      fmtiter fmt' true;
+
+    | Formatting_lit (fmting_lit, rest) ->
+      bprint_string_literal buf (string_of_formatting_lit fmting_lit);
+      fmtiter rest ign_flag;
+    | Formatting_gen (fmting_gen, rest) ->
+      bprint_string_literal buf "@{";
+      bprint_string_literal buf (string_of_formatting_gen fmting_gen);
+      fmtiter rest ign_flag;
+
+    | End_of_format -> ()
+
+  in fmtiter fmt false
+
+(***)
+
+(* Convert a format to string. *)
+let string_of_fmt fmt =
+  let buf = buffer_create 16 in
+  bprint_fmt buf fmt;
+  buffer_contents buf
+
+(******************************************************************************)
+                          (* Type extraction *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+(* Invariant: this function is the identity on values.
+
+   In particular, if (ty1, ty2) have equal values, then
+   (trans (symm ty1) ty2) respects the 'trans' precondition. *)
+let rec symm : type a1 b1 c1 d1 e1 f1 a2 b2 c2 d2 e2 f2 .
+   (a1, b1, c1, d1, e1, f1,
+    a2, b2, c2, d2, e2, f2) fmtty_rel
+-> (a2, b2, c2, d2, e2, f2,
+    a1, b1, c1, d1, e1, f1) fmtty_rel
+= function
+  | Char_ty rest -> Char_ty (symm rest)
+  | Int_ty rest -> Int_ty (symm rest)
+  | Int32_ty rest -> Int32_ty (symm rest)
+  | Int64_ty rest -> Int64_ty (symm rest)
+  | Nativeint_ty rest -> Nativeint_ty (symm rest)
+  | Float_ty rest -> Float_ty (symm rest)
+  | Bool_ty rest -> Bool_ty (symm rest)
+  | String_ty rest -> String_ty (symm rest)
+  | Theta_ty rest -> Theta_ty (symm rest)
+  | Alpha_ty rest -> Alpha_ty (symm rest)
+  | Any_ty rest -> Any_ty (symm rest)
+  | Reader_ty rest -> Reader_ty (symm rest)
+  | Ignored_reader_ty rest -> Ignored_reader_ty (symm rest)
+  | Format_arg_ty (ty, rest) ->
+    Format_arg_ty (ty, symm rest)
+  | Format_subst_ty (ty1, ty2, rest) ->
+    Format_subst_ty (ty2, ty1, symm rest)
+  | End_of_fmtty -> End_of_fmtty
+
+let rec fmtty_rel_det : type a1 b c d1 e1 f1 a2 d2 e2 f2 .
+  (a1, b, c, d1, e1, f1,
+   a2, b, c, d2, e2, f2) fmtty_rel ->
+    ((f1, f2) eq -> (a1, a2) eq)
+  * ((a1, a2) eq -> (f1, f2) eq)
+  * ((e1, e2) eq -> (d1, d2) eq)
+  * ((d1, d2) eq -> (e1, e2) eq)
+= function
+  | End_of_fmtty ->
+    (fun Refl -> Refl),
+    (fun Refl -> Refl),
+    (fun Refl -> Refl),
+    (fun Refl -> Refl)
+  | Char_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | String_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Int_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Int32_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Int64_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Nativeint_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Float_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Bool_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+
+  | Theta_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Alpha_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Any_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Reader_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    (fun Refl -> let Refl = ed Refl in Refl),
+    (fun Refl -> let Refl = de Refl in Refl)
+  | Ignored_reader_ty rest ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    (fun Refl -> let Refl = ed Refl in Refl),
+    (fun Refl -> let Refl = de Refl in Refl)
+  | Format_arg_ty (_ty, rest) ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    (fun Refl -> let Refl = fa Refl in Refl),
+    (fun Refl -> let Refl = af Refl in Refl),
+    ed, de
+  | Format_subst_ty (ty1, ty2, rest) ->
+    let fa, af, ed, de = fmtty_rel_det rest in
+    let ty = trans (symm ty1) ty2 in
+    let ag, ga, dj, jd = fmtty_rel_det ty in
+    (fun Refl -> let Refl = fa Refl in let Refl = ag Refl in Refl),
+    (fun Refl -> let Refl = ga Refl in let Refl = af Refl in Refl),
+    (fun Refl -> let Refl = ed Refl in let Refl = dj Refl in Refl),
+    (fun Refl -> let Refl = jd Refl in let Refl = de Refl in Refl)
+
+(* Precondition: we assume that the two fmtty_rel arguments have equal
+   values (at possibly distinct types); this invariant comes from the way
+   fmtty_rel witnesses are produced by the type-checker
+
+   The code below uses (assert false) when this assumption is broken. The
+   code pattern is the following:
+
+     | Foo x, Foo y ->
+       (* case where indeed both values
+          start with constructor Foo *)
+     | Foo _, _
+     | _, Foo _ ->
+       (* different head constructors: broken precondition *)
+       assert false
+*)
+and trans : type
+  a1 b1 c1 d1 e1 f1
+  a2 b2 c2 d2 e2 f2
+  a3 b3 c3 d3 e3 f3
+.
+   (a1, b1, c1, d1, e1, f1,
+    a2, b2, c2, d2, e2, f2) fmtty_rel
+-> (a2, b2, c2, d2, e2, f2,
+    a3, b3, c3, d3, e3, f3) fmtty_rel
+-> (a1, b1, c1, d1, e1, f1,
+    a3, b3, c3, d3, e3, f3) fmtty_rel
+= fun ty1 ty2 -> match ty1, ty2 with
+  | Char_ty rest1, Char_ty rest2 -> Char_ty (trans rest1 rest2)
+  | String_ty rest1, String_ty rest2 -> String_ty (trans rest1 rest2)
+  | Bool_ty rest1, Bool_ty rest2 -> Bool_ty (trans rest1 rest2)
+  | Int_ty rest1, Int_ty rest2 -> Int_ty (trans rest1 rest2)
+  | Int32_ty rest1, Int32_ty rest2 -> Int32_ty (trans rest1 rest2)
+  | Int64_ty rest1, Int64_ty rest2 -> Int64_ty (trans rest1 rest2)
+  | Nativeint_ty rest1, Nativeint_ty rest2 -> Nativeint_ty (trans rest1 rest2)
+  | Float_ty rest1, Float_ty rest2 -> Float_ty (trans rest1 rest2)
+
+  | Alpha_ty rest1, Alpha_ty rest2 -> Alpha_ty (trans rest1 rest2)
+  | Alpha_ty _, _ -> assert false
+  | _, Alpha_ty _ -> assert false
+
+  | Theta_ty rest1, Theta_ty rest2 -> Theta_ty (trans rest1 rest2)
+  | Theta_ty _, _ -> assert false
+  | _, Theta_ty _ -> assert false
+
+  | Any_ty rest1, Any_ty rest2 -> Any_ty (trans rest1 rest2)
+  | Any_ty _, _ -> assert false
+  | _, Any_ty _ -> assert false
+
+  | Reader_ty rest1, Reader_ty rest2 -> Reader_ty (trans rest1 rest2)
+  | Reader_ty _, _ -> assert false
+  | _, Reader_ty _ -> assert false
+
+  | Ignored_reader_ty rest1, Ignored_reader_ty rest2 ->
+    Ignored_reader_ty (trans rest1 rest2)
+  | Ignored_reader_ty _, _ -> assert false
+  | _, Ignored_reader_ty _ -> assert false
+
+  | Format_arg_ty (ty1, rest1), Format_arg_ty (ty2, rest2) ->
+    Format_arg_ty (trans ty1 ty2, trans rest1 rest2)
+  | Format_arg_ty _, _ -> assert false
+  | _, Format_arg_ty _ -> assert false
+
+  | Format_subst_ty (ty11, ty12, rest1),
+    Format_subst_ty (ty21, ty22, rest2) ->
+    let ty = trans (symm ty12) ty21 in
+    let _, f2, _, f4 = fmtty_rel_det ty in
+    let Refl = f2 Refl in
+    let Refl = f4 Refl in
+    Format_subst_ty (ty11, ty22, trans rest1 rest2)
+  | Format_subst_ty _, _ -> assert false
+  | _, Format_subst_ty _ -> assert false
+
+  | End_of_fmtty, End_of_fmtty -> End_of_fmtty
+  | End_of_fmtty, _ -> assert false
+  | _, End_of_fmtty -> assert false
+
+let rec fmtty_of_formatting_gen : type a b c d e f .
+  (a, b, c, d, e, f) formatting_gen ->
+    (a, b, c, d, e, f) fmtty =
+fun formatting_gen -> match formatting_gen with
+  | Open_tag (Format (fmt, _)) -> fmtty_of_fmt fmt
+  | Open_box (Format (fmt, _)) -> fmtty_of_fmt fmt
+
+(* Extract the type representation (an fmtty) of a format. *)
+and fmtty_of_fmt : type a b c d e f .
+  (a, b, c, d, e, f) fmt -> (a, b, c, d, e, f) fmtty =
+fun fmtty -> match fmtty with
+  | String (pad, rest) ->
+    fmtty_of_padding_fmtty pad (String_ty (fmtty_of_fmt rest))
+  | Caml_string (pad, rest) ->
+    fmtty_of_padding_fmtty pad (String_ty (fmtty_of_fmt rest))
+
+  | Int (_, pad, prec, rest) ->
+    let ty_rest = fmtty_of_fmt rest in
+    let prec_ty = fmtty_of_precision_fmtty prec (Int_ty ty_rest) in
+    fmtty_of_padding_fmtty pad prec_ty
+  | Int32 (_, pad, prec, rest) ->
+    let ty_rest = fmtty_of_fmt rest in
+    let prec_ty = fmtty_of_precision_fmtty prec (Int32_ty ty_rest) in
+    fmtty_of_padding_fmtty pad prec_ty
+  | Nativeint (_, pad, prec, rest) ->
+    let ty_rest = fmtty_of_fmt rest in
+    let prec_ty = fmtty_of_precision_fmtty prec (Nativeint_ty ty_rest) in
+    fmtty_of_padding_fmtty pad prec_ty
+  | Int64 (_, pad, prec, rest) ->
+    let ty_rest = fmtty_of_fmt rest in
+    let prec_ty = fmtty_of_precision_fmtty prec (Int64_ty ty_rest) in
+    fmtty_of_padding_fmtty pad prec_ty
+  | Float (_, pad, prec, rest) ->
+    let ty_rest = fmtty_of_fmt rest in
+    let prec_ty = fmtty_of_precision_fmtty prec (Float_ty ty_rest) in
+    fmtty_of_padding_fmtty pad prec_ty
+
+  | Char rest                  -> Char_ty (fmtty_of_fmt rest)
+  | Caml_char rest             -> Char_ty (fmtty_of_fmt rest)
+  | Bool rest                  -> Bool_ty (fmtty_of_fmt rest)
+  | Alpha rest                 -> Alpha_ty (fmtty_of_fmt rest)
+  | Theta rest                 -> Theta_ty (fmtty_of_fmt rest)
+  | Custom (arity, _, rest)    -> fmtty_of_custom arity (fmtty_of_fmt rest)
+  | Reader rest                -> Reader_ty (fmtty_of_fmt rest)
+
+  | Format_arg (_, ty, rest) ->
+    Format_arg_ty (ty, fmtty_of_fmt rest)
+  | Format_subst (_, ty, rest) ->
+    Format_subst_ty (ty, ty, fmtty_of_fmt rest)
+
+  | Flush rest                 -> fmtty_of_fmt rest
+  | String_literal (_, rest)   -> fmtty_of_fmt rest
+  | Char_literal (_, rest)     -> fmtty_of_fmt rest
+
+  | Scan_char_set (_, _, rest) -> String_ty (fmtty_of_fmt rest)
+  | Scan_get_counter (_, rest) -> Int_ty (fmtty_of_fmt rest)
+  | Scan_next_char rest        -> Char_ty (fmtty_of_fmt rest)
+  | Ignored_param (ign, rest)  -> fmtty_of_ignored_format ign rest
+  | Formatting_lit (_, rest)   -> fmtty_of_fmt rest
+  | Formatting_gen (fmting_gen, rest)  ->
+    concat_fmtty (fmtty_of_formatting_gen fmting_gen) (fmtty_of_fmt rest)
+
+  | End_of_format              -> End_of_fmtty
+
+and fmtty_of_custom : type x y a b c d e f .
+  (a, x, y) custom_arity -> (a, b, c, d, e, f) fmtty ->
+  (y, b, c, d, e, f) fmtty =
+fun arity fmtty -> match arity with
+  | Custom_zero -> fmtty
+  | Custom_succ arity -> Any_ty (fmtty_of_custom arity fmtty)
+
+(* Extract the fmtty of an ignored parameter followed by the rest of
+   the format. *)
+and fmtty_of_ignored_format : type x y a b c d e f .
+    (a, b, c, d, y, x) ignored ->
+    (x, b, c, y, e, f) fmt ->
+    (a, b, c, d, e, f) fmtty =
+fun ign fmt -> match ign with
+  | Ignored_char                    -> fmtty_of_fmt fmt
+  | Ignored_caml_char               -> fmtty_of_fmt fmt
+  | Ignored_string _                -> fmtty_of_fmt fmt
+  | Ignored_caml_string _           -> fmtty_of_fmt fmt
+  | Ignored_int (_, _)              -> fmtty_of_fmt fmt
+  | Ignored_int32 (_, _)            -> fmtty_of_fmt fmt
+  | Ignored_nativeint (_, _)        -> fmtty_of_fmt fmt
+  | Ignored_int64 (_, _)            -> fmtty_of_fmt fmt
+  | Ignored_float (_, _)            -> fmtty_of_fmt fmt
+  | Ignored_bool                    -> fmtty_of_fmt fmt
+  | Ignored_format_arg _            -> fmtty_of_fmt fmt
+  | Ignored_format_subst (_, fmtty) -> concat_fmtty fmtty (fmtty_of_fmt fmt)
+  | Ignored_reader                  -> Ignored_reader_ty (fmtty_of_fmt fmt)
+  | Ignored_scan_char_set _         -> fmtty_of_fmt fmt
+  | Ignored_scan_get_counter _      -> fmtty_of_fmt fmt
+  | Ignored_scan_next_char          -> fmtty_of_fmt fmt
+
+(* Add an Int_ty node if padding is taken as an extra argument (ex: "%*s"). *)
+and fmtty_of_padding_fmtty : type x a b c d e f .
+    (x, a) padding -> (a, b, c, d, e, f) fmtty -> (x, b, c, d, e, f) fmtty =
+  fun pad fmtty -> match pad with
+    | No_padding    -> fmtty
+    | Lit_padding _ -> fmtty
+    | Arg_padding _ -> Int_ty fmtty
+
+(* Add an Int_ty node if precision is taken as an extra argument (ex: "%.*f").*)
+and fmtty_of_precision_fmtty : type x a b c d e f .
+    (x, a) precision -> (a, b, c, d, e, f) fmtty -> (x, b, c, d, e, f) fmtty =
+  fun prec fmtty -> match prec with
+    | No_precision    -> fmtty
+    | Lit_precision _ -> fmtty
+    | Arg_precision   -> Int_ty fmtty
+
+(******************************************************************************)
+                            (* Format typing *)
+
+(* Exception raised when a format does not match a given format type. *)
+exception Type_mismatch
+
+(* Type a padding. *)
+(* Take an Int_ty from the fmtty if the integer should be kept as argument. *)
+(* Raise Type_mismatch in case of type mismatch. *)
+let type_padding : type a b c d e f x y .
+    (x, y) padding -> (a, b, c, d, e, f) fmtty ->
+      (a, b, c, d, e, f) padding_fmtty_ebb =
+fun pad fmtty -> match pad, fmtty with
+  | No_padding, _ -> Padding_fmtty_EBB (No_padding, fmtty)
+  | Lit_padding (padty, w), _ -> Padding_fmtty_EBB (Lit_padding (padty,w),fmtty)
+  | Arg_padding padty, Int_ty rest -> Padding_fmtty_EBB (Arg_padding padty,rest)
+  | _ -> raise Type_mismatch
+
+(* Convert a (upadding, uprecision) to a (padding, precision). *)
+(* Take one or two Int_ty from the fmtty if needed. *)
+(* Raise Type_mismatch in case of type mismatch. *)
+let type_padprec : type a b c d e f x y z .
+  (x, y) padding -> (y, z) precision -> (a, b, c, d, e, f) fmtty ->
+    (a, b, c, d, e, f) padprec_fmtty_ebb =
+fun pad prec fmtty -> match prec, type_padding pad fmtty with
+  | No_precision, Padding_fmtty_EBB (pad, rest) ->
+    Padprec_fmtty_EBB (pad, No_precision, rest)
+  | Lit_precision p, Padding_fmtty_EBB (pad, rest) ->
+    Padprec_fmtty_EBB (pad, Lit_precision p, rest)
+  | Arg_precision, Padding_fmtty_EBB (pad, Int_ty rest) ->
+    Padprec_fmtty_EBB (pad, Arg_precision, rest)
+  | _, Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+
+(* Type a format according to an fmtty. *)
+(* If typing succeed, generate a copy of the format with the same
+    type parameters as the fmtty. *)
+(* Raise a Failure with an error message in case of type mismatch. *)
+let rec type_format :
+  type a1 b1 c1 d1 e1 f1
+       a2 b2 c2 d2 e2 f2  .
+     (a1, b1, c1, d1, e1, f1) fmt
+  -> (a2, b2, c2, d2, e2, f2) fmtty
+  -> (a2, b2, c2, d2, e2, f2) fmt
+= fun fmt fmtty -> match type_format_gen fmt fmtty with
+  | Fmt_fmtty_EBB (fmt', End_of_fmtty) -> fmt'
+  | _ -> raise Type_mismatch
+
+and type_format_gen :
+  type a1 b1 c1 d1 e1 f1
+       a2 b2 c2 d2 e2 f2  .
+     (a1, b1, c1, d1, e1, f1) fmt
+  -> (a2, b2, c2, d2, e2, f2) fmtty
+  -> (a2, b2, c2, d2, e2, f2) fmt_fmtty_ebb
+= fun fmt fmtty -> match fmt, fmtty with
+  | Char fmt_rest, Char_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Char fmt', fmtty')
+  | Caml_char fmt_rest, Char_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Caml_char fmt', fmtty')
+  | String (pad, fmt_rest), _ -> (
+    match type_padding pad fmtty with
+    | Padding_fmtty_EBB (pad, String_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (String (pad, fmt'), fmtty')
+    | Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+  )
+  | Caml_string (pad, fmt_rest), _ -> (
+    match type_padding pad fmtty with
+    | Padding_fmtty_EBB (pad, String_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Caml_string (pad, fmt'), fmtty')
+    | Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+  )
+  | Int (iconv, pad, prec, fmt_rest), _ -> (
+    match type_padprec pad prec fmtty with
+    | Padprec_fmtty_EBB (pad, prec, Int_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Int (iconv, pad, prec, fmt'), fmtty')
+    | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+  )
+  | Int32 (iconv, pad, prec, fmt_rest), _ -> (
+    match type_padprec pad prec fmtty with
+    | Padprec_fmtty_EBB (pad, prec, Int32_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Int32 (iconv, pad, prec, fmt'), fmtty')
+    | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+  )
+  | Nativeint (iconv, pad, prec, fmt_rest), _ -> (
+    match type_padprec pad prec fmtty with
+    | Padprec_fmtty_EBB (pad, prec, Nativeint_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Nativeint (iconv, pad, prec, fmt'), fmtty')
+    | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+  )
+  | Int64 (iconv, pad, prec, fmt_rest), _ -> (
+    match type_padprec pad prec fmtty with
+    | Padprec_fmtty_EBB (pad, prec, Int64_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Int64 (iconv, pad, prec, fmt'), fmtty')
+    | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+  )
+  | Float (fconv, pad, prec, fmt_rest), _ -> (
+    match type_padprec pad prec fmtty with
+    | Padprec_fmtty_EBB (pad, prec, Float_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Float (fconv, pad, prec, fmt'), fmtty')
+    | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+  )
+  | Bool fmt_rest, Bool_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Bool fmt', fmtty')
+  | Flush fmt_rest, fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Flush fmt', fmtty')
+
+  | String_literal (str, fmt_rest), fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (String_literal (str, fmt'), fmtty')
+  | Char_literal (chr, fmt_rest), fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Char_literal (chr, fmt'), fmtty')
+
+  | Format_arg (pad_opt, sub_fmtty, fmt_rest),
+    Format_arg_ty (sub_fmtty', fmtty_rest) ->
+    if Fmtty_EBB sub_fmtty <> Fmtty_EBB sub_fmtty' then raise Type_mismatch;
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Format_arg (pad_opt, sub_fmtty', fmt'), fmtty')
+  | Format_subst (pad_opt, sub_fmtty, fmt_rest),
+    Format_subst_ty (sub_fmtty1, _sub_fmtty2, fmtty_rest) ->
+    if Fmtty_EBB (erase_rel sub_fmtty) <> Fmtty_EBB (erase_rel sub_fmtty1) then
+      raise Type_mismatch;
+    let Fmt_fmtty_EBB (fmt', fmtty') =
+      type_format_gen fmt_rest (erase_rel fmtty_rest)
+    in
+    Fmt_fmtty_EBB (Format_subst (pad_opt, sub_fmtty1, fmt'), fmtty')
+  (* Printf and Format specific constructors: *)
+  | Alpha fmt_rest, Alpha_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Alpha fmt', fmtty')
+  | Theta fmt_rest, Theta_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Theta fmt', fmtty')
+
+  (* Format specific constructors: *)
+  | Formatting_lit (formatting_lit, fmt_rest), fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Formatting_lit (formatting_lit, fmt'), fmtty')
+  | Formatting_gen (formatting_gen, fmt_rest), fmtty_rest ->
+    type_formatting_gen formatting_gen fmt_rest fmtty_rest
+
+  (* Scanf specific constructors: *)
+  | Reader fmt_rest, Reader_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Reader fmt', fmtty')
+  | Scan_char_set (width_opt, char_set, fmt_rest), String_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Scan_char_set (width_opt, char_set, fmt'), fmtty')
+  | Scan_get_counter (counter, fmt_rest), Int_ty fmtty_rest ->
+    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+    Fmt_fmtty_EBB (Scan_get_counter (counter, fmt'), fmtty')
+  | Ignored_param (ign, rest), fmtty_rest ->
+    type_ignored_param ign rest fmtty_rest
+
+  | End_of_format, fmtty_rest -> Fmt_fmtty_EBB (End_of_format, fmtty_rest)
+
+  | _ -> raise Type_mismatch
+
+and type_formatting_gen : type a1 a3 b1 b3 c1 c3 d1 d3 e1 e2 e3 f1 f2 f3 .
+    (a1, b1, c1, d1, e1, f1) formatting_gen ->
+    (f1, b1, c1, e1, e2, f2) fmt ->
+    (a3, b3, c3, d3, e3, f3) fmtty ->
+    (a3, b3, c3, d3, e3, f3) fmt_fmtty_ebb =
+fun formatting_gen fmt0 fmtty0 -> match formatting_gen with
+  | Open_tag (Format (fmt1, str)) ->
+    let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in
+    let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in
+    Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3)
+  | Open_box (Format (fmt1, str)) ->
+    let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in
+    let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in
+    Fmt_fmtty_EBB (Formatting_gen (Open_box (Format (fmt2, str)), fmt3), fmtty3)
+
+(* Type an Ignored_param node according to an fmtty. *)
+and type_ignored_param : type p q x y z t u v a b c d e f .
+    (x, y, z, t, q, p) ignored ->
+    (p, y, z, q, u, v) fmt ->
+    (a, b, c, d, e, f) fmtty ->
+    (a, b, c, d, e, f) fmt_fmtty_ebb =
+fun ign fmt fmtty -> match ign with
+  | Ignored_char               as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_caml_char          as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_string _           as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_caml_string _      as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_int _              as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_int32 _            as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_nativeint _        as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_int64 _            as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_float _            as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_bool               as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_scan_char_set _    as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_scan_get_counter _ as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_scan_next_char     as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_format_arg (pad_opt, sub_fmtty) ->
+    type_ignored_param_one (Ignored_format_arg (pad_opt, sub_fmtty)) fmt fmtty
+  | Ignored_format_subst (pad_opt, sub_fmtty) ->
+    let Fmtty_fmt_EBB (sub_fmtty', Fmt_fmtty_EBB (fmt', fmtty')) =
+      type_ignored_format_substitution sub_fmtty fmt fmtty in
+    Fmt_fmtty_EBB (Ignored_param (Ignored_format_subst (pad_opt, sub_fmtty'),
+                                  fmt'),
+                   fmtty')
+  | Ignored_reader -> (
+    match fmtty with
+    | Ignored_reader_ty fmtty_rest ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt fmtty_rest in
+      Fmt_fmtty_EBB (Ignored_param (Ignored_reader, fmt'), fmtty')
+    | _ -> raise Type_mismatch
+  )
+
+and type_ignored_param_one : type a1 a2 b1 b2 c1 c2 d1 d2 e1 e2 f1 f2 .
+    (a2, b2, c2, d2, d2, a2) ignored ->
+    (a1, b1, c1, d1, e1, f1) fmt ->
+    (a2, b2, c2, d2, e2, f2) fmtty ->
+    (a2, b2, c2, d2, e2, f2) fmt_fmtty_ebb
+= fun ign fmt fmtty ->
+  let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt fmtty in
+  Fmt_fmtty_EBB (Ignored_param (ign, fmt'), fmtty')
+
+(* Typing of the complex case: "%_(...%)". *)
+and type_ignored_format_substitution : type w x y z p s t u a b c d e f .
+    (w, x, y, z, s, p) fmtty ->
+    (p, x, y, s, t, u) fmt ->
+    (a, b, c, d, e, f) fmtty -> (a, b, c, d, e, f) fmtty_fmt_ebb =
+fun sub_fmtty fmt fmtty -> match sub_fmtty, fmtty with
+  | Char_ty sub_fmtty_rest, Char_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Char_ty sub_fmtty_rest', fmt')
+  | String_ty sub_fmtty_rest, String_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (String_ty sub_fmtty_rest', fmt')
+  | Int_ty sub_fmtty_rest, Int_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Int_ty sub_fmtty_rest', fmt')
+  | Int32_ty sub_fmtty_rest, Int32_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Int32_ty sub_fmtty_rest', fmt')
+  | Nativeint_ty sub_fmtty_rest, Nativeint_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Nativeint_ty sub_fmtty_rest', fmt')
+  | Int64_ty sub_fmtty_rest, Int64_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Int64_ty sub_fmtty_rest', fmt')
+  | Float_ty sub_fmtty_rest, Float_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Float_ty sub_fmtty_rest', fmt')
+  | Bool_ty sub_fmtty_rest, Bool_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Bool_ty sub_fmtty_rest', fmt')
+  | Alpha_ty sub_fmtty_rest, Alpha_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Alpha_ty sub_fmtty_rest', fmt')
+  | Theta_ty sub_fmtty_rest, Theta_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Theta_ty sub_fmtty_rest', fmt')
+  | Reader_ty sub_fmtty_rest, Reader_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Reader_ty sub_fmtty_rest', fmt')
+  | Ignored_reader_ty sub_fmtty_rest, Ignored_reader_ty fmtty_rest ->
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Ignored_reader_ty sub_fmtty_rest', fmt')
+
+  | Format_arg_ty (sub2_fmtty, sub_fmtty_rest),
+    Format_arg_ty (sub2_fmtty', fmtty_rest) ->
+    if Fmtty_EBB sub2_fmtty <> Fmtty_EBB sub2_fmtty' then raise Type_mismatch;
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+    Fmtty_fmt_EBB (Format_arg_ty (sub2_fmtty', sub_fmtty_rest'), fmt')
+  | Format_subst_ty (sub1_fmtty,  sub2_fmtty,  sub_fmtty_rest),
+    Format_subst_ty (sub1_fmtty', sub2_fmtty', fmtty_rest) ->
+    (* TODO define Fmtty_rel_EBB to remove those erase_rel *)
+    if Fmtty_EBB (erase_rel sub1_fmtty) <> Fmtty_EBB (erase_rel sub1_fmtty')
+    then raise Type_mismatch;
+    if Fmtty_EBB (erase_rel sub2_fmtty) <> Fmtty_EBB (erase_rel sub2_fmtty')
+    then raise Type_mismatch;
+    let sub_fmtty' = trans (symm sub1_fmtty') sub2_fmtty' in
+    let _, f2, _, f4 = fmtty_rel_det sub_fmtty' in
+    let Refl = f2 Refl in
+    let Refl = f4 Refl in
+    let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+      type_ignored_format_substitution (erase_rel sub_fmtty_rest) fmt fmtty_rest
+    in
+    Fmtty_fmt_EBB (Format_subst_ty (sub1_fmtty', sub2_fmtty',
+                                    symm sub_fmtty_rest'),
+                   fmt')
+  | End_of_fmtty, fmtty ->
+    Fmtty_fmt_EBB (End_of_fmtty, type_format_gen fmt fmtty)
+  | _ -> raise Type_mismatch
+
+(* This implementation of `recast` is a bit disappointing. The
+   invariant provided by the type are very strong: the input format's
+   type is in relation to the output type's as witnessed by the
+   fmtty_rel argument. One would at first expect this function to be
+   total, and implementable by exhaustive pattern matching. Instead,
+   we reuse the highly partial and much less well-defined function
+   `type_format` that has lost all knowledge of the correspondence
+   between the argument's types.
+
+   Besides the fact that this function reuses a lot of the
+   `type_format` logic (eg.: seeing Int_ty in the fmtty parameter does
+   not let you match on Int only, as you may in fact have Float
+   (Arg_padding, ...) ("%.*d") beginning with an Int_ty), it is also
+   a partial function, because the typing information in a format is
+   not quite enough to reconstruct it unambiguously. For example, the
+   format types of "%d%_r" and "%_r%d" have the same format6
+   parameters, but they are not at all exchangeable, and putting one
+   in place of the other must result in a dynamic failure.
+
+   Given that:
+   - we'd have to duplicate a lot of non-trivial typing logic from type_format
+   - this wouldn't even eliminate (all) the dynamic failures
+   we decided to just reuse type_format directly for now.
+*)
+let recast :
+  type a1 b1 c1 d1 e1 f1
+       a2 b2 c2 d2 e2 f2
+  .
+     (a1, b1, c1, d1, e1, f1) fmt
+  -> (a1, b1, c1, d1, e1, f1,
+      a2, b2, c2, d2, e2, f2) fmtty_rel
+  -> (a2, b2, c2, d2, e2, f2) fmt
+= fun fmt fmtty ->
+  type_format fmt (erase_rel (symm fmtty))
+
+(******************************************************************************)
+                             (* Printing tools *)
+
+(* Add padding spaces arround a string. *)
+let fix_padding padty width str =
+  let len = String.length str in
+  let width, padty =
+    abs width,
+    (* while literal padding widths are always non-negative,
+       dynamically-set widths (Arg_padding, eg. %*d) may be negative;
+       we interpret those as specifying a padding-to-the-left; this
+       means that '0' may get dropped even if it was explicitly set,
+       but:
+       - this is what the legacy implementation does, and
+         we preserve compatibility if possible
+       - we could only signal this issue by failing at runtime,
+         which is not very nice... *)
+    if width < 0 then Left else padty in
+  if width <= len then str else
+    let res = Bytes.make width (if padty = Zeros then '0' else ' ') in
+    begin match padty with
+    | Left  -> String.blit str 0 res 0 len
+    | Right -> String.blit str 0 res (width - len) len
+    | Zeros when len > 0 && (str.[0] = '+' || str.[0] = '-' || str.[0] = ' ') ->
+      Bytes.set res 0 str.[0];
+      String.blit str 1 res (width - len + 1) (len - 1)
+    | Zeros when len > 1 && str.[0] = '0' && (str.[1] = 'x' || str.[1] = 'X') ->
+      Bytes.set res 1 str.[1];
+      String.blit str 2 res (width - len + 2) (len - 2)
+    | Zeros ->
+      String.blit str 0 res (width - len) len
+    end;
+    Bytes.unsafe_to_string res
+
+(* Add '0' padding to int, int32, nativeint or int64 string representation. *)
+let fix_int_precision prec str =
+  let prec = abs prec in
+  let len = String.length str in
+  match str.[0] with
+  | ('+' | '-' | ' ') as c when prec + 1 > len ->
+    let res = Bytes.make (prec + 1) '0' in
+    Bytes.set res 0 c;
+    String.blit str 1 res (prec - len + 2) (len - 1);
+    Bytes.unsafe_to_string res
+  | '0' when prec + 2 > len && len > 1 && (str.[1] = 'x' || str.[1] = 'X') ->
+    let res = Bytes.make (prec + 2) '0' in
+    Bytes.set res 1 str.[1];
+    String.blit str 2 res (prec - len + 4) (len - 2);
+    Bytes.unsafe_to_string res
+  | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' when prec > len ->
+    let res = Bytes.make prec '0' in
+    String.blit str 0 res (prec - len) len;
+    Bytes.unsafe_to_string res
+  | _ ->
+    str
+
+(* Escape a string according to the OCaml lexing convention. *)
+let string_to_caml_string str =
+  let str = String.escaped str in
+  let l = String.length str in
+  let res = Bytes.make (l + 2) '\"' in
+  String.unsafe_blit str 0 res 1 l;
+  Bytes.unsafe_to_string res
+
+(* Generate the format_int/int32/nativeint/int64 first argument
+   from an int_conv. *)
+let format_of_iconv = function
+  | Int_d -> "%d" | Int_pd -> "%+d" | Int_sd -> "% d"
+  | Int_i -> "%i" | Int_pi -> "%+i" | Int_si -> "% i"
+  | Int_x -> "%x" | Int_Cx -> "%#x"
+  | Int_X -> "%X" | Int_CX -> "%#X"
+  | Int_o -> "%o" | Int_Co -> "%#o"
+  | Int_u -> "%u"
+
+let format_of_iconvL = function
+  | Int_d -> "%Ld" | Int_pd -> "%+Ld" | Int_sd -> "% Ld"
+  | Int_i -> "%Li" | Int_pi -> "%+Li" | Int_si -> "% Li"
+  | Int_x -> "%Lx" | Int_Cx -> "%#Lx"
+  | Int_X -> "%LX" | Int_CX -> "%#LX"
+  | Int_o -> "%Lo" | Int_Co -> "%#Lo"
+  | Int_u -> "%Lu"
+
+let format_of_iconvl = function
+  | Int_d -> "%ld" | Int_pd -> "%+ld" | Int_sd -> "% ld"
+  | Int_i -> "%li" | Int_pi -> "%+li" | Int_si -> "% li"
+  | Int_x -> "%lx" | Int_Cx -> "%#lx"
+  | Int_X -> "%lX" | Int_CX -> "%#lX"
+  | Int_o -> "%lo" | Int_Co -> "%#lo"
+  | Int_u -> "%lu"
+
+let format_of_iconvn = function
+  | Int_d -> "%nd" | Int_pd -> "%+nd" | Int_sd -> "% nd"
+  | Int_i -> "%ni" | Int_pi -> "%+ni" | Int_si -> "% ni"
+  | Int_x -> "%nx" | Int_Cx -> "%#nx"
+  | Int_X -> "%nX" | Int_CX -> "%#nX"
+  | Int_o -> "%no" | Int_Co -> "%#no"
+  | Int_u -> "%nu"
+
+(* Generate the format_float first argument form a float_conv. *)
+let format_of_fconv fconv prec =
+  if fconv = Float_F then "%.12g" else
+    let prec = abs prec in
+    let symb = char_of_fconv fconv in
+    let buf = buffer_create 16 in
+    buffer_add_char buf '%';
+    bprint_fconv_flag buf fconv;
+    buffer_add_char buf '.';
+    buffer_add_string buf (string_of_int prec);
+    buffer_add_char buf symb;
+    buffer_contents buf
+
+(* Convert an integer to a string according to a conversion. *)
+let convert_int iconv n = format_int (format_of_iconv iconv) n
+let convert_int32 iconv n = format_int32 (format_of_iconvl iconv) n
+let convert_nativeint iconv n = format_nativeint (format_of_iconvn iconv) n
+let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) n
+
+(* Convert a float to string. *)
+(* Fix special case of "OCaml float format". *)
+let convert_float fconv prec x =
+  match fconv with
+  | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH ->
+    let sign =
+      match fconv with
+      | Float_ph | Float_pH -> '+'
+      | Float_sh | Float_sH -> ' '
+      | _ -> '-' in
+    let str = hexstring_of_float x prec sign in
+    begin match fconv with
+    | Float_H | Float_pH | Float_sH -> String.uppercase_ascii str
+    | _ -> str
+    end
+  | _ ->
+    let str = format_float (format_of_fconv fconv prec) x in
+    if fconv <> Float_F then str else
+      let len = String.length str in
+      let rec is_valid i =
+        if i = len then false else
+          match str.[i] with
+          | '.' | 'e' | 'E' -> true
+          | _ -> is_valid (i + 1)
+      in
+      match classify_float x with
+      | FP_normal | FP_subnormal | FP_zero ->
+        if is_valid 0 then str else str ^ "."
+      | FP_infinite ->
+        if x < 0.0 then "neg_infinity" else "infinity"
+      | FP_nan -> "nan"
+
+(* Convert a char to a string according to the OCaml lexical convention. *)
+let format_caml_char c =
+  let str = Char.escaped c in
+  let l = String.length str in
+  let res = Bytes.make (l + 2) '\'' in
+  String.unsafe_blit str 0 res 1 l;
+  Bytes.unsafe_to_string res
+
+(* Convert a format type to string *)
+let string_of_fmtty fmtty =
+  let buf = buffer_create 16 in
+  bprint_fmtty buf fmtty;
+  buffer_contents buf
+
+(******************************************************************************)
+                        (* Generic printing function *)
+
+(* Make a generic printing function. *)
+(* Used to generate Printf and Format printing functions. *)
+(* Parameters:
+     k: a continuation finally applied to the output stream and the accumulator.
+     o: the output stream (see k, %a and %t).
+     acc: rev list of printing entities (string, char, flush, formatting, ...).
+     fmt: the format. *)
+let rec make_printf : type a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, e, f) fmt -> a =
+fun k o acc fmt -> match fmt with
+  | Char rest ->
+    fun c ->
+      let new_acc = Acc_data_char (acc, c) in
+      make_printf k o new_acc rest
+  | Caml_char rest ->
+    fun c ->
+      let new_acc = Acc_data_string (acc, format_caml_char c) in
+      make_printf k o new_acc rest
+  | String (pad, rest) ->
+    make_string_padding k o acc rest pad (fun str -> str)
+  | Caml_string (pad, rest) ->
+    make_string_padding k o acc rest pad string_to_caml_string
+  | Int (iconv, pad, prec, rest) ->
+    make_int_padding_precision k o acc rest pad prec convert_int iconv
+  | Int32 (iconv, pad, prec, rest) ->
+    make_int_padding_precision k o acc rest pad prec convert_int32 iconv
+  | Nativeint (iconv, pad, prec, rest) ->
+    make_int_padding_precision k o acc rest pad prec convert_nativeint iconv
+  | Int64 (iconv, pad, prec, rest) ->
+    make_int_padding_precision k o acc rest pad prec convert_int64 iconv
+  | Float (fconv, pad, prec, rest) ->
+    make_float_padding_precision k o acc rest pad prec fconv
+  | Bool rest ->
+    fun b -> make_printf k o (Acc_data_string (acc, string_of_bool b)) rest
+  | Alpha rest ->
+    fun f x -> make_printf k o (Acc_delay (acc, fun o -> f o x)) rest
+  | Theta rest ->
+    fun f -> make_printf k o (Acc_delay (acc, f)) rest
+  | Custom (arity, f, rest) ->
+    make_custom k o acc rest arity (f ())
+  | Reader _ ->
+    (* This case is impossible, by typing of formats. *)
+    (* Indeed, since printf and co. take a format4 as argument, the 'd and 'e
+       type parameters of fmt are obviously equals. The Reader is the
+       only constructor which touch 'd and 'e type parameters of the format
+       type, it adds an (->) to the 'd parameters. Consequently, a format4
+       cannot contain a Reader node, except in the sub-format associated to
+       an %{...%}. It's not a problem because make_printf do not call
+       itself recursively on the sub-format associated to %{...%}. *)
+    assert false
+  | Flush rest ->
+    make_printf k o (Acc_flush acc) rest
+
+  | String_literal (str, rest) ->
+    make_printf k o (Acc_string_literal (acc, str)) rest
+  | Char_literal (chr, rest) ->
+    make_printf k o (Acc_char_literal (acc, chr)) rest
+
+  | Format_arg (_, sub_fmtty, rest) ->
+    let ty = string_of_fmtty sub_fmtty in
+    (fun str ->
+      ignore str;
+      make_printf k o (Acc_data_string (acc, ty)) rest)
+  | Format_subst (_, fmtty, rest) ->
+    fun (Format (fmt, _)) -> make_printf k o acc
+      (concat_fmt (recast fmt fmtty) rest)
+
+  | Scan_char_set (_, _, rest) ->
+    let new_acc = Acc_invalid_arg (acc, "Printf: bad conversion %[") in
+    fun _ -> make_printf k o new_acc rest
+  | Scan_get_counter (_, rest) ->
+    (* This case should be refused for Printf. *)
+    (* Accepted for backward compatibility. *)
+    (* Interpret %l, %n and %L as %u. *)
+    fun n ->
+      let new_acc = Acc_data_string (acc, format_int "%u" n) in
+      make_printf k o new_acc rest
+  | Scan_next_char rest ->
+    fun c ->
+      let new_acc = Acc_data_char (acc, c) in
+      make_printf k o new_acc rest
+  | Ignored_param (ign, rest) ->
+    make_ignored_param k o acc ign rest
+
+  | Formatting_lit (fmting_lit, rest) ->
+    make_printf k o (Acc_formatting_lit (acc, fmting_lit)) rest
+  | Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
+    let k' koc kacc =
+      make_printf k koc (Acc_formatting_gen (acc, Acc_open_tag kacc)) rest in
+    make_printf k' o End_of_acc fmt'
+  | Formatting_gen (Open_box (Format (fmt', _)), rest) ->
+    let k' koc kacc =
+      make_printf k koc (Acc_formatting_gen (acc, Acc_open_box kacc)) rest in
+    make_printf k' o End_of_acc fmt'
+
+  | End_of_format ->
+    k o acc
+
+(* Delay the error (Invalid_argument "Printf: bad conversion %_"). *)
+(* Generate functions to take remaining arguments (after the "%_"). *)
+and make_ignored_param : type x y a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, y, x) ignored ->
+    (x, b, c, y, e, f) fmt -> a =
+fun k o acc ign fmt -> match ign with
+  | Ignored_char                    -> make_invalid_arg k o acc fmt
+  | Ignored_caml_char               -> make_invalid_arg k o acc fmt
+  | Ignored_string _                -> make_invalid_arg k o acc fmt
+  | Ignored_caml_string _           -> make_invalid_arg k o acc fmt
+  | Ignored_int (_, _)              -> make_invalid_arg k o acc fmt
+  | Ignored_int32 (_, _)            -> make_invalid_arg k o acc fmt
+  | Ignored_nativeint (_, _)        -> make_invalid_arg k o acc fmt
+  | Ignored_int64 (_, _)            -> make_invalid_arg k o acc fmt
+  | Ignored_float (_, _)            -> make_invalid_arg k o acc fmt
+  | Ignored_bool                    -> make_invalid_arg k o acc fmt
+  | Ignored_format_arg _            -> make_invalid_arg k o acc fmt
+  | Ignored_format_subst (_, fmtty) -> make_from_fmtty k o acc fmtty fmt
+  | Ignored_reader                  -> assert false
+  | Ignored_scan_char_set _         -> make_invalid_arg k o acc fmt
+  | Ignored_scan_get_counter _      -> make_invalid_arg k o acc fmt
+  | Ignored_scan_next_char          -> make_invalid_arg k o acc fmt
+
+
+(* Special case of printf "%_(". *)
+and make_from_fmtty : type x y a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, y, x) fmtty ->
+    (x, b, c, y, e, f) fmt -> a =
+fun k o acc fmtty fmt -> match fmtty with
+  | Char_ty rest            -> fun _ -> make_from_fmtty k o acc rest fmt
+  | String_ty rest          -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Int_ty rest             -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Int32_ty rest           -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Nativeint_ty rest       -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Int64_ty rest           -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Float_ty rest           -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Bool_ty rest            -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Alpha_ty rest           -> fun _ _ -> make_from_fmtty k o acc rest fmt
+  | Theta_ty rest           -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Any_ty rest             -> fun _ -> make_from_fmtty k o acc rest fmt
+  | Reader_ty _             -> assert false
+  | Ignored_reader_ty _     -> assert false
+  | Format_arg_ty (_, rest) -> fun _ -> make_from_fmtty k o acc rest fmt
+  | End_of_fmtty            -> make_invalid_arg k o acc fmt
+  | Format_subst_ty (ty1, ty2, rest) ->
+    let ty = trans (symm ty1) ty2 in
+    fun _ -> make_from_fmtty k o acc (concat_fmtty ty rest) fmt
+
+(* Insert an Acc_invalid_arg in the accumulator and continue to generate
+   closures to get the remaining arguments. *)
+and make_invalid_arg : type a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, e, f) fmt -> a =
+fun k o acc fmt ->
+  make_printf k o (Acc_invalid_arg (acc, "Printf: bad conversion %_")) fmt
+
+(* Fix padding, take it as an extra integer argument if needed. *)
+and make_string_padding : type x z a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, e, f) fmt ->
+    (x, z -> a) padding -> (z -> string) -> x =
+  fun k o acc fmt pad trans -> match pad with
+  | No_padding ->
+    fun x ->
+      let new_acc = Acc_data_string (acc, trans x) in
+      make_printf k o new_acc fmt
+  | Lit_padding (padty, width) ->
+    fun x ->
+      let new_acc = Acc_data_string (acc, fix_padding padty width (trans x)) in
+      make_printf k o new_acc fmt
+  | Arg_padding padty ->
+    fun w x ->
+      let new_acc = Acc_data_string (acc, fix_padding padty w (trans x)) in
+      make_printf k o new_acc fmt
+
+(* Fix padding and precision for int, int32, nativeint or int64. *)
+(* Take one or two extra integer arguments if needed. *)
+and make_int_padding_precision : type x y z a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, e, f) fmt ->
+    (x, y) padding -> (y, z -> a) precision -> (int_conv -> z -> string) ->
+    int_conv -> x =
+  fun k o acc fmt pad prec trans iconv -> match pad, prec with
+  | No_padding, No_precision ->
+    fun x ->
+      let str = trans iconv x in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | No_padding, Lit_precision p ->
+    fun x ->
+      let str = fix_int_precision p (trans iconv x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | No_padding, Arg_precision ->
+    fun p x ->
+      let str = fix_int_precision p (trans iconv x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Lit_padding (padty, w), No_precision ->
+    fun x ->
+      let str = fix_padding padty w (trans iconv x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Lit_padding (padty, w), Lit_precision p ->
+    fun x ->
+      let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Lit_padding (padty, w), Arg_precision ->
+    fun p x ->
+      let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Arg_padding padty, No_precision ->
+    fun w x ->
+      let str = fix_padding padty w (trans iconv x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Arg_padding padty, Lit_precision p ->
+    fun w x ->
+      let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Arg_padding padty, Arg_precision ->
+    fun w p x ->
+      let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+
+(* Convert a float, fix padding and precision if needed. *)
+(* Take the float argument and one or two extra integer arguments if needed. *)
+and make_float_padding_precision : type x y a b c d e f .
+    (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+    (a, b, c, d, e, f) fmt ->
+    (x, y) padding -> (y, float -> a) precision -> float_conv -> x =
+  fun k o acc fmt pad prec fconv -> match pad, prec with
+  | No_padding, No_precision ->
+    fun x ->
+      let str = convert_float fconv default_float_precision x in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | No_padding, Lit_precision p ->
+    fun x ->
+      let str = convert_float fconv p x in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | No_padding, Arg_precision ->
+    fun p x ->
+      let str = convert_float fconv p x in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Lit_padding (padty, w), No_precision ->
+    fun x ->
+      let str = convert_float fconv default_float_precision x in
+      let str' = fix_padding padty w str in
+      make_printf k o (Acc_data_string (acc, str')) fmt
+  | Lit_padding (padty, w), Lit_precision p ->
+    fun x ->
+      let str = fix_padding padty w (convert_float fconv p x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Lit_padding (padty, w), Arg_precision ->
+    fun p x ->
+      let str = fix_padding padty w (convert_float fconv p x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Arg_padding padty, No_precision ->
+    fun w x ->
+      let str = convert_float fconv default_float_precision x in
+      let str' = fix_padding padty w str in
+      make_printf k o (Acc_data_string (acc, str')) fmt
+  | Arg_padding padty, Lit_precision p ->
+    fun w x ->
+      let str = fix_padding padty w (convert_float fconv p x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+  | Arg_padding padty, Arg_precision ->
+    fun w p x ->
+      let str = fix_padding padty w (convert_float fconv p x) in
+      make_printf k o (Acc_data_string (acc, str)) fmt
+and make_custom : type x y a b c d e f .
+  (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+  (a, b, c, d, e, f) fmt ->
+  (a, x, y) custom_arity -> x -> y =
+  fun k o acc rest arity f -> match arity with
+  | Custom_zero -> make_printf k o (Acc_data_string (acc, f)) rest
+  | Custom_succ arity ->
+    fun x ->
+      make_custom k o acc rest arity (f x)
+
+let const x _ = x
+
+let rec make_iprintf : type a b c d e f.
+  (b -> f) -> b -> (a, b, c, d, e, f) fmt -> a =
+  fun k o fmt -> match fmt with
+    | Char rest ->
+        const (make_iprintf k o rest)
+    | Caml_char rest ->
+        const (make_iprintf k o rest)
+    | String (No_padding, rest) ->
+        const (make_iprintf k o rest)
+    | String (Lit_padding _, rest) ->
+        const (make_iprintf k o rest)
+    | String (Arg_padding _, rest) ->
+        const (const (make_iprintf k o rest))
+    | Caml_string (No_padding, rest) ->
+        const (make_iprintf k o rest)
+    | Caml_string (Lit_padding _, rest) ->
+        const (make_iprintf k o rest)
+    | Caml_string (Arg_padding _, rest) ->
+        const (const (make_iprintf k o rest))
+    | Int (_, pad, prec, rest) ->
+        fn_of_padding_precision k o rest pad prec
+    | Int32 (_, pad, prec, rest) ->
+        fn_of_padding_precision k o rest pad prec
+    | Nativeint (_, pad, prec, rest) ->
+        fn_of_padding_precision k o rest pad prec
+    | Int64 (_, pad, prec, rest) ->
+        fn_of_padding_precision k o rest pad prec
+    | Float (_, pad, prec, rest) ->
+        fn_of_padding_precision k o rest pad prec
+    | Bool rest ->
+        const (make_iprintf k o rest)
+    | Alpha rest ->
+        const (const (make_iprintf k o rest))
+    | Theta rest ->
+        const (make_iprintf k o rest)
+    | Custom (arity, _, rest) ->
+        fn_of_custom_arity k o rest arity
+    | Reader _ ->
+        (* This case is impossible, by typing of formats.  See the
+           note in the corresponding case for make_printf. *)
+        assert false
+    | Flush rest ->
+        make_iprintf k o rest
+    | String_literal (_, rest) ->
+        make_iprintf k o rest
+    | Char_literal (_, rest) ->
+        make_iprintf k o rest
+    | Format_arg (_, _, rest) ->
+        const (make_iprintf k o rest)
+    | Format_subst (_, fmtty, rest) ->
+        fun (Format (fmt, _)) ->
+          make_iprintf k o
+            (concat_fmt (recast fmt fmtty) rest)
+    | Scan_char_set (_, _, rest) ->
+        const (make_iprintf k o rest)
+    | Scan_get_counter (_, rest) ->
+        const (make_iprintf k o rest)
+    | Scan_next_char rest ->
+        const (make_iprintf k o rest)
+    | Ignored_param (ign, rest) ->
+        make_ignored_param (fun x _ -> k x) o (End_of_acc) ign rest
+    | Formatting_lit (_, rest) ->
+        make_iprintf k o rest
+    | Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
+        make_iprintf (fun koc -> make_iprintf k koc rest) o fmt'
+    | Formatting_gen (Open_box (Format (fmt', _)), rest) ->
+        make_iprintf (fun koc -> make_iprintf k koc rest) o fmt'
+    | End_of_format ->
+        k o
+and fn_of_padding_precision :
+  type x y z a b c d e f.
+  (b -> f) -> b -> (a, b, c, d, e, f) fmt ->
+  (x, y) padding -> (y, z -> a) precision -> x =
+  fun k o fmt pad prec -> match pad, prec with
+    | No_padding   , No_precision    ->
+        const (make_iprintf k o fmt)
+    | No_padding   , Lit_precision _ ->
+        const (make_iprintf k o fmt)
+    | No_padding   , Arg_precision   ->
+        const (const (make_iprintf k o fmt))
+    | Lit_padding _, No_precision    ->
+        const (make_iprintf k o fmt)
+    | Lit_padding _, Lit_precision _ ->
+        const (make_iprintf k o fmt)
+    | Lit_padding _, Arg_precision   ->
+        const (const (make_iprintf k o fmt))
+    | Arg_padding _, No_precision    ->
+        const (const (make_iprintf k o fmt))
+    | Arg_padding _, Lit_precision _ ->
+        const (const (make_iprintf k o fmt))
+    | Arg_padding _, Arg_precision   ->
+        const (const (const (make_iprintf k o fmt)))
+and fn_of_custom_arity : type x y a b c d e f .
+  (b -> f) -> b -> (a, b, c, d, e, f) fmt -> (a, x, y) custom_arity -> y =
+  fun k o fmt -> function
+    | Custom_zero ->
+        make_iprintf k o fmt
+    | Custom_succ arity ->
+        const (fn_of_custom_arity k o fmt arity)
+
+(******************************************************************************)
+                          (* Continuations for make_printf *)
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in an output_stream. *)
+(* Used as a continuation of make_printf. *)
+let rec output_acc o acc = match acc with
+  | Acc_formatting_lit (p, fmting_lit) ->
+    let s = string_of_formatting_lit fmting_lit in
+    output_acc o p; output_string o s;
+  | Acc_formatting_gen (p, Acc_open_tag acc') ->
+    output_acc o p; output_string o "@{"; output_acc o acc';
+  | Acc_formatting_gen (p, Acc_open_box acc') ->
+    output_acc o p; output_string o "@["; output_acc o acc';
+  | Acc_string_literal (p, s)
+  | Acc_data_string (p, s)   -> output_acc o p; output_string o s
+  | Acc_char_literal (p, c)
+  | Acc_data_char (p, c)     -> output_acc o p; output_char o c
+  | Acc_delay (p, f)         -> output_acc o p; f o
+  | Acc_flush p              -> output_acc o p; flush o
+  | Acc_invalid_arg (p, msg) -> output_acc o p; invalid_arg msg;
+  | End_of_acc               -> ()
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in a buffer. *)
+(* Used as a continuation of make_printf. *)
+let rec bufput_acc b acc = match acc with
+  | Acc_formatting_lit (p, fmting_lit) ->
+    let s = string_of_formatting_lit fmting_lit in
+    bufput_acc b p; Buffer.add_string b s;
+  | Acc_formatting_gen (p, Acc_open_tag acc') ->
+    bufput_acc b p; Buffer.add_string b "@{"; bufput_acc b acc';
+  | Acc_formatting_gen (p, Acc_open_box acc') ->
+    bufput_acc b p; Buffer.add_string b "@["; bufput_acc b acc';
+  | Acc_string_literal (p, s)
+  | Acc_data_string (p, s)   -> bufput_acc b p; Buffer.add_string b s
+  | Acc_char_literal (p, c)
+  | Acc_data_char (p, c)     -> bufput_acc b p; Buffer.add_char b c
+  | Acc_delay (p, f)         -> bufput_acc b p; f b
+  | Acc_flush p              -> bufput_acc b p;
+  | Acc_invalid_arg (p, msg) -> bufput_acc b p; invalid_arg msg;
+  | End_of_acc               -> ()
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in a buffer. *)
+(* Differ from bufput_acc by the interpretation of %a and %t. *)
+(* Used as a continuation of make_printf. *)
+let rec strput_acc b acc = match acc with
+  | Acc_formatting_lit (p, fmting_lit) ->
+    let s = string_of_formatting_lit fmting_lit in
+    strput_acc b p; Buffer.add_string b s;
+  | Acc_formatting_gen (p, Acc_open_tag acc') ->
+    strput_acc b p; Buffer.add_string b "@{"; strput_acc b acc';
+  | Acc_formatting_gen (p, Acc_open_box acc') ->
+    strput_acc b p; Buffer.add_string b "@["; strput_acc b acc';
+  | Acc_string_literal (p, s)
+  | Acc_data_string (p, s)   -> strput_acc b p; Buffer.add_string b s
+  | Acc_char_literal (p, c)
+  | Acc_data_char (p, c)     -> strput_acc b p; Buffer.add_char b c
+  | Acc_delay (p, f)         -> strput_acc b p; Buffer.add_string b (f ())
+  | Acc_flush p              -> strput_acc b p;
+  | Acc_invalid_arg (p, msg) -> strput_acc b p; invalid_arg msg;
+  | End_of_acc               -> ()
+
+(******************************************************************************)
+                          (* Error managment *)
+
+(* Raise a Failure with a pretty-printed error message. *)
+let failwith_message (Format (fmt, _)) =
+  let buf = Buffer.create 256 in
+  let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in
+  make_printf k () End_of_acc fmt
+
+(******************************************************************************)
+                            (* Formatting tools *)
+
+(* Convert a string to an open block description (indent, block_type) *)
+let open_box_of_string str =
+  if str = "" then (0, Pp_box) else
+    let len = String.length str in
+    let invalid_box () = failwith_message "invalid box description %S" str in
+    let rec parse_spaces i =
+      if i = len then i else
+        match str.[i] with
+        | ' ' | '\t' -> parse_spaces (i + 1)
+        | _ -> i
+    and parse_lword i j =
+      if j = len then j else
+        match str.[j] with
+        | 'a' .. 'z' -> parse_lword i (j + 1)
+        | _ -> j
+    and parse_int i j =
+      if j = len then j else
+        match str.[j] with
+        | '0' .. '9' | '-' -> parse_int i (j + 1)
+        | _ -> j in
+    let wstart = parse_spaces 0 in
+    let wend = parse_lword wstart wstart in
+    let box_name = String.sub str wstart (wend - wstart) in
+    let nstart = parse_spaces wend in
+    let nend = parse_int nstart nstart in
+    let indent =
+      if nstart = nend then 0 else
+        try int_of_string (String.sub str nstart (nend - nstart))
+        with Failure _ -> invalid_box () in
+    let exp_end = parse_spaces nend in
+    if exp_end <> len then invalid_box ();
+    let box_type = match box_name with
+      | "" | "b" -> Pp_box
+      | "h"      -> Pp_hbox
+      | "v"      -> Pp_vbox
+      | "hv"     -> Pp_hvbox
+      | "hov"    -> Pp_hovbox
+      | _        -> invalid_box () in
+    (indent, box_type)
+
+(******************************************************************************)
+                            (* Parsing tools *)
+
+(* Create a padding_fmt_ebb from a padding and a format. *)
+(* Copy the padding to disjoin the type parameters of argument and result. *)
+let make_padding_fmt_ebb : type x y .
+    (x, y) padding -> (_, _, _, _, _, _) fmt ->
+      (_, _, _, _, _) padding_fmt_ebb =
+fun pad fmt -> match pad with
+  | No_padding         -> Padding_fmt_EBB (No_padding, fmt)
+  | Lit_padding (s, w) -> Padding_fmt_EBB (Lit_padding (s, w), fmt)
+  | Arg_padding s      -> Padding_fmt_EBB (Arg_padding s, fmt)
+
+(* Create a precision_fmt_ebb from a precision and a format. *)
+(* Copy the precision to disjoin the type parameters of argument and result. *)
+let make_precision_fmt_ebb : type x y .
+    (x, y) precision -> (_, _, _, _, _, _) fmt ->
+      (_, _, _, _, _) precision_fmt_ebb =
+fun prec fmt -> match prec with
+  | No_precision    -> Precision_fmt_EBB (No_precision, fmt)
+  | Lit_precision p -> Precision_fmt_EBB (Lit_precision p, fmt)
+  | Arg_precision   -> Precision_fmt_EBB (Arg_precision, fmt)
+
+(* Create a padprec_fmt_ebb forma a padding, a precision and a format. *)
+(* Copy the padding and the precision to disjoin type parameters of arguments
+   and result. *)
+let make_padprec_fmt_ebb : type x y z t .
+    (x, y) padding -> (z, t) precision ->
+    (_, _, _, _, _, _) fmt ->
+    (_, _, _, _, _) padprec_fmt_ebb =
+fun pad prec fmt ->
+  let Precision_fmt_EBB (prec, fmt') = make_precision_fmt_ebb prec fmt in
+  match pad with
+  | No_padding         -> Padprec_fmt_EBB (No_padding, prec, fmt')
+  | Lit_padding (s, w) -> Padprec_fmt_EBB (Lit_padding (s, w), prec, fmt')
+  | Arg_padding s      -> Padprec_fmt_EBB (Arg_padding s, prec, fmt')
+
+(******************************************************************************)
+                             (* Format parsing *)
+
+(* Parse a string representing a format and create a fmt_ebb. *)
+(* Raise an Failure exception in case of invalid format. *)
+let fmt_ebb_of_string ?legacy_behavior str =
+  (* Parameters naming convention:                                    *)
+  (*   - lit_start: start of the literal sequence.                    *)
+  (*   - str_ind: current index in the string.                        *)
+  (*   - end_ind: end of the current (sub-)format.                    *)
+  (*   - pct_ind: index of the '%' in the current micro-format.       *)
+  (*   - zero:  is the '0' flag defined in the current micro-format.  *)
+  (*   - minus: is the '-' flag defined in the current micro-format.  *)
+  (*   - plus:  is the '+' flag defined in the current micro-format.  *)
+  (*   - hash:  is the '#' flag defined in the current micro-format.  *)
+  (*   - space: is the ' ' flag defined in the current micro-format.  *)
+  (*   - ign:   is the '_' flag defined in the current micro-format.  *)
+  (*   - pad: padding of the current micro-format.                    *)
+  (*   - prec: precision of the current micro-format.                 *)
+  (*   - symb: char representing the conversion ('c', 's', 'd', ...). *)
+  (*   - char_set: set of characters as bitmap (see scanf %[...]).    *)
+
+  let legacy_behavior = match legacy_behavior with
+    | Some flag -> flag
+    | None -> true
+  (*  When this flag is enabled, the format parser tries to behave as
+      the <4.02 implementations, in particular it ignores most benine
+      nonsensical format. When the flag is disabled, it will reject any
+      format that is not accepted by the specification.
+
+      A typical example would be "%+ d": specifying both '+' (if the
+      number is positive, pad with a '+' to get the same width as
+      negative numbres) and ' ' (if the number is positive, pad with
+      a space) does not make sense, but the legacy (< 4.02)
+      implementation was happy to just ignore the space.
+  *)
+  in
+
+  (* Raise a Failure with a friendly error message. *)
+  let invalid_format_message str_ind msg =
+    failwith_message
+      "invalid format %S: at character number %d, %s"
+      str str_ind msg;
+  in
+
+  (* Used when the end of the format (or the current sub-format) was encoutered
+      unexpectedly. *)
+  let unexpected_end_of_format end_ind =
+    invalid_format_message end_ind
+      "unexpected end of format"
+  in
+
+  (* Used for %0c: no other widths are implemented *)
+  let invalid_nonnull_char_width str_ind =
+    invalid_format_message str_ind
+      "non-zero widths are unsupported for %c conversions"
+  in
+  (* Raise Failure with a friendly error message about an option dependencie
+     problem. *)
+  let invalid_format_without str_ind c s =
+    failwith_message
+      "invalid format %S: at character number %d, '%c' without %s"
+      str str_ind c s
+  in
+
+  (* Raise Failure with a friendly error message about an unexpected
+     character. *)
+  let expected_character str_ind expected read =
+    failwith_message
+     "invalid format %S: at character number %d, %s expected, read %C"
+      str str_ind expected read
+  in
+
+  (* Parse the string from beg_ind (included) to end_ind (excluded). *)
+  let rec parse : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+  fun beg_ind end_ind -> parse_literal beg_ind beg_ind end_ind
+
+  (* Read literal characters up to '%' or '@' special characters. *)
+  and parse_literal : type e f . int -> int -> int -> (_, _, e, f) fmt_ebb =
+  fun lit_start str_ind end_ind ->
+    if str_ind = end_ind then add_literal lit_start str_ind End_of_format else
+      match str.[str_ind] with
+      | '%' ->
+        let Fmt_EBB fmt_rest = parse_format str_ind end_ind in
+        add_literal lit_start str_ind fmt_rest
+      | '@' ->
+        let Fmt_EBB fmt_rest = parse_after_at (str_ind + 1) end_ind in
+        add_literal lit_start str_ind fmt_rest
+      | _ ->
+        parse_literal lit_start (str_ind + 1) end_ind
+
+  (* Parse a format after '%' *)
+  and parse_format : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+  fun pct_ind end_ind -> parse_ign pct_ind (pct_ind + 1) end_ind
+
+  and parse_ign : type e f . int -> int -> int -> (_, _, e, f) fmt_ebb =
+  fun pct_ind str_ind end_ind ->
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    match str.[str_ind] with
+      | '_' -> parse_flags pct_ind (str_ind+1) end_ind true
+      | _ -> parse_flags pct_ind str_ind end_ind false
+
+  and parse_flags : type e f . int -> int -> int -> bool -> (_, _, e, f) fmt_ebb
+  =
+  fun pct_ind str_ind end_ind ign ->
+    let zero = ref false and minus = ref false
+    and plus = ref false and space = ref false
+    and hash = ref false in
+    let set_flag str_ind flag =
+      (* in legacy mode, duplicate flags are accepted *)
+      if !flag && not legacy_behavior then
+        failwith_message
+          "invalid format %S: at character number %d, duplicate flag %C"
+          str str_ind str.[str_ind];
+      flag := true;
+    in
+    let rec read_flags str_ind =
+      if str_ind = end_ind then unexpected_end_of_format end_ind;
+      begin match str.[str_ind] with
+      | '0' -> set_flag str_ind zero;  read_flags (str_ind + 1)
+      | '-' -> set_flag str_ind minus; read_flags (str_ind + 1)
+      | '+' -> set_flag str_ind plus;  read_flags (str_ind + 1)
+      | '#' -> set_flag str_ind hash; read_flags (str_ind + 1)
+      | ' ' -> set_flag str_ind space; read_flags (str_ind + 1)
+      | _ ->
+        parse_padding pct_ind str_ind end_ind
+          !zero !minus !plus !hash !space ign
+      end
+    in
+    read_flags str_ind
+
+  (* Try to read a digital or a '*' padding. *)
+  and parse_padding : type e f .
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool -> bool ->
+        (_, _, e, f) fmt_ebb =
+  fun pct_ind str_ind end_ind zero minus plus hash space ign ->
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    let padty = match zero, minus with
+      | false, false -> Right
+      | false, true  -> Left
+      |  true, false -> Zeros
+      |  true, true  ->
+        if legacy_behavior then Left
+        else incompatible_flag pct_ind str_ind '-' "0" in
+    match str.[str_ind] with
+    | '0' .. '9' ->
+      let new_ind, width = parse_positive str_ind end_ind 0 in
+      parse_after_padding pct_ind new_ind end_ind minus plus hash space ign
+        (Lit_padding (padty, width))
+    | '*' ->
+      parse_after_padding pct_ind (str_ind + 1) end_ind minus plus hash space
+        ign (Arg_padding padty)
+    | _ ->
+      begin match padty with
+      | Left  ->
+        if not legacy_behavior then
+          invalid_format_without (str_ind - 1) '-' "padding";
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
+          No_padding
+      | Zeros ->
+         (* a '0' padding indication not followed by anything should
+           be interpreted as a Right padding of width 0. This is used
+           by scanning conversions %0s and %0c *)
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
+          (Lit_padding (Right, 0))
+      | Right ->
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
+          No_padding
+      end
+
+  (* Is precision defined? *)
+  and parse_after_padding : type x e f .
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
+        (x, _) padding -> (_, _, e, f) fmt_ebb =
+  fun pct_ind str_ind end_ind minus plus hash space ign pad ->
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    match str.[str_ind] with
+    | '.' ->
+      parse_precision pct_ind (str_ind + 1) end_ind minus plus hash space ign
+        pad
+    | symb ->
+      parse_conversion pct_ind (str_ind + 1) end_ind plus hash space ign pad
+        No_precision pad symb
+
+  (* Read the digital or '*' precision. *)
+  and parse_precision : type x e f .
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
+        (x, _) padding -> (_, _, e, f) fmt_ebb =
+  fun pct_ind str_ind end_ind minus plus hash space ign pad ->
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    let parse_literal minus str_ind =
+      let new_ind, prec = parse_positive str_ind end_ind 0 in
+      parse_after_precision pct_ind new_ind end_ind minus plus hash space ign
+        pad (Lit_precision prec) in
+    match str.[str_ind] with
+    | '0' .. '9' -> parse_literal minus str_ind
+    | ('+' | '-') as symb when legacy_behavior ->
+      (* Legacy mode would accept and ignore '+' or '-' before the
+         integer describing the desired precision; not that this
+         cannot happen for padding width, as '+' and '-' already have
+         a semantics there.
+
+         That said, the idea (supported by this tweak) that width and
+         precision literals are "integer literals" in the OCaml sense is
+         still blatantly wrong, as 123_456 or 0xFF are rejected. *)
+      parse_literal (minus || symb = '-') (str_ind + 1)
+    | '*' ->
+      parse_after_precision pct_ind (str_ind + 1) end_ind minus plus hash space
+        ign pad Arg_precision
+    | _ ->
+      if legacy_behavior then
+        (* note that legacy implementation did not ignore '.' without
+           a number (as it does for padding indications), but
+           interprets it as '.0' *)
+        parse_after_precision pct_ind str_ind end_ind minus plus hash space ign
+          pad (Lit_precision 0)
+      else
+        invalid_format_without (str_ind - 1) '.' "precision"
+
+  (* Try to read the conversion. *)
+  and parse_after_precision : type x y z t e f .
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
+        (x, y) padding -> (z, t) precision -> (_, _, e, f) fmt_ebb =
+  fun pct_ind str_ind end_ind minus plus hash space ign pad prec ->
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    let parse_conv (type u) (type v) (padprec : (u, v) padding) =
+      parse_conversion pct_ind (str_ind + 1) end_ind plus hash space ign pad
+        prec padprec str.[str_ind] in
+    (* in legacy mode, some formats (%s and %S) accept a weird mix of
+       padding and precision, which is merged as a single padding
+       information. For example, in %.10s the precision is implicitly
+       understood as padding %10s, but the left-padding component may
+       be specified either as a left padding or a negative precision:
+       %-.3s and %.-3s are equivalent to %-3s *)
+    match pad with
+    | No_padding -> (
+      match minus, prec with
+        | _, No_precision -> parse_conv No_padding
+        | false, Lit_precision n -> parse_conv (Lit_padding (Right, n))
+        | true, Lit_precision n -> parse_conv (Lit_padding (Left, n))
+        | false, Arg_precision -> parse_conv (Arg_padding Right)
+        | true, Arg_precision -> parse_conv (Arg_padding Left)
+    )
+    | pad -> parse_conv pad
+
+  (* Case analysis on conversion. *)
+  and parse_conversion : type x y z t u v e f .
+      int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding ->
+        (z, t) precision -> (u, v) padding -> char -> (_, _, e, f) fmt_ebb =
+  fun pct_ind str_ind end_ind plus hash space ign pad prec padprec symb ->
+    (* Flags used to check option usages/compatibilities. *)
+    let plus_used  = ref false and hash_used = ref false
+    and space_used = ref false and ign_used   = ref false
+    and pad_used   = ref false and prec_used  = ref false in
+
+    (* Access to options, update flags. *)
+    let get_plus    () = plus_used  := true; plus
+    and get_hash   () = hash_used := true; hash
+    and get_space   () = space_used := true; space
+    and get_ign     () = ign_used   := true; ign
+    and get_pad     () = pad_used   := true; pad
+    and get_prec    () = prec_used  := true; prec
+    and get_padprec () = pad_used   := true; padprec in
+
+    let get_int_pad () =
+      (* %5.3d is accepted and meaningful: pad to length 5 with
+         spaces, but first pad with zeros upto length 3 (0-padding
+         is the interpretation of "precision" for integer formats).
+
+         %05.3d is redundant: pad to length 5 *with zeros*, but
+         first pad with zeros... To add insult to the injury, the
+         legacy implementation ignores the 0-padding indication and
+         does the 5 padding with spaces instead. We reuse this
+         interpretation for compatiblity, but statically reject this
+         format when the legacy mode is disabled, to protect strict
+         users from this corner case. *)
+       match get_pad (), get_prec () with
+         | pad, No_precision -> pad
+         | No_padding, _     -> No_padding
+         | Lit_padding (Zeros, n), _ ->
+           if legacy_behavior then Lit_padding (Right, n)
+           else incompatible_flag pct_ind str_ind '0' "precision"
+         | Arg_padding Zeros, _ ->
+           if legacy_behavior then Arg_padding Right
+           else incompatible_flag pct_ind str_ind '0' "precision"
+         | Lit_padding _ as pad, _ -> pad
+         | Arg_padding _ as pad, _ -> pad in
+
+    (* Check that padty <> Zeros. *)
+    let check_no_0 symb (type a) (type b) (pad : (a, b) padding) =
+      match pad with
+      | No_padding -> pad
+      | Lit_padding ((Left | Right), _) -> pad
+      | Arg_padding (Left | Right) -> pad
+      | Lit_padding (Zeros, width) ->
+        if legacy_behavior then Lit_padding (Right, width)
+        else incompatible_flag pct_ind str_ind symb "0"
+      | Arg_padding Zeros ->
+        if legacy_behavior then Arg_padding Right
+        else incompatible_flag pct_ind str_ind symb "0"
+    in
+
+    (* Get padding as a pad_option (see "%_", "%{", "%(" and "%[").
+       (no need for legacy mode tweaking, those were rejected by the
+       legacy parser as well) *)
+    let opt_of_pad c (type a) (type b) (pad : (a, b) padding) = match pad with
+      | No_padding -> None
+      | Lit_padding (Right, width) -> Some width
+      | Lit_padding (Zeros, width) ->
+        if legacy_behavior then Some width
+        else incompatible_flag pct_ind str_ind c "'0'"
+      | Lit_padding (Left, width) ->
+        if legacy_behavior then Some width
+        else incompatible_flag pct_ind str_ind c "'-'"
+      | Arg_padding _ -> incompatible_flag pct_ind str_ind c "'*'"
+    in
+    let get_pad_opt c = opt_of_pad c (get_pad ()) in
+    let get_padprec_opt c = opt_of_pad c (get_padprec ()) in
+
+    (* Get precision as a prec_option (see "%_f").
+       (no need for legacy mode tweaking, those were rejected by the
+       legacy parser as well) *)
+    let get_prec_opt () = match get_prec () with
+      | No_precision       -> None
+      | Lit_precision ndec -> Some ndec
+      | Arg_precision      -> incompatible_flag pct_ind str_ind '_' "'*'"
+    in
+
+    let fmt_result = match symb with
+    | ',' ->
+      parse str_ind end_ind
+    | 'c' ->
+      let char_format fmt_rest = (* %c *)
+        if get_ign ()
+        then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest))
+        else Fmt_EBB (Char fmt_rest)
+      in
+      let scan_format fmt_rest = (* %0c *)
+        if get_ign ()
+        then Fmt_EBB (Ignored_param (Ignored_scan_next_char, fmt_rest))
+        else Fmt_EBB (Scan_next_char fmt_rest)
+      in
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      begin match get_pad_opt 'c' with
+        | None -> char_format fmt_rest
+        | Some 0 -> scan_format fmt_rest
+        | Some _n ->
+           if not legacy_behavior
+           then invalid_nonnull_char_width str_ind
+           else (* legacy ignores %c widths *) char_format fmt_rest
+      end
+    | 'C' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then Fmt_EBB (Ignored_param (Ignored_caml_char,fmt_rest))
+      else Fmt_EBB (Caml_char fmt_rest)
+    | 's' ->
+      let pad = check_no_0 symb (get_padprec ()) in
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then
+        let ignored = Ignored_string (get_padprec_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padding_fmt_EBB (pad', fmt_rest') =
+          make_padding_fmt_ebb pad fmt_rest in
+        Fmt_EBB (String (pad', fmt_rest'))
+    | 'S' ->
+      let pad = check_no_0 symb (get_padprec ()) in
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then
+        let ignored = Ignored_caml_string (get_padprec_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padding_fmt_EBB (pad', fmt_rest') =
+          make_padding_fmt_ebb pad fmt_rest in
+        Fmt_EBB (Caml_string (pad', fmt_rest'))
+    | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' ->
+      let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_hash ())
+        (get_space ()) symb in
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then
+        let ignored = Ignored_int (iconv, get_pad_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+          make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in
+        Fmt_EBB (Int (iconv, pad', prec', fmt_rest'))
+    | 'N' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      let counter = Token_counter in
+      if get_ign () then
+        let ignored = Ignored_scan_get_counter counter in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        Fmt_EBB (Scan_get_counter (counter, fmt_rest))
+    | 'l' | 'n' | 'L' when str_ind=end_ind || not (is_int_base str.[str_ind]) ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      let counter = counter_of_char symb in
+      if get_ign () then
+        let ignored = Ignored_scan_get_counter counter in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        Fmt_EBB (Scan_get_counter (counter, fmt_rest))
+    | 'l' ->
+      let iconv =
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_hash ())
+          (get_space ()) str.[str_ind] in
+      let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+      if get_ign () then
+        let ignored = Ignored_int32 (iconv, get_pad_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+          make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in
+        Fmt_EBB (Int32 (iconv, pad', prec', fmt_rest'))
+    | 'n' ->
+      let iconv =
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ())
+          (get_hash ()) (get_space ()) str.[str_ind] in
+      let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+      if get_ign () then
+        let ignored = Ignored_nativeint (iconv, get_pad_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+          make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in
+        Fmt_EBB (Nativeint (iconv, pad', prec', fmt_rest'))
+    | 'L' ->
+      let iconv =
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_hash ())
+          (get_space ()) str.[str_ind] in
+      let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+      if get_ign () then
+        let ignored = Ignored_int64 (iconv, get_pad_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+          make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in
+        Fmt_EBB (Int64 (iconv, pad', prec', fmt_rest'))
+    | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' | 'h' | 'H' ->
+      let fconv = compute_float_conv pct_ind str_ind (get_plus ())
+        (get_space ()) symb in
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then
+        let ignored = Ignored_float (get_pad_opt '_', get_prec_opt ()) in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+          make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+        Fmt_EBB (Float (fconv, pad', prec', fmt_rest'))
+    | 'b' | 'B' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then Fmt_EBB (Ignored_param (Ignored_bool, fmt_rest))
+      else Fmt_EBB (Bool fmt_rest)
+    | 'a' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      Fmt_EBB (Alpha fmt_rest)
+    | 't' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      Fmt_EBB (Theta fmt_rest)
+    | 'r' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      if get_ign () then Fmt_EBB (Ignored_param (Ignored_reader, fmt_rest))
+      else Fmt_EBB (Reader fmt_rest)
+    | '!' ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      Fmt_EBB (Flush fmt_rest)
+    | ('%' | '@') as c ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      Fmt_EBB (Char_literal (c, fmt_rest))
+    | '{' ->
+      let sub_end = search_subformat_end str_ind end_ind '}' in
+      let Fmt_EBB sub_fmt = parse str_ind sub_end in
+      let Fmt_EBB fmt_rest = parse (sub_end + 2) end_ind in
+      let sub_fmtty = fmtty_of_fmt sub_fmt in
+      if get_ign () then
+        let ignored = Ignored_format_arg (get_pad_opt '_', sub_fmtty) in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        Fmt_EBB (Format_arg (get_pad_opt '{', sub_fmtty, fmt_rest))
+    | '(' ->
+      let sub_end = search_subformat_end str_ind end_ind ')' in
+      let Fmt_EBB fmt_rest = parse (sub_end + 2) end_ind in
+      let Fmt_EBB sub_fmt = parse str_ind sub_end in
+      let sub_fmtty = fmtty_of_fmt sub_fmt in
+      if get_ign () then
+        let ignored = Ignored_format_subst (get_pad_opt '_', sub_fmtty) in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        Fmt_EBB (Format_subst (get_pad_opt '(', sub_fmtty, fmt_rest))
+    | '[' ->
+      let next_ind, char_set = parse_char_set str_ind end_ind in
+      let Fmt_EBB fmt_rest = parse next_ind end_ind in
+      if get_ign () then
+        let ignored = Ignored_scan_char_set (get_pad_opt '_', char_set) in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        Fmt_EBB (Scan_char_set (get_pad_opt '[', char_set, fmt_rest))
+    | '-' | '+' | '#' | ' ' | '_' ->
+      failwith_message
+        "invalid format %S: at character number %d, \
+         flag %C is only allowed after the '%%', before padding and precision"
+        str pct_ind symb
+    | _ ->
+      failwith_message
+        "invalid format %S: at character number %d, \
+         invalid conversion \"%%%c\"" str (str_ind - 1) symb
+    in
+    (* Check for unused options, and reject them as incompatible.
+
+       Such checks need to be disabled in legacy mode, as the legacy
+       parser silently ignored incompatible flags. *)
+    if not legacy_behavior then begin
+    if not !plus_used && plus then
+      incompatible_flag pct_ind str_ind symb "'+'";
+    if not !hash_used && hash then
+      incompatible_flag pct_ind str_ind symb "'#'";
+    if not !space_used && space then
+      incompatible_flag pct_ind str_ind symb "' '";
+    if not !pad_used  && Padding_EBB pad <> Padding_EBB No_padding then
+      incompatible_flag pct_ind str_ind symb "`padding'";
+    if not !prec_used && Precision_EBB prec <> Precision_EBB No_precision then
+      incompatible_flag pct_ind str_ind (if ign then '_' else symb)
+        "`precision'";
+    if ign && plus then incompatible_flag pct_ind str_ind '_' "'+'";
+    end;
+    (* this last test must not be disabled in legacy mode,
+       as ignoring it would typically result in a different typing
+       than what the legacy parser used *)
+    if not !ign_used && ign then
+      begin match symb with
+        (* argument-less formats can safely be ignored in legacy mode *)
+        | ('@' | '%' | '!' | ',') when legacy_behavior -> ()
+        | _ ->
+          incompatible_flag pct_ind str_ind symb "'_'"
+      end;
+    fmt_result
+
+  (* Parse formatting informations (after '@'). *)
+  and parse_after_at : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+  fun str_ind end_ind ->
+    if str_ind = end_ind then Fmt_EBB (Char_literal ('@', End_of_format))
+    else
+      match str.[str_ind] with
+      | '[' ->
+        parse_tag false (str_ind + 1) end_ind
+      | ']' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Close_box, fmt_rest))
+      | '{' ->
+        parse_tag true (str_ind + 1) end_ind
+      | '}' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Close_tag, fmt_rest))
+      | ',' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Break ("@,", 0, 0), fmt_rest))
+      | ' ' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Break ("@ ", 1, 0), fmt_rest))
+      | ';' ->
+        parse_good_break (str_ind + 1) end_ind
+      | '?' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (FFlush, fmt_rest))
+      | '\n' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Force_newline, fmt_rest))
+      | '.' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Flush_newline, fmt_rest))
+      | '<' ->
+        parse_magic_size (str_ind + 1) end_ind
+      | '@' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Escaped_at, fmt_rest))
+      | '%' when str_ind + 1 < end_ind && str.[str_ind + 1] = '%' ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 2) end_ind in
+        Fmt_EBB (Formatting_lit (Escaped_percent, fmt_rest))
+      | '%' ->
+        let Fmt_EBB fmt_rest = parse str_ind end_ind in
+        Fmt_EBB (Char_literal ('@', fmt_rest))
+      | c ->
+        let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+        Fmt_EBB (Formatting_lit (Scan_indic c, fmt_rest))
+
+  and check_open_box : type a b c d e f . (a, b, c, d, e, f) fmt -> unit =
+  fun fmt -> match fmt with
+    | String_literal (str, End_of_format) -> (
+      try ignore (open_box_of_string str) with Failure _ ->
+        ((* Emit warning: invalid open box *))
+    )
+    | _ -> ()
+
+  (* Try to read the optionnal <name> after "@{" or "@[". *)
+  and parse_tag : type e f . bool -> int -> int -> (_, _, e, f) fmt_ebb =
+  fun is_open_tag str_ind end_ind ->
+    try
+      if str_ind = end_ind then raise Not_found;
+      match str.[str_ind] with
+      | '<' ->
+        let ind = String.index_from str (str_ind + 1) '>' in
+        if ind >= end_ind then raise Not_found;
+        let sub_str = String.sub str str_ind (ind - str_ind + 1) in
+        let Fmt_EBB fmt_rest = parse (ind + 1) end_ind in
+        let Fmt_EBB sub_fmt = parse str_ind (ind + 1) in
+        let sub_format = Format (sub_fmt, sub_str) in
+        let formatting = if is_open_tag then Open_tag sub_format else (
+          check_open_box sub_fmt;
+          Open_box sub_format) in
+        Fmt_EBB (Formatting_gen (formatting, fmt_rest))
+      | _ ->
+        raise Not_found
+    with Not_found ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      let sub_format = Format (End_of_format, "") in
+      let formatting =
+        if is_open_tag then Open_tag sub_format else Open_box sub_format in
+      Fmt_EBB (Formatting_gen (formatting, fmt_rest))
+
+  (* Try to read the optionnal <width offset> after "@;". *)
+  and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+  fun str_ind end_ind ->
+    let next_ind, formatting_lit =
+      try
+        if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found;
+        let str_ind_1 = parse_spaces (str_ind + 1) end_ind in
+        match str.[str_ind_1] with
+        | '0' .. '9' | '-' -> (
+          let str_ind_2, width = parse_integer str_ind_1 end_ind in
+            let str_ind_3 = parse_spaces str_ind_2 end_ind in
+            match str.[str_ind_3] with
+              | '>' ->
+                let s = String.sub str (str_ind-2) (str_ind_3-str_ind+3) in
+                str_ind_3 + 1, Break (s, width, 0)
+              | '0' .. '9' | '-' ->
+                let str_ind_4, offset = parse_integer str_ind_3 end_ind in
+                let str_ind_5 = parse_spaces str_ind_4 end_ind in
+                if str.[str_ind_5] <> '>' then raise Not_found;
+                let s = String.sub str (str_ind-2) (str_ind_5-str_ind+3) in
+                str_ind_5 + 1, Break (s, width, offset)
+              | _ -> raise Not_found
+        )
+        | _ -> raise Not_found
+      with Not_found | Failure _ ->
+        str_ind, Break ("@;", 1, 0)
+    in
+    let Fmt_EBB fmt_rest = parse next_ind end_ind in
+    Fmt_EBB (Formatting_lit (formatting_lit, fmt_rest))
+
+  (* Parse the size in a <n>. *)
+  and parse_magic_size : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+  fun str_ind end_ind ->
+    match
+      try
+        let str_ind_1 = parse_spaces str_ind end_ind in
+        match str.[str_ind_1] with
+        | '0' .. '9' | '-' ->
+          let str_ind_2, size = parse_integer str_ind_1 end_ind in
+          let str_ind_3 = parse_spaces str_ind_2 end_ind in
+          if str.[str_ind_3] <> '>' then raise Not_found;
+          let s = String.sub str (str_ind - 2) (str_ind_3 - str_ind + 3) in
+          Some (str_ind_3 + 1, Magic_size (s, size))
+        | _ -> None
+      with Not_found | Failure _ ->
+        None
+    with
+    | Some (next_ind, formatting_lit) ->
+      let Fmt_EBB fmt_rest = parse next_ind end_ind in
+      Fmt_EBB (Formatting_lit (formatting_lit, fmt_rest))
+    | None ->
+      let Fmt_EBB fmt_rest = parse str_ind end_ind in
+      Fmt_EBB (Formatting_lit (Scan_indic '<', fmt_rest))
+
+  (* Parse and construct a char set. *)
+  and parse_char_set str_ind end_ind =
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+
+    let char_set = create_char_set () in
+    let add_char c =
+      add_in_char_set char_set c;
+    in
+    let add_range c c' =
+      for i = int_of_char c to int_of_char c' do
+        add_in_char_set char_set (char_of_int i);
+      done;
+    in
+
+    let fail_single_percent str_ind =
+      failwith_message
+        "invalid format %S: '%%' alone is not accepted in character sets, \
+         use %%%% instead at position %d." str str_ind;
+    in
+
+    (* Parse the first character of a char set. *)
+    let rec parse_char_set_start str_ind end_ind =
+      if str_ind = end_ind then unexpected_end_of_format end_ind;
+      let c = str.[str_ind] in
+      parse_char_set_after_char (str_ind + 1) end_ind c;
+
+    (* Parse the content of a char set until the first ']'. *)
+    and parse_char_set_content str_ind end_ind =
+      if str_ind = end_ind then unexpected_end_of_format end_ind;
+      match str.[str_ind] with
+      | ']' ->
+        str_ind + 1
+      | '-' ->
+        add_char '-';
+        parse_char_set_content (str_ind + 1) end_ind;
+      | c ->
+        parse_char_set_after_char (str_ind + 1) end_ind c;
+
+    (* Test for range in char set. *)
+    and parse_char_set_after_char str_ind end_ind c =
+      if str_ind = end_ind then unexpected_end_of_format end_ind;
+      match str.[str_ind] with
+      | ']' ->
+        add_char c;
+        str_ind + 1
+      | '-' ->
+        parse_char_set_after_minus (str_ind + 1) end_ind c
+      | ('%' | '@') as c' when c = '%' ->
+        add_char c';
+        parse_char_set_content (str_ind + 1) end_ind
+      | c' ->
+        if c = '%' then fail_single_percent str_ind;
+        (* note that '@' alone is accepted, as done by the legacy
+           implementation; the documentation specifically requires %@
+           so we could warn on that *)
+        add_char c;
+        parse_char_set_after_char (str_ind + 1) end_ind c'
+
+    (* Manage range in char set (except if the '-' the last char before ']') *)
+    and parse_char_set_after_minus str_ind end_ind c =
+      if str_ind = end_ind then unexpected_end_of_format end_ind;
+      match str.[str_ind] with
+      | ']' ->
+        add_char c;
+        add_char '-';
+        str_ind + 1
+      | '%' ->
+        if str_ind + 1 = end_ind then unexpected_end_of_format end_ind;
+        begin match str.[str_ind + 1] with
+          | ('%' | '@') as c' ->
+            add_range c c';
+            parse_char_set_content (str_ind + 2) end_ind
+          | _ -> fail_single_percent str_ind
+        end
+      | c' ->
+        add_range c c';
+        parse_char_set_content (str_ind + 1) end_ind
+    in
+    let str_ind, reverse =
+      if str_ind = end_ind then unexpected_end_of_format end_ind;
+      match str.[str_ind] with
+        | '^' -> str_ind + 1, true
+        | _ -> str_ind, false in
+    let next_ind = parse_char_set_start str_ind end_ind in
+    let char_set = freeze_char_set char_set in
+    next_ind, (if reverse then rev_char_set char_set else char_set)
+
+  (* Consume all next spaces, raise an Failure if end_ind is reached. *)
+  and parse_spaces str_ind end_ind =
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    if str.[str_ind] = ' ' then parse_spaces (str_ind + 1) end_ind else str_ind
+
+  (* Read a positive integer from the string, raise a Failure if end_ind is
+     reached. *)
+  and parse_positive str_ind end_ind acc =
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    match str.[str_ind] with
+    | '0' .. '9' as c ->
+      let new_acc = acc * 10 + (int_of_char c - int_of_char '0') in
+      if new_acc > Sys.max_string_length then
+        failwith_message
+          "invalid format %S: integer %d is greater than the limit %d"
+          str new_acc Sys.max_string_length
+      else
+        parse_positive (str_ind + 1) end_ind new_acc
+    | _ -> str_ind, acc
+
+  (* Read a positive or negative integer from the string, raise a Failure
+     if end_ind is reached. *)
+  and parse_integer str_ind end_ind =
+    if str_ind = end_ind then unexpected_end_of_format end_ind;
+    match str.[str_ind] with
+    | '0' .. '9' -> parse_positive str_ind end_ind 0
+    | '-' -> (
+      if str_ind + 1 = end_ind then unexpected_end_of_format end_ind;
+      match str.[str_ind + 1] with
+      | '0' .. '9' ->
+        let next_ind, n = parse_positive (str_ind + 1) end_ind 0 in
+        next_ind, -n
+      | c ->
+        expected_character (str_ind + 1) "digit" c
+    )
+    | _ -> assert false
+
+  (* Add a literal to a format from a literal character sub-sequence. *)
+  and add_literal : type a d e f .
+      int -> int -> (a, _, _, d, e, f) fmt ->
+      (_, _, e, f) fmt_ebb =
+  fun lit_start str_ind fmt -> match str_ind - lit_start with
+    | 0    -> Fmt_EBB fmt
+    | 1    -> Fmt_EBB (Char_literal (str.[lit_start], fmt))
+    | size -> Fmt_EBB (String_literal (String.sub str lit_start size, fmt))
+
+  (* Search the end of the current sub-format
+     (i.e. the corresponding "%}" or "%)") *)
+  and search_subformat_end str_ind end_ind c =
+    if str_ind = end_ind then
+      failwith_message
+        "invalid format %S: unclosed sub-format, \
+         expected \"%%%c\" at character number %d" str c end_ind;
+    match str.[str_ind] with
+    | '%' ->
+      if str_ind + 1 = end_ind then unexpected_end_of_format end_ind;
+      if str.[str_ind + 1] = c then (* End of format found *) str_ind else
+        begin match str.[str_ind + 1] with
+        | '_' ->
+          (* Search for "%_(" or "%_{". *)
+          if str_ind + 2 = end_ind then unexpected_end_of_format end_ind;
+          begin match str.[str_ind + 2] with
+          | '{' ->
+            let sub_end = search_subformat_end (str_ind + 3) end_ind '}' in
+            search_subformat_end (sub_end + 2) end_ind c
+          | '(' ->
+            let sub_end = search_subformat_end (str_ind + 3) end_ind ')' in
+            search_subformat_end (sub_end + 2) end_ind c
+          | _ -> search_subformat_end (str_ind + 3) end_ind c
+          end
+        | '{' ->
+          (* %{...%} sub-format found. *)
+          let sub_end = search_subformat_end (str_ind + 2) end_ind '}' in
+          search_subformat_end (sub_end + 2) end_ind c
+        | '(' ->
+          (* %(...%) sub-format found. *)
+          let sub_end = search_subformat_end (str_ind + 2) end_ind ')' in
+          search_subformat_end (sub_end + 2) end_ind c
+        | '}' ->
+          (* Error: %(...%}. *)
+          expected_character (str_ind + 1) "character ')'" '}';
+        | ')' ->
+          (* Error: %{...%). *)
+          expected_character (str_ind + 1) "character '}'" ')';
+        | _ ->
+          search_subformat_end (str_ind + 2) end_ind c
+        end
+    | _ -> search_subformat_end (str_ind + 1) end_ind c
+
+  (* Check if symb is a valid int conversion after "%l", "%n" or "%L" *)
+  and is_int_base symb = match symb with
+    | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' -> true
+    | _ -> false
+
+  (* Convert a char (l, n or L) to its associated counter. *)
+  and counter_of_char symb = match symb with
+    | 'l' -> Line_counter  | 'n' -> Char_counter
+    | 'L' -> Token_counter | _ -> assert false
+
+  (* Convert (plus, symb) to its associated int_conv. *)
+  and compute_int_conv pct_ind str_ind plus hash space symb =
+    match plus, hash, space, symb with
+    | false, false, false, 'd' -> Int_d  | false, false, false, 'i' -> Int_i
+    | false, false,  true, 'd' -> Int_sd | false, false,  true, 'i' -> Int_si
+    |  true, false, false, 'd' -> Int_pd |  true, false, false, 'i' -> Int_pi
+    | false, false, false, 'x' -> Int_x  | false, false, false, 'X' -> Int_X
+    | false,  true, false, 'x' -> Int_Cx | false,  true, false, 'X' -> Int_CX
+    | false, false, false, 'o' -> Int_o
+    | false,  true, false, 'o' -> Int_Co
+    | false, false, false, 'u' -> Int_u
+    | _, true, _, 'x' when legacy_behavior -> Int_Cx
+    | _, true, _, 'X' when legacy_behavior -> Int_CX
+    | _, true, _, 'o' when legacy_behavior -> Int_Co
+    | _, true, _, ('d' | 'i' | 'u') ->
+      if legacy_behavior then (* ignore *)
+        compute_int_conv pct_ind str_ind plus false space symb
+      else incompatible_flag pct_ind str_ind symb "'#'"
+    | true, _, true, _ ->
+      if legacy_behavior then
+        (* plus and space: legacy implementation prefers plus *)
+        compute_int_conv pct_ind str_ind plus hash false symb
+      else incompatible_flag pct_ind str_ind ' ' "'+'"
+    | false, _, true, _    ->
+      if legacy_behavior then (* ignore *)
+        compute_int_conv pct_ind str_ind plus hash false symb
+      else incompatible_flag pct_ind str_ind symb "' '"
+    | true, _, false, _    ->
+      if legacy_behavior then (* ignore *)
+        compute_int_conv pct_ind str_ind false hash space symb
+      else incompatible_flag pct_ind str_ind symb "'+'"
+    | false, _, false, _ -> assert false
+
+  (* Convert (plus, symb) to its associated float_conv. *)
+  and compute_float_conv pct_ind str_ind plus space symb =
+  match plus, space, symb with
+    | false, false, 'f' -> Float_f  | false, false, 'e' -> Float_e
+    | false,  true, 'f' -> Float_sf | false,  true, 'e' -> Float_se
+    |  true, false, 'f' -> Float_pf |  true, false, 'e' -> Float_pe
+    | false, false, 'E' -> Float_E  | false, false, 'g' -> Float_g
+    | false,  true, 'E' -> Float_sE | false,  true, 'g' -> Float_sg
+    |  true, false, 'E' -> Float_pE |  true, false, 'g' -> Float_pg
+    | false, false, 'G' -> Float_G
+    | false,  true, 'G' -> Float_sG
+    |  true, false, 'G' -> Float_pG
+    | false, false, 'h' -> Float_h
+    | false,  true, 'h' -> Float_sh
+    |  true, false, 'h' -> Float_ph
+    | false, false, 'H' -> Float_H
+    | false,  true, 'H' -> Float_sH
+    |  true, false, 'H' -> Float_pH
+    | false, false, 'F' -> Float_F
+    |  true,  true, _ ->
+      if legacy_behavior then
+        (* plus and space: legacy implementation prefers plus *)
+        compute_float_conv pct_ind str_ind plus false symb
+      else incompatible_flag pct_ind str_ind ' ' "'+'"
+    | false,  true, _ ->
+      if legacy_behavior then (* ignore *)
+        compute_float_conv pct_ind str_ind plus false symb
+      else incompatible_flag pct_ind str_ind symb "' '"
+    |  true, false, _ ->
+      if legacy_behavior then (* ignore *)
+        compute_float_conv pct_ind str_ind false space symb
+      else incompatible_flag pct_ind str_ind symb "'+'"
+    | false, false, _ -> assert false
+
+  (* Raise a Failure with a friendly error message about incompatible options.*)
+  and incompatible_flag : type a . int -> int -> char -> string -> a =
+    fun pct_ind str_ind symb option ->
+      let subfmt = String.sub str pct_ind (str_ind - pct_ind) in
+      failwith_message
+        "invalid format %S: at character number %d, \
+         %s is incompatible with '%c' in sub-format %S"
+        str pct_ind option symb subfmt;
+
+  in parse 0 (String.length str)
+
+(******************************************************************************)
+                  (* Guarded string to format conversions *)
+
+(* Convert a string to a format according to an fmtty. *)
+(* Raise a Failure with an error message in case of type mismatch. *)
+let format_of_string_fmtty str fmtty =
+  let Fmt_EBB fmt = fmt_ebb_of_string str in
+  try Format (type_format fmt fmtty, str)
+  with Type_mismatch ->
+    failwith_message
+      "bad input: format type mismatch between %S and %S"
+      str (string_of_fmtty fmtty)
+
+(* Convert a string to a format compatible with an other format. *)
+(* Raise a Failure with an error message in case of type mismatch. *)
+let format_of_string_format str (Format (fmt', str')) =
+  let Fmt_EBB fmt = fmt_ebb_of_string str in
+  try Format (type_format fmt (fmtty_of_fmt fmt'), str)
+  with Type_mismatch ->
+    failwith_message
+      "bad input: format type mismatch between %S and %S" str str'
diff --git a/stdlib/camlinternalFormat.mli b/stdlib/camlinternalFormat.mli
new file mode 100644
index 00000000..ccb4076c
--- /dev/null
+++ b/stdlib/camlinternalFormat.mli
@@ -0,0 +1,122 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Benoit Vaugon, ENSTA                          *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* No comments, OCaml stdlib internal use only. *)
+
+open CamlinternalFormatBasics
+
+val is_in_char_set : char_set -> char -> bool
+val rev_char_set : char_set -> char_set
+
+type mutable_char_set = bytes
+val create_char_set : unit -> mutable_char_set
+val add_in_char_set : mutable_char_set -> char -> unit
+val freeze_char_set : mutable_char_set -> char_set
+
+type ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb = Param_format_EBB :
+     ('x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt ->
+     ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb
+
+val param_format_of_ignored_format :
+  ('a, 'b, 'c, 'd, 'y, 'x) ignored -> ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
+  ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb
+
+type ('b, 'c) acc_formatting_gen =
+  | Acc_open_tag of ('b, 'c) acc
+  | Acc_open_box of ('b, 'c) acc
+
+and ('b, 'c) acc =
+  | Acc_formatting_lit of ('b, 'c) acc * formatting_lit
+  | Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen
+  | Acc_string_literal of ('b, 'c) acc * string
+  | Acc_char_literal   of ('b, 'c) acc * char
+  | Acc_data_string    of ('b, 'c) acc * string
+  | Acc_data_char      of ('b, 'c) acc * char
+  | Acc_delay          of ('b, 'c) acc * ('b -> 'c)
+  | Acc_flush          of ('b, 'c) acc
+  | Acc_invalid_arg    of ('b, 'c) acc * string
+  | End_of_acc
+
+type ('a, 'b) heter_list =
+  | Cons : 'c * ('a, 'b) heter_list -> ('c -> 'a, 'b) heter_list
+  | Nil : ('b, 'b) heter_list
+
+type ('b, 'c, 'e, 'f) fmt_ebb = Fmt_EBB :
+     ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt ->
+     ('b, 'c, 'e, 'f) fmt_ebb
+
+val make_printf :
+  ('b -> ('b, 'c) acc -> 'd) -> 'b -> ('b, 'c) acc ->
+  ('a, 'b, 'c, 'c, 'c, 'd) CamlinternalFormatBasics.fmt -> 'a
+
+val make_iprintf : ('b -> 'f) -> 'b -> ('a, 'b, 'c, 'd, 'e, 'f) fmt -> 'a
+
+val output_acc : out_channel -> (out_channel, unit) acc -> unit
+val bufput_acc : Buffer.t -> (Buffer.t, unit) acc -> unit
+val strput_acc : Buffer.t -> (unit, string) acc -> unit
+
+val type_format :
+  ('x, 'b, 'c, 't, 'u, 'v) CamlinternalFormatBasics.fmt ->
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty ->
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+
+val fmt_ebb_of_string :
+  ?legacy_behavior:bool -> string -> ('b, 'c, 'e, 'f) fmt_ebb
+(* warning: the optional flag legacy_behavior is EXPERIMENTAL and will
+   be removed in the next version. You must not set it explicitly. It
+   is only used by the type-checker implementation.
+*)
+
+val format_of_string_fmtty :
+  string ->
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty ->
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+
+val format_of_string_format :
+  string ->
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 ->
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+
+val char_of_iconv : CamlinternalFormatBasics.int_conv -> char
+val string_of_formatting_lit : CamlinternalFormatBasics.formatting_lit -> string
+val string_of_formatting_gen :
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.formatting_gen -> string
+
+val string_of_fmtty :
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty -> string
+val string_of_fmt :
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -> string
+
+val open_box_of_string : string -> int * block_type
+
+val symm :
+   ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+    'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+-> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2,
+    'a1, 'b1, 'c1, 'd1, 'e1, 'f1) fmtty_rel
+
+val trans :
+   ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+    'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+-> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2,
+    'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel
+-> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+    'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel
+
+val recast :
+   ('a1, 'b1, 'c1, 'd1, 'e1, 'f1) fmt
+-> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+    'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+-> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmt
diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml
new file mode 100644
index 00000000..9dbd563d
--- /dev/null
+++ b/stdlib/camlinternalFormatBasics.ml
@@ -0,0 +1,683 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Benoit Vaugon, ENSTA                          *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Padding position. *)
+type padty =
+  | Left   (* Text is left justified ('-' option).               *)
+  | Right  (* Text is right justified (no '-' option).           *)
+  | Zeros  (* Text is right justified by zeros (see '0' option). *)
+
+(***)
+
+(* Integer conversion. *)
+type int_conv =
+  | Int_d | Int_pd | Int_sd        (*  %d | %+d | % d  *)
+  | Int_i | Int_pi | Int_si        (*  %i | %+i | % i  *)
+  | Int_x | Int_Cx                 (*  %x | %#x        *)
+  | Int_X | Int_CX                 (*  %X | %#X        *)
+  | Int_o | Int_Co                 (*  %o | %#o        *)
+  | Int_u                          (*  %u              *)
+
+(* Float conversion. *)
+type float_conv =
+  | Float_f | Float_pf | Float_sf  (*  %f | %+f | % f  *)
+  | Float_e | Float_pe | Float_se  (*  %e | %+e | % e  *)
+  | Float_E | Float_pE | Float_sE  (*  %E | %+E | % E  *)
+  | Float_g | Float_pg | Float_sg  (*  %g | %+g | % g  *)
+  | Float_G | Float_pG | Float_sG  (*  %G | %+G | % G  *)
+  | Float_F                        (*  %F              *)
+  | Float_h | Float_ph | Float_sh  (*  %h | %+h | % h  *)
+  | Float_H | Float_pH | Float_sH  (*  %H | %+H | % H  *)
+
+(***)
+
+(* Char sets (see %[...]) are bitmaps implemented as 32-char strings. *)
+type char_set = string
+
+(***)
+
+(* Counter used in Scanf. *)
+type counter =
+  | Line_counter     (*  %l      *)
+  | Char_counter     (*  %n      *)
+  | Token_counter    (*  %N, %L  *)
+
+(***)
+
+(* Padding of strings and numbers. *)
+type ('a, 'b) padding =
+  (* No padding (ex: "%d") *)
+  | No_padding  : ('a, 'a) padding
+  (* Literal padding (ex: "%8d") *)
+  | Lit_padding : padty * int -> ('a, 'a) padding
+  (* Padding as extra argument (ex: "%*d") *)
+  | Arg_padding : padty -> (int -> 'a, 'a) padding
+
+(* Some formats, such as %_d,
+   only accept an optional number as padding option (no extra argument) *)
+type pad_option = int option
+
+(* Precision of floats and '0'-padding of integers. *)
+type ('a, 'b) precision =
+  (* No precision (ex: "%f") *)
+  | No_precision : ('a, 'a) precision
+  (* Literal precision (ex: "%.3f") *)
+  | Lit_precision : int -> ('a, 'a) precision
+  (* Precision as extra argument (ex: "%.*f") *)
+  | Arg_precision : (int -> 'a, 'a) precision
+
+(* Some formats, such as %_f,
+   only accept an optional number as precision option (no extra argument) *)
+type prec_option = int option
+
+(* see the Custom format combinator *)
+type ('a, 'b, 'c) custom_arity =
+  | Custom_zero : ('a, string, 'a) custom_arity
+  | Custom_succ : ('a, 'b, 'c) custom_arity ->
+    ('a, 'x -> 'b, 'x -> 'c) custom_arity
+
+(***)
+
+(*        Relational format types
+
+In the first format+gadts implementation, the type for %(..%) in the
+fmt GADT was as follows:
+
+| Format_subst :                                           (* %(...%) *)
+    pad_option * ('d1, 'q1, 'd2, 'q2) reader_nb_unifier *
+    ('x, 'b, 'c, 'd1, 'q1, 'u) fmtty *
+    ('u, 'b, 'c, 'q1, 'e1, 'f) fmt ->
+      (('x, 'b, 'c, 'd2, 'q2, 'u) format6 -> 'x, 'b, 'c, 'd1, 'e1, 'f) fmt
+
+Notice that the 'u parameter in 'f position in the format argument
+(('x, .., 'u) format6 -> ..) is equal to the 'u parameter in 'a
+position in the format tail (('u, .., 'f) fmt). This means that the
+type of the expected format parameter depends of where the %(...%)
+are in the format string:
+
+  # Printf.printf "%(%)"
+  - : (unit, out_channel, unit, '_a, '_a, unit)
+      CamlinternalFormatBasics.format6 -> unit
+  = <fun>
+  # Printf.printf "%(%)%d"
+  - : (int -> unit, out_channel, unit, '_a, '_a, int -> unit)
+      CamlinternalFormatBasics.format6 -> int -> unit
+  = <fun>
+
+On the contrary, the legacy typer gives a clever type that does not
+depend on the position of %(..%) in the format string. For example,
+%(%) will have the polymorphic type ('a, 'b, 'c, 'd, 'd, 'a): it can
+be concatenated to any format type, and only enforces the constraint
+that its 'a and 'f parameters are equal (no format arguments) and 'd
+and 'e are equal (no reader argument).
+
+The weakening of this parameter type in the GADT version broke user
+code (in fact it essentially made %(...%) unusable except at the last
+position of a format). In particular, the following would not work
+anymore:
+
+  fun sep ->
+    Format.printf "foo%(%)bar%(%)baz" sep sep
+
+As the type-checker would require two *incompatible* types for the %(%)
+in different positions.
+
+The solution to regain a general type for %(..%) is to generalize this
+technique, not only on the 'd, 'e parameters, but on all six
+parameters of a format: we introduce a "relational" type
+  ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+   'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+whose values are proofs that ('a1, .., 'f1) and ('a2, .., 'f2) morally
+correspond to the same format type: 'a1 is obtained from 'f1,'b1,'c1
+in the exact same way that 'a2 is obtained from 'f2,'b2,'c2, etc.
+
+For example, the relation between two format types beginning with a Char
+parameter is as follows:
+
+| Char_ty :                                                 (* %c  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+
+In the general case, the term structure of fmtty_rel is (almost[1])
+isomorphic to the fmtty of the previous implementation: every
+constructor is re-read with a binary, relational type, instead of the
+previous unary typing. fmtty can then be re-defined as the diagonal of
+fmtty_rel:
+
+  type ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
+       ('a, 'b, 'c, 'd, 'e, 'f,
+        'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel
+
+Once we have this fmtty_rel type in place, we can give the more
+general type to %(...%):
+
+| Format_subst :                                           (* %(...%) *)
+    pad_option *
+    ('g, 'h, 'i, 'j, 'k, 'l,
+     'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt
+
+We accept any format (('g, 'h, 'i, 'j, 'k, 'l) format6) (this is
+completely unrelated to the type of the current format), but also
+require a proof that this format is in relation to another format that
+is concatenable to the format tail. When executing a %(...%) format
+(in camlinternalFormat.ml:make_printf or scanf.ml:make_scanf), we
+transtype the format along this relation using the 'recast' function
+to transpose between related format types.
+
+  val recast :
+     ('a1, 'b1, 'c1, 'd1, 'e1, 'f1) fmt
+  -> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+      'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  -> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmt
+
+NOTE [1]: the typing of Format_subst_ty requires not one format type, but
+two, one to establish the link between the format argument and the
+first six parameters, and the other for the link between the format
+argumant and the last six parameters.
+
+| Format_subst_ty :                                         (* %(...%) *)
+    ('g, 'h, 'i, 'j, 'k, 'l,
+     'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel *
+    ('g, 'h, 'i, 'j, 'k, 'l,
+     'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel *
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1,
+     ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
+
+When we generate a format AST, we generate exactly the same witness
+for both relations, and the witness-conversion functions in
+camlinternalFormat do rely on this invariant. For example, the
+function that proves that the relation is transitive
+
+  val trans :
+     ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+      'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  -> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2,
+      'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel
+  -> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+      'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel
+
+does assume that the two input have exactly the same term structure
+(and is only every used for argument witnesses of the
+Format_subst_ty constructor).
+*)
+
+(* Type of a block used by the Format pretty-printer. *)
+type block_type =
+  | Pp_hbox   (* Horizontal block no line breaking *)
+  | Pp_vbox   (* Vertical block each break leads to a new line *)
+  | Pp_hvbox  (* Horizontal-vertical block: same as vbox, except if this block
+                 is small enough to fit on a single line *)
+  | Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line
+                 only when necessary to print the content of the block *)
+  | Pp_box    (* Horizontal or Indent block: breaks lead to new line
+                 only when necessary to print the content of the block, or
+                 when it leads to a new indentation of the current line *)
+  | Pp_fits   (* Internal usage: when a block fits on a single line *)
+
+(* Formatting element used by the Format pretty-printter. *)
+type formatting_lit =
+  | Close_box                                           (* @]   *)
+  | Close_tag                                           (* @}   *)
+  | Break of string * int * int          (* @, | @  | @; | @;<> *)
+  | FFlush                                              (* @?   *)
+  | Force_newline                                       (* @\n  *)
+  | Flush_newline                                       (* @.   *)
+  | Magic_size of string * int                          (* @<n> *)
+  | Escaped_at                                          (* @@   *)
+  | Escaped_percent                                     (* @%%  *)
+  | Scan_indic of char                                  (* @X   *)
+
+(* Formatting element used by the Format pretty-printter. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
+  | Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->      (* @{   *)
+    ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
+  | Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->      (* @[   *)
+    ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
+
+(***)
+
+(* List of format type elements. *)
+(* In particular used to represent %(...%) and %{...%} contents. *)
+and ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
+     ('a, 'b, 'c, 'd, 'e, 'f,
+      'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel
+and ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel =
+  | Char_ty :                                                 (* %c  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | String_ty :                                               (* %s  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (string -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       string -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Int_ty :                                                  (* %d  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (int -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       int -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Int32_ty :                                                (* %ld *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (int32 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       int32 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Nativeint_ty :                                            (* %nd *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (nativeint -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       nativeint -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Int64_ty :                                                (* %Ld *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (int64 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       int64 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Float_ty :                                                (* %f  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (float -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       float -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Bool_ty :                                                 (* %B  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (bool -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       bool -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+
+  | Format_arg_ty :                                           (* %{...%} *)
+      ('g, 'h, 'i, 'j, 'k, 'l) fmtty *
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2)
+           fmtty_rel
+  | Format_subst_ty :                                         (* %(...%) *)
+      ('g, 'h, 'i, 'j, 'k, 'l,
+       'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel *
+      ('g, 'h, 'i, 'j, 'k, 'l,
+       'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel *
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1,
+       ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2)
+           fmtty_rel
+
+  (* Printf and Format specific constructors. *)
+  | Alpha_ty :                                                (* %a  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (('b1 -> 'x -> 'c1) -> 'x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       ('b2 -> 'x -> 'c2) -> 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Theta_ty :                                                (* %t  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      (('b1 -> 'c1) -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       ('b2 -> 'c2) -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+  | Any_ty :                                    (* Used for custom formats *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      ('x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+
+  (* Scanf specific constructor. *)
+  | Reader_ty :                                               (* %r  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      ('x -> 'a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
+       'x -> 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
+  | Ignored_reader_ty :                                       (* %_r  *)
+      ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+      ('a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
+       'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
+
+  | End_of_fmtty :
+      ('f1, 'b1, 'c1, 'd1, 'd1, 'f1,
+       'f2, 'b2, 'c2, 'd2, 'd2, 'f2) fmtty_rel
+
+(***)
+
+(* List of format elements. *)
+and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
+  | Char :                                                   (* %c *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Caml_char :                                              (* %C *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | String :                                                 (* %s *)
+      ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Caml_string :                                            (* %S *)
+      ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Int :                                                    (* %[dixXuo] *)
+      int_conv * ('x, 'y) padding * ('y, int -> 'a) precision *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Int32 :                                                  (* %l[dixXuo] *)
+      int_conv * ('x, 'y) padding * ('y, int32 -> 'a) precision *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Nativeint :                                              (* %n[dixXuo] *)
+      int_conv * ('x, 'y) padding * ('y, nativeint -> 'a) precision *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Int64 :                                                  (* %L[dixXuo] *)
+      int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Float :                                                  (* %[feEgGF] *)
+      float_conv * ('x, 'y) padding * ('y, float -> 'a) precision *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
+  | Bool :                                                   (* %[bB] *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Flush :                                                  (* %! *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+  | String_literal :                                         (* abc *)
+      string * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Char_literal :                                           (* x *)
+      char * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+  | Format_arg :                                             (* %{...%} *)
+      pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Format_subst :                                           (* %(...%) *)
+      pad_option *
+      ('g, 'h, 'i, 'j, 'k, 'l,
+       'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel *
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt
+
+  (* Printf and Format specific constructor. *)
+  | Alpha :                                                  (* %a *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (('b -> 'x -> 'c) -> 'x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Theta :                                                  (* %t *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (('b -> 'c) -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+
+  (* Format specific constructor: *)
+  | Formatting_lit :                                         (* @_ *)
+      formatting_lit * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Formatting_gen :                                             (* @_ *)
+      ('a1, 'b, 'c, 'd1, 'e1, 'f1) formatting_gen *
+      ('f1, 'b, 'c, 'e1, 'e2, 'f2) fmt -> ('a1, 'b, 'c, 'd1, 'e2, 'f2) fmt
+
+  (* Scanf specific constructors: *)
+  | Reader :                                                 (* %r *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x -> 'a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmt
+  | Scan_char_set :                                          (* %[...] *)
+      pad_option * char_set * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (string -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Scan_get_counter :                                       (* %[nlNL] *)
+      counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Scan_next_char :                                         (* %0c *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Ignored_param :                                          (* %_ *)
+      ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
+        ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+  (* Custom printing format (PR#6452, GPR#140)
+
+     We include a type Custom of "custom converters", where an
+     arbitrary function can be used to convert one or more
+     arguments. There is no syntax for custom converters, it is only
+     inteded for custom processors that wish to rely on the
+     stdlib-defined format GADTs.
+
+     For instance a pre-processor could choose to interpret strings
+     prefixed with ["!"] as format strings where [%{{ ... }}] is
+     a special form to pass a to_string function, so that one could
+     write:
+
+     {[
+       type t = { x : int; y : int }
+
+       let string_of_t t = Printf.sprintf "{ x = %d; y = %d }" t.x t.y
+
+       Printf.printf !"t = %{{string_of_t}}" { x = 42; y = 42 }
+     ]}
+  *)
+  | Custom :
+      ('a, 'x, 'y) custom_arity * (unit -> 'x) * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('y, 'b, 'c, 'd, 'e, 'f) fmt
+
+  (* end of a format specification *)
+  | End_of_format :
+        ('f, 'b, 'c, 'e, 'e, 'f) fmt
+
+(***)
+
+(* Type for ignored parameters (see "%_"). *)
+and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
+  | Ignored_char :                                           (* %_c *)
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_caml_char :                                      (* %_C *)
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_string :                                         (* %_s *)
+      pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_caml_string :                                    (* %_S *)
+      pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_int :                                            (* %_d *)
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_int32 :                                          (* %_ld *)
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_nativeint :                                      (* %_nd *)
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_int64 :                                          (* %_Ld *)
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_float :                                          (* %_f *)
+      pad_option * prec_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_bool :                                           (* %_B *)
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_format_arg :                                     (* %_{...%} *)
+      pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty ->
+        ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_format_subst :                                   (* %_(...%) *)
+      pad_option * ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+        ('a, 'b, 'c, 'd, 'e, 'f) ignored
+  | Ignored_reader :                                         (* %_r *)
+      ('a, 'b, 'c, ('b -> 'x) -> 'd, 'd, 'a) ignored
+  | Ignored_scan_char_set :                                  (* %_[...] *)
+      pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_scan_get_counter :                               (* %_[nlNL] *)
+      counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_scan_next_char :                                 (* %_0c *)
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+
+and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+  Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
+
+let rec erase_rel : type a b c d e f g h i j k l .
+  (a, b, c, d, e, f,
+   g, h, i, j, k, l) fmtty_rel -> (a, b, c, d, e, f) fmtty
+= function
+  | Char_ty rest ->
+    Char_ty (erase_rel rest)
+  | String_ty rest ->
+    String_ty (erase_rel rest)
+  | Int_ty rest ->
+    Int_ty (erase_rel rest)
+  | Int32_ty rest ->
+    Int32_ty (erase_rel rest)
+  | Int64_ty rest ->
+    Int64_ty (erase_rel rest)
+  | Nativeint_ty rest ->
+    Nativeint_ty (erase_rel rest)
+  | Float_ty rest ->
+    Float_ty (erase_rel rest)
+  | Bool_ty rest ->
+    Bool_ty (erase_rel rest)
+  | Format_arg_ty (ty, rest) ->
+    Format_arg_ty (ty, erase_rel rest)
+  | Format_subst_ty (ty1, _ty2, rest) ->
+    Format_subst_ty (ty1, ty1, erase_rel rest)
+  | Alpha_ty rest ->
+    Alpha_ty (erase_rel rest)
+  | Theta_ty rest ->
+    Theta_ty (erase_rel rest)
+  | Any_ty rest ->
+    Any_ty (erase_rel rest)
+  | Reader_ty rest ->
+    Reader_ty (erase_rel rest)
+  | Ignored_reader_ty rest ->
+    Ignored_reader_ty (erase_rel rest)
+  | End_of_fmtty -> End_of_fmtty
+
+(******************************************************************************)
+                         (* Format type concatenation *)
+
+(* Concatenate two format types. *)
+(* Used by:
+   * reader_nb_unifier_of_fmtty to count readers in an fmtty,
+   * Scanf.take_fmtty_format_readers to extract readers inside %(...%),
+   * CamlinternalFormat.fmtty_of_ignored_format to extract format type. *)
+
+(*
+let rec concat_fmtty : type a b c d e f g h .
+    (a, b, c, d, e, f) fmtty ->
+    (f, b, c, e, g, h) fmtty ->
+    (a, b, c, d, g, h) fmtty =
+*)
+let rec concat_fmtty :
+  type a1 b1 c1 d1 e1 f1
+       a2 b2 c2 d2 e2 f2
+       g1 j1 g2 j2
+  .
+    (g1, b1, c1, j1, d1, a1,
+     g2, b2, c2, j2, d2, a2) fmtty_rel ->
+    (a1, b1, c1, d1, e1, f1,
+     a2, b2, c2, d2, e2, f2) fmtty_rel ->
+    (g1, b1, c1, j1, e1, f1,
+     g2, b2, c2, j2, e2, f2) fmtty_rel =
+fun fmtty1 fmtty2 -> match fmtty1 with
+  | Char_ty rest ->
+    Char_ty (concat_fmtty rest fmtty2)
+  | String_ty rest ->
+    String_ty (concat_fmtty rest fmtty2)
+  | Int_ty rest ->
+    Int_ty (concat_fmtty rest fmtty2)
+  | Int32_ty rest ->
+    Int32_ty (concat_fmtty rest fmtty2)
+  | Nativeint_ty rest ->
+    Nativeint_ty (concat_fmtty rest fmtty2)
+  | Int64_ty rest ->
+    Int64_ty (concat_fmtty rest fmtty2)
+  | Float_ty rest ->
+    Float_ty (concat_fmtty rest fmtty2)
+  | Bool_ty rest ->
+    Bool_ty (concat_fmtty rest fmtty2)
+  | Alpha_ty rest ->
+    Alpha_ty (concat_fmtty rest fmtty2)
+  | Theta_ty rest ->
+    Theta_ty (concat_fmtty rest fmtty2)
+  | Any_ty rest ->
+    Any_ty (concat_fmtty rest fmtty2)
+  | Reader_ty rest ->
+    Reader_ty (concat_fmtty rest fmtty2)
+  | Ignored_reader_ty rest ->
+    Ignored_reader_ty (concat_fmtty rest fmtty2)
+  | Format_arg_ty (ty, rest) ->
+    Format_arg_ty (ty, concat_fmtty rest fmtty2)
+  | Format_subst_ty (ty1, ty2, rest) ->
+    Format_subst_ty (ty1, ty2, concat_fmtty rest fmtty2)
+  | End_of_fmtty -> fmtty2
+
+(******************************************************************************)
+                           (* Format concatenation *)
+
+(* Concatenate two formats. *)
+let rec concat_fmt : type a b c d e f g h .
+    (a, b, c, d, e, f) fmt ->
+    (f, b, c, e, g, h) fmt ->
+    (a, b, c, d, g, h) fmt =
+fun fmt1 fmt2 -> match fmt1 with
+  | String (pad, rest) ->
+    String (pad, concat_fmt rest fmt2)
+  | Caml_string (pad, rest) ->
+    Caml_string (pad, concat_fmt rest fmt2)
+
+  | Int (iconv, pad, prec, rest) ->
+    Int (iconv, pad, prec, concat_fmt rest fmt2)
+  | Int32 (iconv, pad, prec, rest) ->
+    Int32 (iconv, pad, prec, concat_fmt rest fmt2)
+  | Nativeint (iconv, pad, prec, rest) ->
+    Nativeint (iconv, pad, prec, concat_fmt rest fmt2)
+  | Int64 (iconv, pad, prec, rest) ->
+    Int64 (iconv, pad, prec, concat_fmt rest fmt2)
+  | Float (fconv, pad, prec, rest) ->
+    Float (fconv, pad, prec, concat_fmt rest fmt2)
+
+  | Char (rest) ->
+    Char (concat_fmt rest fmt2)
+  | Caml_char rest ->
+    Caml_char (concat_fmt rest fmt2)
+  | Bool rest ->
+    Bool (concat_fmt rest fmt2)
+  | Alpha rest ->
+    Alpha (concat_fmt rest fmt2)
+  | Theta rest ->
+    Theta (concat_fmt rest fmt2)
+  | Custom (arity, f, rest) ->
+    Custom (arity, f, concat_fmt rest fmt2)
+  | Reader rest ->
+    Reader (concat_fmt rest fmt2)
+  | Flush rest ->
+    Flush (concat_fmt rest fmt2)
+
+  | String_literal (str, rest) ->
+    String_literal (str, concat_fmt rest fmt2)
+  | Char_literal (chr, rest) ->
+    Char_literal   (chr, concat_fmt rest fmt2)
+
+  | Format_arg (pad, fmtty, rest) ->
+    Format_arg   (pad, fmtty, concat_fmt rest fmt2)
+  | Format_subst (pad, fmtty, rest) ->
+    Format_subst (pad, fmtty, concat_fmt rest fmt2)
+
+  | Scan_char_set (width_opt, char_set, rest) ->
+    Scan_char_set (width_opt, char_set, concat_fmt rest fmt2)
+  | Scan_get_counter (counter, rest) ->
+    Scan_get_counter (counter, concat_fmt rest fmt2)
+  | Scan_next_char (rest) ->
+    Scan_next_char (concat_fmt rest fmt2)
+  | Ignored_param (ign, rest) ->
+    Ignored_param (ign, concat_fmt rest fmt2)
+
+  | Formatting_lit (fmting_lit, rest) ->
+    Formatting_lit (fmting_lit, concat_fmt rest fmt2)
+  | Formatting_gen (fmting_gen, rest) ->
+    Formatting_gen (fmting_gen, concat_fmt rest fmt2)
+
+  | End_of_format ->
+    fmt2
diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli
new file mode 100644
index 00000000..aba9f6f4
--- /dev/null
+++ b/stdlib/camlinternalFormatBasics.mli
@@ -0,0 +1,325 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                          Benoit Vaugon, ENSTA                          *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* No comments, OCaml stdlib internal use only. *)
+
+type padty = Left | Right | Zeros
+
+type int_conv =
+  | Int_d | Int_pd | Int_sd | Int_i | Int_pi | Int_si
+  | Int_x | Int_Cx | Int_X | Int_CX | Int_o | Int_Co | Int_u
+
+type float_conv =
+  | Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se
+  | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg
+  | Float_G | Float_pG | Float_sG | Float_F
+  | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH
+
+type char_set = string
+
+type counter = Line_counter | Char_counter | Token_counter
+
+type ('a, 'b) padding =
+  | No_padding  : ('a, 'a) padding
+  | Lit_padding : padty * int -> ('a, 'a) padding
+  | Arg_padding : padty -> (int -> 'a, 'a) padding
+
+type pad_option = int option
+
+type ('a, 'b) precision =
+  | No_precision : ('a, 'a) precision
+  | Lit_precision : int -> ('a, 'a) precision
+  | Arg_precision : (int -> 'a, 'a) precision
+
+type prec_option = int option
+
+type ('a, 'b, 'c) custom_arity =
+  | Custom_zero : ('a, string, 'a) custom_arity
+  | Custom_succ : ('a, 'b, 'c) custom_arity ->
+    ('a, 'x -> 'b, 'x -> 'c) custom_arity
+
+type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
+
+type formatting_lit =
+  | Close_box
+  | Close_tag
+  | Break of string * int * int
+  | FFlush
+  | Force_newline
+  | Flush_newline
+  | Magic_size of string * int
+  | Escaped_at
+  | Escaped_percent
+  | Scan_indic of char
+
+type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
+  | Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+    ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
+  | Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+    ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
+
+and ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
+    ('a, 'b, 'c, 'd, 'e, 'f,
+     'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel
+and ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+   'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel =
+| Char_ty :                                                 (* %c  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| String_ty :                                               (* %s  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (string -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     string -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Int_ty :                                                  (* %d  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (int -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     int -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Int32_ty :                                                (* %ld *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (int32 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     int32 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Nativeint_ty :                                            (* %nd *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (nativeint -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     nativeint -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Int64_ty :                                                (* %Ld *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (int64 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     int64 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Float_ty :                                                (* %f  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (float -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     float -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Bool_ty :                                                 (* %B  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (bool -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     bool -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Format_arg_ty :                                           (* %{...%} *)
+    ('g, 'h, 'i, 'j, 'k, 'l) fmtty *
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Format_subst_ty :                                         (* %(...%) *)
+    ('g, 'h, 'i, 'j, 'k, 'l,
+     'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel *
+    ('g, 'h, 'i, 'j, 'k, 'l,
+     'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel *
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1,
+     ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
+
+(* Printf and Format specific constructors. *)
+| Alpha_ty :                                                (* %a  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (('b1 -> 'x -> 'c1) -> 'x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     ('b2 -> 'x -> 'c2) -> 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Theta_ty :                                                (* %t  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    (('b1 -> 'c1) -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     ('b2 -> 'c2) -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+| Any_ty :                                         (* Used for custom formats *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    ('x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
+
+(* Scanf specific constructor. *)
+| Reader_ty :                                               (* %r  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    ('x -> 'a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
+     'x -> 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
+| Ignored_reader_ty :                                       (* %_r  *)
+    ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+    ('a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
+     'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
+
+| End_of_fmtty :
+    ('f1, 'b1, 'c1, 'd1, 'd1, 'f1,
+     'f2, 'b2, 'c2, 'd2, 'd2, 'f2) fmtty_rel
+
+(**)
+
+(** List of format elements. *)
+and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
+| Char :                                                   (* %c *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Caml_char :                                              (* %C *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| String :                                                 (* %s *)
+    ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Caml_string :                                            (* %S *)
+    ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Int :                                                    (* %[dixXuo] *)
+    int_conv * ('x, 'y) padding * ('y, int -> 'a) precision *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Int32 :                                                  (* %l[dixXuo] *)
+    int_conv * ('x, 'y) padding * ('y, int32 -> 'a) precision *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Nativeint :                                              (* %n[dixXuo] *)
+    int_conv * ('x, 'y) padding * ('y, nativeint -> 'a) precision *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Int64 :                                                  (* %L[dixXuo] *)
+    int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Float :                                                  (* %[feEgGF] *)
+    float_conv * ('x, 'y) padding * ('y, float -> 'a) precision *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
+| Bool :                                                   (* %[bB] *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Flush :                                                  (* %! *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+| String_literal :                                         (* abc *)
+    string * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt
+| Char_literal :                                           (* x *)
+    char * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+| Format_arg :                                             (* %{...%} *)
+    pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Format_subst :                                           (* %(...%) *)
+    pad_option *
+    ('g, 'h, 'i, 'j, 'k, 'l,
+     'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel *
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt
+
+(* Printf and Format specific constructor. *)
+| Alpha :                                                  (* %a *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (('b -> 'x -> 'c) -> 'x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Theta :                                                  (* %t *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (('b -> 'c) -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+
+(* Format specific constructor: *)
+| Formatting_lit :                                         (* @_ *)
+    formatting_lit * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt
+| Formatting_gen :                                             (* @_ *)
+    ('a1, 'b, 'c, 'd1, 'e1, 'f1) formatting_gen *
+    ('f1, 'b, 'c, 'e1, 'e2, 'f2) fmt -> ('a1, 'b, 'c, 'd1, 'e2, 'f2) fmt
+
+(* Scanf specific constructors: *)
+| Reader :                                                 (* %r *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x -> 'a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmt
+| Scan_char_set :                                          (* %[...] *)
+    pad_option * char_set * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (string -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Scan_get_counter :                                       (* %[nlNL] *)
+    counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Scan_next_char :                                         (* %0c *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  (* %0c behaves as %c for printing, but when scanning it does not
+     consume the character from the input stream *)
+| Ignored_param :                                          (* %_ *)
+    ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+(* Custom printing format *)
+| Custom :
+    ('a, 'x, 'y) custom_arity * (unit -> 'x) * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    ('y, 'b, 'c, 'd, 'e, 'f) fmt
+
+| End_of_format :
+      ('f, 'b, 'c, 'e, 'e, 'f) fmt
+
+and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
+  | Ignored_char :
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_caml_char :
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_string :
+      pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_caml_string :
+      pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_int :
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_int32 :
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_nativeint :
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_int64 :
+      int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_float :
+      pad_option * prec_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_bool :
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_format_arg :
+      pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty ->
+        ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_format_subst :
+      pad_option * ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+        ('a, 'b, 'c, 'd, 'e, 'f) ignored
+  | Ignored_reader :
+      ('a, 'b, 'c, ('b -> 'x) -> 'd, 'd, 'a) ignored
+  | Ignored_scan_char_set :
+      pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_scan_get_counter :
+      counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_scan_next_char :
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+
+and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+  Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
+
+val concat_fmtty :
+  ('g1, 'b1, 'c1, 'j1, 'd1, 'a1,
+   'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel ->
+  ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
+   'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
+  ('g1, 'b1, 'c1, 'j1, 'e1, 'f1,
+   'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
+
+val erase_rel :
+  ('a, 'b, 'c, 'd, 'e, 'f,
+   'g, 'h, 'i, 'j, 'k, 'l) fmtty_rel -> ('a, 'b, 'c, 'd, 'e, 'f) fmtty
+
+val concat_fmt :
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    ('f, 'b, 'c, 'e, 'g, 'h) fmt ->
+    ('a, 'b, 'c, 'd, 'g, 'h) fmt
diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
new file mode 100644
index 00000000..f64be62e
--- /dev/null
+++ b/stdlib/camlinternalLazy.ml
@@ -0,0 +1,65 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Internals of forcing lazy values. *)
+
+exception Undefined
+
+let raise_undefined = Obj.repr (fun () -> raise Undefined)
+
+(* Assume [blk] is a block with tag lazy *)
+let force_lazy_block (blk : 'arg lazy_t) =
+  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
+  Obj.set_field (Obj.repr blk) 0 raise_undefined;
+  try
+    let result = closure () in
+    (* do set_field BEFORE set_tag *)
+    Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
+    Obj.set_tag (Obj.repr blk) Obj.forward_tag;
+    result
+  with e ->
+    Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e));
+    raise e
+
+
+(* Assume [blk] is a block with tag lazy *)
+let force_val_lazy_block (blk : 'arg lazy_t) =
+  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
+  Obj.set_field (Obj.repr blk) 0 raise_undefined;
+  let result = closure () in
+  (* do set_field BEFORE set_tag *)
+  Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
+  Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
+  result
+
+
+(* [force] is not used, since [Lazy.force] is declared as a primitive
+   whose code inlines the tag tests of its argument.  This function is
+   here for the sake of completeness, and for debugging purpose. *)
+
+let force (lzv : 'arg lazy_t) =
+  let x = Obj.repr lzv in
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
+  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  else force_lazy_block lzv
+
+
+let force_val (lzv : 'arg lazy_t) =
+  let x = Obj.repr lzv in
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
+  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  else force_val_lazy_block lzv
diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli
new file mode 100644
index 00000000..101535cd
--- /dev/null
+++ b/stdlib/camlinternalLazy.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Run-time support for lazy values.
+    All functions in this module are for system use only, not for the
+    casual user. *)
+
+exception Undefined
+
+val force_lazy_block : 'a lazy_t -> 'a
+
+val force_val_lazy_block : 'a lazy_t -> 'a
+
+val force : 'a lazy_t -> 'a
+val force_val : 'a lazy_t -> 'a
diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
new file mode 100644
index 00000000..9e261926
--- /dev/null
+++ b/stdlib/camlinternalMod.ml
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type shape =
+  | Function
+  | Lazy
+  | Class
+  | Module of shape array
+  | Value of Obj.t
+
+let overwrite o n =
+  assert (Obj.size o >= Obj.size n);
+  for i = 0 to Obj.size n - 1 do
+    Obj.set_field o i (Obj.field n i)
+  done
+
+let rec init_mod loc shape =
+  match shape with
+  | Function ->
+      (* Two code pointer words (curried and full application), arity
+         and eight environment entries makes 11 words. *)
+      let closure = Obj.new_block Obj.closure_tag 11 in
+      let template =
+        Obj.repr (fun _ -> raise (Undefined_recursive_module loc))
+      in
+      overwrite closure template;
+      closure
+  | Lazy ->
+      Obj.repr (lazy (raise (Undefined_recursive_module loc)))
+  | Class ->
+      Obj.repr (CamlinternalOO.dummy_class loc)
+  | Module comps ->
+      Obj.repr (Array.map (init_mod loc) comps)
+  | Value v ->
+      v
+
+let rec update_mod shape o n =
+  match shape with
+  | Function ->
+      if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o
+      then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end
+      else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
+  | Lazy ->
+      if Obj.tag n = Obj.lazy_tag then
+        Obj.set_field o 0 (Obj.field n 0)
+      else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *)
+        Obj.set_tag o Obj.forward_tag;
+        Obj.set_field o 0 (Obj.field n 0)
+      end else begin
+        (* forwarding pointer was shortcut by GC *)
+        Obj.set_tag o Obj.forward_tag;
+        Obj.set_field o 0 n
+      end
+  | Class ->
+      assert (Obj.tag n = 0 && Obj.size n = 4);
+      overwrite o n
+  | Module comps ->
+      assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
+      for i = 0 to Array.length comps - 1 do
+        update_mod comps.(i) (Obj.field o i) (Obj.field n i)
+      done
+  | Value _ -> () (* the value is already there *)
diff --git a/stdlib/camlinternalMod.mli b/stdlib/camlinternalMod.mli
new file mode 100644
index 00000000..cf7ffb09
--- /dev/null
+++ b/stdlib/camlinternalMod.mli
@@ -0,0 +1,28 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Run-time support for recursive modules.
+    All functions in this module are for system use only, not for the
+    casual user. *)
+
+type shape =
+  | Function
+  | Lazy
+  | Class
+  | Module of shape array
+  | Value of Obj.t
+
+val init_mod: string * int * int -> shape -> Obj.t
+val update_mod: shape -> Obj.t -> Obj.t -> unit
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
new file mode 100644
index 00000000..0188c148
--- /dev/null
+++ b/stdlib/camlinternalOO.ml
@@ -0,0 +1,613 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Obj
+
+(**** Object representation ****)
+
+external set_id: 'a -> 'a = "caml_set_oo_id" [@@noalloc]
+
+(**** Object copy ****)
+
+let copy o =
+  let o = (Obj.obj (Obj.dup (Obj.repr o))) in
+  set_id o
+
+(**** Compression options ****)
+(* Parameters *)
+type params = {
+    mutable compact_table : bool;
+    mutable copy_parent : bool;
+    mutable clean_when_copying : bool;
+    mutable retry_count : int;
+    mutable bucket_small_size : int
+  }
+
+let params = {
+  compact_table = true;
+  copy_parent = true;
+  clean_when_copying = true;
+  retry_count = 3;
+  bucket_small_size = 16
+}
+
+(**** Parameters ****)
+
+let initial_object_size = 2
+
+(**** Items ****)
+
+type item = DummyA | DummyB | DummyC of int
+let _ = [DummyA; DummyB; DummyC 0] (* to avoid warnings *)
+
+let dummy_item = (magic () : item)
+
+(**** Types ****)
+
+type tag
+type label = int
+type closure = item
+type t = DummyA | DummyB | DummyC of int
+let _ = [DummyA; DummyB; DummyC 0] (* to avoid warnings *)
+
+type obj = t array
+external ret : (obj -> 'a) -> closure = "%identity"
+
+(**** Labels ****)
+
+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 ****)
+
+module Vars =
+  Map.Make(struct type t = string let compare (x:t) y = compare x y end)
+type vars = int Vars.t
+
+module Meths =
+  Map.Make(struct type t = string let compare (x:t) y = compare x y end)
+type meths = label Meths.t
+module Labs =
+  Map.Make(struct type t = label let compare (x:t) y = compare x y end)
+type labs = bool Labs.t
+
+(* The compiler assumes that the first field of this structure is [size]. *)
+type table =
+ { mutable size: int;
+   mutable methods: closure array;
+   mutable methods_by_name: meths;
+   mutable methods_by_label: labs;
+   mutable previous_states:
+     (meths * labs * (label * item) list * vars *
+      label list * string list) list;
+   mutable hidden_meths: (label * item) list;
+   mutable vars: vars;
+   mutable initializers: (obj -> unit) list }
+
+let dummy_table =
+  { methods = [| dummy_item |];
+    methods_by_name = Meths.empty;
+    methods_by_label = Labs.empty;
+    previous_states = [];
+    hidden_meths = [];
+    vars = Vars.empty;
+    initializers = [];
+    size = 0 }
+
+let table_count = ref 0
+
+(* dummy_met should be a pointer, so use an atom *)
+let dummy_met : item = obj (Obj.new_block 0 0)
+(* if debugging is needed, this could be a good idea: *)
+(* let dummy_met () = failwith "Undefined method" *)
+
+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;
+  let len = Array.length pub_labels in
+  let methods = Array.make (len*2+2) dummy_met 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 = [];
+    hidden_meths = [];
+    vars = Vars.empty;
+    initializers = [];
+    size = initial_object_size }
+
+let resize array new_size =
+  let old_size = Array.length array.methods in
+  if new_size > old_size then begin
+    let new_buck = Array.make new_size dummy_met in
+    Array.blit array.methods 0 new_buck 0 old_size;
+    array.methods <- new_buck
+ end
+
+let put array label element =
+  resize array (label + 1);
+  array.methods.(label) <- element
+
+(**** Classes ****)
+
+let method_count = ref 0
+let inst_var_count = ref 0
+
+(* 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_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
+    put table label element
+  else
+    table.hidden_meths <- (label, element) :: table.hidden_meths
+
+let get_method table label =
+  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 <-
+     (table.methods_by_name, table.methods_by_label, table.hidden_meths,
+      table.vars, virt_meth_labs, vars)
+     :: table.previous_states;
+  table.vars <-
+    Vars.fold
+      (fun lab info tvars ->
+        if List.mem lab vars then Vars.add lab info tvars else tvars)
+      table.vars Vars.empty;
+  let by_name = ref Meths.empty in
+  let by_label = ref Labs.empty in
+  List.iter2
+    (fun met label ->
+       by_name := Meths.add met label !by_name;
+       by_label :=
+          Labs.add label
+            (try Labs.find label table.methods_by_label with Not_found -> true)
+            !by_label)
+    concr_meths concr_meth_labs;
+  List.iter2
+    (fun met label ->
+       by_name := Meths.add met label !by_name;
+       by_label := Labs.add label false !by_label)
+    virt_meths virt_meth_labs;
+  table.methods_by_name <- !by_name;
+  table.methods_by_label <- !by_label;
+  table.hidden_meths <-
+     List.fold_right
+       (fun ((lab, _) as met) hm ->
+          if List.mem lab virt_meth_labs then hm else met::hm)
+       table.hidden_meths
+       []
+
+let widen table =
+  let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) =
+    List.hd table.previous_states
+  in
+  table.previous_states <- List.tl table.previous_states;
+  table.vars <-
+     List.fold_left
+       (fun s v -> Vars.add v (Vars.find v table.vars) s)
+       saved_vars vars;
+  table.methods_by_name <- by_name;
+  table.methods_by_label <- by_label;
+  table.hidden_meths <-
+     List.fold_right
+       (fun ((lab, _) as met) hm ->
+          if List.mem lab virt_meths then hm else met::hm)
+       table.hidden_meths
+       saved_hidden_meths
+
+let new_slot table =
+  let index = table.size in
+  table.size <- index + 1;
+  index
+
+let new_variable table name =
+  try Vars.find name table.vars
+  with Not_found ->
+    let index = new_slot table in
+    if name <> "" then table.vars <- Vars.add name index table.vars;
+    index
+
+let to_array arr =
+  if arr = Obj.magic 0 then [||] else arr
+
+let new_methods_variables table meths vals =
+  let meths = to_array meths in
+  let nmeths = Array.length meths and nvals = Array.length vals in
+  let res = Array.make (nmeths + nvals) 0 in
+  for i = 0 to nmeths - 1 do
+    res.(i) <- get_method_label table meths.(i)
+  done;
+  for i = 0 to nvals - 1 do
+    res.(i+nmeths) <- new_variable table vals.(i)
+  done;
+  res
+
+let get_variable table name =
+  try Vars.find name table.vars with Not_found -> assert false
+
+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 (x:t) y = compare x y 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 =
+  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;
+  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;
+  Array.concat
+    [[| repr init |];
+     magic (Array.map (get_variable cla) (to_array vals) : int array);
+     Array.map
+       (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
+       (to_array concr_meths) ]
+
+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
+
+let dummy_class loc =
+  let undef = fun _ -> raise (Undefined_recursive_module loc) in
+  (Obj.magic undef, undef, undef, Obj.repr 0)
+
+(**** Objects ****)
+
+let create_object table =
+  (* XXX Appel de [obj_block] | Call to [obj_block]  *)
+  let obj = Obj.new_block Obj.object_tag table.size in
+  (* XXX Appel de [caml_modify] | Call to [caml_modify] *)
+  Obj.set_field obj 0 (Obj.repr table.methods);
+  Obj.obj (set_id obj)
+
+let create_object_opt obj_0 table =
+  if (Obj.magic obj_0 : bool) then obj_0 else begin
+    (* XXX Appel de [obj_block] | Call to [obj_block]  *)
+    let obj = Obj.new_block Obj.object_tag table.size in
+    (* XXX Appel de [caml_modify] | Call to [caml_modify] *)
+    Obj.set_field obj 0 (Obj.repr table.methods);
+    Obj.obj (set_id obj)
+  end
+
+let rec iter_f obj =
+  function
+    []   -> ()
+  | f::l -> f obj; iter_f obj l
+
+let run_initializers obj table =
+  let inits = table.initializers in
+  if inits <> [] then
+    iter_f obj inits
+
+let run_initializers_opt obj_0 obj table =
+  if (Obj.magic obj_0 : bool) then obj else begin
+    let inits = table.initializers in
+    if inits <> [] then iter_f obj inits;
+    obj
+  end
+
+let create_object_and_run_initializers obj_0 table =
+  if (Obj.magic obj_0 : bool) then obj_0 else begin
+    let obj = create_object table in
+    run_initializers obj table;
+    obj
+  end
+
+(* 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 {key : closure; mutable data: tables; mutable next: tables}
+
+let set_data tables v = match tables with
+  | Empty -> assert false
+  | Cons tables -> tables.data <- v
+let set_next tables v = match tables with
+  | Empty -> assert false
+  | Cons tables -> tables.next <- v
+let get_key = function
+  | Empty -> assert false
+  | Cons tables -> tables.key
+let get_data = function
+  | Empty -> assert false
+  | Cons tables -> tables.data
+let get_next = function
+  | Empty -> assert false
+  | Cons tables -> tables.next
+
+let build_path n keys tables =
+  let res = Cons {key = Obj.magic 0; data = Empty; next = Empty} in
+  let r = ref res in
+  for i = 0 to n do
+    r := Cons {key = keys.(i); data = !r; next = Empty}
+  done;
+  set_data tables !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:tables) =
+    if get_key tables == key then
+      match get_data tables with
+      | Empty -> assert false
+      | Cons _ as tables_data ->
+          lookup_keys (i-1) keys tables_data
+    else
+      match get_next tables with
+      | Cons _ as next -> lookup_key next
+      | Empty ->
+          let next : tables = Cons {key; data = Empty; next = Empty} in
+          set_next tables next;
+          build_path (i-1) keys next
+  in
+  lookup_key tables
+
+let lookup_tables root keys =
+  match get_data root with
+  | Cons _ as root_data ->
+    lookup_keys (Array.length keys - 1) keys root_data
+  | Empty ->
+    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() in let 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() in let x = next() in app_const f x
+  | AppVar   -> let f = next() in let n = next () in app_var f n
+  | AppEnv   ->
+      let f = next() in  let e = next() in let n = next() in
+      app_env f e n
+  | AppMeth  -> let f = next() in let n = next () in app_meth f n
+  | AppConstConst ->
+      let f = next() in let x = next() in let y = next() in
+      app_const_const f x y
+  | AppConstVar ->
+      let f = next() in let x = next() in let n = next() in
+      app_const_var f x n
+  | AppConstEnv ->
+      let f = next() in let x = next() in let e = next () in let n = next() in
+      app_const_env f x e n
+  | AppConstMeth ->
+      let f = next() in let x = next() in let n = next() in
+      app_const_meth f x n
+  | AppVarConst ->
+      let f = next() in let n = next() in let x = next() in
+      app_var_const f n x
+  | AppEnvConst ->
+      let f = next() in let e = next () in let n = next() in let x = next() in
+      app_env_const f e n x
+  | AppMethConst ->
+      let f = next() in let n = next() in let x = next() in
+      app_meth_const f n x
+  | MethAppConst ->
+      let n = next() in let x = next() in meth_app_const n x
+  | MethAppVar ->
+      let n = next() in let m = next() in meth_app_var n m
+  | MethAppEnv ->
+      let n = next() in let e = next() in let m = next() in
+      meth_app_env n e m
+  | MethAppMeth ->
+      let n = next() in let m = next() in meth_app_meth n m
+  | SendConst ->
+      let m = next() in let x = next() in send_const m x (new_cache table)
+  | SendVar ->
+      let m = next() in let n = next () in send_var m n (new_cache table)
+  | SendEnv ->
+      let m = next() in let e = next() in let n = next() in
+      send_env m e n (new_cache table)
+  | SendMeth ->
+      let m = next() in let 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 in let i = ref 0 in
+  while !i < len do
+    let label = methods.(!i) in let clo = method_impl table i methods in
+    set_method table label clo;
+    incr i
+  done
+
+(**** Statistics ****)
+
+type stats =
+  { classes: int; methods: int; inst_vars: int; }
+
+let stats () =
+  { classes = !table_count;
+    methods = !method_count; inst_vars = !inst_var_count; }
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
new file mode 100644
index 00000000..7c7e0013
--- /dev/null
+++ b/stdlib/camlinternalOO.mli
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Run-time support for objects and classes.
+    All functions in this module are for system use only, not for the
+    casual user. *)
+
+(** {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_methods_variables :
+    table -> string array -> string array -> label array
+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 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 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 array
+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
+val dummy_class :
+    string * int * int ->
+    (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+
+(** {6 Objects} *)
+
+val copy : (< .. > as 'a) -> 'a
+val create_object : table -> obj
+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
+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;
+    mutable clean_when_copying : bool;
+    mutable retry_count : int;
+    mutable bucket_small_size : int }
+
+val params : params
+
+(** {6 Statistics} *)
+
+type stats =
+  { classes : int;
+    methods : int;
+    inst_vars : int }
+val stats : unit -> stats
diff --git a/stdlib/char.ml b/stdlib/char.ml
new file mode 100644
index 00000000..fb7660d0
--- /dev/null
+++ b/stdlib/char.ml
@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Character operations *)
+
+external code: char -> int = "%identity"
+external unsafe_chr: int -> char = "%identity"
+
+let chr n =
+  if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n
+
+external bytes_create: int -> bytes = "caml_create_bytes"
+external bytes_unsafe_set : bytes -> int -> char -> unit
+                           = "%bytes_unsafe_set"
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
+
+let escaped = function
+  | '\'' -> "\\'"
+  | '\\' -> "\\\\"
+  | '\n' -> "\\n"
+  | '\t' -> "\\t"
+  | '\r' -> "\\r"
+  | '\b' -> "\\b"
+  | ' ' .. '~' as c ->
+      let s = bytes_create 1 in
+      bytes_unsafe_set s 0 c;
+      unsafe_to_string s
+  | c ->
+      let n = code c in
+      let s = bytes_create 4 in
+      bytes_unsafe_set s 0 '\\';
+      bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+      bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+      bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+      unsafe_to_string s
+
+let lowercase c =
+  if (c >= 'A' && c <= 'Z')
+  || (c >= '\192' && c <= '\214')
+  || (c >= '\216' && c <= '\222')
+  then unsafe_chr(code c + 32)
+  else c
+
+let uppercase c =
+  if (c >= 'a' && c <= 'z')
+  || (c >= '\224' && c <= '\246')
+  || (c >= '\248' && c <= '\254')
+  then unsafe_chr(code c - 32)
+  else c
+
+let lowercase_ascii c =
+  if (c >= 'A' && c <= 'Z')
+  then unsafe_chr(code c + 32)
+  else c
+
+let uppercase_ascii c =
+  if (c >= 'a' && c <= 'z')
+  then unsafe_chr(code c - 32)
+  else c
+
+type t = char
+
+let compare c1 c2 = code c1 - code c2
+let equal (c1: t) (c2: t) = compare c1 c2 = 0
diff --git a/stdlib/char.mli b/stdlib/char.mli
new file mode 100644
index 00000000..5d5fc033
--- /dev/null
+++ b/stdlib/char.mli
@@ -0,0 +1,72 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Character operations. *)
+
+external code : char -> int = "%identity"
+(** Return the ASCII code of the argument. *)
+
+val chr : int -> char
+(** Return the character with the given ASCII code.
+   Raise [Invalid_argument "Char.chr"] if the argument is
+   outside the range 0--255. *)
+
+val escaped : char -> string
+(** Return a string representing the given character,
+    with special characters escaped following the lexical conventions
+    of OCaml.
+    All characters outside the ASCII printable range (32..126) are
+    escaped, as well as backslash, double-quote, and single-quote. *)
+
+val lowercase : char -> char
+  [@@ocaml.deprecated "Use Char.lowercase_ascii instead."]
+(** Convert the given character to its equivalent lowercase character,
+   using the ISO Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase : char -> char
+  [@@ocaml.deprecated "Use Char.uppercase_ascii instead."]
+(** Convert the given character to its equivalent uppercase character,
+   using the ISO Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val lowercase_ascii : char -> char
+(** Convert the given character to its equivalent lowercase character,
+   using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val uppercase_ascii : char -> char
+(** Convert the given character to its equivalent uppercase character,
+   using the US-ASCII character set.
+   @since 4.03.0 *)
+
+type t = char
+(** An alias for the type of characters. *)
+
+val compare: t -> t -> int
+(** The comparison function for characters, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [Char] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equal function for chars.
+    @since 4.03.0 *)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_chr : int -> char = "%identity"
diff --git a/stdlib/complex.ml b/stdlib/complex.ml
new file mode 100644
index 00000000..4df53cba
--- /dev/null
+++ b/stdlib/complex.ml
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Complex numbers *)
+
+type t = { re: float; im: float }
+
+let zero = { re = 0.0; im = 0.0 }
+let one = { re = 1.0; im = 0.0 }
+let i = { re = 0.0; im = 1.0 }
+
+let add x y = { re = x.re +. y.re; im = x.im +. y.im }
+
+let sub x y = { re = x.re -. y.re; im = x.im -. y.im }
+
+let neg x = { re = -. x.re; im = -. x.im }
+
+let conj x = { re = x.re; im = -. x.im }
+
+let mul x y = { re = x.re *. y.re -. x.im *. y.im;
+                im = x.re *. y.im +. x.im *. y.re }
+
+let div x y =
+  if abs_float y.re >= abs_float y.im then
+    let r = y.im /. y.re in
+    let d = y.re +. r *. y.im in
+    { re = (x.re +. r *. x.im) /. d;
+      im = (x.im -. r *. x.re) /. d }
+  else
+    let r = y.re /. y.im in
+    let d = y.im +. r *. y.re in
+    { re = (r *. x.re +. x.im) /. d;
+      im = (r *. x.im -. x.re) /. d }
+
+let inv x = div one x
+
+let norm2 x = x.re *. x.re +. x.im *. x.im
+
+let norm x =
+  (* Watch out for overflow in computing re^2 + im^2 *)
+  let r = abs_float x.re and i = abs_float x.im in
+  if r = 0.0 then i
+  else if i = 0.0 then r
+  else if r >= i then
+    let q = i /. r in r *. sqrt(1.0 +. q *. q)
+  else
+    let q = r /. i in i *. sqrt(1.0 +. q *. q)
+
+let arg x = atan2 x.im x.re
+
+let polar n a = { re = cos a *. n; im = sin a *. n }
+
+let sqrt x =
+  if x.re = 0.0 && x.im = 0.0 then { re = 0.0; im = 0.0 }
+  else begin
+    let r = abs_float x.re and i = abs_float x.im in
+    let w =
+      if r >= i then begin
+        let q = i /. r in
+        sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q)))
+      end else begin
+        let q = r /. i in
+        sqrt(i) *. sqrt(0.5 *. (q +. sqrt(1.0 +. q *. q)))
+      end in
+    if x.re >= 0.0
+    then { re = w;  im = 0.5 *. x.im /. w }
+    else { re = 0.5 *. i /. w;  im = if x.im >= 0.0 then w else -. w }
+  end
+
+let exp x =
+  let e = exp x.re in { re = e *. cos x.im; im = e *. sin x.im }
+
+let log x = { re = log (norm x); im = atan2 x.im x.re }
+
+let pow x y = exp (mul y (log x))
diff --git a/stdlib/complex.mli b/stdlib/complex.mli
new file mode 100644
index 00000000..2080eccc
--- /dev/null
+++ b/stdlib/complex.mli
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Complex numbers.
+
+    This module provides arithmetic operations on complex numbers.
+    Complex numbers are represented by their real and imaginary parts
+    (cartesian representation).  Each part is represented by a
+    double-precision floating-point number (type [float]).   *)
+
+type t = { re: float; im: float }
+(** The type of complex numbers.  [re] is the real part and [im] the
+    imaginary part. *)
+
+val zero: t
+(** The complex number [0]. *)
+
+val one: t
+(** The complex number [1]. *)
+
+val i: t
+(** The complex number [i]. *)
+
+val neg: t -> t
+(** Unary negation. *)
+
+val conj: t -> t
+(** Conjugate: given the complex [x + i.y], returns [x - i.y]. *)
+
+val add: t -> t -> t
+(** Addition *)
+
+val sub: t -> t -> t
+(** Subtraction *)
+
+val mul: t -> t -> t
+(** Multiplication *)
+
+val inv: t -> t
+(** Multiplicative inverse ([1/z]). *)
+
+val div: t -> t -> t
+(** Division *)
+
+val sqrt: t -> t
+(** Square root.  The result [x + i.y] is such that [x > 0] or
+    [x = 0] and [y >= 0].
+    This function has a discontinuity along the negative real axis. *)
+
+val norm2: t -> float
+(** Norm squared: given [x + i.y], returns [x^2 + y^2]. *)
+
+val norm: t -> float
+(** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *)
+
+val arg: t -> float
+(** Argument.  The argument of a complex number is the angle
+    in the complex plane between the positive real axis and a line
+    passing through zero and the number.  This angle ranges from
+    [-pi] to [pi].  This function has a discontinuity along the
+    negative real axis. *)
+
+val polar: float -> float -> t
+(** [polar norm arg] returns the complex having norm [norm]
+    and argument [arg]. *)
+
+val exp: t -> t
+(** Exponentiation.  [exp z] returns [e] to the [z] power. *)
+
+val log: t -> t
+(** Natural logarithm (in base [e]). *)
+
+val pow: t -> t -> t
+(** Power function.  [pow z1 z2] returns [z1] to the [z2] power. *)
diff --git a/stdlib/digest.ml b/stdlib/digest.ml
new file mode 100644
index 00000000..408194b5
--- /dev/null
+++ b/stdlib/digest.ml
@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Message digest (MD5) *)
+
+type t = string
+
+let compare = String.compare
+let equal = String.equal
+
+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)
+
+let bytes b = string (Bytes.unsafe_to_string b)
+
+let substring str ofs len =
+  if ofs < 0 || len < 0 || ofs > String.length str - len
+  then invalid_arg "Digest.substring"
+  else unsafe_string str ofs len
+
+let subbytes b ofs len = substring (Bytes.unsafe_to_string b) ofs len
+
+let file filename =
+  let ic = open_in_bin filename in
+  match channel ic (-1) with
+    | d -> close_in ic; d
+    | exception e -> close_in ic; raise e
+
+let output chan digest =
+  output_string chan digest
+
+let input chan = really_input_string chan 16
+
+let char_hex n =
+  Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10))
+
+let to_hex d =
+  if String.length d <> 16 then invalid_arg "Digest.to_hex";
+  let result = Bytes.create 32 in
+  for i = 0 to 15 do
+    let x = Char.code d.[i] in
+    Bytes.unsafe_set result (i*2) (char_hex (x lsr 4));
+    Bytes.unsafe_set result (i*2+1) (char_hex (x land 0x0f));
+  done;
+  Bytes.unsafe_to_string result
+
+let from_hex s =
+  if String.length s <> 32 then invalid_arg "Digest.from_hex";
+  let digit c =
+    match c with
+    | '0'..'9' -> Char.code c - Char.code '0'
+    | 'A'..'F' -> Char.code c - Char.code 'A' + 10
+    | 'a'..'f' -> Char.code c - Char.code 'a' + 10
+    | _ -> raise (Invalid_argument "Digest.from_hex")
+  in
+  let byte i = digit s.[i] lsl 4 + digit s.[i+1] in
+  let result = Bytes.create 16 in
+  for i = 0 to 15 do
+    Bytes.set result i (Char.chr (byte (2 * i)));
+  done;
+  Bytes.unsafe_to_string result
diff --git a/stdlib/digest.mli b/stdlib/digest.mli
new file mode 100644
index 00000000..2c9bebc5
--- /dev/null
+++ b/stdlib/digest.mli
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** MD5 message digest.
+
+   This module provides functions to compute 128-bit 'digests' of
+   arbitrary-length strings or files. The digests are of cryptographic
+   quality: it is very hard, given a digest, to forge a string having
+   that digest. The algorithm used is MD5. This module should not be
+   used for secure and sensitive cryptographic applications. For these
+   kind of applications more recent and stronger cryptographic
+   primitives should be used instead.
+*)
+
+type t = string
+(** The type of digests: 16-character strings. *)
+
+val compare : t -> t -> int
+(** The comparison function for 16-character digest, with the same
+    specification as {!Pervasives.compare} and the implementation
+    shared with {!String.compare}. Along with the type [t], this
+    function [compare] allows the module [Digest] to be passed as
+    argument to the functors {!Set.Make} and {!Map.Make}.
+    @since 4.00.0 *)
+
+val equal : t -> t -> bool
+(** The equal function for 16-character digest.
+    @since 4.03.0 *)
+
+val string : string -> t
+(** Return the digest of the given string. *)
+
+val bytes : bytes -> t
+(** Return the digest of the given byte sequence.
+    @since 4.02.0 *)
+
+val substring : string -> int -> int -> t
+(** [Digest.substring s ofs len] returns the digest of the substring
+   of [s] starting at index [ofs] and containing [len] characters. *)
+
+val subbytes : bytes -> int -> int -> t
+(** [Digest.subbytes s ofs len] returns the digest of the subsequence
+    of [s] starting at index [ofs] and containing [len] bytes.
+    @since 4.02.0 *)
+
+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
+   are read.  If [len] is negative, [Digest.channel ic len] reads
+   all characters from [ic] until end-of-file is reached and return
+   their digest. *)
+
+val file : string -> t
+(** Return the digest of the file whose name is given. *)
+
+val output : out_channel -> t -> unit
+(** Write a digest on the given output channel. *)
+
+val input : in_channel -> t
+(** Read a digest from the given input channel. *)
+
+val to_hex : t -> string
+(** Return the printable hexadecimal representation of the given digest.
+    Raise [Invalid_argument] if the argument is not exactly 16 bytes.
+ *)
+
+val from_hex : string -> t
+(** Convert a hexadecimal representation back into the corresponding digest.
+   Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal
+   characters.
+   @since 4.00.0 *)
diff --git a/stdlib/ephemeron.ml b/stdlib/ephemeron.ml
new file mode 100644
index 00000000..c2b3d05d
--- /dev/null
+++ b/stdlib/ephemeron.ml
@@ -0,0 +1,641 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type SeededS = sig
+  include Hashtbl.SeededS
+  val clean: 'a t -> unit
+  val stats_alive: 'a t -> Hashtbl.statistics
+    (** same as {!stats} but only count the alive bindings *)
+end
+
+module type S = sig
+  include Hashtbl.S
+  val clean: 'a t -> unit
+  val stats_alive: 'a t -> Hashtbl.statistics
+    (** same as {!stats} but only count the alive bindings *)
+end
+
+module GenHashTable = struct
+
+  type equal =
+  | ETrue | EFalse
+  | EDead (** the garbage collector reclaimed the data *)
+
+  module MakeSeeded(H: sig
+    type t
+    type 'a container
+    val create: t -> 'a -> 'a container
+    val hash: int -> t -> int
+    val equal: 'a container -> t -> equal
+    val get_data: 'a container -> 'a option
+    val get_key: 'a container -> t option
+    val set_key_data: 'a container -> t -> 'a -> unit
+    val check_key: 'a container -> bool
+  end) : SeededS with type key = H.t
+  = struct
+
+    type 'a t =
+      { mutable size: int;                  (* number of entries *)
+        mutable data: 'a bucketlist array;  (* the buckets *)
+        mutable seed: int;                  (* for randomization *)
+        initial_size: int;                  (* initial array size *)
+      }
+
+    and 'a bucketlist =
+    | Empty
+    | Cons of int (* hash of the key *) * 'a H.container * 'a bucketlist
+
+    (** the hash of the key is kept in order to test the equality of the hash
+      before the key. Same reason as for Weak.Make *)
+
+    type key = H.t
+
+    let rec power_2_above x n =
+      if x >= n then x
+      else if x * 2 > Sys.max_array_length then x
+      else power_2_above (x * 2) n
+
+    let prng = lazy (Random.State.make_self_init())
+
+    let create ?(random = (Hashtbl.is_randomized ())) initial_size =
+      let s = power_2_above 16 initial_size in
+      let seed = if random then Random.State.bits (Lazy.force prng) else 0 in
+      { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
+
+    let clear h =
+      h.size <- 0;
+      let len = Array.length h.data in
+      for i = 0 to len - 1 do
+        h.data.(i) <- Empty
+      done
+
+    let reset h =
+      let len = Array.length h.data in
+      if len = h.initial_size then
+        clear h
+      else begin
+        h.size <- 0;
+        h.data <- Array.make h.initial_size Empty
+      end
+
+    let copy h = { h with data = Array.copy h.data }
+
+    let key_index h hkey =
+      hkey land (Array.length h.data - 1)
+
+    let clean h =
+      let rec do_bucket = function
+        | Empty ->
+            Empty
+        | Cons(_, c, rest) when not (H.check_key c) ->
+            h.size <- h.size - 1;
+            do_bucket rest
+        | Cons(hkey, c, rest) ->
+            Cons(hkey, c, do_bucket rest)
+      in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        d.(i) <- do_bucket d.(i)
+      done
+
+    (** resize is the only function to do the actual cleaning of dead keys
+        (remove does it just because it could).
+
+        The goal is to:
+
+        - not resize infinitely when the actual number of alive keys is
+        bounded but keys are continuously added. That would happen if
+        this function always resize.
+        - not call this function after each addition, that would happen if this
+        function don't resize even when only one key is dead.
+
+        So the algorithm:
+        - clean the keys before resizing
+        - if the number of remaining keys is less than half the size of the
+        array, don't resize.
+        - if it is more, resize.
+
+        The second problem remains if the table reaches {!Sys.max_array_length}.
+
+    *)
+    let resize h =
+      let odata = h.data in
+      let osize = Array.length odata in
+      let nsize = osize * 2 in
+      clean h;
+      if nsize < Sys.max_array_length && h.size >= osize lsr 1 then begin
+        let ndata = Array.make nsize Empty in
+        h.data <- ndata;       (* so that key_index sees the new bucket count *)
+        let rec insert_bucket = function
+            Empty -> ()
+          | Cons(hkey, data, rest) ->
+              insert_bucket rest; (* preserve original order of elements *)
+              let nidx = key_index h hkey in
+              ndata.(nidx) <- Cons(hkey, data, ndata.(nidx)) in
+        for i = 0 to osize - 1 do
+          insert_bucket odata.(i)
+        done
+      end
+
+    let add h key info =
+      let hkey = H.hash h.seed key in
+      let i = key_index h hkey in
+      let container = H.create key info in
+      let bucket = Cons(hkey, container, h.data.(i)) in
+      h.data.(i) <- bucket;
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize h
+
+    let remove h key =
+      let hkey = H.hash h.seed key in
+      let rec remove_bucket = function
+        | Empty -> Empty
+        | Cons(hk, c, next) when hkey = hk ->
+            begin match H.equal c key with
+            | ETrue -> h.size <- h.size - 1; next
+            | EFalse -> Cons(hk, c, remove_bucket next)
+            | EDead ->
+                (* The dead key is automatically removed. It is acceptable
+                    for this function since it already removes a binding *)
+                h.size <- h.size - 1;
+                remove_bucket next
+            end
+        | Cons(hk,c,next) -> Cons(hk, c, remove_bucket next) in
+      let i = key_index h hkey in
+      h.data.(i) <- remove_bucket h.data.(i)
+
+    (** {!find} don't remove dead keys because it would be surprising for
+        the user that a read-only function mutates the state (eg. concurrent
+        access). Same for {!iter}, {!fold}, {!mem}.
+    *)
+    let rec find_rec key hkey = function
+      | Empty ->
+          raise Not_found
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue ->
+              begin match H.get_data c with
+              | None ->
+                  (* This case is not impossible because the gc can run between
+                      H.equal and H.get_data *)
+                  find_rec key hkey rest
+              | Some d -> d
+              end
+          | EFalse -> find_rec key hkey rest
+          | EDead ->
+              find_rec key hkey rest
+          end
+      | Cons(_, _, rest) ->
+          find_rec key hkey rest
+
+    let find h key =
+      let hkey = H.hash h.seed key in
+      (* TODO inline 3 iterations *)
+      find_rec key hkey (h.data.(key_index h hkey))
+
+    let rec find_rec_opt key hkey = function
+      | Empty ->
+          None
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue ->
+              begin match H.get_data c with
+              | None ->
+                  (* This case is not impossible because the gc can run between
+                      H.equal and H.get_data *)
+                  find_rec_opt key hkey rest
+              | Some _ as d -> d
+              end
+          | EFalse -> find_rec_opt key hkey rest
+          | EDead ->
+              find_rec_opt key hkey rest
+          end
+      | Cons(_, _, rest) ->
+          find_rec_opt key hkey rest
+
+    let find_opt h key =
+      let hkey = H.hash h.seed key in
+      (* TODO inline 3 iterations *)
+      find_rec_opt key hkey (h.data.(key_index h hkey))
+
+    let find_all h key =
+      let hkey = H.hash h.seed key in
+      let rec find_in_bucket = function
+      | Empty -> []
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue -> begin match H.get_data c with
+              | None ->
+                  find_in_bucket rest
+              | Some d -> d::find_in_bucket rest
+            end
+          | EFalse -> find_in_bucket rest
+          | EDead ->
+              find_in_bucket rest
+          end
+      | Cons(_, _, rest) ->
+          find_in_bucket rest in
+      find_in_bucket h.data.(key_index h hkey)
+
+
+    let replace h key info =
+      let hkey = H.hash h.seed key in
+      let rec replace_bucket = function
+        | Empty -> raise Not_found
+        | Cons(hk, c, next) when hkey = hk ->
+            begin match H.equal c key with
+            | ETrue -> H.set_key_data c key info
+            | EFalse | EDead -> replace_bucket next
+            end
+        | Cons(_,_,next) -> replace_bucket next
+      in
+      let i = key_index h hkey in
+      let l = h.data.(i) in
+      try
+        replace_bucket l
+      with Not_found ->
+        let container = H.create key info in
+        h.data.(i) <- Cons(hkey, container, l);
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize h
+
+    let mem h key =
+      let hkey = H.hash h.seed key in
+      let rec mem_in_bucket = function
+      | Empty ->
+          false
+      | Cons(hk, c, rest) when hk = hkey ->
+          begin match H.equal c key with
+          | ETrue -> true
+          | EFalse | EDead -> mem_in_bucket rest
+          end
+      | Cons(_hk, _c, rest) -> mem_in_bucket rest in
+      mem_in_bucket h.data.(key_index h hkey)
+
+    let iter f h =
+      let rec do_bucket = function
+        | Empty ->
+            ()
+        | Cons(_, c, rest) ->
+            begin match H.get_key c, H.get_data c with
+            | None, _ | _, None -> ()
+            | Some k, Some d -> f k d
+            end; do_bucket rest in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        do_bucket d.(i)
+      done
+
+    let fold f h init =
+      let rec do_bucket b accu =
+        match b with
+          Empty ->
+            accu
+        | Cons(_, c, rest) ->
+            let accu = begin match H.get_key c, H.get_data c with
+              | None, _ | _, None -> accu
+              | Some k, Some d -> f k d accu
+            end in
+            do_bucket rest accu  in
+      let d = h.data in
+      let accu = ref init in
+      for i = 0 to Array.length d - 1 do
+        accu := do_bucket d.(i) !accu
+      done;
+      !accu
+
+    let filter_map_inplace f h =
+      let rec do_bucket = function
+        | Empty ->
+            Empty
+        | Cons(hk, c, rest) ->
+            match H.get_key c, H.get_data c with
+            | None, _ | _, None ->
+                do_bucket rest
+            | Some k, Some d ->
+                match f k d with
+                | None ->
+                    do_bucket rest
+                | Some new_d ->
+                    H.set_key_data c k new_d;
+                    Cons(hk, c, do_bucket rest)
+      in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        d.(i) <- do_bucket d.(i)
+      done
+
+    let length h = h.size
+
+    let rec bucket_length accu = function
+      | Empty -> accu
+      | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+
+    let stats h =
+      let mbl =
+        Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
+      let histo = Array.make (mbl + 1) 0 in
+      Array.iter
+        (fun b ->
+           let l = bucket_length 0 b in
+           histo.(l) <- histo.(l) + 1)
+        h.data;
+      { Hashtbl.num_bindings = h.size;
+        num_buckets = Array.length h.data;
+        max_bucket_length = mbl;
+        bucket_histogram = histo }
+
+    let rec bucket_length_alive accu = function
+      | Empty -> accu
+      | Cons(_, c, rest) when H.check_key c ->
+          bucket_length_alive (accu + 1) rest
+      | Cons(_, _, rest) -> bucket_length_alive accu rest
+
+    let stats_alive h =
+      let size = ref 0 in
+      let mbl =
+        Array.fold_left (fun m b -> max m (bucket_length_alive 0 b)) 0 h.data in
+      let histo = Array.make (mbl + 1) 0 in
+      Array.iter
+        (fun b ->
+           let l = bucket_length_alive 0 b in
+           size := !size + l;
+           histo.(l) <- histo.(l) + 1)
+        h.data;
+      { Hashtbl.num_bindings = !size;
+        num_buckets = Array.length h.data;
+        max_bucket_length = mbl;
+        bucket_histogram = histo }
+
+
+  end
+end
+
+module ObjEph = Obj.Ephemeron
+
+let _obj_opt : Obj.t option -> 'a option = fun x ->
+  match x with
+  | None -> x
+  | Some v -> Some (Obj.obj v)
+
+(** The previous function is typed so this one is also correct *)
+let obj_opt : Obj.t option -> 'a option = fun x -> Obj.magic x
+
+
+module K1 = struct
+  type ('k,'d) t = ObjEph.t
+
+  let create () : ('k,'d) t = ObjEph.create 1
+
+  let get_key (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key t 0)
+  let get_key_copy (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key_copy t 0)
+  let set_key (t:('k,'d) t) (k:'k) : unit = ObjEph.set_key t 0 (Obj.repr k)
+  let unset_key (t:('k,'d) t) : unit = ObjEph.unset_key t 0
+  let check_key (t:('k,'d) t) : bool = ObjEph.check_key t 0
+
+  let blit_key (t1:('k,'d) t) (t2:('k,'d) t): unit =
+    ObjEph.blit_key t1 0 t2 0 1
+
+  let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let get_data_copy (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data_copy t)
+  let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t
+  let check_data (t:('k,'d) t) : bool = ObjEph.check_data t
+  let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H.t,'a) t
+      type t = H.t
+      let create k d =
+        let c = create () in
+        set_data c d;
+        set_key c k;
+        c
+      let hash = H.hash
+      let equal c k =
+        (* {!get_key_copy} is not used because the equality of the user can be
+            the physical equality *)
+        match get_key c with
+        | None -> GenHashTable.EDead
+        | Some k' ->
+            if H.equal k k' then GenHashTable.ETrue else GenHashTable.EFalse
+      let get_data = get_data
+      let get_key = get_key
+      let set_key_data c k d =
+        unset_data c;
+        set_key c k;
+        set_data c d
+      let check_key = check_key
+    end)
+
+  module Make(H: Hashtbl.HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (_seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+  end
+
+end
+
+module K2 = struct
+  type ('k1, 'k2, 'd) t = ObjEph.t
+
+  let create () : ('k1,'k2,'d) t = ObjEph.create 2
+
+  let get_key1 (t:('k1,'k2,'d) t) : 'k1 option = obj_opt (ObjEph.get_key t 0)
+  let get_key1_copy (t:('k1,'k2,'d) t) : 'k1 option =
+    obj_opt (ObjEph.get_key_copy t 0)
+  let set_key1 (t:('k1,'k2,'d) t) (k:'k1) : unit =
+    ObjEph.set_key t 0 (Obj.repr k)
+  let unset_key1 (t:('k1,'k2,'d) t) : unit = ObjEph.unset_key t 0
+  let check_key1 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 0
+
+  let get_key2 (t:('k1,'k2,'d) t) : 'k2 option = obj_opt (ObjEph.get_key t 1)
+  let get_key2_copy (t:('k1,'k2,'d) t) : 'k2 option =
+    obj_opt (ObjEph.get_key_copy t 1)
+  let set_key2 (t:('k1,'k2,'d) t) (k:'k2) : unit =
+    ObjEph.set_key t 1 (Obj.repr k)
+  let unset_key2 (t:('k1,'k2,'d) t) : unit = ObjEph.unset_key t 1
+  let check_key2 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 1
+
+
+  let blit_key1 (t1:('k1,_,_) t) (t2:('k1,_,_) t) : unit =
+    ObjEph.blit_key t1 0 t2 0 1
+  let blit_key2 (t1:(_,'k2,_) t) (t2:(_,'k2,_) t) : unit =
+    ObjEph.blit_key t1 1 t2 1 1
+  let blit_key12 (t1:('k1,'k2,_) t) (t2:('k1,'k2,_) t) : unit =
+    ObjEph.blit_key t1 0 t2 0 2
+
+  let get_data (t:('k1,'k2,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let get_data_copy (t:('k1,'k2,'d) t) : 'd option =
+    obj_opt (ObjEph.get_data_copy t)
+  let set_data (t:('k1,'k2,'d) t) (d:'d) : unit =
+    ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k1,'k2,'d) t) : unit = ObjEph.unset_data t
+  let check_data (t:('k1,'k2,'d) t) : bool = ObjEph.check_data t
+  let blit_data (t1:(_,_,'d) t) (t2:(_,_,'d) t) : unit = ObjEph.blit_data t1 t2
+
+  module MakeSeeded
+      (H1:Hashtbl.SeededHashedType)
+      (H2:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H1.t,H2.t,'a) t
+      type t = H1.t * H2.t
+      let create (k1,k2) d =
+        let c = create () in
+        set_data c d;
+        set_key1 c k1; set_key2 c k2;
+        c
+      let hash seed (k1,k2) =
+        H1.hash seed k1 + H2.hash seed k2 * 65599
+      let equal c (k1,k2) =
+        match get_key1 c, get_key2 c with
+        | None, _ | _ , None -> GenHashTable.EDead
+        | Some k1', Some k2' ->
+            if H1.equal k1 k1' && H2.equal k2 k2'
+            then GenHashTable.ETrue else GenHashTable.EFalse
+      let get_data = get_data
+      let get_key c =
+        match get_key1 c, get_key2 c with
+        | None, _ | _ , None -> None
+        | Some k1', Some k2' -> Some (k1', k2')
+      let set_key_data c (k1,k2) d =
+        unset_data c;
+        set_key1 c k1; set_key2 c k2;
+        set_data c d
+      let check_key c = check_key1 c && check_key2 c
+    end)
+
+  module Make(H1: Hashtbl.HashedType)(H2: Hashtbl.HashedType):
+    (S with type key = H1.t * H2.t) =
+  struct
+    include MakeSeeded
+        (struct
+          type t = H1.t
+          let equal = H1.equal
+          let hash (_seed: int) x = H1.hash x
+        end)
+        (struct
+          type t = H2.t
+          let equal = H2.equal
+          let hash (_seed: int) x = H2.hash x
+        end)
+    let create sz = create ~random:false sz
+  end
+
+end
+
+module Kn = struct
+  type ('k,'d) t = ObjEph.t
+
+  let create n : ('k,'d) t = ObjEph.create n
+  let length (k:('k,'d) t) : int = ObjEph.length k
+
+  let get_key (t:('k,'d) t) (n:int) : 'k option = obj_opt (ObjEph.get_key t n)
+  let get_key_copy (t:('k,'d) t) (n:int) : 'k option =
+    obj_opt (ObjEph.get_key_copy t n)
+  let set_key (t:('k,'d) t) (n:int) (k:'k) : unit =
+    ObjEph.set_key t n (Obj.repr k)
+  let unset_key (t:('k,'d) t) (n:int) : unit = ObjEph.unset_key t n
+  let check_key (t:('k,'d) t) (n:int) : bool = ObjEph.check_key t n
+
+  let blit_key (t1:('k,'d) t) (o1:int) (t2:('k,'d) t) (o2:int) (l:int) : unit =
+    ObjEph.blit_key t1 o1 t2 o2 l
+
+  let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let get_data_copy (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data_copy t)
+  let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t
+  let check_data (t:('k,'d) t) : bool = ObjEph.check_data t
+  let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H.t,'a) t
+      type t = H.t array
+      let create k d =
+        let c = create (Array.length k) in
+        set_data c d;
+        for i=0 to Array.length k -1 do
+          set_key c i k.(i);
+        done;
+        c
+      let hash seed k =
+        let h = ref 0 in
+        for i=0 to Array.length k -1 do
+          h := H.hash seed k.(i) * 65599 + !h;
+        done;
+        !h
+      let equal c k =
+        let len  = Array.length k in
+        let len' = length c in
+        if len != len' then GenHashTable.EFalse
+        else
+          let rec equal_array k c i =
+            if i < 0 then GenHashTable.ETrue
+            else
+              match get_key c i with
+              | None -> GenHashTable.EDead
+              | Some ki ->
+                  if H.equal k.(i) ki
+                  then equal_array k c (i-1)
+                  else GenHashTable.EFalse
+          in
+          equal_array k c (len-1)
+      let get_data = get_data
+      let get_key c =
+        let len = length c in
+        if len = 0 then Some [||]
+        else
+          match get_key c 0 with
+          | None -> None
+          | Some k0 ->
+              let rec fill a i =
+                if i < 1 then Some a
+                else
+                  match get_key c i with
+                  | None -> None
+                  | Some ki ->
+                      a.(i) <- ki;
+                      fill a (i-1)
+              in
+              let a = Array.make len k0 in
+              fill a (len-1)
+      let set_key_data c k d =
+        unset_data c;
+        for i=0 to Array.length k -1 do
+          set_key c i k.(i);
+        done;
+        set_data c d
+      let check_key c =
+        let rec check c i =
+          i < 0 || (check_key c i && check c (i-1)) in
+        check c (length c - 1)
+    end)
+
+  module Make(H: Hashtbl.HashedType): (S with type key = H.t array) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (_seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+  end
+end
diff --git a/stdlib/ephemeron.mli b/stdlib/ephemeron.mli
new file mode 100644
index 00000000..46d3aad3
--- /dev/null
+++ b/stdlib/ephemeron.mli
@@ -0,0 +1,373 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Ephemerons and weak hash table *)
+
+(** Ephemerons and weak hash table
+
+    Ephemerons and weak hash table are useful when one wants to cache
+    or memorize the computation of a function, as long as the
+    arguments and the function are used, without creating memory leaks
+    by continuously keeping old computation results that are not
+    useful anymore because one argument or the function is freed. An
+    implementation using {Hashtbl.t} is not suitable because all
+    associations would keep in memory the arguments and the result.
+
+    Ephemerons can also be used for "adding" a field to an arbitrary
+    boxed ocaml value: you can attach an information to a value
+    created by an external library without memory leaks.
+
+    Ephemerons hold some keys and one or no data. They are all boxed
+    ocaml values. The keys of an ephemeron have the same behavior
+    than weak pointers according to the garbage collector. In fact
+    ocaml weak pointers are implemented as ephemerons without data.
+
+    The keys and data of an ephemeron are said to be full if they
+    point to a value, empty if the value have never been set, have
+    been unset, or was erased by the GC. In the function that accesses
+    the keys or data these two states are represented by the [option]
+    type.
+
+    The data is considered by the garbage collector alive if all the
+    full keys are alive and if the ephemeron is alive. When one of the
+    keys is not considered alive anymore by the GC, the data is
+    emptied from the ephemeron. The data could be alive for another
+    reason and in that case the GC will not free it, but the ephemeron
+    will not hold the data anymore.
+
+    The ephemerons complicate the notion of liveness of values, because
+    it is not anymore an equivalence with the reachability from root
+    value by usual pointers (not weak and not ephemerons). With ephemerons
+    the notion of liveness is constructed by the least fixpoint of:
+       A value is alive if:
+        - it is a root value
+        - it is reachable from alive value by usual pointers
+        - it is the data of an alive ephemeron with all its full keys alive
+
+    Notes:
+    - All the types defined in this module cannot be marshaled
+    using {!Pervasives.output_value} or the functions of the
+    {!Marshal} module.
+
+    Ephemerons are defined in a language agnostic way in this paper:
+    B. Hayes, Ephemerons: a New Finalization Mechanism, OOPSLA'9
+
+    @since 4.03.0
+*)
+
+module type S = sig
+  (** Propose the same interface as usual hash table. However since
+      the bindings are weak, even if [mem h k] is true, a subsequent
+      [find h k] may raise [Not_found] because the garbage collector
+      can run between the two.
+
+      Moreover, the table shouldn't be modified during a call to [iter].
+      Use [filter_map_inplace] in this case.
+  *)
+
+  include Hashtbl.S
+
+  val clean: 'a t -> unit
+  (** remove all dead bindings. Done automatically during automatic resizing. *)
+
+  val stats_alive: 'a t -> Hashtbl.statistics
+  (** same as {!Hashtbl.SeededS.stats} but only count the alive bindings *)
+end
+(** The output signature of the functor {!K1.Make} and {!K2.Make}.
+    These hash tables are weak in the keys. If all the keys of a binding are
+    alive the binding is kept, but if one of the keys of the binding
+    is dead then the binding is removed.
+*)
+
+module type SeededS = sig
+  include Hashtbl.SeededS
+  val clean: 'a t -> unit
+  (** remove all dead bindings. Done automatically during automatic resizing. *)
+
+  val stats_alive: 'a t -> Hashtbl.statistics
+  (** same as {!Hashtbl.SeededS.stats} but only count the alive bindings *)
+end
+(** The output signature of the functor {!K1.MakeSeeded} and {!K2.MakeSeeded}.
+*)
+
+module K1 : sig
+  type ('k,'d) t (** an ephemeron with one key *)
+
+  val create: unit -> ('k,'d) t
+  (** [Ephemeron.K1.create ()] creates an ephemeron with one key. The
+      data and the key are empty *)
+
+  val get_key: ('k,'d) t -> 'k option
+  (** [Ephemeron.K1.get_key eph] returns [None] if the key of [eph] is
+      empty, [Some x] (where [x] is the key) if it is full. *)
+
+  val get_key_copy: ('k,'d) t -> 'k option
+  (** [Ephemeron.K1.get_key_copy eph] returns [None] if the key of [eph] is
+      empty, [Some x] (where [x] is a (shallow) copy of the key) if
+      it is full. This function has the same GC friendliness as {!Weak.get_copy}
+
+      If the element is a custom block it is not copied.
+  *)
+
+  val set_key: ('k,'d) t -> 'k -> unit
+  (** [Ephemeron.K1.set_key eph el] sets the key of [eph] to be a
+      (full) key to [el]
+  *)
+
+  val unset_key: ('k,'d) t -> unit
+  (** [Ephemeron.K1.unset_key eph el] sets the key of [eph] to be an
+      empty key. Since there is only one key, the ephemeron starts
+      behaving like a reference on the data. *)
+
+  val check_key: ('k,'d) t -> bool
+  (** [Ephemeron.K1.check_key eph] returns [true] if the key of the [eph]
+      is full, [false] if it is empty. Note that even if
+      [Ephemeron.K1.check_key eph] returns [true], a subsequent
+      {!Ephemeron.K1.get_key}[eph] can return [None].
+  *)
+
+
+  val blit_key : ('k,_) t -> ('k,_) t -> unit
+  (** [Ephemeron.K1.blit_key eph1 eph2] sets the key of [eph2] with
+      the key of [eph1]. Contrary to using {!Ephemeron.K1.get_key}
+      followed by {!Ephemeron.K1.set_key} or {!Ephemeron.K1.unset_key}
+      this function does not prevent the incremental GC from erasing
+      the value in its current cycle. *)
+
+  val get_data: ('k,'d) t -> 'd option
+  (** [Ephemeron.K1.get_data eph] returns [None] if the data of [eph] is
+      empty, [Some x] (where [x] is the data) if it is full. *)
+
+  val get_data_copy: ('k,'d) t -> 'd option
+  (** [Ephemeron.K1.get_data_copy eph] returns [None] if the data of [eph] is
+      empty, [Some x] (where [x] is a (shallow) copy of the data) if
+      it is full. This function has the same GC friendliness as {!Weak.get_copy}
+
+      If the element is a custom block it is not copied.
+  *)
+
+  val set_data: ('k,'d) t -> 'd -> unit
+  (** [Ephemeron.K1.set_data eph el] sets the data of [eph] to be a
+      (full) data to [el]
+  *)
+
+  val unset_data: ('k,'d) t -> unit
+  (** [Ephemeron.K1.unset_data eph el] sets the key of [eph] to be an
+      empty key. The ephemeron starts behaving like a weak pointer.
+  *)
+
+  val check_data: ('k,'d) t -> bool
+  (** [Ephemeron.K1.check_data eph] returns [true] if the data of the [eph]
+      is full, [false] if it is empty. Note that even if
+      [Ephemeron.K1.check_data eph] returns [true], a subsequent
+      {!Ephemeron.K1.get_data}[eph] can return [None].
+  *)
+
+  val blit_data : (_,'d) t -> (_,'d) t -> unit
+  (** [Ephemeron.K1.blit_data eph1 eph2] sets the data of [eph2] with
+      the data of [eph1]. Contrary to using {!Ephemeron.K1.get_data}
+      followed by {!Ephemeron.K1.set_data} or {!Ephemeron.K1.unset_data}
+      this function does not prevent the incremental GC from erasing
+      the value in its current cycle. *)
+
+  module Make (H:Hashtbl.HashedType) : S with type key = H.t
+  (** Functor building an implementation of a weak hash table *)
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) : SeededS with type key = H.t
+  (** Functor building an implementation of a weak hash table.
+      The seed is similar to the one of {!Hashtbl.MakeSeeded}. *)
+
+end
+
+module K2 : sig
+  type ('k1,'k2,'d) t (** an ephemeron with two keys *)
+
+  val create: unit -> ('k1,'k2,'d) t
+  (** Same as {!Ephemeron.K1.create} *)
+
+  val get_key1: ('k1,'k2,'d) t -> 'k1 option
+  (** Same as {!Ephemeron.K1.get_key} *)
+
+  val get_key1_copy: ('k1,'k2,'d) t -> 'k1 option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+
+  val set_key1: ('k1,'k2,'d) t -> 'k1 -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+
+  val unset_key1: ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+
+  val check_key1: ('k1,'k2,'d) t ->  bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val get_key2: ('k1,'k2,'d) t -> 'k2 option
+  (** Same as {!Ephemeron.K1.get_key} *)
+
+  val get_key2_copy: ('k1,'k2,'d) t -> 'k2 option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+
+  val set_key2: ('k1,'k2,'d) t -> 'k2 -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+
+  val unset_key2: ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+
+  val check_key2: ('k1,'k2,'d) t -> bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val blit_key1: ('k1,_,_) t -> ('k1,_,_) t -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val blit_key2: (_,'k2,_) t -> (_,'k2,_) t -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val blit_key12: ('k1,'k2,_) t -> ('k1,'k2,_) t -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val get_data: ('k1,'k2,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data} *)
+
+  val get_data_copy: ('k1,'k2,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data_copy} *)
+
+  val set_data: ('k1,'k2,'d) t -> 'd -> unit
+  (** Same as {!Ephemeron.K1.set_data} *)
+
+  val unset_data: ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_data} *)
+
+  val check_data: ('k1,'k2,'d) t -> bool
+  (** Same as {!Ephemeron.K1.check_data} *)
+
+  val blit_data: ('k1,'k2,'d) t -> ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.blit_data} *)
+
+  module Make
+      (H1:Hashtbl.HashedType)
+      (H2:Hashtbl.HashedType) :
+    S with type key = H1.t * H2.t
+  (** Functor building an implementation of a weak hash table *)
+
+  module MakeSeeded
+      (H1:Hashtbl.SeededHashedType)
+      (H2:Hashtbl.SeededHashedType) :
+    SeededS with type key = H1.t * H2.t
+  (** Functor building an implementation of a weak hash table.
+      The seed is similar to the one of {!Hashtbl.MakeSeeded}. *)
+
+end
+
+module Kn : sig
+  type ('k,'d) t (** an ephemeron with an arbitrary number of keys
+                      of the same type *)
+
+  val create: int -> ('k,'d) t
+  (** Same as {!Ephemeron.K1.create} *)
+
+  val get_key: ('k,'d) t -> int -> 'k option
+  (** Same as {!Ephemeron.K1.get_key} *)
+
+  val get_key_copy: ('k,'d) t -> int -> 'k option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+
+  val set_key: ('k,'d) t -> int -> 'k -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+
+  val unset_key: ('k,'d) t -> int -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+
+  val check_key: ('k,'d) t -> int ->  bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val blit_key: ('k,_) t -> int -> ('k,_) t -> int -> int -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val get_data: ('k,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data} *)
+
+  val get_data_copy: ('k,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data_copy} *)
+
+  val set_data: ('k,'d) t -> 'd -> unit
+  (** Same as {!Ephemeron.K1.set_data} *)
+
+  val unset_data: ('k,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_data} *)
+
+  val check_data: ('k,'d) t -> bool
+  (** Same as {!Ephemeron.K1.check_data} *)
+
+  val blit_data: ('k,'d) t -> ('k,'d) t -> unit
+  (** Same as {!Ephemeron.K1.blit_data} *)
+
+  module Make
+      (H:Hashtbl.HashedType) :
+    S with type key = H.t array
+  (** Functor building an implementation of a weak hash table *)
+
+  module MakeSeeded
+      (H:Hashtbl.SeededHashedType) :
+    SeededS with type key = H.t array
+  (** Functor building an implementation of a weak hash table.
+      The seed is similar to the one of {!Hashtbl.MakeSeeded}. *)
+
+end
+
+module GenHashTable: sig
+  (** Define a hash table on generic containers which have a notion of
+      "death" and aliveness. If a binding is dead the hash table can
+      automatically remove it. *)
+
+  type equal =
+  | ETrue | EFalse
+  | EDead (** the container is dead *)
+
+  module MakeSeeded(H:
+  sig
+    type t
+    (** keys *)
+
+    type 'a container
+    (** contains keys and the associated data *)
+
+    val hash: int -> t -> int
+    (** same as {!Hashtbl.SeededHashedType} *)
+
+    val equal: 'a container -> t -> equal
+    (** equality predicate used to compare a key with the one in a
+        container. Can return [EDead] if the keys in the container are
+        dead *)
+
+    val create: t -> 'a -> 'a container
+    (** [create key data] creates a container from
+        some initials keys and one data *)
+
+    val get_key: 'a container -> t option
+    (** [get_key cont] returns the keys if they are all alive *)
+
+    val get_data: 'a container -> 'a option
+    (** [get_data cont] returns the data if it is alive *)
+
+    val set_key_data: 'a container -> t -> 'a -> unit
+    (** [set_key_data cont] modifies the key and data *)
+
+    val check_key: 'a container -> bool
+    (** [check_key cont] checks if all the keys contained in the data
+        are alive *)
+  end) : SeededS with type key = H.t
+  (** Functor building an implementation of an hash table that use the container
+      for keeping the information given *)
+
+end
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
new file mode 100644
index 00000000..f9b0bc6c
--- /dev/null
+++ b/stdlib/filename.ml
@@ -0,0 +1,262 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Xavier Leroy and Damien Doligez, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let generic_quote quotequote s =
+  let l = String.length s in
+  let b = Buffer.create (l + 20) in
+  Buffer.add_char b '\'';
+  for i = 0 to l - 1 do
+    if s.[i] = '\''
+    then Buffer.add_string b quotequote
+    else Buffer.add_char b  s.[i]
+  done;
+  Buffer.add_char b '\'';
+  Buffer.contents b
+
+(* This function implements the Open Group specification found here:
+  [[1]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/basename.html
+  In step 1 of [[1]], we choose to return "." for empty input.
+    (for compatibility with previous versions of OCaml)
+  In step 2, we choose to process "//" normally.
+  Step 6 is not implemented: we consider that the [suffix] operand is
+    always absent.  Suffixes are handled by [chop_suffix] and [chop_extension].
+*)
+let generic_basename is_dir_sep current_dir_name name =
+  let rec find_end n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then find_end (n - 1)
+    else find_beg n (n + 1)
+  and find_beg n p =
+    if n < 0 then String.sub name 0 p
+    else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1)
+    else find_beg (n - 1) p
+  in
+  if name = ""
+  then current_dir_name
+  else find_end (String.length name - 1)
+
+(* This function implements the Open Group specification found here:
+  [[2]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/dirname.html
+  In step 6 of [[2]], we choose to process "//" normally.
+*)
+let generic_dirname is_dir_sep current_dir_name name =
+  let rec trailing_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then trailing_sep (n - 1)
+    else base n
+  and base n =
+    if n < 0 then current_dir_name
+    else if is_dir_sep name n then intermediate_sep n
+    else base (n - 1)
+  and intermediate_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then intermediate_sep (n - 1)
+    else String.sub name 0 (n + 1)
+  in
+  if name = ""
+  then current_dir_name
+  else trailing_sep (String.length name - 1)
+
+module Unix = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let dir_sep = "/"
+  let is_dir_sep s i = s.[i] = '/'
+  let is_relative n = String.length n < 1 || n.[0] <> '/'
+  let is_implicit n =
+    is_relative n
+    && (String.length n < 2 || String.sub n 0 2 <> "./")
+    && (String.length n < 3 || String.sub n 0 3 <> "../")
+  let check_suffix name suff =
+    String.length name >= String.length suff &&
+    String.sub name (String.length name - String.length suff)
+                    (String.length suff) = suff
+  let temp_dir_name =
+    try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
+  let quote = generic_quote "'\\''"
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
+end
+
+module Win32 = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let dir_sep = "\\"
+  let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
+  let is_relative n =
+    (String.length n < 1 || n.[0] <> '/')
+    && (String.length n < 1 || n.[0] <> '\\')
+    && (String.length n < 2 || n.[1] <> ':')
+  let is_implicit n =
+    is_relative n
+    && (String.length n < 2 || String.sub n 0 2 <> "./")
+    && (String.length n < 2 || String.sub n 0 2 <> ".\\")
+    && (String.length n < 3 || String.sub n 0 3 <> "../")
+    && (String.length n < 3 || String.sub n 0 3 <> "..\\")
+  let check_suffix name suff =
+   String.length name >= String.length suff &&
+   (let s = String.sub name (String.length name - String.length suff)
+                            (String.length suff) in
+    String.lowercase_ascii s = String.lowercase_ascii suff)
+  let temp_dir_name =
+    try Sys.getenv "TEMP" with Not_found -> "."
+  let quote s =
+    let l = String.length s in
+    let b = Buffer.create (l + 20) in
+    Buffer.add_char b '\"';
+    let rec loop i =
+      if i = l then Buffer.add_char b '\"' else
+      match s.[i] with
+      | '\"' -> loop_bs 0 i;
+      | '\\' -> loop_bs 0 i;
+      | c    -> Buffer.add_char b c; loop (i+1);
+    and loop_bs n i =
+      if i = l then begin
+        Buffer.add_char b '\"';
+        add_bs n;
+      end else begin
+        match s.[i] with
+        | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1);
+        | '\\' -> loop_bs (n+1) (i+1);
+        | _    -> add_bs n; loop i
+      end
+    and add_bs n = for _j = 1 to n do Buffer.add_char b '\\'; done
+    in
+    loop 0;
+    Buffer.contents b
+  let has_drive s =
+    let is_letter = function
+      | 'A' .. 'Z' | 'a' .. 'z' -> true
+      | _ -> false
+    in
+    String.length s >= 2 && is_letter s.[0] && s.[1] = ':'
+  let drive_and_path s =
+    if has_drive s
+    then (String.sub s 0 2, String.sub s 2 (String.length s - 2))
+    else ("", s)
+  let dirname s =
+    let (drive, path) = drive_and_path s in
+    let dir = generic_dirname is_dir_sep current_dir_name path in
+    drive ^ dir
+  let basename s =
+    let (_drive, path) = drive_and_path s in
+    generic_basename is_dir_sep current_dir_name path
+end
+
+module Cygwin = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let dir_sep = "/"
+  let is_dir_sep = Win32.is_dir_sep
+  let is_relative = Win32.is_relative
+  let is_implicit = Win32.is_implicit
+  let check_suffix = Win32.check_suffix
+  let temp_dir_name = Unix.temp_dir_name
+  let quote = Unix.quote
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
+end
+
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
+     is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
+     dirname) =
+  match Sys.os_type with
+  | "Win32" ->
+      (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
+       Win32.is_dir_sep,
+       Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
+       Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname)
+  | "Cygwin" ->
+      (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
+       Cygwin.is_dir_sep,
+       Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
+       Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
+  | _ -> (* normally "Unix" *)
+      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
+       Unix.is_dir_sep,
+       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
+       Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
+
+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 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 extension_len name =
+  let rec check i0 i =
+    if i < 0 || is_dir_sep name i then 0
+    else if name.[i] = '.' then check i0 (i - 1)
+    else String.length name - i0
+  in
+  let rec search_dot i =
+    if i < 0 || is_dir_sep name i then 0
+    else if name.[i] = '.' then check i (i - 1)
+    else search_dot (i - 1)
+  in
+  search_dot (String.length name - 1)
+
+let extension name =
+  let l = extension_len name in
+  if l = 0 then "" else String.sub name (String.length name - l) l
+
+let chop_extension name =
+  let l = extension_len name in
+  if l = 0 then invalid_arg "Filename.chop_extension"
+  else String.sub name 0 (String.length name - l)
+
+let remove_extension name =
+  let l = extension_len name in
+  if l = 0 then name else String.sub name 0 (String.length name - l)
+
+external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
+external close_desc: int -> unit = "caml_sys_close"
+
+let prng = lazy(Random.State.make_self_init ())
+
+let temp_file_name temp_dir prefix suffix =
+  let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in
+  concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
+
+
+let current_temp_dir_name = ref temp_dir_name
+
+let set_temp_dir_name s = current_temp_dir_name := s
+let get_temp_dir_name () = !current_temp_dir_name
+
+let temp_file ?(temp_dir = !current_temp_dir_name) prefix suffix =
+  let rec try_name counter =
+    let name = temp_file_name temp_dir prefix suffix in
+    try
+      close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o600);
+      name
+    with Sys_error _ as e ->
+      if counter >= 1000 then raise e else try_name (counter + 1)
+  in try_name 0
+
+let open_temp_file ?(mode = [Open_text]) ?(perms = 0o600)
+                   ?(temp_dir = !current_temp_dir_name) prefix suffix =
+  let rec try_name counter =
+    let name = temp_file_name temp_dir prefix suffix in
+    try
+      (name,
+       open_out_gen (Open_wronly::Open_creat::Open_excl::mode) perms name)
+    with Sys_error _ as e ->
+      if counter >= 1000 then raise e else try_name (counter + 1)
+  in try_name 0
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
new file mode 100644
index 00000000..fa6f0369
--- /dev/null
+++ b/stdlib/filename.mli
@@ -0,0 +1,167 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Operations on file names. *)
+
+val current_dir_name : string
+(** The conventional name for the current directory (e.g. [.] in Unix). *)
+
+val parent_dir_name : string
+(** The conventional name for the parent of the current directory
+   (e.g. [..] in Unix). *)
+
+val dir_sep : string
+(** The directory separator (e.g. [/] in Unix). @since 3.11.2 *)
+
+val concat : string -> string -> string
+(** [concat dir file] returns a file name that designates file
+   [file] in directory [dir]. *)
+
+val is_relative : string -> bool
+(** Return [true] if the file name is relative to the current
+   directory, [false] if it is absolute (i.e. in Unix, starts
+   with [/]). *)
+
+val is_implicit : string -> bool
+(** Return [true] if the file name is relative and does not start
+   with an explicit reference to the current directory ([./] or
+   [../] in Unix), [false] if it starts with an explicit reference
+   to the root directory or the current directory. *)
+
+val check_suffix : string -> string -> bool
+(** [check_suffix name suff] returns [true] if the filename [name]
+   ends with the suffix [suff]. *)
+
+val chop_suffix : string -> string -> string
+(** [chop_suffix name suff] removes the suffix [suff] from
+   the filename [name]. The behavior is undefined if [name] does not
+   end with the suffix [suff]. *)
+
+val extension : string -> string
+(** [extension name] is the shortest suffix [ext] of [name0] where:
+
+    - [name0] is the longest suffix of [name] that does not
+      contain a directory separator;
+    - [ext] starts with a period;
+    - [ext] is preceded by at least one non-period character
+      in [name0].
+
+    If such a suffix does not exist, [extension name] is the empty
+    string.
+
+    @since 4.04
+*)
+
+val remove_extension : string -> string
+(** Return the given file name without its extension, as defined
+    in {!Filename.extension}. If the extension is empty, the function
+    returns the given file name.
+
+    The following invariant holds for any file name [s]:
+
+    [remove_extension s ^ extension s = s]
+
+    @since 4.04
+*)
+
+val chop_extension : string -> string
+(** Same as {!Filename.remove_extension}, but raise [Invalid_argument]
+    if the given name has an empty extension. *)
+
+
+val basename : string -> string
+(** Split a file name into directory name / base file name.
+   If [name] is a valid file name, then [concat (dirname name) (basename name)]
+   returns a file name which is equivalent to [name]. Moreover,
+   after setting the current directory to [dirname name] (with {!Sys.chdir}),
+   references to [basename name] (which is a relative file name)
+   designate the same file as [name] before the call to {!Sys.chdir}.
+
+   This function conforms to the specification of POSIX.1-2008 for the
+   [basename] utility. *)
+
+val dirname : string -> string
+(** See {!Filename.basename}.
+   This function conforms to the specification of POSIX.1-2008 for the
+   [dirname] utility. *)
+
+val temp_file : ?temp_dir: string -> string -> string -> string
+(** [temp_file prefix suffix] returns the name of a
+   fresh temporary file in the temporary directory.
+   The base name of the temporary file is formed by concatenating
+   [prefix], then a suitably chosen integer number, then [suffix].
+   The optional argument [temp_dir] indicates the temporary directory
+   to use, defaulting to the current result of {!Filename.get_temp_dir_name}.
+   The temporary file is created empty, with permissions [0o600]
+   (readable and writable only by the file owner).  The file is
+   guaranteed to be different from any other file that existed when
+   [temp_file] was called.
+   Raise [Sys_error] if the file could not be created.
+   @before 3.11.2 no ?temp_dir optional argument
+*)
+
+val open_temp_file :
+      ?mode: open_flag list -> ?perms: int -> ?temp_dir: string -> string ->
+      string -> string * out_channel
+(** Same as {!Filename.temp_file}, but returns both the name of a fresh
+   temporary file, and an output channel opened (atomically) on
+   this file.  This function is more secure than [temp_file]: there
+   is no risk that the temporary file will be modified (e.g. replaced
+   by a symbolic link) before the program opens it.  The optional argument
+   [mode] is a list of additional flags to control the opening of the file.
+   It can contain one or several of [Open_append], [Open_binary],
+   and [Open_text].  The default is [[Open_text]] (open in text mode). The
+   file is created with permissions [perms] (defaults to readable and
+   writable only by the file owner, [0o600]).
+
+   @raise Sys_error if the file could not be opened.
+   @before 4.03.0 no ?perms optional argument
+   @before 3.11.2 no ?temp_dir optional argument
+*)
+
+val get_temp_dir_name : unit -> string
+(** The name of the temporary directory:
+    Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
+    if the variable is not set.
+    Under Windows, the value of the [TEMP] environment variable, or "."
+    if the variable is not set.
+    The temporary directory can be changed with {!Filename.set_temp_dir_name}.
+    @since 4.00.0
+*)
+
+val set_temp_dir_name : string -> unit
+(** Change the temporary directory returned by {!Filename.get_temp_dir_name}
+    and used by {!Filename.temp_file} and {!Filename.open_temp_file}.
+    @since 4.00.0
+*)
+
+val temp_dir_name : string
+  [@@ocaml.deprecated "Use Filename.get_temp_dir_name instead"]
+(** The name of the initial temporary directory:
+    Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
+    if the variable is not set.
+    Under Windows, the value of the [TEMP] environment variable, or "."
+    if the variable is not set.
+    @deprecated You should use {!Filename.get_temp_dir_name} instead.
+    @since 3.09.1
+*)
+
+val quote : string -> string
+(** Return a quoted version of a file name, suitable for use as
+    one argument in a command line, escaping all meta-characters.
+    Warning: under Windows, the output is only suitable for use
+    with programs that follow the standard Windows quoting
+    conventions.
+ *)
diff --git a/stdlib/format.ml b/stdlib/format.ml
new file mode 100644
index 00000000..8caa18f5
--- /dev/null
+++ b/stdlib/format.ml
@@ -0,0 +1,1326 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A pretty-printing facility and definition of formatters for 'parallel'
+   (i.e. unrelated or independent) pretty-printing on multiple out channels. *)
+
+(*
+   The pretty-printing engine internal data structures.
+*)
+
+(* A devoted type for sizes to avoid confusion
+   between sizes and mere integers. *)
+type size
+
+external size_of_int : int -> size = "%identity"
+
+external int_of_size : size -> int = "%identity"
+
+
+(* The pretty-printing boxes definition:
+   a pretty-printing box is either
+   - hbox: horizontal (no split in the line)
+   - vbox: vertical (the line is splitted at every break hint)
+   - hvbox: horizontal/vertical
+     (the box behaves as an horizontal box if it fits on
+      the current line, otherwise the box behaves as a vertical box)
+   - hovbox: horizontal or vertical
+     (the box is compacting material, printing as much material on every
+     lines)
+   - box: horizontal or vertical with box enhanced structure
+     (the box behaves as an horizontal or vertical box but break hints split
+      the line if splitting would move to the left)
+*)
+type box_type = CamlinternalFormatBasics.block_type =
+  | Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
+
+
+(* The pretty-printing tokens definition:
+   are either text to print or pretty printing
+   elements that drive indentation and line splitting. *)
+type pp_token =
+  | Pp_text of string          (* normal text *)
+  | Pp_break of int * int      (* complete break *)
+  | Pp_tbreak of int * int     (* go to next tabulation *)
+  | Pp_stab                    (* set a tabulation *)
+  | Pp_begin of int * box_type (* beginning of a box *)
+  | Pp_end                     (* end of a box *)
+  | Pp_tbegin of tbox          (* beginning of a tabulation box *)
+  | Pp_tend                    (* end of a tabulation box *)
+  | Pp_newline                 (* to force a newline inside a box *)
+  | Pp_if_newline              (* to do something only if this very
+                                  line has been broken *)
+  | Pp_open_tag of tag         (* opening a tag name *)
+  | Pp_close_tag               (* closing the most recently opened tag *)
+
+and tag = string
+
+and tbox = Pp_tbox of int list ref  (* Tabulation box *)
+
+
+(* The pretty-printer queue definition:
+   pretty-printing material is not written in the output as soon as emitted;
+   instead, the material is simply recorded in the pretty-printer queue,
+   until the enclosing box has a known computed size and proper splitting
+   decisions can be made.
+
+   To define the pretty-printer queue, we first define polymorphic queues,
+   then pretty-printer queue elements.
+*)
+
+(* The pretty-printer queue: polymorphic queue definition. *)
+type 'a queue_elem =
+  | Nil
+  | Cons of {
+      head : 'a;
+      mutable tail : 'a queue_elem;
+    }
+
+
+type 'a queue = {
+  mutable insert : 'a queue_elem;
+  mutable body : 'a queue_elem;
+}
+
+
+(* The pretty-printer queue: queue element definition.
+   The pretty-printer queue contains formatting elements to be printed.
+   Each formatting element is a tuple (size, token, length), where
+   - length is the declared length of the token,
+   - size is effective size of the token when it is printed
+     (size is set when the size of the box is known, so that size of break
+      hints are definitive). *)
+type pp_queue_elem = {
+  mutable elem_size : size;
+  token : pp_token;
+  length : int;
+}
+
+
+(* The pretty-printer queue definition. *)
+type pp_queue = pp_queue_elem queue
+
+(* The pretty-printer scanning stack. *)
+
+(* The pretty-printer scanning stack: scanning element definition.
+   Each element is (left_total, queue element) where left_total
+   is the value of pp_left_total when the element has been enqueued. *)
+type pp_scan_elem = Scan_elem of int * pp_queue_elem
+
+(* The pretty-printer scanning stack definition. *)
+type pp_scan_stack = pp_scan_elem list
+
+(* The pretty-printer formatting stack:
+   the formatting stack contains the description of all the currently active
+   boxes; the pretty-printer formatting stack is used to split the lines
+   while printing tokens. *)
+
+(* The pretty-printer formatting stack: formatting stack element definition.
+   Each stack element describes a pretty-printing box. *)
+type pp_format_elem = Format_elem of box_type * int
+
+(* The pretty-printer formatting stack definition. *)
+type pp_format_stack = pp_format_elem list
+
+(* The pretty-printer semantics tag stack definition. *)
+type pp_tag_stack = tag list
+
+(* The formatter definition.
+   Each formatter value is a pretty-printer instance with all its
+   machinery. *)
+type formatter = {
+  (* The various stacks. *)
+  mutable pp_scan_stack : pp_scan_stack;
+  mutable pp_format_stack : pp_format_stack;
+  mutable pp_tbox_stack : tbox list;
+  mutable pp_tag_stack : pp_tag_stack;
+  mutable pp_mark_stack : pp_tag_stack;
+  (* Value of right margin. *)
+  mutable pp_margin : int;
+  (* Minimal space left before margin, when opening a box. *)
+  mutable pp_min_space_left : int;
+  (* Maximum value of indentation:
+     no box can be opened further. *)
+  mutable pp_max_indent : int;
+  (* Space remaining on the current line. *)
+  mutable pp_space_left : int;
+  (* Current value of indentation. *)
+  mutable pp_current_indent : int;
+  (* True when the line has been broken by the pretty-printer. *)
+  mutable pp_is_new_line : bool;
+  (* Total width of tokens already printed. *)
+  mutable pp_left_total : int;
+  (* Total width of tokens ever put in queue. *)
+  mutable pp_right_total : int;
+  (* Current number of opened boxes. *)
+  mutable pp_curr_depth : int;
+  (* Maximum number of boxes which can be simultaneously opened. *)
+  mutable pp_max_boxes : int;
+  (* Ellipsis string. *)
+  mutable pp_ellipsis : string;
+  (* Output function. *)
+  mutable pp_out_string : string -> int -> int -> unit;
+  (* Flushing function. *)
+  mutable pp_out_flush : unit -> unit;
+  (* Output of new lines. *)
+  mutable pp_out_newline : unit -> unit;
+  (* Output of indentation spaces. *)
+  mutable pp_out_spaces : int -> unit;
+  (* Are tags printed ? *)
+  mutable pp_print_tags : bool;
+  (* Are tags marked ? *)
+  mutable pp_mark_tags : bool;
+  (* Find opening and closing markers of tags. *)
+  mutable pp_mark_open_tag : tag -> string;
+  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. *)
+  mutable pp_queue : pp_queue;
+}
+
+
+(* The formatter specific tag handling functions. *)
+type formatter_tag_functions = {
+  mark_open_tag : tag -> string;
+  mark_close_tag : tag -> string;
+  print_open_tag : tag -> unit;
+  print_close_tag : tag -> unit;
+}
+
+
+(* The formatter functions to output material. *)
+type formatter_out_functions = {
+  out_string : string -> int -> int -> unit;
+  out_flush : unit -> unit;
+  out_newline : unit -> unit;
+  out_spaces : int -> unit;
+}
+
+
+(*
+
+  Auxiliaries and basic functions.
+
+*)
+
+(* Queues auxiliaries. *)
+
+let make_queue () = { insert = Nil; body = Nil; }
+
+let clear_queue q = q.insert <- Nil; q.body <- Nil
+
+let add_queue x q =
+  let c = Cons { head = x; tail = Nil; } in
+  match q with
+  | { insert = Cons cell; body = _; } ->
+    q.insert <- c; cell.tail <- c
+  (* Invariant: when insert is Nil body should be Nil. *)
+  | { insert = Nil; body = _; } ->
+    q.insert <- c; q.body <- c
+
+
+exception Empty_queue
+
+let peek_queue = function
+  | { body = Cons { head = x; tail = _; }; _ } -> x
+  | { body = Nil; insert = _; } -> raise Empty_queue
+
+
+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. *)
+    x
+  | { body = Nil; insert = _; } -> raise Empty_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
+
+
+let pp_clear_queue state =
+  state.pp_left_total <- 1; state.pp_right_total <- 1;
+  clear_queue state.pp_queue
+
+
+(* Pp_infinity: large value for default tokens size.
+
+   Pp_infinity is documented as being greater than 1e10; to avoid
+   confusion about the word 'greater', we choose pp_infinity greater
+   than 1e10 + 1; for correct handling of tests in the algorithm,
+   pp_infinity must be even one more than 1e10 + 1; let's stand on the
+   safe side by choosing 1.e10+10.
+
+   Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is
+   the minimal upper bound for integers; now that max_int is defined,
+   this limit could also be defined as max_int - 1.
+
+   However, before setting pp_infinity to something around max_int, we
+   must carefully double-check all the integer arithmetic operations
+   that involve pp_infinity, since any overflow would wreck havoc the
+   pretty-printing algorithm's invariants. Given that this arithmetic
+   correctness check is difficult and error prone and given that 1e10
+   + 1 is in practice large enough, there is no need to attempt to set
+   pp_infinity to the theoretically maximum limit. It is not worth the
+   burden ! *)
+let pp_infinity = 1000000010
+
+(* Output functions for the formatter. *)
+let pp_output_string state s = state.pp_out_string s 0 (String.length s)
+and pp_output_newline state = state.pp_out_newline ()
+and pp_output_spaces state n = state.pp_out_spaces n
+
+(* 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. *)
+  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_output_spaces state state.pp_current_indent
+
+
+(* To force a line break inside a box: 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. *)
+let break_same_line state width =
+  state.pp_space_left <- state.pp_space_left - width;
+  pp_output_spaces state width
+
+
+(* To indent no more than pp_max_indent, if one tries to open a box
+   beyond pp_max_indent, then the box is rejected on the left
+   by simulating a break. *)
+let pp_force_break_line state =
+  match state.pp_format_stack with
+  | Format_elem (bl_ty, width) :: _ ->
+    if width > state.pp_space_left then
+      (match bl_ty with
+       | Pp_fits -> () | Pp_hbox -> ()
+       | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box ->
+         break_line state width)
+  | [] -> pp_output_newline state
+
+
+(* 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. *)
+  match take_queue state.pp_queue with
+  | { elem_size = size; length = len; token = _; } ->
+    state.pp_left_total <- state.pp_left_total - len;
+    state.pp_space_left <- state.pp_space_left + int_of_size size
+
+
+(*
+
+  The main pretty printing functions.
+
+*)
+
+(* Formatting a token with a given size. *)
+let format_pp_token state size = function
+
+  | Pp_text s ->
+    state.pp_space_left <- state.pp_space_left - size;
+    pp_output_string state s;
+    state.pp_is_new_line <- false
+
+  | Pp_begin (off, ty) ->
+    let insertion_point = state.pp_margin - state.pp_space_left in
+    if insertion_point > state.pp_max_indent then
+      (* can not open a box right there. *)
+      begin pp_force_break_line state end;
+    let offset = state.pp_space_left - off in
+    let bl_type =
+      begin match ty with
+      | Pp_vbox -> Pp_vbox
+      | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits ->
+        if size > state.pp_space_left then ty else Pp_fits
+      end in
+    state.pp_format_stack <-
+      Format_elem (bl_type, offset) :: state.pp_format_stack
+
+  | Pp_end ->
+    begin match state.pp_format_stack with
+    | _ :: ls -> state.pp_format_stack <- ls
+    | [] -> () (* No more box to close. *)
+    end
+
+  | Pp_tbegin (Pp_tbox _ as tbox) ->
+    state.pp_tbox_stack <- tbox :: state.pp_tbox_stack
+
+  | Pp_tend ->
+    begin match state.pp_tbox_stack with
+    | _ :: ls -> state.pp_tbox_stack <- ls
+    | [] -> () (* No more tabulation box to close. *)
+    end
+
+  | Pp_stab ->
+    begin match state.pp_tbox_stack with
+    | Pp_tbox tabs :: _ ->
+      let rec add_tab n = 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 box. *)
+    end
+
+  | Pp_tbreak (n, off) ->
+    let insertion_point = state.pp_margin - state.pp_space_left in
+    begin match state.pp_tbox_stack with
+    | Pp_tbox tabs :: _ ->
+      let rec find n = function
+        | x :: l -> if x >= n then x else find n l
+        | [] -> raise Not_found in
+      let tab =
+        match !tabs with
+        | x :: _ ->
+          begin
+            try find insertion_point !tabs with
+            | Not_found -> x
+          end
+        | _ -> insertion_point in
+      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 box. *)
+    end
+
+  | Pp_newline ->
+    begin match state.pp_format_stack with
+    | Format_elem (_, width) :: _ -> break_line state width
+    | [] -> pp_output_newline state (* No opened box. *)
+    end
+
+  | Pp_if_newline ->
+    if state.pp_current_indent != state.pp_margin - state.pp_space_left
+    then pp_skip_token state
+
+  | Pp_break (n, off) ->
+    begin match state.pp_format_stack with
+    | Format_elem (ty, width) :: _ ->
+      begin match ty with
+      | Pp_hovbox ->
+        if size > state.pp_space_left
+        then break_new_line state off width
+        else break_same_line state n
+      | Pp_box ->
+        (* Have the line just been broken here ? *)
+        if state.pp_is_new_line then break_same_line state n else
+        if size > state.pp_space_left
+         then break_new_line state off width else
+        (* break the line here leads to new indentation ? *)
+        if state.pp_current_indent > state.pp_margin - width + off
+        then break_new_line state off width
+        else break_same_line state n
+      | Pp_hvbox -> break_new_line state off width
+      | Pp_fits -> break_same_line state n
+      | Pp_vbox -> break_new_line state off width
+      | Pp_hbox -> break_same_line state n
+      end
+    | [] -> () (* No opened box. *)
+    end
+
+   | Pp_open_tag tag_name ->
+     let marker = state.pp_mark_open_tag tag_name in
+     pp_output_string state marker;
+     state.pp_mark_stack <- tag_name :: state.pp_mark_stack
+
+   | Pp_close_tag ->
+     begin match state.pp_mark_stack with
+     | tag_name :: tags ->
+       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. *)
+     end
+
+
+(* Print if token size is known else 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.
+
+   Note: [advance_loop] must be tail recursive to prevent stack overflows. *)
+let rec advance_loop state =
+  match peek_queue state.pp_queue with
+  | {elem_size = size; token = tok; length = len} ->
+    let size = int_of_size size in
+    if not
+         (size < 0 &&
+          (state.pp_right_total - state.pp_left_total < state.pp_space_left))
+    then begin
+      ignore (take_queue state.pp_queue);
+      format_pp_token state (if size < 0 then pp_infinity else size) tok;
+      state.pp_left_total <- len + state.pp_left_total;
+      advance_loop state
+    end
+
+
+let advance_left state =
+  try advance_loop state with
+  | Empty_queue -> ()
+
+
+(* To enqueue a token : try to advance. *)
+let enqueue_advance state tok = pp_enqueue state tok; advance_left state
+
+(* Building pretty-printer queue elements. *)
+let make_queue_elem size tok len =
+  { elem_size = size; token = tok; length = len; }
+
+
+(* To enqueue strings. *)
+let enqueue_string_as state size s =
+  let len = int_of_size size in
+  enqueue_advance state (make_queue_elem size (Pp_text s) len)
+
+
+let enqueue_string state s =
+  let len = String.length s in
+  enqueue_string_as state (size_of_int len) s
+
+
+(* Routines for scan stack
+   determine size of boxes. *)
+
+(* The scan_stack is never empty. *)
+let scan_stack_bottom =
+  let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in
+  [Scan_elem (-1, q_elem)]
+
+
+(* Clearing the pretty-printer scanning stack. *)
+let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom
+
+(* Setting the size of boxes on scan stack:
+   if ty = true then size of break is set else size of box is set;
+   in each case pp_scan_stack is popped.
+
+   Note:
+   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. *)
+let set_size state ty =
+  match state.pp_scan_stack with
+  | Scan_elem
+      (left_tot,
+       ({ elem_size = size; token = tok; length = _; } as queue_elem)) :: t ->
+    let size = int_of_size size in
+    (* 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 (_, _) ->
+        if ty then
+        begin
+          queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
+          state.pp_scan_stack <- t
+        end
+      | Pp_begin (_, _) ->
+        if not ty then
+        begin
+          queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
+          state.pp_scan_stack <- t
+        end
+      | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end
+      | Pp_newline | Pp_if_newline
+      | Pp_open_tag _ | Pp_close_tag ->
+        () (* scan_push is only used for breaks and boxes. *)
+      end
+  | [] -> () (* scan_stack is never empty. *)
+
+
+(* Push a token on pretty-printer scanning 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;
+  state.pp_scan_stack <-
+    Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack
+
+
+(* To open a new box :
+   the user may set the depth bound pp_max_boxes
+   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
+    let elem =
+      make_queue_elem
+        (size_of_int (- state.pp_right_total))
+        (Pp_begin (indent, br_ty))
+        0 in
+    scan_push state false elem else
+  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 = pp_open_box_gen state 0 Pp_hovbox
+
+(* Close a box, setting sizes of its sub boxes. *)
+let pp_close_box state () =
+  if state.pp_curr_depth > 1 then
+  begin
+    if state.pp_curr_depth < state.pp_max_boxes then
+    begin
+      pp_enqueue state
+        { elem_size = size_of_int 0; token = Pp_end; length = 0; };
+      set_size state true; set_size state false
+    end;
+    state.pp_curr_depth <- state.pp_curr_depth - 1;
+  end
+
+
+(* Open a tag, pushing it on the tag stack. *)
+let pp_open_tag state tag_name =
+  if state.pp_print_tags then
+  begin
+    state.pp_tag_stack <- tag_name :: state.pp_tag_stack;
+    state.pp_print_open_tag tag_name
+  end;
+  if state.pp_mark_tags then
+    pp_enqueue state {
+      elem_size = size_of_int 0;
+      token = Pp_open_tag tag_name;
+      length = 0;
+    }
+
+
+(* Close a tag, popping it from the tag stack. *)
+let pp_close_tag state () =
+  if state.pp_mark_tags then
+    pp_enqueue state {
+      elem_size = size_of_int 0;
+      token = Pp_close_tag;
+      length = 0;
+    };
+  if state.pp_print_tags then
+  begin
+    match state.pp_tag_stack with
+    | tag_name :: tags ->
+      state.pp_print_close_tag tag_name;
+      state.pp_tag_stack <- tags
+    | _ -> () (* No more tag to close. *)
+  end
+
+
+let pp_set_print_tags state b = state.pp_print_tags <- b
+let pp_set_mark_tags state b = state.pp_mark_tags <- b
+let pp_get_print_tags state () = state.pp_print_tags
+let pp_get_mark_tags state () = state.pp_mark_tags
+let pp_set_tags state b =
+  pp_set_print_tags state b; pp_set_mark_tags state b
+
+
+(* Handling tag handling functions: get/set functions. *)
+let pp_get_formatter_tag_functions state () = {
+  mark_open_tag = state.pp_mark_open_tag;
+  mark_close_tag = state.pp_mark_close_tag;
+  print_open_tag = state.pp_print_open_tag;
+  print_close_tag = state.pp_print_close_tag;
+}
+
+
+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_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. *)
+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;
+  if b then pp_output_newline state;
+  pp_rinit state
+
+
+(*
+
+  Procedures to format values and use boxes.
+
+*)
+
+(* To format a string. *)
+let pp_print_as_size state size s =
+  if state.pp_curr_depth < state.pp_max_boxes
+  then enqueue_string_as state size s
+
+
+let pp_print_as state isize s =
+  pp_print_as_size state (size_of_int isize) s
+
+
+let pp_print_string state s =
+  pp_print_as state (String.length s) s
+
+
+(* To format an integer. *)
+let pp_print_int state i = pp_print_string state (string_of_int i)
+
+(* To format a float. *)
+let pp_print_float state f = pp_print_string state (string_of_float f)
+
+(* To format a boolean. *)
+let pp_print_bool state b = pp_print_string state (string_of_bool b)
+
+(* To format a char. *)
+let pp_print_char state c =
+  pp_print_as state 1 (String.make 1 c)
+
+
+(* 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
+
+and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox
+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
+
+
+(* Printing all queued text.
+   [print_newline] prints a new line after flushing the queue.
+   [print_flush] on flush the queue without adding a newline. *)
+let pp_print_newline state () =
+  pp_flush_queue state true; state.pp_out_flush ()
+and pp_print_flush state () =
+  pp_flush_queue state false; state.pp_out_flush ()
+
+
+(* To get a newline when one does not want to close the current box. *)
+let pp_force_newline state () =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0)
+
+
+(* To format something, only in case 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 (make_queue_elem (size_of_int 0) Pp_if_newline 0)
+
+
+(* Printing break hints:
+   A break hint indicates where a box may be broken.
+   If line is broken then offset is added to the indentation of the current
+   box else (the value of) width blanks are printed. *)
+let pp_print_break state width offset =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    let elem =
+      make_queue_elem
+        (size_of_int (- state.pp_right_total))
+        (Pp_break (width, offset))
+        width in
+    scan_push state true elem
+
+
+(* Print a space :
+   a space is a break hint that prints a single space if the break does not
+   split the line;
+   a cut is a break hint that prints nothing if the break does not split the
+   line. *)
+let pp_print_space state () = pp_print_break state 1 0
+and pp_print_cut state () = pp_print_break state 0 0
+
+
+(* 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
+    let elem =
+      make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in
+    enqueue_advance state elem
+
+
+(* Close a tabulation box. *)
+let pp_close_tbox state () =
+  if state.pp_curr_depth > 1 then
+  begin
+   if state.pp_curr_depth < state.pp_max_boxes then
+     let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in
+     enqueue_advance state elem;
+     state.pp_curr_depth <- state.pp_curr_depth - 1
+  end
+
+
+(* Print a tabulation break. *)
+let pp_print_tbreak state width offset =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    let elem =
+      make_queue_elem
+        (size_of_int (- state.pp_right_total))
+        (Pp_tbreak (width, offset))
+        width in
+    scan_push state true elem
+
+
+let pp_print_tab state () = pp_print_tbreak state 0 0
+
+let pp_set_tab state () =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    let elem =
+      make_queue_elem (size_of_int 0) Pp_stab 0 in
+    enqueue_advance state elem
+
+
+(*
+
+  Procedures to control the pretty-printers
+
+*)
+
+(* Set_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. *)
+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. *)
+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. *)
+let pp_limit n =
+  if n < pp_infinity then n else pred pp_infinity
+
+
+(* Internal pretty-printer functions. *)
+let pp_set_min_space_left state n =
+  if n >= 1 then
+    let n = pp_limit n in
+    state.pp_min_space_left <- n;
+    state.pp_max_indent <- state.pp_margin - state.pp_min_space_left;
+    pp_rinit state
+
+
+(* Initially, we have :
+   pp_max_indent = pp_margin - pp_min_space_left, and
+   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
+
+let pp_set_margin state n =
+  if n >= 1 then
+    let n = pp_limit n in
+    state.pp_margin <- n;
+    let new_max_indent =
+      (* 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. *)
+       max (max (state.pp_margin - state.pp_min_space_left)
+                (state.pp_margin / 2)) 1 in
+    (* Rebuild invariants. *)
+    pp_set_max_indent state new_max_indent
+
+
+let pp_get_margin state () = state.pp_margin
+
+(* Setting a formatter basic output functions. *)
+let pp_set_formatter_out_functions state {
+      out_string = f;
+      out_flush = g;
+      out_newline = h;
+      out_spaces = i;
+    } =
+  state.pp_out_string <- f;
+  state.pp_out_flush <- g;
+  state.pp_out_newline <- h;
+  state.pp_out_spaces <- i
+
+
+let pp_get_formatter_out_functions state () = {
+  out_string = state.pp_out_string;
+  out_flush = state.pp_out_flush;
+  out_newline = state.pp_out_newline;
+  out_spaces = state.pp_out_spaces;
+}
+
+
+(* Setting a formatter basic string output and flush functions. *)
+let pp_set_formatter_output_functions state f g =
+  state.pp_out_string <- f; state.pp_out_flush <- g
+
+let pp_get_formatter_output_functions state () =
+  (state.pp_out_string, state.pp_out_flush)
+
+
+let pp_flush_formatter state =
+  pp_flush_queue state false
+
+(* The default function to output new lines. *)
+let display_newline state () = state.pp_out_string "\n" 0  1
+
+(* The default function to output spaces. *)
+let blank_line = String.make 80 ' '
+let rec display_blanks state n =
+  if n > 0 then
+  if n <= 80 then state.pp_out_string blank_line 0 n else
+  begin
+    state.pp_out_string blank_line 0 80;
+    display_blanks state (n - 80)
+  end
+
+
+(* Setting a formatter basic output functions as printing to a given
+   [Pervasive.out_channel] value. *)
+let pp_set_formatter_out_channel state os =
+  state.pp_out_string <- output_substring os;
+  state.pp_out_flush <- (fun () -> flush os);
+  state.pp_out_newline <- display_newline state;
+  state.pp_out_spaces <- display_blanks state
+
+
+(*
+
+  Defining specific formatters
+
+*)
+
+let default_pp_mark_open_tag s = "<" ^ s ^ ">"
+let default_pp_mark_close_tag s = "</" ^ s ^ ">"
+
+let default_pp_print_open_tag = ignore
+let default_pp_print_close_tag = ignore
+
+(* Bulding a formatter given its basic output functions.
+   Other fields get reasonable default values. *)
+let pp_make_formatter f g h i =
+  (* The initial state of the formatter contains a dummy box. *)
+  let pp_queue = make_queue () in
+  let sys_tok =
+    make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in
+  add_queue sys_tok pp_queue;
+  let sys_scan_stack =
+    Scan_elem (1, sys_tok) :: scan_stack_bottom in
+  let pp_margin = 78
+  and pp_min_space_left = 10 in
+  {
+    pp_scan_stack = sys_scan_stack;
+    pp_format_stack = [];
+    pp_tbox_stack = [];
+    pp_tag_stack = [];
+    pp_mark_stack = [];
+    pp_margin = pp_margin;
+    pp_min_space_left = pp_min_space_left;
+    pp_max_indent = pp_margin - pp_min_space_left;
+    pp_space_left = pp_margin;
+    pp_current_indent = 0;
+    pp_is_new_line = true;
+    pp_left_total = 1;
+    pp_right_total = 1;
+    pp_curr_depth = 1;
+    pp_max_boxes = max_int;
+    pp_ellipsis = ".";
+    pp_out_string = f;
+    pp_out_flush = g;
+    pp_out_newline = h;
+    pp_out_spaces = i;
+    pp_print_tags = false;
+    pp_mark_tags = false;
+    pp_mark_open_tag = default_pp_mark_open_tag;
+    pp_mark_close_tag = default_pp_mark_close_tag;
+    pp_print_open_tag = default_pp_print_open_tag;
+    pp_print_close_tag = default_pp_print_close_tag;
+    pp_queue = pp_queue;
+  }
+
+
+(* Make a formatter with default functions to output spaces and new lines. *)
+let make_formatter output flush =
+  let ppf = pp_make_formatter output flush ignore ignore in
+  ppf.pp_out_newline <- display_newline ppf;
+  ppf.pp_out_spaces <- display_blanks ppf;
+  ppf
+
+
+(* Make a formatter writing to a given [Pervasive.out_channel] value. *)
+let formatter_of_out_channel oc =
+  make_formatter (output_substring oc) (fun () -> flush oc)
+
+
+(* Make a formatter writing to a given [Buffer.t] value. *)
+let formatter_of_buffer b =
+  make_formatter (Buffer.add_substring b) ignore
+
+
+(* Allocating buffer for pretty-printing purposes.
+   Default buffer size is pp_buffer_size or 512.
+*)
+let pp_buffer_size = 512
+let pp_make_buffer () = Buffer.create pp_buffer_size
+
+(* The standard (shared) buffer. *)
+let stdbuf = pp_make_buffer ()
+
+(* Predefined formatters standard formatter to print
+   to [Pervasives.stdout], [Pervasives.stderr], and {!stdbuf}. *)
+let std_formatter = formatter_of_out_channel Pervasives.stdout
+and err_formatter = formatter_of_out_channel Pervasives.stderr
+and str_formatter = formatter_of_buffer stdbuf
+
+
+(* [flush_buffer_formatter buf ppf] flushes formatter [ppf],
+   then return the contents of buffer [buff] thst is reset.
+   Formatter [ppf] is supposed to print to buffer [buf], otherwise this
+   function is not really useful. *)
+let flush_buffer_formatter buf ppf =
+  pp_flush_queue ppf false;
+  let s = Buffer.contents buf in
+  Buffer.reset buf;
+  s
+
+
+(* Flush [str_formatter] and get the contents of [stdbuf]. *)
+let flush_str_formatter () = flush_buffer_formatter stdbuf str_formatter
+
+(*
+
+  Basic functions on the 'standard' formatter
+  (the formatter that prints to [Pervasives.stdout]).
+
+*)
+
+let open_hbox = pp_open_hbox std_formatter
+and open_vbox = pp_open_vbox std_formatter
+and open_hvbox = pp_open_hvbox std_formatter
+and open_hovbox = pp_open_hovbox std_formatter
+and open_box = pp_open_box std_formatter
+and close_box = pp_close_box std_formatter
+and open_tag = pp_open_tag std_formatter
+and close_tag = pp_close_tag std_formatter
+and print_as = pp_print_as std_formatter
+and print_string = pp_print_string std_formatter
+and print_int = pp_print_int std_formatter
+and print_float = pp_print_float std_formatter
+and print_char = pp_print_char std_formatter
+and print_bool = pp_print_bool std_formatter
+and print_break = pp_print_break std_formatter
+and print_cut = pp_print_cut std_formatter
+and print_space = pp_print_space std_formatter
+and force_newline = pp_force_newline std_formatter
+and print_flush = pp_print_flush std_formatter
+and print_newline = pp_print_newline std_formatter
+and print_if_newline = pp_print_if_newline std_formatter
+
+and open_tbox = pp_open_tbox std_formatter
+and close_tbox = pp_close_tbox std_formatter
+and print_tbreak = pp_print_tbreak std_formatter
+
+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 get_margin = pp_get_margin std_formatter
+
+and set_max_indent = pp_set_max_indent std_formatter
+and get_max_indent = pp_get_max_indent std_formatter
+
+and set_max_boxes = pp_set_max_boxes std_formatter
+and get_max_boxes = pp_get_max_boxes std_formatter
+and over_max_boxes = pp_over_max_boxes std_formatter
+
+and set_ellipsis_text = pp_set_ellipsis_text std_formatter
+and get_ellipsis_text = pp_get_ellipsis_text std_formatter
+
+and set_formatter_out_channel =
+  pp_set_formatter_out_channel std_formatter
+
+and set_formatter_out_functions =
+  pp_set_formatter_out_functions std_formatter
+and get_formatter_out_functions =
+  pp_get_formatter_out_functions std_formatter
+
+and set_formatter_output_functions =
+  pp_set_formatter_output_functions std_formatter
+and get_formatter_output_functions =
+  pp_get_formatter_output_functions std_formatter
+
+and set_formatter_tag_functions =
+  pp_set_formatter_tag_functions std_formatter
+and get_formatter_tag_functions =
+  pp_get_formatter_tag_functions std_formatter
+and set_print_tags =
+  pp_set_print_tags std_formatter
+and get_print_tags =
+  pp_get_print_tags std_formatter
+and set_mark_tags =
+  pp_set_mark_tags std_formatter
+and get_mark_tags =
+  pp_get_mark_tags std_formatter
+and set_tags =
+  pp_set_tags std_formatter
+
+
+(* Convenience functions *)
+
+(* To format a list *)
+let rec pp_print_list ?(pp_sep = pp_print_cut) pp_v ppf = function
+  | [] -> ()
+  | [v] -> pp_v ppf v
+  | v :: vs ->
+    pp_v ppf v;
+    pp_sep ppf ();
+    pp_print_list ~pp_sep pp_v ppf vs
+
+(* To format free-flowing text *)
+let pp_print_text ppf s =
+  let len = String.length s in
+  let left = ref 0 in
+  let right = ref 0 in
+  let flush () =
+    pp_print_string ppf (String.sub s !left (!right - !left));
+    incr right; left := !right;
+  in
+  while (!right <> len) do
+    match s.[!right] with
+      | '\n' ->
+        flush ();
+        pp_force_newline ppf ()
+      | ' ' ->
+        flush (); pp_print_space ppf ()
+      (* there is no specific support for '\t'
+         as it is unclear what a right semantics would be *)
+      | _ -> incr right
+  done;
+  if !left <> len then flush ()
+
+ (**************************************************************)
+
+let compute_tag output tag_acc =
+  let buf = Buffer.create 16 in
+  let ppf = formatter_of_buffer buf in
+  output ppf tag_acc;
+  pp_print_flush ppf ();
+  let len = Buffer.length buf in
+  if len < 2 then Buffer.contents buf
+  else Buffer.sub buf 1 (len - 2)
+
+ (**************************************************************
+
+  Defining continuations to be passed as arguments of
+  CamlinternalFormat.make_printf.
+
+  **************************************************************)
+
+open CamlinternalFormatBasics
+open CamlinternalFormat
+
+(* Interpret a formatting entity on a formatter. *)
+let output_formatting_lit ppf fmting_lit = match fmting_lit with
+  | Close_box                 -> pp_close_box ppf ()
+  | Close_tag                 -> pp_close_tag ppf ()
+  | Break (_, width, offset)  -> pp_print_break ppf width offset
+  | FFlush                    -> pp_print_flush ppf ()
+  | Force_newline             -> pp_force_newline ppf ()
+  | Flush_newline             -> pp_print_newline ppf ()
+  | Magic_size (_, _)         -> ()
+  | Escaped_at                -> pp_print_char ppf '@'
+  | Escaped_percent           -> pp_print_char ppf '%'
+  | Scan_indic c              -> pp_print_char ppf '@'; pp_print_char ppf c
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in an output_stream. *)
+(* Differ from Printf.output_acc by the interpretation of formatting. *)
+(* Used as a continuation of CamlinternalFormat.make_printf. *)
+let rec output_acc ppf acc = match acc with
+  | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s)
+  | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) ->
+    output_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) s;
+  | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c)
+  | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) ->
+    output_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) (String.make 1 c);
+  | Acc_formatting_lit (p, f) ->
+    output_acc ppf p;
+    output_formatting_lit ppf f;
+  | Acc_formatting_gen (p, Acc_open_tag acc') ->
+    output_acc ppf p;
+    pp_open_tag ppf (compute_tag output_acc acc')
+  | Acc_formatting_gen (p, Acc_open_box acc') ->
+    output_acc ppf p;
+    let (indent, bty) = open_box_of_string (compute_tag output_acc acc') in
+    pp_open_box_gen ppf indent bty
+  | Acc_string_literal (p, s)
+  | Acc_data_string (p, s)   -> output_acc ppf p; pp_print_string ppf s;
+  | Acc_char_literal (p, c)
+  | Acc_data_char (p, c)     -> output_acc ppf p; pp_print_char ppf c;
+  | Acc_delay (p, f)         -> output_acc ppf p; f ppf;
+  | Acc_flush p              -> output_acc ppf p; pp_print_flush ppf ();
+  | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg;
+  | End_of_acc               -> ()
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in a buffer. *)
+(* Differ from Printf.bufput_acc by the interpretation of formatting. *)
+(* Used as a continuation of CamlinternalFormat.make_printf. *)
+let rec strput_acc ppf acc = match acc with
+  | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s)
+  | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) ->
+    strput_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) s;
+  | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c)
+  | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) ->
+    strput_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) (String.make 1 c);
+  | Acc_delay (Acc_formatting_lit (p, Magic_size (_, size)), f) ->
+    strput_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) (f ());
+  | Acc_formatting_lit (p, f) ->
+    strput_acc ppf p;
+    output_formatting_lit ppf f;
+  | Acc_formatting_gen (p, Acc_open_tag acc') ->
+    strput_acc ppf p;
+    pp_open_tag ppf (compute_tag strput_acc acc')
+  | Acc_formatting_gen (p, Acc_open_box acc') ->
+    strput_acc ppf p;
+    let (indent, bty) = open_box_of_string (compute_tag strput_acc acc') in
+    pp_open_box_gen ppf indent bty
+  | Acc_string_literal (p, s)
+  | Acc_data_string (p, s)   -> strput_acc ppf p; pp_print_string ppf s;
+  | Acc_char_literal (p, c)
+  | Acc_data_char (p, c)     -> strput_acc ppf p; pp_print_char ppf c;
+  | Acc_delay (p, f)         -> strput_acc ppf p; pp_print_string ppf (f ());
+  | Acc_flush p              -> strput_acc ppf p; pp_print_flush ppf ();
+  | Acc_invalid_arg (p, msg) -> strput_acc ppf p; invalid_arg msg;
+  | End_of_acc               -> ()
+
+(*
+
+  Defining [fprintf] and various flavors of [fprintf].
+
+*)
+
+let kfprintf k ppf (Format (fmt, _)) =
+  make_printf
+    (fun ppf acc -> output_acc ppf acc; k ppf)
+    ppf End_of_acc fmt
+
+and ikfprintf k ppf (Format (fmt, _)) =
+  make_iprintf k ppf fmt
+
+let fprintf ppf = kfprintf ignore ppf
+let ifprintf ppf = ikfprintf ignore ppf
+let printf fmt = fprintf std_formatter fmt
+let eprintf fmt = fprintf err_formatter fmt
+
+let ksprintf k (Format (fmt, _)) =
+  let b = pp_make_buffer () in
+  let ppf = formatter_of_buffer b in
+  let k () acc =
+    strput_acc ppf acc;
+    k (flush_buffer_formatter b ppf) in
+  make_printf k () End_of_acc fmt
+
+
+let sprintf fmt = ksprintf (fun s -> s) fmt
+
+let kasprintf k (Format (fmt, _)) =
+  let b = pp_make_buffer () in
+  let ppf = formatter_of_buffer b in
+  let k ppf acc =
+    output_acc ppf acc;
+    k (flush_buffer_formatter b ppf) in
+  make_printf k ppf End_of_acc fmt
+
+
+let asprintf fmt = kasprintf (fun s -> s) fmt
+
+(* Output everything left in the pretty printer queue at end of execution. *)
+let () = at_exit print_flush
+
+
+(*
+
+  Deprecated stuff.
+
+*)
+
+(* Deprecated : subsumed by pp_set_formatter_out_functions *)
+let pp_set_all_formatter_output_functions state
+    ~out:f ~flush:g ~newline:h ~spaces:i =
+  pp_set_formatter_output_functions state f g;
+  state.pp_out_newline <- h;
+  state.pp_out_spaces <- i
+
+
+(* Deprecated : subsumed by pp_get_formatter_out_functions *)
+let pp_get_all_formatter_output_functions state () =
+  (state.pp_out_string, state.pp_out_flush,
+   state.pp_out_newline, state.pp_out_spaces)
+
+
+(* Deprecated : subsumed by set_formatter_out_functions *)
+let set_all_formatter_output_functions =
+  pp_set_all_formatter_output_functions std_formatter
+
+
+(* Deprecated : subsumed by get_formatter_out_functions *)
+let get_all_formatter_output_functions =
+  pp_get_all_formatter_output_functions std_formatter
+
+
+(* Deprecated : error prone function, do not use it.
+   Define a formatter of your own writing to the buffer,
+   as in
+   let ppf = formatter_of_buffer b
+   then use {!fprintf ppf} as useual. *)
+let bprintf b (Format (fmt, _) : ('a, formatter, unit) format) =
+  let k ppf acc = output_acc ppf acc; pp_flush_queue ppf false in
+  make_printf k (formatter_of_buffer b) End_of_acc fmt
+
+
+(* Deprecated : alias for ksprintf. *)
+let kprintf = ksprintf
diff --git a/stdlib/format.mli b/stdlib/format.mli
new file mode 100644
index 00000000..7ff5fda2
--- /dev/null
+++ b/stdlib/format.mli
@@ -0,0 +1,823 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Pretty printing.
+
+   This module implements a pretty-printing facility to format values
+   within 'pretty-printing boxes'. The pretty-printer splits lines
+   at specified break hints, and indents lines according to the box
+   structure.
+
+   For a gentle introduction to the basics of pretty-printing using
+   [Format], read
+   {{:http://caml.inria.fr/resources/doc/guides/format.en.html}
+    http://caml.inria.fr/resources/doc/guides/format.en.html}.
+
+   You may consider this module as providing an extension to the
+   [printf] facility to provide automatic line splitting. The addition of
+   pretty-printing annotations to your regular [printf] formats gives you
+   fancy indentation and line breaks.
+   Pretty-printing annotations are described below in the documentation of
+   the function {!Format.fprintf}.
+
+   You may also use the explicit box management and printing functions
+   provided by this module. This style is more basic but more verbose
+   than the [fprintf] concise formats.
+
+   For instance, the sequence
+   [open_box 0; print_string "x ="; print_space ();
+    print_int 1; close_box (); print_newline ()]
+   that prints [x = 1] within a pretty-printing box, can be
+   abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter
+   [printf "@[x =@ %i@]@." 1].
+
+   Rule of thumb for casual users of this library:
+ - use simple boxes (as obtained by [open_box 0]);
+ - use simple break hints (as obtained by [print_cut ()] that outputs a
+   simple break hint, or by [print_space ()] that outputs a space
+   indicating a break hint);
+ - once a box is opened, display its material with basic printing
+   functions (e. g. [print_int] and [print_string]);
+ - when the material for a box has been printed, call [close_box ()] to
+   close the box;
+ - at the end of your routine, flush the pretty-printer to display all the
+   remaining material, e.g. evaluate [print_newline ()].
+
+   The behaviour of pretty-printing commands is unspecified
+   if there is no opened pretty-printing box. Each box opened via
+   one of the [open_] functions below must be closed using [close_box]
+   for proper formatting. Otherwise, some of the material printed in the
+   boxes may not be output, or may be formatted incorrectly.
+
+   In case of interactive use, the system closes all opened boxes and
+   flushes all pending text (as with the [print_newline] function)
+   after each phrase. Each phrase is therefore executed in the initial
+   state of the pretty-printer.
+
+   Warning: the material output by the following functions is delayed
+   in the pretty-printer queue in order to compute the proper line
+   splitting. Hence, you should not mix calls to the printing functions
+   of the basic I/O system with calls to the functions of this module:
+   this could result in some strange output seemingly unrelated with
+   the evaluation order of printing commands.
+*)
+
+(** {6 Boxes} *)
+
+val open_box : int -> unit
+(** [open_box d] opens a new pretty-printing box
+   with offset [d].
+
+   This box prints material as much as possible on every line.
+
+   A break hint splits the line if there is no more room on the line to
+   print the remainder of the box.
+   A break hint also splits the line if the splitting ``moves to the left''
+   (i.e. it gives an indentation smaller than the one of the current line).
+
+   This box is the general purpose pretty-printing box.
+
+   If the pretty-printer splits the line in the box, offset [d] is added to
+   the current indentation. *)
+
+val close_box : unit -> unit
+(** Closes the most recently opened pretty-printing box. *)
+
+(** {6 Formatting functions} *)
+
+val print_string : string -> unit
+(** [print_string str] prints [str] in the current box. *)
+
+val print_as : int -> string -> unit
+(** [print_as len str] prints [str] in the
+   current box. The pretty-printer formats [str] as if
+   it were of length [len]. *)
+
+val print_int : int -> unit
+(** Prints an integer in the current box. *)
+
+val print_float : float -> unit
+(** Prints a floating point number in the current box. *)
+
+val print_char : char -> unit
+(** Prints a character in the current box. *)
+
+val print_bool : bool -> unit
+(** Prints a boolean in the current box. *)
+
+(** {6 Break hints} *)
+
+(** A 'break hint' tells the pretty-printer to output some space or split the
+  line whichever way is more appropriate to the current box splitting rules.
+
+  Break hints are used to separate printing items and are mandatory to let
+  the pretty-printer correctly split lines and indent items.
+
+  Simple break hints are:
+  - the 'space': output a space or split the line if appropriate,
+  - the 'cut': split the line if appropriate.
+
+  Note: the notions of space and line splitting are abstract for the
+  pretty-printing engine, since those notions can be completely defined
+  by the programmer.
+  However, in the pretty-printer default setting, ``output a space'' simply
+  means printing a space character (ASCII code 32) and ``split the line''
+  is printing a newline character (ASCII code 10).
+
+*)
+
+val print_space : unit -> unit
+(** [print_space ()] the 'space' break hint:
+  the pretty-printer may split the line at this
+  point, otherwise it prints one space.
+  It is equivalent to [print_break 1 0]. *)
+
+val print_cut : unit -> unit
+(** [print_cut ()] the 'cut' break hint:
+  the pretty-printer may split the line at this
+  point, otherwise it prints nothing.
+  It is equivalent to [print_break 0 0]. *)
+
+val print_break : int -> int -> unit
+(** [print_break nspaces offset] the 'full' break hint:
+  the pretty-printer may split the line at this
+  point, otherwise it prints [nspaces] spaces.
+
+  If the pretty-printer splits the line, [offset] is added to
+  the current indentation.
+*)
+
+val print_flush : unit -> unit
+(** Flushes the pretty printer: all opened boxes are closed,
+  and all pending text is displayed. *)
+
+val print_newline : unit -> unit
+(** Equivalent to [print_flush] followed by a new line. *)
+
+val force_newline : unit -> unit
+(** Forces a new line in the current box.
+  Not the normal way of pretty-printing, since the new line does not reset
+  the current line count.
+  You should prefer using break hints within a vertcal box. *)
+
+val print_if_newline : unit -> unit
+(** Executes the next formatting command if the preceding line
+  has just been split. Otherwise, ignore the next formatting
+  command. *)
+
+(** {6 Margin} *)
+
+val set_margin : int -> unit
+(** [set_margin d] sets the right margin to [d] (in characters):
+  the pretty-printer splits lines that overflow the right margin according to
+  the break hints given.
+  Nothing happens if [d] is smaller than 2.
+  If [d] is too large, the right margin is set to the maximum
+  admissible value (which is greater than [10^9]). *)
+
+val get_margin : unit -> int
+(** Returns the position of the right margin. *)
+
+(** {6 Maximum indentation limit} *)
+
+val set_max_indent : int -> unit
+(** [set_max_indent d] sets the maximum indentation limit of lines to [d] (in
+  characters):
+  once this limit is reached, new boxes are rejected to the left,
+  if they do not fit on the current line.
+  Nothing happens if [d] is smaller than 2.
+  If [d] is too large, the limit is set to the maximum
+  admissible value (which is greater than [10 ^ 9]). *)
+
+val get_max_indent : unit -> int
+(** Return the maximum indentation limit (in characters). *)
+
+(** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
+
+val set_max_boxes : int -> unit
+(** [set_max_boxes max] sets the maximum number of boxes simultaneously
+  opened.
+  Material inside boxes nested deeper is printed as an ellipsis (more
+  precisely as the text returned by [get_ellipsis_text ()]).
+  Nothing happens if [max] is smaller than 2. *)
+
+val get_max_boxes : unit -> int
+(** Returns the maximum number of boxes allowed before ellipsis. *)
+
+val over_max_boxes : unit -> bool
+(** Tests if the maximum number of boxes allowed have already been opened. *)
+
+(** {6 Advanced formatting} *)
+
+val open_hbox : unit -> unit
+(** [open_hbox ()] opens a new 'horizontal' pretty-printing box.
+
+  This box prints material on a single line.
+
+  Break hints in a horizontal box never split the line.
+  (Line splitting may still occur inside boxes nested deeper). *)
+
+val open_vbox : int -> unit
+(** [open_vbox d] opens a new 'vertical' pretty-printing box
+  with offset [d].
+
+  This box prints material on as many lines as break hints in the box.
+
+  Every break hint in a vertical box splits the line.
+
+  If the pretty-printer splits the line in the box, [d] is added to the
+  current indentation. *)
+
+val open_hvbox : int -> unit
+(** [open_hvbox d] opens a new 'horizontal-vertical' pretty-printing box
+  with offset [d].
+
+  This box behaves as an horizontal box if it fits on a single line,
+  otherwise it behaves as a vertical box.
+
+  If the pretty-printer splits the line in the box, [d] is added to the
+  current indentation. *)
+
+val open_hovbox : int -> unit
+(** [open_hovbox d] opens a new 'horizontal-or-vertical' pretty-printing box
+  with offset [d].
+
+  This box prints material as much as possible on every line.
+
+  A break hint splits the line if there is no more room on the line to
+  print the remainder of the box.
+
+  If the pretty-printer splits the line in the box, [d] is added to the
+  current indentation. *)
+
+(** {6 Ellipsis} *)
+
+val set_ellipsis_text : string -> unit
+(** Set the text of the ellipsis printed when too many boxes
+  are opened (a single dot, [.], by default). *)
+
+val get_ellipsis_text : unit -> string
+(** Return the text of the ellipsis. *)
+
+(** {6:tags Semantic Tags} *)
+
+type tag = string
+
+(** {i Semantic tags} (or simply {e tags}) are used to decorate printed
+  entities for user's defined purposes, e.g. setting font and giving size
+  indications for a display device, or marking delimitation of semantic
+  entities (e.g. HTML or TeX elements or terminal escape sequences).
+
+  By default, those tags do not influence line splitting calculation:
+  the tag 'markers' are not considered as part of the printing
+  material that drives line splitting (in other words, the length of
+  those strings is considered as zero for line splitting).
+
+  Thus, tag handling is in some sense transparent to pretty-printing
+  and does not interfere with usual indentation. Hence, a single
+  pretty printing routine can output both simple 'verbatim'
+  material or richer decorated output depending on the treatment of
+  tags. By default, tags are not active, hence the output is not
+  decorated with tag information. Once [set_tags] is set to [true],
+  the pretty printer engine honours tags and decorates the output
+  accordingly.
+
+  When a tag has been opened (or closed), it is both and successively
+  'printed' and 'marked'. Printing a tag means calling a
+  formatter specific function with the name of the tag as argument:
+  that 'tag printing' function can then print any regular material
+  to the formatter (so that this material is enqueued as usual in the
+  formatter queue for further line splitting computation). Marking a
+  tag means to output an arbitrary string (the 'tag marker'),
+  directly into the output device of the formatter. Hence, the
+  formatter specific 'tag marking' function must return the tag
+  marker string associated to its tag argument. Being flushed
+  directly into the output device of the formatter, tag marker
+  strings are not considered as part of the printing material that
+  drives line splitting (in other words, the length of the strings
+  corresponding to tag markers is considered as zero for line
+  splitting). In addition, advanced users may take advantage of
+  the specificity of tag markers to be precisely output when the
+  pretty printer has already decided where to split the lines, and
+  precisely when the queue is flushed into the output device.
+
+  In the spirit of HTML tags, the default tag marking functions
+  output tags enclosed in "<" and ">": hence, the opening marker of
+  tag [t] is ["<t>"] and the closing marker ["</t>"].
+
+  Default tag printing functions just do nothing.
+
+  Tag marking and tag printing functions are user definable and can
+  be set by calling [set_formatter_tag_functions]. *)
+
+val open_tag : tag -> unit
+(** [open_tag t] opens the tag named [t]; the [print_open_tag]
+  function of the formatter is called with [t] as argument;
+  the tag marker [mark_open_tag t] will be flushed into the output
+  device of the formatter. *)
+
+val close_tag : unit -> unit
+(** [close_tag ()] closes the most recently opened tag [t].
+  In addition, the [print_close_tag] function of the formatter is called
+  with [t] as argument. The marker [mark_close_tag t] will be flushed
+  into the output device of the formatter. *)
+
+val set_tags : bool -> unit
+(** [set_tags b] turns on or off the treatment of tags (default is off). *)
+
+val set_print_tags : bool -> unit
+(** [set_print_tags b] turns on or off the printing of tags. *)
+
+val set_mark_tags : bool -> unit
+(** [set_mark_tags b] turns on or off the output of tag markers. *)
+
+val get_print_tags : unit -> bool
+(** Return the current status of tags printing. *)
+
+val get_mark_tags : unit -> bool
+(** Return the current status of tags marking. *)
+
+(** {6 Redirecting the standard formatter output} *)
+
+val set_formatter_out_channel : Pervasives.out_channel -> unit
+(** Redirect the pretty-printer output to the given channel.
+  (All the output functions of the standard formatter are set to the
+   default output functions printing to the given channel.) *)
+
+val set_formatter_output_functions :
+  (string -> int -> int -> unit) -> (unit -> unit) -> unit
+(** [set_formatter_output_functions out flush] redirects the
+  pretty-printer output functions to the functions [out] and
+  [flush].
+
+  The [out] function performs all the pretty-printer string output.
+  It is called with a string [s], a start position [p], and a number of
+  characters [n]; it is supposed to output characters [p] to [p + n - 1] of
+  [s].
+
+  The [flush] function is called whenever the pretty-printer is flushed
+  (via conversion [%!], or pretty-printing indications [@?] or [@.], or
+  using low level functions [print_flush] or [print_newline]). *)
+
+val get_formatter_output_functions :
+  unit -> (string -> int -> int -> unit) * (unit -> unit)
+(** Return the current output functions of the pretty-printer. *)
+
+(** {6:meaning Changing the meaning of standard formatter pretty printing} *)
+
+(** The [Format] module is versatile enough to let you completely redefine
+  the meaning of pretty printing: you may provide your own functions to define
+  how to handle indentation, line splitting, and even printing of all the
+  characters that have to be printed! *)
+
+type formatter_out_functions = {
+  out_string : string -> int -> int -> unit;
+  out_flush : unit -> unit;
+  out_newline : unit -> unit;
+  out_spaces : int -> unit;
+} (** @since 4.01.0 *)
+
+val set_formatter_out_functions : formatter_out_functions -> unit
+(** [set_formatter_out_functions f]
+  Redirect the pretty-printer output to the functions [f.out_string]
+  and [f.out_flush] as described in
+  [set_formatter_output_functions]. In addition, the pretty-printer function
+  that outputs a newline is set to the function [f.out_newline] and
+  the function that outputs indentation spaces is set to the function
+  [f.out_spaces].
+
+  This way, you can change the meaning of indentation (which can be
+  something else than just printing space characters) and the meaning of new
+  lines opening (which can be connected to any other action needed by the
+  application at hand). The two functions [f.out_spaces] and [f.out_newline]
+  are normally connected to [f.out_string] and [f.out_flush]: respective
+  default values for [f.out_space] and [f.out_newline] are
+  [f.out_string (String.make n ' ') 0 n] and [f.out_string "\n" 0 1].
+  @since 4.01.0 *)
+
+val get_formatter_out_functions : unit -> formatter_out_functions
+(** Return the current output functions of the pretty-printer,
+  including line splitting and indentation functions. Useful to record the
+  current setting and restore it afterwards.
+  @since 4.01.0 *)
+
+(** {6:tagsmeaning Changing the meaning of printing semantic tags} *)
+
+type formatter_tag_functions = {
+  mark_open_tag : tag -> string;
+  mark_close_tag : tag -> string;
+  print_open_tag : tag -> unit;
+  print_close_tag : tag -> unit;
+}
+(** The tag handling functions specific to a formatter:
+  [mark] versions are the 'tag marking' functions that associate a string
+  marker to a tag in order for the pretty-printing engine to flush
+  those markers as 0 length tokens in the output device of the formatter.
+  [print] versions are the 'tag printing' functions that can perform
+  regular printing when a tag is closed or opened. *)
+
+val set_formatter_tag_functions : formatter_tag_functions -> unit
+(** [set_formatter_tag_functions tag_funs] changes the meaning of
+  opening and closing tags to use the functions in [tag_funs].
+
+  When opening a tag name [t], the string [t] is passed to the
+  opening tag marking function (the [mark_open_tag] field of the
+  record [tag_funs]), that must return the opening tag marker for
+  that name. When the next call to [close_tag ()] happens, the tag
+  name [t] is sent back to the closing tag marking function (the
+  [mark_close_tag] field of record [tag_funs]), that must return a
+  closing tag marker for that name.
+
+  The [print_] field of the record contains the functions that are
+  called at tag opening and tag closing time, to output regular
+  material in the pretty-printer queue. *)
+
+val get_formatter_tag_functions : unit -> formatter_tag_functions
+(** Return the current tag functions of the pretty-printer. *)
+
+(** {6 Multiple formatted output} *)
+
+type formatter
+(** Abstract data corresponding to a pretty-printer (also called a
+  formatter) and all its machinery.
+
+  Defining new pretty-printers permits unrelated output of material in
+  parallel on several output channels.
+  All the parameters of a pretty-printer are local to a formatter:
+  margin, maximum indentation limit, maximum number of boxes
+  simultaneously opened, ellipsis, and so on, are specific to
+  each pretty-printer and may be fixed independently.
+  Given a {!Pervasives.out_channel} output channel [oc], a new formatter
+  writing to that channel is simply obtained by calling
+  [formatter_of_out_channel oc].
+  Alternatively, the [make_formatter] function allocates a new
+  formatter with explicit output and flushing functions
+  (convenient to output material to strings for instance).
+*)
+
+val formatter_of_out_channel : out_channel -> formatter
+(** [formatter_of_out_channel oc] returns a new formatter that
+  writes to the corresponding channel [oc]. *)
+
+val std_formatter : formatter
+(** The standard formatter used by the formatting functions
+  above. It is defined as [formatter_of_out_channel stdout]. *)
+
+val err_formatter : formatter
+(** A formatter to use with formatting functions below for
+  output to standard error. It is defined as
+  [formatter_of_out_channel stderr]. *)
+
+val formatter_of_buffer : Buffer.t -> formatter
+(** [formatter_of_buffer b] returns a new formatter writing to
+  buffer [b]. As usual, the formatter has to be flushed at
+  the end of pretty printing, using [pp_print_flush] or
+  [pp_print_newline], to display all the pending material. *)
+
+val stdbuf : Buffer.t
+(** The string buffer in which [str_formatter] writes. *)
+
+val str_formatter : formatter
+(** A formatter to use with formatting functions below for
+  output to the [stdbuf] string buffer.
+  [str_formatter] is defined as [formatter_of_buffer stdbuf]. *)
+
+val flush_str_formatter : unit -> string
+(** Returns the material printed with [str_formatter], flushes
+  the formatter and resets the corresponding buffer. *)
+
+val make_formatter :
+  (string -> int -> int -> unit) -> (unit -> unit) -> formatter
+(** [make_formatter out flush] returns a new formatter that writes according
+  to the output function [out], and the flushing function [flush]. For
+  instance, a formatter to the {!Pervasives.out_channel} [oc] is returned by
+  [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *)
+
+(** {6 Basic functions to use with formatters} *)
+
+val pp_open_hbox : formatter -> unit -> unit
+val pp_open_vbox : formatter -> int -> unit
+val pp_open_hvbox : formatter -> int -> unit
+val pp_open_hovbox : formatter -> int -> unit
+val pp_open_box : formatter -> int -> unit
+val pp_close_box : formatter -> unit -> unit
+val pp_open_tag : formatter -> string -> unit
+val pp_close_tag : formatter -> unit -> unit
+val pp_print_string : formatter -> string -> unit
+val pp_print_as : formatter -> int -> string -> unit
+val pp_print_int : formatter -> int -> unit
+val pp_print_float : formatter -> float -> unit
+val pp_print_char : formatter -> char -> unit
+val pp_print_bool : formatter -> bool -> unit
+val pp_print_break : formatter -> int -> int -> unit
+val pp_print_cut : formatter -> unit -> unit
+val pp_print_space : formatter -> unit -> unit
+val pp_force_newline : formatter -> unit -> unit
+val pp_print_flush : formatter -> unit -> unit
+val pp_print_newline : formatter -> unit -> unit
+val pp_print_if_newline : formatter -> unit -> unit
+val pp_set_tags : formatter -> bool -> unit
+val pp_set_print_tags : formatter -> bool -> unit
+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_get_margin : formatter -> unit -> int
+val pp_set_max_indent : formatter -> int -> unit
+val pp_get_max_indent : formatter -> unit -> int
+val pp_set_max_boxes : formatter -> int -> unit
+val pp_get_max_boxes : formatter -> unit -> int
+val pp_over_max_boxes : formatter -> unit -> bool
+val pp_set_ellipsis_text : formatter -> string -> unit
+val pp_get_ellipsis_text : formatter -> unit -> string
+val pp_set_formatter_out_channel :
+  formatter -> Pervasives.out_channel -> unit
+
+val pp_set_formatter_output_functions :
+  formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
+
+val pp_get_formatter_output_functions :
+  formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
+
+val pp_set_formatter_tag_functions :
+  formatter -> formatter_tag_functions -> unit
+
+val pp_get_formatter_tag_functions :
+  formatter -> unit -> formatter_tag_functions
+
+val pp_set_formatter_out_functions :
+  formatter -> formatter_out_functions -> unit
+(** @since 4.01.0 *)
+
+val pp_get_formatter_out_functions :
+  formatter -> unit -> formatter_out_functions
+(** These functions are the basic ones: usual functions
+   operating on the standard formatter are defined via partial
+   evaluation of these primitives. For instance,
+   [print_string] is equal to [pp_print_string std_formatter].
+   @since 4.01.0 *)
+
+val pp_flush_formatter : formatter -> unit
+(** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all
+    the printing and flushing actions have been performed. In addition, this
+    operation will close all boxes and reset the state of the formatter.
+
+    This will not flush [fmt]'s output. In most cases, the user may want to use
+    {!pp_print_flush} instead.
+    @since 4.04.0 *)
+
+(** {6 Convenience formatting functions.} *)
+
+val pp_print_list:
+  ?pp_sep:(formatter -> unit -> unit) ->
+  (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit)
+(** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l],
+  using [pp_v] to print each item, and calling [pp_sep]
+  between items ([pp_sep] defaults to {!pp_print_cut}).
+  Does nothing on empty lists.
+
+  @since 4.02.0
+*)
+
+val pp_print_text : formatter -> string -> unit
+(** [pp_print_text ppf s] prints [s] with spaces and newlines
+  respectively printed with {!pp_print_space} and
+  {!pp_force_newline}.
+
+  @since 4.02.0
+*)
+
+(** {6 [printf] like functions for pretty-printing.} *)
+
+val fprintf : formatter -> ('a, formatter, unit) format -> 'a
+
+(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN]
+  according to the format string [fmt], and outputs the resulting string on
+  the formatter [ff].
+
+  The format [fmt] is a character string which contains three types of
+  objects: plain characters and conversion specifications as specified in
+  the {!Printf} module, and pretty-printing indications specific to the
+  [Format] module.
+
+  The pretty-printing indication characters are introduced by
+  a [@] character, and their meanings are:
+  - [@\[]: open a pretty-printing box. The type and offset of the
+    box may be optionally specified with the following syntax:
+    the [<] character, followed by an optional box type indication,
+    then an optional integer offset, and the closing [>] character.
+    Box type is one of [h], [v], [hv], [b], or [hov].
+    '[h]' stands for an 'horizontal' box,
+    '[v]' stands for a 'vertical' box,
+    '[hv]' stands for an 'horizontal-vertical' box,
+    '[b]' stands for an 'horizontal-or-vertical' box demonstrating indentation,
+    '[hov]' stands a simple 'horizontal-or-vertical' box.
+    For instance, [@\[<hov 2>] opens an 'horizontal-or-vertical'
+    box with indentation 2 as obtained with [open_hovbox 2].
+    For more details about boxes, see the various box opening
+    functions [open_*box].
+  - [@\]]: close the most recently opened pretty-printing box.
+  - [@,]: output a 'cut' break hint, as with [print_cut ()].
+  - [@ ]: output a 'space' break hint, as with [print_space ()].
+  - [@;]: output a 'full' break hint as with [print_break]. The
+    [nspaces] and [offset] parameters of the break hint may be
+    optionally specified with the following syntax:
+    the [<] character, followed by an integer [nspaces] value,
+    then an integer [offset], and a closing [>] character.
+    If no parameters are provided, the good break defaults to a
+    'space' break hint.
+  - [@.]: flush the pretty printer and split the line, as with
+    [print_newline ()].
+  - [@<n>]: print the following item as if it were of length [n].
+    Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string.
+    If [@<n>] is not followed by a conversion specification,
+    then the following character of the format is printed as if
+    it were of length [n].
+  - [@\{]: open a tag. The name of the tag may be optionally
+    specified with the following syntax:
+    the [<] character, followed by an optional string
+    specification, and the closing [>] character. The string
+    specification is any character string that does not contain the
+    closing character ['>']. If omitted, the tag name defaults to the
+    empty string.
+    For more details about tags, see the functions [open_tag] and
+    [close_tag].
+  - [@\}]: close the most recently opened tag.
+  - [@?]: flush the pretty printer as with [print_flush ()].
+    This is equivalent to the conversion [%!].
+  - [@\n]: force a newline, as with [force_newline ()], not the normal way
+    of pretty-printing, you should prefer using break hints inside a vertical
+    box.
+
+  Note: If you need to prevent the interpretation of a [@] character as a
+  pretty-printing indication, you must escape it with a [%] character.
+  Old quotation mode [@@] is deprecated since it is not compatible with
+  formatted input interpretation of character ['@'].
+
+  Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to
+  [open_box (); print_string "x ="; print_space ();
+   print_int 1; close_box (); print_newline ()].
+  It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box.
+
+*)
+
+val printf : ('a, formatter, unit) format -> 'a
+(** Same as [fprintf] above, but output on [std_formatter]. *)
+
+val eprintf : ('a, formatter, unit) format -> 'a
+(** Same as [fprintf] above, but output on [err_formatter]. *)
+
+val sprintf : ('a, unit, string) format -> 'a
+(** Same as [printf] above, but instead of printing on a formatter,
+  returns a string containing the result of formatting the arguments.
+  Note that the pretty-printer queue is flushed at the end of {e each
+  call} to [sprintf].
+
+  In case of multiple and related calls to [sprintf] to output
+  material on a single string, you should consider using [fprintf]
+  with the predefined formatter [str_formatter] and call
+  [flush_str_formatter ()] to get the final result.
+
+  Alternatively, you can use [Format.fprintf] with a formatter writing to a
+  buffer of your own: flushing the formatter and the buffer at the end of
+  pretty-printing returns the desired string.
+*)
+
+val asprintf : ('a, formatter, unit, string) format4 -> 'a
+(** Same as [printf] above, but instead of printing on a formatter,
+  returns a string containing the result of formatting the arguments.
+  The type of [asprintf] is general enough to interact nicely with [%a]
+  conversions.
+  @since 4.01.0
+*)
+
+val ifprintf : formatter -> ('a, formatter, unit) format -> 'a
+(** Same as [fprintf] above, but does not print anything.
+  Useful to ignore some material when conditionally printing.
+  @since 3.10.0
+*)
+
+(** Formatted output functions with continuations. *)
+
+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 ikfprintf :
+  (formatter -> 'a) -> formatter ->
+  ('b, formatter, unit, 'a) format4 -> 'b
+(** Same as [kfprintf] above, but does not print anything.
+  Useful to ignore some material when conditionally printing.
+  @since 3.12.0
+*)
+
+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 kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b
+(** Same as [asprintf] above, but instead of returning the string,
+  passes it to the first argument.
+  @since 4.03
+*)
+
+(** {6 Deprecated} *)
+
+val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a
+  [@@ocaml.deprecated]
+(** @deprecated This function is error prone. Do not use it.
+
+  If you need to print to some buffer [b], you must first define a
+  formatter writing to [b], using [let to_b = formatter_of_buffer b]; then
+  use regular calls to [Format.fprintf] on formatter [to_b]. *)
+
+val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
+  [@@ocaml.deprecated "Use Format.ksprintf instead."]
+(** @deprecated An alias for [ksprintf]. *)
+
+val set_all_formatter_output_functions :
+  out:(string -> int -> int -> unit) ->
+  flush:(unit -> unit) ->
+  newline:(unit -> unit) ->
+  spaces:(int -> unit) ->
+  unit
+[@@ocaml.deprecated "Use Format.set_formatter_out_functions instead."]
+(** @deprecated Subsumed by [set_formatter_out_functions]. *)
+
+val get_all_formatter_output_functions :
+  unit ->
+  (string -> int -> int -> unit) *
+  (unit -> unit) *
+  (unit -> unit) *
+  (int -> unit)
+[@@ocaml.deprecated "Use Format.get_formatter_out_functions instead."]
+(** @deprecated Subsumed by [get_formatter_out_functions]. *)
+
+val pp_set_all_formatter_output_functions :
+  formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
+  newline:(unit -> unit) -> spaces:(int -> unit) -> unit
+[@@ocaml.deprecated "Use Format.pp_set_formatter_out_functions instead."]
+(** @deprecated Subsumed by [pp_set_formatter_out_functions]. *)
+
+val pp_get_all_formatter_output_functions :
+  formatter -> unit ->
+  (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
+  (int -> unit)
+[@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."]
+(** @deprecated Subsumed by [pp_get_formatter_out_functions]. *)
+
+(** Tabulation boxes are deprecated. *)
+
+val pp_open_tbox : formatter -> unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val pp_close_tbox : formatter -> unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val pp_print_tbreak : formatter -> int -> int -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val pp_set_tab : formatter -> unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val pp_print_tab : formatter -> unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val open_tbox : unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val close_tbox : unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val print_tbreak : int -> int -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val set_tab : unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
+
+val print_tab : unit -> unit
+[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
+(** @deprecated since 4.03.0 *)
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
new file mode 100644
index 00000000..d3dd069b
--- /dev/null
+++ b/stdlib/gc.ml
@@ -0,0 +1,116 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type stat = {
+  minor_words : float;
+  promoted_words : float;
+  major_words : float;
+  minor_collections : int;
+  major_collections : int;
+  heap_words : int;
+  heap_chunks : int;
+  live_words : int;
+  live_blocks : int;
+  free_words : int;
+  free_blocks : int;
+  largest_free : int;
+  fragments : int;
+  compactions : int;
+  top_heap_words : int;
+  stack_size : int;
+}
+
+type control = {
+  mutable minor_heap_size : int;
+  mutable major_heap_increment : int;
+  mutable space_overhead : int;
+  mutable verbose : int;
+  mutable max_overhead : int;
+  mutable stack_limit : int;
+  mutable allocation_policy : int;
+  window_size : int;
+}
+
+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 minor_words : unit -> (float [@unboxed])
+  = "caml_gc_minor_words" "caml_gc_minor_words_unboxed"
+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"
+external get_minor_free : unit -> int = "caml_get_minor_free"
+external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc]
+external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc]
+external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count"
+
+open Printf
+
+let print_stat c =
+  let st = stat () in
+  fprintf c "minor_collections: %d\n" st.minor_collections;
+  fprintf c "major_collections: %d\n" st.major_collections;
+  fprintf c "compactions:       %d\n" st.compactions;
+  fprintf c "\n";
+  let l1 = String.length (sprintf "%.0f" st.minor_words) in
+  fprintf c "minor_words:    %*.0f\n" l1 st.minor_words;
+  fprintf c "promoted_words: %*.0f\n" l1 st.promoted_words;
+  fprintf c "major_words:    %*.0f\n" l1 st.major_words;
+  fprintf c "\n";
+  let l2 = String.length (sprintf "%d" st.top_heap_words) in
+  fprintf c "top_heap_words: %*d\n" l2 st.top_heap_words;
+  fprintf c "heap_words:     %*d\n" l2 st.heap_words;
+  fprintf c "live_words:     %*d\n" l2 st.live_words;
+  fprintf c "free_words:     %*d\n" l2 st.free_words;
+  fprintf c "largest_free:   %*d\n" l2 st.largest_free;
+  fprintf c "fragments:      %*d\n" l2 st.fragments;
+  fprintf c "\n";
+  fprintf c "live_blocks: %d\n" st.live_blocks;
+  fprintf c "free_blocks: %d\n" st.free_blocks;
+  fprintf c "heap_chunks: %d\n" st.heap_chunks
+
+
+let allocated_bytes () =
+  let (mi, pro, ma) = counters () in
+  (mi +. ma -. pro) *. float_of_int (Sys.word_size / 8)
+
+
+external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register"
+external finalise_last : (unit -> unit) -> 'a -> unit =
+  "caml_final_register_called_without_value"
+external finalise_release : unit -> unit = "caml_final_release"
+
+
+type alarm = bool ref
+type alarm_rec = {active : alarm; f : unit -> unit}
+
+let rec call_alarm arec =
+  if !(arec.active) then begin
+    finalise call_alarm arec;
+    arec.f ();
+  end
+
+
+let create_alarm f =
+  let arec = { active = ref true; f = f } in
+  finalise call_alarm arec;
+  arec.active
+
+
+let delete_alarm a = a := false
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
new file mode 100644
index 00000000..80020379
--- /dev/null
+++ b/stdlib/gc.mli
@@ -0,0 +1,346 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Memory management control and statistics; finalised values. *)
+
+type stat =
+  { minor_words : float;
+    (** Number of words allocated in the minor heap since
+       the program was started.  This number is accurate in
+       byte-code programs, but only an approximation in programs
+       compiled to native code. *)
+
+    promoted_words : float;
+    (** Number of words allocated in the minor heap that
+       survived a minor collection and were moved to the major heap
+       since the program was started. *)
+
+    major_words : float;
+    (** Number of words allocated in the major heap, including
+       the promoted words, since the program was started. *)
+
+    minor_collections : int;
+    (** Number of minor collections since the program was started. *)
+
+    major_collections : int;
+    (** Number of major collection cycles completed since the program
+        was started. *)
+
+    heap_words : int;
+    (** Total size of the major heap, in words. *)
+
+    heap_chunks : int;
+    (** Number of contiguous pieces of memory that make up the major heap. *)
+
+    live_words : int;
+    (** Number of words of live data in the major heap, including the header
+       words. *)
+
+    live_blocks : int;
+    (** Number of live blocks in the major heap. *)
+
+    free_words : int;
+    (** Number of words in the free list. *)
+
+    free_blocks : int;
+    (** Number of blocks in the free list. *)
+
+    largest_free : int;
+    (** Size (in words) of the largest block in the free list. *)
+
+    fragments : int;
+    (** Number of wasted words due to fragmentation.  These are
+       1-words free blocks placed between two live blocks.  They
+       are not available for allocation. *)
+
+    compactions : int;
+    (** Number of heap compactions since the program was started. *)
+
+    top_heap_words : int;
+    (** Maximum size reached by the major heap, in words. *)
+
+    stack_size: int;
+    (** Current size of the stack, in words. @since 3.12.0 *)
+}
+(** The memory management counters are returned in a [stat] record.
+
+   The total amount of memory allocated by the program since it was started
+   is (in words) [minor_words + major_words - promoted_words].  Multiply by
+   the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get
+   the number of bytes.
+*)
+
+type control =
+  { mutable minor_heap_size : int;
+    (** The size (in words) of the minor heap.  Changing
+       this parameter will trigger a minor collection.  Default: 256k. *)
+
+    mutable major_heap_increment : int;
+    (** How much to add to the major heap when increasing it. If this
+        number is less than or equal to 1000, it is a percentage of
+        the current heap size (i.e. setting it to 100 will double the heap
+        size at each increase). If it is more than 1000, it is a fixed
+        number of words that will be added to the heap. Default: 15. *)
+
+    mutable space_overhead : int;
+    (** The major GC speed is computed from this parameter.
+       This is the memory that will be "wasted" because the GC does not
+       immediatly collect unreachable blocks.  It is expressed as a
+       percentage of the memory used for live data.
+       The GC will work more (use more CPU time and collect
+       blocks more eagerly) if [space_overhead] is smaller.
+       Default: 80. *)
+
+    mutable verbose : int;
+    (** This value controls the GC messages on standard error output.
+       It is a sum of some of the following flags, to print messages
+       on the corresponding events:
+       - [0x001] Start of major GC cycle.
+       - [0x002] Minor collection and major GC slice.
+       - [0x004] Growing and shrinking of the heap.
+       - [0x008] Resizing of stacks and memory manager tables.
+       - [0x010] Heap compaction.
+       - [0x020] Change of GC parameters.
+       - [0x040] Computation of major GC slice size.
+       - [0x080] Calling of finalisation functions.
+       - [0x100] Bytecode executable and shared library search at start-up.
+       - [0x200] Computation of compaction-triggering condition.
+       - [0x400] Output GC statistics at program exit.
+       Default: 0. *)
+
+    mutable max_overhead : int;
+    (** Heap compaction is triggered when the estimated amount
+       of "wasted" memory is more than [max_overhead] percent of the
+       amount of live data.  If [max_overhead] is set to 0, heap
+       compaction is triggered at the end of each major GC cycle
+       (this setting is intended for testing purposes only).
+       If [max_overhead >= 1000000], compaction is never triggered.
+       If compaction is permanently disabled, it is strongly suggested
+       to set [allocation_policy] to 1.
+       Default: 500. *)
+
+    mutable stack_limit : int;
+    (** The maximum size of the stack (in words).  This is only
+       relevant to the byte-code runtime, as the native code runtime
+       uses the operating system's stack.  Default: 1024k. *)
+
+    mutable allocation_policy : int;
+    (** The policy used for allocating in the heap.  Possible
+        values are 0 and 1.  0 is the next-fit policy, which is
+        quite fast but can result in fragmentation.  1 is the
+        first-fit policy, which can be slower in some cases but
+        can be better for programs with fragmentation problems.
+        Default: 0. @since 3.11.0 *)
+
+    window_size : int;
+    (** The size of the window used by the major GC for smoothing
+        out variations in its workload. This is an integer between
+        1 and 50.
+        Default: 1. @since 4.03.0 *)
+}
+(** The GC parameters are given as a [control] record.  Note that
+    these parameters can also be initialised by setting the
+    OCAMLRUNPARAM environment variable.  See the documentation of
+    [ocamlrun]. *)
+
+external stat : unit -> stat = "caml_gc_stat"
+(** Return the current values of the memory management counters in a
+   [stat] record.  This function examines every heap block to get the
+   statistics. *)
+
+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 counters : unit -> float * float * float = "caml_gc_counters"
+(** Return [(minor_words, promoted_words, major_words)].  This function
+    is as fast as [quick_stat]. *)
+
+external minor_words : unit -> (float [@unboxed])
+  = "caml_gc_minor_words" "caml_gc_minor_words_unboxed"
+(** Number of words allocated in the minor heap since the program was
+    started. This number is accurate in byte-code programs, but only an
+    approximation in programs compiled to native code.
+
+    In native code this function does not allocate.
+
+    @since 4.04 *)
+
+external get : unit -> control = "caml_gc_get"
+(** Return the current values of the GC parameters in a [control] record. *)
+
+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 = "caml_gc_minor"
+(** Trigger a minor collection. *)
+
+external major_slice : int -> int = "caml_gc_major_slice"
+(** [major_slice n]
+    Do a minor collection and a slice of major collection. [n] is the
+    size of the slice: the GC will do enough work to free (on average)
+    [n] words of memory. If [n] = 0, the GC will try to do enough work
+    to ensure that the next automatic slice has no work to do.
+    This function returns an unspecified integer (currently: 0). *)
+
+external major : unit -> unit = "caml_gc_major"
+(** Do a minor collection and finish the current major collection cycle. *)
+
+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 = "caml_gc_compaction"
+(** Perform a full major collection and compact the heap.  Note that heap
+   compaction is a lengthy operation. *)
+
+val print_stat : out_channel -> unit
+(** Print the current values of the memory management counters (in
+   human-readable form) into the channel argument. *)
+
+val allocated_bytes : unit -> float
+(** Return the total number of bytes allocated since the program was
+   started.  It is returned as a [float] to avoid overflow problems
+   with [int] on 32-bit machines. *)
+
+external get_minor_free : unit -> int = "caml_get_minor_free"
+(** Return the current size of the free space inside the minor heap.
+
+    @since 4.03.0 *)
+
+external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc]
+(** [get_bucket n] returns the current size of the [n]-th future bucket
+    of the GC smoothing system. The unit is one millionth of a full GC.
+    Raise [Invalid_argument] if [n] is negative, return 0 if n is larger
+    than the smoothing window.
+
+    @since 4.03.0 *)
+
+external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc]
+(** [get_credit ()] returns the current size of the "work done in advance"
+    counter of the GC smoothing system. The unit is one millionth of a
+    full GC.
+
+    @since 4.03.0 *)
+
+external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count"
+(** Return the number of times we tried to map huge pages and had to fall
+    back to small pages. This is always 0 if [OCAMLRUNPARAM] contains [H=1].
+    @since 4.03.0 *)
+
+val finalise : ('a -> unit) -> 'a -> unit
+(** [finalise f v] registers [f] as a finalisation function for [v].
+   [v] must be heap-allocated.  [f] will be called with [v] as
+   argument at some point between the first time [v] becomes unreachable
+   (including through weak pointers) and the time [v] is collected by
+   the GC. Several functions can
+   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).
+
+   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.
+
+   In the presence of multiple OCaml threads it should be assumed that
+   any particular finaliser may be executed in any of the threads.
+
+   Anything reachable from the closure of finalisation functions
+   is considered reachable, so the following code will not work
+   as expected:
+   - [ let v = ... in Gc.finalise (fun _ -> ...v...) v ]
+
+   Instead you should make sure that [v] is not in the closure of
+   the finalisation function by writing:
+   - [ let f = fun x -> ...  let v = ... in Gc.finalise f v ]
+
+
+   The [f] function can use all features of OCaml, including
+   assignments that make the value reachable again.  It can also
+   loop forever (in this case, the other
+   finalisation functions will not be called during the execution of f,
+   unless it calls [finalise_release]).
+   It can call [finalise] on [v] or other values to register other
+   functions or even itself.  It can raise an exception; in this case
+   the exception will interrupt whatever the program was doing when
+   the function was called.
+
+
+   [finalise] will raise [Invalid_argument] if [v] is not
+   guaranteed to be heap-allocated.  Some examples of values that are not
+   heap-allocated are integers, constant constructors, booleans,
+   the empty array, the empty list, the unit value.  The exact list
+   of what is heap-allocated or not is implementation-dependent.
+   Some constant values can be heap-allocated but never deallocated
+   during the lifetime of the program, for example a list of integer
+   constants; this is also implementation-dependent.
+   Note that values of types [float] are sometimes allocated and
+   sometimes not, so finalising them is unsafe, and [finalise] will
+   also raise [Invalid_argument] for them. Values of type ['a Lazy.t]
+   (for any ['a]) are like [float] in this respect, except that the
+   compiler sometimes optimizes them in a way that prevents [finalise]
+   from detecting them. In this case, it will not raise
+   [Invalid_argument], but you should still avoid calling [finalise]
+   on lazy values.
+
+
+   The results of calling {!String.make}, {!Bytes.make}, {!Bytes.create},
+   {!Array.make}, and {!Pervasives.ref} are guaranteed to be
+   heap-allocated and non-constant except when the length argument is [0].
+*)
+
+val finalise_last : (unit -> unit) -> 'a -> unit
+(** same as {!finalise} except the value is not given as argument. So
+    you can't use the given value for the computation of the
+    finalisation function. The benefit is that the function is called
+    after the value is unreachable for the last time instead of the
+    first time. So contrary to {!finalise} the value will never be
+    reachable again or used again. In particular every weak pointer
+    and ephemeron that contained this value as key or data is unset
+    before running the finalisation function. Moreover the
+    finalisation function attached with `GC.finalise` are always
+    called before the finalisation function attached with `GC.finalise_last`.
+
+    @since 4.04
+*)
+
+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
+   and delete alarms. *)
+
+val create_alarm : (unit -> unit) -> alarm
+(** [create_alarm f] will arrange for [f] to be called at the end of each
+   major GC cycle, starting with the current cycle or the next one.
+   A value of type [alarm] is returned that you can
+   use to call [delete_alarm]. *)
+
+val delete_alarm : alarm -> unit
+(** [delete_alarm a] will stop the calls to the function associated
+   to [a].  Calling [delete_alarm a] again has no effect. *)
diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
new file mode 100644
index 00000000..b015bb95
--- /dev/null
+++ b/stdlib/genlex.ml
@@ -0,0 +1,201 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type token =
+    Kwd of string
+  | Ident of string
+  | Int of int
+  | Float of float
+  | String of string
+  | Char of char
+
+(* The string buffering machinery *)
+
+let initial_buffer = Bytes.create 32
+
+let buffer = ref initial_buffer
+let bufpos = ref 0
+
+let reset_buffer () = buffer := initial_buffer; bufpos := 0
+
+let store c =
+  if !bufpos >= Bytes.length !buffer then begin
+    let newbuffer = Bytes.create (2 * !bufpos) in
+    Bytes.blit !buffer 0 newbuffer 0 !bufpos;
+    buffer := newbuffer
+  end;
+  Bytes.set !buffer !bufpos c;
+  incr bufpos
+
+let get_string () =
+  let s = Bytes.sub_string !buffer 0 !bufpos in buffer := initial_buffer; s
+
+(* The lexer *)
+
+let make_lexer keywords =
+  let kwd_table = Hashtbl.create 17 in
+  List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) keywords;
+  let ident_or_keyword id =
+    try Hashtbl.find kwd_table id with
+      Not_found -> Ident id
+  and keyword_or_error c =
+    let s = String.make 1 c in
+    try Hashtbl.find kwd_table s with
+      Not_found -> raise (Stream.Error ("Illegal character " ^ s))
+  in
+  let rec next_token (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') ->
+        Stream.junk strm__; next_token strm__
+    | Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store c; ident s
+    | Some
+        ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' |
+         '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store c; ident2 s
+    | Some ('0'..'9' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store c; number s
+    | Some '\'' ->
+        Stream.junk strm__;
+        let c =
+          try char strm__ with
+            Stream.Failure -> raise (Stream.Error "")
+        in
+        begin match Stream.peek strm__ with
+          Some '\'' -> Stream.junk strm__; Some (Char c)
+        | _ -> raise (Stream.Error "")
+        end
+    | Some '\"' ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); Some (String (string s))
+    | Some '-' -> Stream.junk strm__; neg_number strm__
+    | Some '(' -> Stream.junk strm__; maybe_comment strm__
+    | Some c -> Stream.junk strm__; Some (keyword_or_error c)
+    | _ -> None
+  and ident (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some
+        ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; ident s
+    | _ -> Some (ident_or_keyword (get_string ()))
+  and ident2 (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some
+        ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' |
+         '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; ident2 s
+    | _ -> Some (ident_or_keyword (get_string ()))
+  and neg_number (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store '-'; store c; number s
+    | _ -> let s = strm__ in reset_buffer (); store '-'; ident2 s
+  and number (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; number s
+    | Some '.' ->
+        Stream.junk strm__; let s = strm__ in store '.'; decimal_part s
+    | Some ('e' | 'E') ->
+        Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s
+    | _ -> Some (Int (int_of_string (get_string ())))
+  and decimal_part (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; decimal_part s
+    | Some ('e' | 'E') ->
+        Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s
+    | _ -> Some (Float (float_of_string (get_string ())))
+  and exponent_part (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('+' | '-' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; end_exponent_part s
+    | _ -> end_exponent_part strm__
+  and end_exponent_part (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; end_exponent_part s
+    | _ -> Some (Float (float_of_string (get_string ())))
+  and string (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '\"' -> Stream.junk strm__; get_string ()
+    | Some '\\' ->
+        Stream.junk strm__;
+        let c =
+          try escape strm__ with
+            Stream.Failure -> raise (Stream.Error "")
+        in
+        let s = strm__ in store c; string s
+    | Some c -> Stream.junk strm__; let s = strm__ in store c; string s
+    | _ -> raise Stream.Failure
+  and char (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '\\' ->
+        Stream.junk strm__;
+        begin try escape strm__ with
+          Stream.Failure -> raise (Stream.Error "")
+        end
+    | Some c -> Stream.junk strm__; c
+    | _ -> raise Stream.Failure
+  and escape (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some 'n' -> Stream.junk strm__; '\n'
+    | Some 'r' -> Stream.junk strm__; '\r'
+    | Some 't' -> Stream.junk strm__; '\t'
+    | Some ('0'..'9' as c1) ->
+        Stream.junk strm__;
+        begin match Stream.peek strm__ with
+          Some ('0'..'9' as c2) ->
+            Stream.junk strm__;
+            begin match Stream.peek strm__ with
+              Some ('0'..'9' as c3) ->
+                Stream.junk strm__;
+                Char.chr
+                  ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 +
+                     (Char.code c3 - 48))
+            | _ -> raise (Stream.Error "")
+            end
+        | _ -> raise (Stream.Error "")
+        end
+    | Some c -> Stream.junk strm__; c
+    | _ -> raise Stream.Failure
+  and maybe_comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '*' ->
+        Stream.junk strm__; let s = strm__ in comment s; next_token s
+    | _ -> Some (keyword_or_error '(')
+  and comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '(' -> Stream.junk strm__; maybe_nested_comment strm__
+    | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
+    | _ -> raise Stream.Failure
+  and maybe_nested_comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s
+    | Some _ -> Stream.junk strm__; comment strm__
+    | _ -> raise Stream.Failure
+  and maybe_end_comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ')' -> Stream.junk strm__; ()
+    | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
+    | _ -> raise Stream.Failure
+  in
+  fun input -> Stream.from (fun _count -> next_token input)
diff --git a/stdlib/genlex.mli b/stdlib/genlex.mli
new file mode 100644
index 00000000..47394926
--- /dev/null
+++ b/stdlib/genlex.mli
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** A generic lexical analyzer.
+
+
+   This module implements a simple 'standard' lexical analyzer, presented
+   as a function from character streams to token streams. It implements
+   roughly the lexical conventions of OCaml, but is parameterized by the
+   set of keywords of your language.
+
+
+   Example: a lexer suitable for a desk calculator is obtained by
+   {[     let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"]  ]}
+
+   The associated parser would be a function from [token stream]
+   to, for instance, [int], and would have rules such as:
+
+   {[
+           let rec parse_expr = parser
+             | [< n1 = parse_atom; n2 = parse_remainder n1 >] -> n2
+           and parse_atom = parser
+             | [< 'Int n >] -> n
+             | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n
+           and parse_remainder n1 = parser
+             | [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
+             | [< >] -> n1
+   ]}
+
+   One should notice that the use of the [parser] keyword and associated
+   notation for streams are only available through camlp4 extensions. This
+   means that one has to preprocess its sources {i e. g.} by using the
+   ["-pp"] command-line switch of the compilers.
+*)
+
+(** The type of tokens. The lexical classes are: [Int] and [Float]
+   for integer and floating-point numbers; [String] for
+   string literals, enclosed in double quotes; [Char] for
+   character literals, enclosed in single quotes; [Ident] for
+   identifiers (either sequences of letters, digits, underscores
+   and quotes, or sequences of 'operator characters' such as
+   [+], [*], etc); and [Kwd] for keywords (either identifiers or
+   single 'special characters' such as [(], [}], etc). *)
+type token =
+    Kwd of string
+  | Ident of string
+  | Int of int
+  | Float of float
+  | String of string
+  | Char of char
+
+val make_lexer : string list -> char Stream.t -> token Stream.t
+(** Construct the lexer function. The first argument is the list of
+   keywords. An identifier [s] is returned as [Kwd s] if [s]
+   belongs to this list, and as [Ident s] otherwise.
+   A special character [s] is returned as [Kwd s] if [s]
+   belongs to this list, and cause a lexical error (exception
+   {!Stream.Error} with the offending lexeme as its parameter) otherwise.
+   Blanks and newlines are skipped. Comments delimited by [(*] and [*)]
+   are skipped as well, and can be nested. A {!Stream.Failure} exception
+   is raised if end of stream is unexpectedly reached.*)
diff --git a/stdlib/hashbang b/stdlib/hashbang
new file mode 100644
index 00000000..04c9334b
--- /dev/null
+++ b/stdlib/hashbang
@@ -0,0 +1 @@
+#! 
\ No newline at end of file
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
new file mode 100644
index 00000000..77e8b907
--- /dev/null
+++ b/stdlib/hashtbl.ml
@@ -0,0 +1,544 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Hash tables *)
+
+external seeded_hash_param :
+  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+external old_hash_param :
+  int -> int -> 'a -> int = "caml_hash_univ_param" [@@noalloc]
+
+let hash x = seeded_hash_param 10 100 0 x
+let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
+let seeded_hash seed x = seeded_hash_param 10 100 seed x
+
+(* We do dynamic hashing, and resize the table and rehash the elements
+   when buckets become too long. *)
+
+type ('a, 'b) t =
+  { mutable size: int;                        (* number of entries *)
+    mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
+    mutable seed: int;                        (* for randomization *)
+    mutable initial_size: int;                (* initial array size *)
+  }
+
+and ('a, 'b) bucketlist =
+    Empty
+  | Cons of { mutable key: 'a;
+              mutable data: 'b;
+              mutable next: ('a, 'b) bucketlist }
+
+(* The sign of initial_size encodes the fact that a traversal is
+   ongoing or not.
+
+   This disables the efficient in place implementation of resizing.
+*)
+
+let ongoing_traversal h =
+  Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
+  || h.initial_size < 0
+
+let flip_ongoing_traversal h =
+  h.initial_size <- - h.initial_size
+
+(* To pick random seeds if requested *)
+
+let randomized_default =
+  let params =
+    try Sys.getenv "OCAMLRUNPARAM" with Not_found ->
+    try Sys.getenv "CAMLRUNPARAM" with Not_found -> "" in
+  String.contains params 'R'
+
+let randomized = ref randomized_default
+
+let randomize () = randomized := true
+let is_randomized () = !randomized
+
+let prng = lazy (Random.State.make_self_init())
+
+(* Creating a fresh, empty table *)
+
+let rec power_2_above x n =
+  if x >= n then x
+  else if x * 2 > Sys.max_array_length then x
+  else power_2_above (x * 2) n
+
+let create ?(random = !randomized) initial_size =
+  let s = power_2_above 16 initial_size in
+  let seed = if random then Random.State.bits (Lazy.force prng) else 0 in
+  { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
+
+let clear h =
+  h.size <- 0;
+  let len = Array.length h.data in
+  for i = 0 to len - 1 do
+    h.data.(i) <- Empty
+  done
+
+let reset h =
+  let len = Array.length h.data in
+  if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
+    || len = abs h.initial_size then
+    clear h
+  else begin
+    h.size <- 0;
+    h.data <- Array.make (abs h.initial_size) Empty
+  end
+
+let copy_bucketlist = function
+  | Empty -> Empty
+  | Cons {key; data; next} ->
+      let rec loop prec = function
+        | Empty -> ()
+        | Cons {key; data; next} ->
+            let r = Cons {key; data; next} in
+            begin match prec with
+            | Empty -> assert false
+            | Cons prec ->  prec.next <- r
+            end;
+            loop r next
+      in
+      let r = Cons {key; data; next} in
+      loop r next;
+      r
+
+let copy h = { h with data = Array.map copy_bucketlist h.data }
+
+let length h = h.size
+
+let resize indexfun h =
+  let odata = h.data in
+  let osize = Array.length odata in
+  let nsize = osize * 2 in
+  if nsize < Sys.max_array_length then begin
+    let ndata = Array.make nsize Empty in
+    let ndata_tail = Array.make nsize Empty in
+    let inplace = not (ongoing_traversal h) in
+    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
+    let rec insert_bucket = function
+      | Empty -> ()
+      | Cons {key; data; next} as cell ->
+          let cell =
+            if inplace then cell
+            else Cons {key; data; next = Empty}
+          in
+          let nidx = indexfun h key in
+          begin match ndata_tail.(nidx) with
+          | Empty -> ndata.(nidx) <- cell;
+          | Cons tail -> tail.next <- cell;
+          end;
+          ndata_tail.(nidx) <- cell;
+          insert_bucket next
+    in
+    for i = 0 to osize - 1 do
+      insert_bucket odata.(i)
+    done;
+    if inplace then
+      for i = 0 to nsize - 1 do
+        match ndata_tail.(i) with
+        | Empty -> ()
+        | Cons tail -> tail.next <- Empty
+      done;
+  end
+
+let key_index h key =
+  (* compatibility with old hash tables *)
+  if Obj.size (Obj.repr h) >= 3
+  then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
+  else (old_hash_param 10 100 key) mod (Array.length h.data)
+
+let add h key data =
+  let i = key_index h key in
+  let bucket = Cons{key; data; next=h.data.(i)} in
+  h.data.(i) <- bucket;
+  h.size <- h.size + 1;
+  if h.size > Array.length h.data lsl 1 then resize key_index h
+
+let rec remove_bucket h i key prec = function
+  | Empty ->
+      ()
+  | (Cons {key=k; next}) as c ->
+      if compare k key = 0
+      then begin
+        h.size <- h.size - 1;
+        match prec with
+        | Empty -> h.data.(i) <- next
+        | Cons c -> c.next <- next
+      end
+      else remove_bucket h i key c next
+
+let remove h key =
+  let i = key_index h key in
+  remove_bucket h i key Empty h.data.(i)
+
+let rec find_rec key = function
+  | Empty ->
+      raise Not_found
+  | Cons{key=k; data; next} ->
+      if compare key k = 0 then data else find_rec key next
+
+let find h key =
+  match h.data.(key_index h key) with
+  | Empty -> raise Not_found
+  | Cons{key=k1; data=d1; next=next1} ->
+      if compare key k1 = 0 then d1 else
+      match next1 with
+      | Empty -> raise Not_found
+      | Cons{key=k2; data=d2; next=next2} ->
+          if compare key k2 = 0 then d2 else
+          match next2 with
+          | Empty -> raise Not_found
+          | Cons{key=k3; data=d3; next=next3} ->
+              if compare key k3 = 0 then d3 else find_rec key next3
+
+let rec find_rec_opt key = function
+  | Empty ->
+      None
+  | Cons{key=k; data; next} ->
+      if compare key k = 0 then Some data else find_rec_opt key next
+
+let find_opt h key =
+  match h.data.(key_index h key) with
+  | Empty -> None
+  | Cons{key=k1; data=d1; next=next1} ->
+      if compare key k1 = 0 then Some d1 else
+      match next1 with
+      | Empty -> None
+      | Cons{key=k2; data=d2; next=next2} ->
+          if compare key k2 = 0 then Some d2 else
+          match next2 with
+          | Empty -> None
+          | Cons{key=k3; data=d3; next=next3} ->
+              if compare key k3 = 0 then Some d3 else find_rec_opt key next3
+
+let find_all h key =
+  let rec find_in_bucket = function
+  | Empty ->
+      []
+  | Cons{key=k; data; next} ->
+      if compare k key = 0
+      then data :: find_in_bucket next
+      else find_in_bucket next in
+  find_in_bucket h.data.(key_index h key)
+
+let rec replace_bucket key data = function
+  | Empty ->
+      true
+  | Cons ({key=k; next} as slot) ->
+      if compare k key = 0
+      then (slot.key <- key; slot.data <- data; false)
+      else replace_bucket key data next
+
+let replace h key data =
+  let i = key_index h key in
+  let l = h.data.(i) in
+  if replace_bucket key data l then begin
+    h.data.(i) <- Cons{key; data; next=l};
+    h.size <- h.size + 1;
+    if h.size > Array.length h.data lsl 1 then resize key_index h
+  end
+
+let mem h key =
+  let rec mem_in_bucket = function
+  | Empty ->
+      false
+  | Cons{key=k; next} ->
+      compare k key = 0 || mem_in_bucket next in
+  mem_in_bucket h.data.(key_index h key)
+
+let iter f h =
+  let rec do_bucket = function
+    | Empty ->
+        ()
+    | Cons{key; data; next} ->
+        f key data; do_bucket next in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    for i = 0 to Array.length d - 1 do
+      do_bucket d.(i)
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+let rec filter_map_inplace_bucket f h i prec = function
+  | Empty ->
+      begin match prec with
+      | Empty -> h.data.(i) <- Empty
+      | Cons c -> c.next <- Empty
+      end
+  | (Cons ({key; data; next} as c)) as slot ->
+      begin match f key data with
+      | None ->
+          h.size <- h.size - 1;
+          filter_map_inplace_bucket f h i prec next
+      | Some data ->
+          begin match prec with
+          | Empty -> h.data.(i) <- slot
+          | Cons c -> c.next <- slot
+          end;
+          c.data <- data;
+          filter_map_inplace_bucket f h i slot next
+      end
+
+let filter_map_inplace f h =
+  let d = h.data in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    for i = 0 to Array.length d - 1 do
+      filter_map_inplace_bucket f h i Empty h.data.(i)
+    done
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+let fold f h init =
+  let rec do_bucket b accu =
+    match b with
+      Empty ->
+        accu
+    | Cons{key; data; next} ->
+        do_bucket next (f key data accu) in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    let accu = ref init in
+    for i = 0 to Array.length d - 1 do
+      accu := do_bucket d.(i) !accu
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+    !accu
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+type statistics = {
+  num_bindings: int;
+  num_buckets: int;
+  max_bucket_length: int;
+  bucket_histogram: int array
+}
+
+let rec bucket_length accu = function
+  | Empty -> accu
+  | Cons{next} -> bucket_length (accu + 1) next
+
+let stats h =
+  let mbl =
+    Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
+  let histo = Array.make (mbl + 1) 0 in
+  Array.iter
+    (fun b ->
+      let l = bucket_length 0 b in
+      histo.(l) <- histo.(l) + 1)
+    h.data;
+  { num_bindings = h.size;
+    num_buckets = Array.length h.data;
+    max_bucket_length = mbl;
+    bucket_histogram = histo }
+
+(* Functorial interface *)
+
+module type HashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val hash: t -> int
+  end
+
+module type SeededHashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val hash: int -> t -> int
+  end
+
+module type S =
+  sig
+    type key
+    type 'a t
+    val create: int -> 'a t
+    val clear : 'a t -> unit
+    val reset : 'a t -> unit
+    val copy: 'a t -> 'a t
+    val add: 'a t -> key -> 'a -> unit
+    val remove: 'a t -> key -> unit
+    val find: 'a t -> key -> 'a
+    val find_opt: 'a t -> key -> 'a option
+    val find_all: 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+    val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length: 'a t -> int
+    val stats: 'a t -> statistics
+  end
+
+module type SeededS =
+  sig
+    type key
+    type 'a t
+    val create : ?random:bool -> int -> 'a t
+    val clear : 'a t -> unit
+    val reset : 'a t -> unit
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_opt: 'a t -> key -> 'a option
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
+    val stats: 'a t -> statistics
+  end
+
+module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
+  struct
+    type key = H.t
+    type 'a hashtbl = (key, 'a) t
+    type 'a t = 'a hashtbl
+    let create = create
+    let clear = clear
+    let reset = reset
+    let copy = copy
+
+    let key_index h key =
+      (H.hash h.seed key) land (Array.length h.data - 1)
+
+    let add h key data =
+      let i = key_index h key in
+      let bucket = Cons{key; data; next=h.data.(i)} in
+      h.data.(i) <- bucket;
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize key_index h
+
+    let rec remove_bucket h i key prec = function
+      | Empty ->
+          ()
+      | (Cons {key=k; next}) as c ->
+          if H.equal k key
+          then begin
+            h.size <- h.size - 1;
+            match prec with
+            | Empty -> h.data.(i) <- next
+            | Cons c -> c.next <- next
+          end
+          else remove_bucket h i key c next
+
+    let remove h key =
+      let i = key_index h key in
+      remove_bucket h i key Empty h.data.(i)
+
+    let rec find_rec key = function
+      | Empty ->
+          raise Not_found
+      | Cons{key=k; data; next} ->
+          if H.equal key k then data else find_rec key next
+
+    let find h key =
+      match h.data.(key_index h key) with
+      | Empty -> raise Not_found
+      | Cons{key=k1; data=d1; next=next1} ->
+          if H.equal key k1 then d1 else
+          match next1 with
+          | Empty -> raise Not_found
+          | Cons{key=k2; data=d2; next=next2} ->
+              if H.equal key k2 then d2 else
+              match next2 with
+              | Empty -> raise Not_found
+              | Cons{key=k3; data=d3; next=next3} ->
+                  if H.equal key k3 then d3 else find_rec key next3
+
+    let rec find_rec_opt key = function
+      | Empty ->
+          None
+      | Cons{key=k; data; next} ->
+          if H.equal key k then Some data else find_rec_opt key next
+
+    let find_opt h key =
+      match h.data.(key_index h key) with
+      | Empty -> None
+      | Cons{key=k1; data=d1; next=next1} ->
+          if H.equal key k1 then Some d1 else
+          match next1 with
+          | Empty -> None
+          | Cons{key=k2; data=d2; next=next2} ->
+              if H.equal key k2 then Some d2 else
+              match next2 with
+              | Empty -> None
+              | Cons{key=k3; data=d3; next=next3} ->
+                  if H.equal key k3 then Some d3 else find_rec_opt key next3
+
+    let find_all h key =
+      let rec find_in_bucket = function
+      | Empty ->
+          []
+      | Cons{key=k; data=d; next} ->
+          if H.equal k key
+          then d :: find_in_bucket next
+          else find_in_bucket next in
+      find_in_bucket h.data.(key_index h key)
+
+    let rec replace_bucket key data = function
+      | Empty ->
+          true
+      | Cons ({key=k; next} as slot) ->
+          if H.equal k key
+          then (slot.key <- key; slot.data <- data; false)
+          else replace_bucket key data next
+
+    let replace h key data =
+      let i = key_index h key in
+      let l = h.data.(i) in
+      if replace_bucket key data l then begin
+        h.data.(i) <- Cons{key; data; next=l};
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize key_index h
+      end
+
+    let mem h key =
+      let rec mem_in_bucket = function
+      | Empty ->
+          false
+      | Cons{key=k; next} ->
+          H.equal k key || mem_in_bucket next in
+      mem_in_bucket h.data.(key_index h key)
+
+    let iter = iter
+    let filter_map_inplace = filter_map_inplace
+    let fold = fold
+    let length = length
+    let stats = stats
+  end
+
+module Make(H: HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (_seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+  end
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
new file mode 100644
index 00000000..d3c0ef3e
--- /dev/null
+++ b/stdlib/hashtbl.mli
@@ -0,0 +1,411 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Hash tables and hash functions.
+
+   Hash tables are hashed association tables, with in-place modification.
+*)
+
+
+(** {6 Generic interface} *)
+
+
+type ('a, 'b) t
+(** The type of hash tables from type ['a] to type ['b]. *)
+
+val create : ?random:bool -> int -> ('a, 'b) t
+(** [Hashtbl.create n] creates a new, empty hash table, with
+   initial size [n].  For best results, [n] should be on the
+   order of the expected number of elements that will be in
+   the table.  The table grows as needed, so [n] is just an
+   initial guess.
+
+   The optional [random] parameter (a boolean) controls whether
+   the internal organization of the hash table is randomized at each
+   execution of [Hashtbl.create] or deterministic over all executions.
+
+   A hash table that is created with [~random:false] uses a
+   fixed hash function ({!Hashtbl.hash}) to distribute keys among
+   buckets.  As a consequence, collisions between keys happen
+   deterministically.  In Web-facing applications or other
+   security-sensitive applications, the deterministic collision
+   patterns can be exploited by a malicious user to create a
+   denial-of-service attack: the attacker sends input crafted to
+   create many collisions in the table, slowing the application down.
+
+   A hash table that is created with [~random:true] uses the seeded
+   hash function {!Hashtbl.seeded_hash} with a seed that is randomly
+   chosen at hash table creation time.  In effect, the hash function
+   used is randomly selected among [2^{30}] different hash functions.
+   All these hash functions have different collision patterns,
+   rendering ineffective the denial-of-service attack described above.
+   However, because of randomization, enumerating all elements of the
+   hash table using {!Hashtbl.fold} or {!Hashtbl.iter} is no longer
+   deterministic: elements are enumerated in different orders at
+   different runs of the program.
+
+   If no [~random] parameter is given, hash tables are created
+   in non-random mode by default.  This default can be changed
+   either programmatically by calling {!Hashtbl.randomize} or by
+   setting the [R] flag in the [OCAMLRUNPARAM] environment variable.
+
+   @before 4.00.0 the [random] parameter was not present and all
+   hash tables were created in non-randomized mode. *)
+
+val clear : ('a, 'b) t -> unit
+(** Empty a hash table. Use [reset] instead of [clear] to shrink the
+    size of the bucket table to its initial size. *)
+
+val reset : ('a, 'b) t -> unit
+(** Empty a hash table and shrink the size of the bucket table
+    to its initial size.
+    @since 4.00.0 *)
+
+val copy : ('a, 'b) t -> ('a, 'b) t
+(** Return a copy of the given hashtable. *)
+
+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
+   hidden. That is, after performing {!Hashtbl.remove}[ tbl x],
+   the previous binding for [x], if any, is restored.
+   (Same behavior as with association lists.) *)
+
+val find : ('a, 'b) t -> 'a -> 'b
+(** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl],
+   or raises [Not_found] if no such binding exists. *)
+
+val find_opt : ('a, 'b) t -> 'a -> 'b option
+(** [Hashtbl.find_opt tbl x] returns the current binding of [x] in [tbl],
+    or [None] if no such binding exists.
+    @since 4.05 *)
+
+val find_all : ('a, 'b) t -> 'a -> 'b list
+(** [Hashtbl.find_all tbl x] returns the list of all data
+   associated with [x] in [tbl].
+   The current binding is returned first, then the previous
+   bindings, in reverse order of introduction in the table. *)
+
+val mem : ('a, 'b) t -> 'a -> bool
+(** [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. *)
+
+val remove : ('a, 'b) t -> 'a -> unit
+(** [Hashtbl.remove tbl x] removes the current binding of [x] in [tbl],
+   restoring the previous binding if it exists.
+   It does nothing if [x] is not bound in [tbl]. *)
+
+val replace : ('a, 'b) t -> 'a -> 'b -> unit
+(** [Hashtbl.replace tbl x y] replaces the current binding of [x]
+   in [tbl] by a binding of [x] to [y].  If [x] is unbound in [tbl],
+   a binding of [x] to [y] is added to [tbl].
+   This is functionally equivalent to {!Hashtbl.remove}[ tbl x]
+   followed by {!Hashtbl.add}[ tbl x y]. *)
+
+val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+(** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl].
+   [f] receives the key as first argument, and the associated value
+   as second argument. Each binding is presented exactly once to [f].
+
+   The order in which the bindings are passed to [f] is unspecified.
+   However, if the table contains several bindings for the same key,
+   they are passed to [f] in reverse order of introduction, that is,
+   the most recent binding is passed first.
+
+   If the hash table was created in non-randomized mode, the order
+   in which the bindings are enumerated is reproducible between
+   successive runs of the program, and even between minor versions
+   of OCaml.  For randomized hash tables, the order of enumeration
+   is entirely random.
+
+   The behavior is not defined if the hash table is modified
+   by [f] during the iteration.
+*)
+
+val filter_map_inplace: ('a -> 'b -> 'b option) -> ('a, 'b) t -> unit
+(** [Hashtbl.filter_map_inplace f tbl] applies [f] to all bindings in
+    table [tbl] and update each binding depending on the result of
+    [f].  If [f] returns [None], the binding is discarded.  If it
+    returns [Some new_val], the binding is update to associate the key
+    to [new_val].
+
+    Other comments for {!Hashtbl.iter} apply as well.
+    @since 4.03.0 *)
+
+val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+(** [Hashtbl.fold f tbl init] computes
+   [(f kN dN ... (f k1 d1 init)...)],
+   where [k1 ... kN] are the keys of all bindings in [tbl],
+   and [d1 ... dN] are the associated values.
+   Each binding is presented exactly once to [f].
+
+   The order in which the bindings are passed to [f] is unspecified.
+   However, if the table contains several bindings for the same key,
+   they are passed to [f] in reverse order of introduction, that is,
+   the most recent binding is passed first.
+
+   If the hash table was created in non-randomized mode, the order
+   in which the bindings are enumerated is reproducible between
+   successive runs of the program, and even between minor versions
+   of OCaml.  For randomized hash tables, the order of enumeration
+   is entirely random.
+
+   The behavior is not defined if the hash table is modified
+   by [f] during the iteration.
+*)
+
+val length : ('a, 'b) t -> int
+(** [Hashtbl.length tbl] returns the number of bindings in [tbl].
+   It takes constant time.  Multiple bindings are counted once each, so
+   [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its
+   first argument. *)
+
+val randomize : unit -> unit
+(** After a call to [Hashtbl.randomize()], hash tables are created in
+    randomized mode by default: {!Hashtbl.create} returns randomized
+    hash tables, unless the [~random:false] optional parameter is given.
+    The same effect can be achieved by setting the [R] parameter in
+    the [OCAMLRUNPARAM] environment variable.
+
+    It is recommended that applications or Web frameworks that need to
+    protect themselves against the denial-of-service attack described
+    in {!Hashtbl.create} call [Hashtbl.randomize()] at initialization
+    time.
+
+    Note that once [Hashtbl.randomize()] was called, there is no way
+    to revert to the non-randomized default behavior of {!Hashtbl.create}.
+    This is intentional.  Non-randomized hash tables can still be
+    created using [Hashtbl.create ~random:false].
+
+    @since 4.00.0 *)
+
+val is_randomized : unit -> bool
+(** return if the tables are currently created in randomized mode by default
+
+    @since 4.03.0 *)
+
+(** @since 4.00.0 *)
+type statistics = {
+  num_bindings: int;
+    (** Number of bindings present in the table.
+        Same value as returned by {!Hashtbl.length}. *)
+  num_buckets: int;
+    (** Number of buckets in the table. *)
+  max_bucket_length: int;
+    (** Maximal number of bindings per bucket. *)
+  bucket_histogram: int array
+    (** Histogram of bucket sizes.  This array [histo] has
+        length [max_bucket_length + 1].  The value of
+        [histo.(i)] is the number of buckets whose size is [i]. *)
+}
+
+val stats : ('a, 'b) t -> statistics
+(** [Hashtbl.stats tbl] returns statistics about the table [tbl]:
+   number of buckets, size of the biggest bucket, distribution of
+   buckets by size.
+   @since 4.00.0 *)
+
+(** {6 Functorial interface} *)
+
+(** The functorial interface allows the use of specific comparison
+    and hash functions, either for performance/security concerns,
+    or because keys are not hashable/comparable with the polymorphic builtins.
+
+    For instance, one might want to specialize a table for integer keys:
+    {[
+      module IntHash =
+        struct
+          type t = int
+          let equal i j = i=j
+          let hash i = i land max_int
+        end
+
+      module IntHashtbl = Hashtbl.Make(IntHash)
+
+      let h = IntHashtbl.create 17 in
+      IntHashtbl.add h 12 "hello"
+    ]}
+
+    This creates a new module [IntHashtbl], with a new type ['a
+    IntHashtbl.t] of tables from [int] to ['a]. In this example, [h]
+    contains [string] values so its type is [string IntHashtbl.t].
+
+    Note that the new type ['a IntHashtbl.t] is not compatible with
+    the type [('a,'b) Hashtbl.t] of the generic interface. For
+    example, [Hashtbl.length h] would not type-check, you must use
+    [IntHashtbl.length].
+*)
+
+module type HashedType =
+  sig
+    type t
+    (** The type of the hashtable keys. *)
+
+    val equal : t -> t -> bool
+    (** The equality predicate used to compare keys. *)
+
+    val hash : t -> int
+      (** A hashing function on keys. It must be such that if two keys are
+          equal according to [equal], then they have identical hash values
+          as computed by [hash].
+          Examples: suitable ([equal], [hash]) pairs for arbitrary key
+          types include
+-         ([(=)], {!Hashtbl.hash}) for comparing objects by structure
+              (provided objects do not contain floats)
+-         ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
+              for comparing objects by structure
+              and handling {!Pervasives.nan} correctly
+-         ([(==)], {!Hashtbl.hash}) for comparing objects by physical
+              equality (e.g. for mutable or cyclic objects). *)
+   end
+(** The input signature of the functor {!Hashtbl.Make}. *)
+
+module type S =
+  sig
+    type key
+    type 'a t
+    val create : int -> 'a t
+    val clear : 'a t -> unit
+    val reset : 'a t -> unit (** @since 4.00.0 *)
+
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_opt : 'a t -> key -> 'a option
+    (** @since 4.05.0 *)
+
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+    (** @since 4.03.0 *)
+
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
+    val stats: 'a t -> statistics (** @since 4.00.0 *)
+  end
+(** The output signature of the functor {!Hashtbl.Make}. *)
+
+module Make (H : HashedType) : S with type key = H.t
+(** Functor building an implementation of the hashtable structure.
+    The functor [Hashtbl.Make] returns a structure containing
+    a type [key] of keys and a type ['a t] of hash tables
+    associating data of type ['a] to keys of type [key].
+    The operations perform similarly to those of the generic
+    interface, but use the hashing and equality functions
+    specified in the functor argument [H] instead of generic
+    equality and hashing.  Since the hash function is not seeded,
+    the [create] operation of the result structure always returns
+    non-randomized hash tables. *)
+
+module type SeededHashedType =
+  sig
+    type t
+    (** The type of the hashtable keys. *)
+
+    val equal: t -> t -> bool
+    (** The equality predicate used to compare keys. *)
+
+    val hash: int -> t -> int
+      (** A seeded hashing function on keys.  The first argument is
+          the seed.  It must be the case that if [equal x y] is true,
+          then [hash seed x = hash seed y] for any value of [seed].
+          A suitable choice for [hash] is the function {!Hashtbl.seeded_hash}
+          below. *)
+  end
+(** The input signature of the functor {!Hashtbl.MakeSeeded}.
+    @since 4.00.0 *)
+
+module type SeededS =
+  sig
+    type key
+    type 'a t
+    val create : ?random:bool -> int -> 'a t
+    val clear : 'a t -> unit
+    val reset : 'a t -> unit
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_opt : 'a t -> key -> 'a option (** @since 4.05.0 *)
+
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+    (** @since 4.03.0 *)
+
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
+    val stats: 'a t -> statistics
+  end
+(** The output signature of the functor {!Hashtbl.MakeSeeded}.
+    @since 4.00.0 *)
+
+module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
+(** Functor building an implementation of the hashtable structure.
+    The functor [Hashtbl.MakeSeeded] returns a structure containing
+    a type [key] of keys and a type ['a t] of hash tables
+    associating data of type ['a] to keys of type [key].
+    The operations perform similarly to those of the generic
+    interface, but use the seeded hashing and equality functions
+    specified in the functor argument [H] instead of generic
+    equality and hashing.  The [create] operation of the
+    result structure supports the [~random] optional parameter
+    and returns randomized hash tables if [~random:true] is passed
+    or if randomization is globally on (see {!Hashtbl.randomize}).
+    @since 4.00.0 *)
+
+
+(** {6 The polymorphic hash functions} *)
+
+
+val hash : 'a -> int
+(** [Hashtbl.hash x] associates a nonnegative integer to any value of
+   any type. It is guaranteed that
+   if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y].
+   Moreover, [hash] always terminates, even on cyclic structures. *)
+
+val seeded_hash : int -> 'a -> int
+(** A variant of {!Hashtbl.hash} that is further parameterized by
+   an integer seed.
+   @since 4.00.0 *)
+
+val hash_param : int -> int -> 'a -> int
+(** [Hashtbl.hash_param meaningful total x] computes a hash value for [x],
+   with the same properties as for [hash]. The two extra integer
+   parameters [meaningful] and [total] give more precise control over
+   hashing. Hashing performs a breadth-first, left-to-right traversal
+   of the structure [x], stopping after [meaningful] meaningful nodes
+   were encountered, or [total] nodes (meaningful or not) were
+   encountered.  If [total] as specified by the user exceeds a certain
+   value, currently 256, then it is capped to that value.
+   Meaningful nodes are: integers; floating-point
+   numbers; strings; characters; booleans; and constant
+   constructors. Larger values of [meaningful] and [total] means that
+   more nodes are taken into account to compute the final hash value,
+   and therefore collisions are less likely to happen.  However,
+   hashing takes longer. The parameters [meaningful] and [total]
+   govern the tradeoff between accuracy and speed.  As default
+   choices, {!Hashtbl.hash} and {!Hashtbl.seeded_hash} take
+   [meaningful = 10] and [total = 100]. *)
+
+val seeded_hash_param : int -> int -> int -> 'a -> int
+(** A variant of {!Hashtbl.hash_param} that is further parameterized by
+   an integer seed.  Usage:
+   [Hashtbl.seeded_hash_param meaningful total seed x].
+   @since 4.00.0 *)
diff --git a/stdlib/header.c b/stdlib/header.c
new file mode 100644
index 00000000..28408a51
--- /dev/null
+++ b/stdlib/header.c
@@ -0,0 +1,193 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1998 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* The launcher for bytecode executables (if #! is not working) */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "../config/s.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include "../byterun/caml/mlvalues.h"
+#include "../byterun/caml/exec.h"
+
+char * default_runtime_path = RUNTIME_NAME;
+
+#ifndef MAXPATHLEN
+#define MAXPATHLEN 1024
+#endif
+
+#ifndef S_ISREG
+#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+#ifndef __CYGWIN__
+
+/* Normal Unix search path function */
+
+static char * searchpath(char * name)
+{
+  static char fullname[MAXPATHLEN + 1];
+  char * path;
+  char * p;
+  char * q;
+  struct stat st;
+
+  for (p = name; *p != 0; p++) {
+    if (*p == '/') return name;
+  }
+  path = getenv("PATH");
+  if (path == NULL) return name;
+  while(1) {
+    for (p = fullname; *path != 0 && *path != ':'; p++, path++)
+      if (p < fullname + MAXPATHLEN) *p = *path;
+    if (p != fullname && p < fullname + MAXPATHLEN)
+      *p++ = '/';
+    for (q = name; *q != 0; p++, q++)
+      if (p < fullname + MAXPATHLEN) *p = *q;
+    *p = 0;
+    if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) break;
+    if (*path == 0) return name;
+    path++;
+  }
+  return fullname;
+}
+
+#else
+
+/* Special version for Cygwin32: takes care of the ".exe" implicit suffix */
+
+static int file_ok(char * name)
+{
+  int fd;
+  /* Cannot use stat() here because it adds ".exe" implicitly */
+  fd = open(name, O_RDONLY);
+  if (fd == -1) return 0;
+  close(fd);
+  return 1;
+}
+
+static char * searchpath(char * name)
+{
+  char * path, * fullname, * p;
+
+  path = getenv("PATH");
+  fullname = malloc(strlen(name) + (path == NULL ? 0 : strlen(path)) + 6);
+  /* 6 = "/" plus ".exe" plus final "\0" */
+  if (fullname == NULL) return name;
+  /* Check for absolute path name */
+  for (p = name; *p != 0; p++) {
+    if (*p == '/' || *p == '\\') {
+      if (file_ok(name)) return name;
+      strcpy(fullname, name);
+      strcat(fullname, ".exe");
+      if (file_ok(fullname)) return fullname;
+      return name;
+    }
+  }
+  /* Search in path */
+  if (path == NULL) return name;
+  while(1) {
+    for (p = fullname; *path != 0 && *path != ':'; p++, path++) *p = *path;
+    if (p != fullname) *p++ = '/';
+    strcpy(p, name);
+    if (file_ok(fullname)) return fullname;
+    strcat(fullname, ".exe");
+    if (file_ok(fullname)) return fullname;
+    if (*path == 0) break;
+    path++;
+  }
+  return name;
+}
+
+#endif
+
+static unsigned long read_size(char * ptr)
+{
+  unsigned char * p = (unsigned char *) ptr;
+  return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) +
+         ((unsigned long) p[2] << 8) + p[3];
+}
+
+static char * read_runtime_path(int fd)
+{
+  char buffer[TRAILER_SIZE];
+  static char runtime_path[MAXPATHLEN];
+  int num_sections, i;
+  uint32_t path_size;
+  long ofs;
+
+  lseek(fd, (long) -TRAILER_SIZE, SEEK_END);
+  if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return NULL;
+  num_sections = read_size(buffer);
+  ofs = TRAILER_SIZE + num_sections * 8;
+  lseek(fd, -ofs, SEEK_END);
+  path_size = 0;
+  for (i = 0; i < num_sections; i++) {
+    if (read(fd, buffer, 8) < 8) return NULL;
+    if (buffer[0] == 'R' && buffer[1] == 'N' &&
+        buffer[2] == 'T' && buffer[3] == 'M') {
+      path_size = read_size(buffer + 4);
+      ofs += path_size;
+    } else if (path_size > 0)
+      ofs += read_size(buffer + 4);
+  }
+  if (path_size == 0) return default_runtime_path;
+  if (path_size >= MAXPATHLEN) return NULL;
+  lseek(fd, -ofs, SEEK_END);
+  if (read(fd, runtime_path, path_size) != path_size) return NULL;
+  runtime_path[path_size - 1] = 0;
+  return runtime_path;
+}
+
+static void errwrite(char * msg)
+{
+  write(2, msg, strlen(msg));
+}
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+int main(int argc, char ** argv)
+{
+  char * truename, * runtime_path;
+  int fd;
+
+  truename = searchpath(argv[0]);
+  fd = open(truename, O_RDONLY | O_BINARY);
+  if (fd == -1 || (runtime_path = read_runtime_path(fd)) == NULL) {
+    errwrite(truename);
+    errwrite(" not found or is not a bytecode executable file\n");
+    return 2;
+  }
+  argv[0] = truename;
+  execv(runtime_path, argv);
+  errwrite("Cannot exec ");
+  errwrite(runtime_path);
+  errwrite("\n");
+  return 2;
+}
diff --git a/stdlib/headernt.c b/stdlib/headernt.c
new file mode 100644
index 00000000..9d4943b2
--- /dev/null
+++ b/stdlib/headernt.c
@@ -0,0 +1,182 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1998 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#define STRICT
+#define WIN32_LEAN_AND_MEAN
+
+#include <windows.h>
+#include "caml/mlvalues.h"
+#include "caml/exec.h"
+
+#ifndef __MINGW32__
+#pragma comment(linker , "/entry:headerentry")
+#pragma comment(linker , "/subsystem:console")
+#pragma comment(lib , "kernel32")
+#ifdef _UCRT
+#pragma comment(lib , "ucrt.lib")
+#pragma comment(lib , "vcruntime.lib")
+#endif
+#endif
+
+char * default_runtime_name = RUNTIME_NAME;
+
+static
+#if _MSC_VER >= 1200
+__forceinline
+#else
+__inline
+#endif
+unsigned long read_size(const char * const ptr)
+{
+  const unsigned char * const p = (const unsigned char * const) ptr;
+  return ((unsigned long) p[0] << 24) | ((unsigned long) p[1] << 16) |
+         ((unsigned long) p[2] << 8) | p[3];
+}
+
+static __inline char * read_runtime_path(HANDLE h)
+{
+  char buffer[TRAILER_SIZE];
+  static char runtime_path[MAX_PATH];
+  DWORD nread;
+  int num_sections, path_size, i;
+  long ofs;
+
+  if (SetFilePointer(h, -TRAILER_SIZE, NULL, FILE_END) == -1) return NULL;
+  if (! ReadFile(h, buffer, TRAILER_SIZE, &nread, NULL)) return NULL;
+  if (nread != TRAILER_SIZE) return NULL;
+  num_sections = read_size(buffer);
+  ofs = TRAILER_SIZE + num_sections * 8;
+  if (SetFilePointer(h, - ofs, NULL, FILE_END) == -1) return NULL;
+  path_size = 0;
+  for (i = 0; i < num_sections; i++) {
+    if (! ReadFile(h, buffer, 8, &nread, NULL) || nread != 8) return NULL;
+    if (buffer[0] == 'R' && buffer[1] == 'N' &&
+        buffer[2] == 'T' && buffer[3] == 'M') {
+      path_size = read_size(buffer + 4);
+      ofs += path_size;
+    } else if (path_size > 0)
+      ofs += read_size(buffer + 4);
+  }
+  if (path_size == 0) return default_runtime_name;
+  if (path_size >= MAX_PATH) return NULL;
+  if (SetFilePointer(h, -ofs, NULL, FILE_END) == -1) return NULL;
+  if (! ReadFile(h, runtime_path, path_size, &nread, NULL)) return NULL;
+  if (nread != path_size) return NULL;
+  runtime_path[path_size - 1] = 0;
+  return runtime_path;
+}
+
+static BOOL WINAPI ctrl_handler(DWORD event)
+{
+  if (event == CTRL_C_EVENT || event == CTRL_BREAK_EVENT)
+    return TRUE;                /* pretend we've handled them */
+  else
+    return FALSE;
+}
+
+#define msg_and_length(msg) msg , (sizeof(msg) - 1)
+
+static __inline void __declspec(noreturn) run_runtime(char * runtime,
+         char * const cmdline)
+{
+  char path[MAX_PATH];
+  STARTUPINFO stinfo;
+  PROCESS_INFORMATION procinfo;
+  DWORD retcode;
+  if (SearchPath(NULL, runtime, ".exe", MAX_PATH, path, &runtime) == 0) {
+    HANDLE errh;
+    DWORD numwritten;
+    errh = GetStdHandle(STD_ERROR_HANDLE);
+    WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL);
+    WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL);
+    WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL);
+    ExitProcess(2);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+  }
+  /* Need to ignore ctrl-C and ctrl-break, otherwise we'll die and take
+     the underlying OCaml program with us! */
+  SetConsoleCtrlHandler(ctrl_handler, TRUE);
+
+  stinfo.cb = sizeof(stinfo);
+  stinfo.lpReserved = NULL;
+  stinfo.lpDesktop = NULL;
+  stinfo.lpTitle = NULL;
+  stinfo.dwFlags = 0;
+  stinfo.cbReserved2 = 0;
+  stinfo.lpReserved2 = NULL;
+  if (!CreateProcess(path, cmdline, NULL, NULL, TRUE, 0, NULL, NULL,
+                     &stinfo, &procinfo)) {
+    HANDLE errh;
+    DWORD numwritten;
+    errh = GetStdHandle(STD_ERROR_HANDLE);
+    WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL);
+    WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL);
+    WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL);
+    ExitProcess(2);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+  }
+  CloseHandle(procinfo.hThread);
+  WaitForSingleObject(procinfo.hProcess , INFINITE);
+  GetExitCodeProcess(procinfo.hProcess , &retcode);
+  CloseHandle(procinfo.hProcess);
+  ExitProcess(retcode);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+}
+
+#ifdef __MINGW32__
+int main()
+#else
+void __declspec(noreturn) __cdecl headerentry()
+#endif
+{
+  char truename[MAX_PATH];
+  char * cmdline = GetCommandLine();
+  char * runtime_path;
+  HANDLE h;
+
+  GetModuleFileName(NULL, truename, sizeof(truename));
+  h = CreateFile(truename, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE,
+                 NULL, OPEN_EXISTING, 0, NULL);
+  if (h == INVALID_HANDLE_VALUE ||
+      (runtime_path = read_runtime_path(h)) == NULL) {
+    HANDLE errh;
+    DWORD numwritten;
+    errh = GetStdHandle(STD_ERROR_HANDLE);
+    WriteFile(errh, truename, strlen(truename), &numwritten, NULL);
+    WriteFile(errh, msg_and_length(" not found or is not a bytecode"
+                                   " executable file\r\n"),
+              &numwritten, NULL);
+    ExitProcess(2);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+  }
+  CloseHandle(h);
+  run_runtime(runtime_path , cmdline);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+#ifdef __MINGW32__
+    return 0;
+#endif
+}
diff --git a/stdlib/int32.ml b/stdlib/int32.ml
new file mode 100644
index 00000000..959c0424
--- /dev/null
+++ b/stdlib/int32.ml
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Int32]: 32-bit integers *)
+
+external neg : int32 -> int32 = "%int32_neg"
+external add : int32 -> int32 -> int32 = "%int32_add"
+external sub : int32 -> int32 -> int32 = "%int32_sub"
+external mul : int32 -> int32 -> int32 = "%int32_mul"
+external div : int32 -> int32 -> int32 = "%int32_div"
+external rem : int32 -> int32 -> int32 = "%int32_mod"
+external logand : int32 -> int32 -> int32 = "%int32_and"
+external logor : int32 -> int32 -> int32 = "%int32_or"
+external logxor : int32 -> int32 -> int32 = "%int32_xor"
+external shift_left : int32 -> int -> int32 = "%int32_lsl"
+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
+  = "caml_int32_of_float" "caml_int32_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external to_float : int32 -> float
+  = "caml_int32_to_float" "caml_int32_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external bits_of_float : float -> int32
+  = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external float_of_bits : int32 -> float
+  = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed"
+  [@@unboxed] [@@noalloc]
+
+let zero = 0l
+let one = 1l
+let minus_one = -1l
+let succ n = add n 1l
+let pred n = sub n 1l
+let abs n = if n >= 0l then n else neg n
+let min_int = 0x80000000l
+let max_int = 0x7FFFFFFFl
+let lognot n = logxor n (-1l)
+
+external format : string -> int32 -> string = "caml_int32_format"
+let to_string n = format "%d" n
+
+external of_string : string -> int32 = "caml_int32_of_string"
+
+let of_string_opt s =
+  (* TODO: expose a non-raising primitive directly. *)
+  try Some (of_string s)
+  with Failure _ -> None
+
+type t = int32
+
+let compare (x: t) (y: t) = Pervasives.compare x y
+let equal (x: t) (y: t) = compare x y = 0
diff --git a/stdlib/int32.mli b/stdlib/int32.mli
new file mode 100644
index 00000000..19d7897a
--- /dev/null
+++ b/stdlib/int32.mli
@@ -0,0 +1,181 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 32-bit integers.
+
+   This module provides operations on the type [int32]
+   of signed 32-bit integers.  Unlike the built-in [int] type,
+   the type [int32] is guaranteed to be exactly 32-bit wide on all
+   platforms.  All arithmetic operations over [int32] are taken
+   modulo 2{^32}.
+
+   Performance notice: values of type [int32] occupy more memory
+   space than values of type [int], and arithmetic operations on
+   [int32] are generally slower than those on [int].  Use [int32]
+   only when the application requires exact 32-bit arithmetic. *)
+
+val zero : int32
+(** The 32-bit integer 0. *)
+
+val one : int32
+(** The 32-bit integer 1. *)
+
+val minus_one : int32
+(** The 32-bit integer -1. *)
+
+external neg : int32 -> int32 = "%int32_neg"
+(** Unary negation. *)
+
+external add : int32 -> int32 -> int32 = "%int32_add"
+(** Addition. *)
+
+external sub : int32 -> int32 -> int32 = "%int32_sub"
+(** Subtraction. *)
+
+external mul : int32 -> int32 -> int32 = "%int32_mul"
+(** Multiplication. *)
+
+external div : int32 -> int32 -> int32 = "%int32_div"
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Pervasives.(/)}. *)
+
+external rem : int32 -> int32 -> int32 = "%int32_mod"
+(** Integer remainder.  If [y] is not zero, the result
+   of [Int32.rem x y] satisfies the following property:
+   [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)].
+   If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *)
+
+val succ : int32 -> int32
+(** Successor.  [Int32.succ x] is [Int32.add x Int32.one]. *)
+
+val pred : int32 -> int32
+(** Predecessor.  [Int32.pred x] is [Int32.sub x Int32.one]. *)
+
+val abs : int32 -> int32
+(** Return the absolute value of its argument. *)
+
+val max_int : int32
+(** The greatest representable 32-bit integer, 2{^31} - 1. *)
+
+val min_int : int32
+(** The smallest representable 32-bit integer, -2{^31}. *)
+
+
+external logand : int32 -> int32 -> int32 = "%int32_and"
+(** Bitwise logical and. *)
+
+external logor : int32 -> int32 -> int32 = "%int32_or"
+(** Bitwise logical or. *)
+
+external logxor : int32 -> int32 -> int32 = "%int32_xor"
+(** Bitwise logical exclusive or. *)
+
+val lognot : int32 -> int32
+(** Bitwise logical negation *)
+
+external shift_left : int32 -> int -> int32 = "%int32_lsl"
+(** [Int32.shift_left x y] shifts [x] to the left by [y] bits.
+   The result is unspecified if [y < 0] or [y >= 32]. *)
+
+external shift_right : int32 -> int -> int32 = "%int32_asr"
+(** [Int32.shift_right x y] shifts [x] to the right by [y] bits.
+   This is an arithmetic shift: the sign bit of [x] is replicated
+   and inserted in the vacated bits.
+   The result is unspecified if [y < 0] or [y >= 32]. *)
+
+external shift_right_logical : int32 -> int -> int32 = "%int32_lsr"
+(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits.
+   This is a logical shift: zeroes are inserted in the vacated bits
+   regardless of the sign of [x].
+   The result is unspecified if [y < 0] or [y >= 32]. *)
+
+external of_int : int -> int32 = "%int32_of_int"
+(** Convert the given integer (type [int]) to a 32-bit integer
+    (type [int32]). *)
+
+external to_int : int32 -> int = "%int32_to_int"
+(** Convert the given 32-bit integer (type [int32]) to an
+   integer (type [int]).  On 32-bit platforms, the 32-bit integer
+   is taken modulo 2{^31}, i.e. the high-order bit is lost
+   during the conversion.  On 64-bit platforms, the conversion
+   is exact. *)
+
+external of_float : float -> int32
+  = "caml_int32_of_float" "caml_int32_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** 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
+  = "caml_int32_to_float" "caml_int32_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** Convert the given 32-bit integer to a floating-point number. *)
+
+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, or if the integer represented
+   exceeds the range of integers representable in type [int32]. *)
+
+val of_string_opt: string -> int32 option
+(** Same as [of_string], but return [None] instead of raising.
+    @since 4.05 *)
+
+
+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" "caml_int32_bits_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** 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" "caml_int32_float_of_bits_unboxed"
+  [@@unboxed] [@@noalloc]
+(** 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. *)
+
+val compare: t -> t -> int
+(** The comparison function for 32-bit integers, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [Int32] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equal function for int32s.
+    @since 4.03.0 *)
+
+(**/**)
+
+(** {6 Deprecated functions} *)
+
+external format : string -> int32 -> string = "caml_int32_format"
+(** Do not use this deprecated function.  Instead,
+   used {!Printf.sprintf} with a [%l...] format. *)
diff --git a/stdlib/int64.ml b/stdlib/int64.ml
new file mode 100644
index 00000000..8bc95a03
--- /dev/null
+++ b/stdlib/int64.ml
@@ -0,0 +1,75 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Int64]: 64-bit integers *)
+
+external neg : int64 -> int64 = "%int64_neg"
+external add : int64 -> int64 -> int64 = "%int64_add"
+external sub : int64 -> int64 -> int64 = "%int64_sub"
+external mul : int64 -> int64 -> int64 = "%int64_mul"
+external div : int64 -> int64 -> int64 = "%int64_div"
+external rem : int64 -> int64 -> int64 = "%int64_mod"
+external logand : int64 -> int64 -> int64 = "%int64_and"
+external logor : int64 -> int64 -> int64 = "%int64_or"
+external logxor : int64 -> int64 -> int64 = "%int64_xor"
+external shift_left : int64 -> int -> int64 = "%int64_lsl"
+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
+  = "caml_int64_of_float" "caml_int64_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external to_float : int64 -> float
+  = "caml_int64_to_float" "caml_int64_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external of_int32 : int32 -> int64 = "%int64_of_int32"
+external to_int32 : int64 -> int32 = "%int64_to_int32"
+external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"
+external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
+
+let zero = 0L
+let one = 1L
+let minus_one = -1L
+let succ n = add n 1L
+let pred n = sub n 1L
+let abs n = if n >= 0L then n else neg n
+let min_int = 0x8000000000000000L
+let max_int = 0x7FFFFFFFFFFFFFFFL
+let lognot n = logxor n (-1L)
+
+external format : string -> int64 -> string = "caml_int64_format"
+let to_string n = format "%d" n
+
+external of_string : string -> int64 = "caml_int64_of_string"
+
+let of_string_opt s =
+  (* TODO: expose a non-raising primitive directly. *)
+  try Some (of_string s)
+  with Failure _ -> None
+
+
+
+external bits_of_float : float -> int64
+  = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external float_of_bits : int64 -> float
+  = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+  [@@unboxed] [@@noalloc]
+
+type t = int64
+
+let compare (x: t) (y: t) = Pervasives.compare x y
+let equal (x: t) (y: t) = compare x y = 0
diff --git a/stdlib/int64.mli b/stdlib/int64.mli
new file mode 100644
index 00000000..d8aacd53
--- /dev/null
+++ b/stdlib/int64.mli
@@ -0,0 +1,202 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** 64-bit integers.
+
+   This module provides operations on the type [int64] of
+   signed 64-bit integers.  Unlike the built-in [int] type,
+   the type [int64] is guaranteed to be exactly 64-bit wide on all
+   platforms.  All arithmetic operations over [int64] are taken
+   modulo 2{^64}
+
+   Performance notice: values of type [int64] occupy more memory
+   space than values of type [int], and arithmetic operations on
+   [int64] are generally slower than those on [int].  Use [int64]
+   only when the application requires exact 64-bit arithmetic.
+*)
+
+val zero : int64
+(** The 64-bit integer 0. *)
+
+val one : int64
+(** The 64-bit integer 1. *)
+
+val minus_one : int64
+(** The 64-bit integer -1. *)
+
+external neg : int64 -> int64 = "%int64_neg"
+(** Unary negation. *)
+
+external add : int64 -> int64 -> int64 = "%int64_add"
+(** Addition. *)
+
+external sub : int64 -> int64 -> int64 = "%int64_sub"
+(** Subtraction. *)
+
+external mul : int64 -> int64 -> int64 = "%int64_mul"
+(** Multiplication. *)
+
+external div : int64 -> int64 -> int64 = "%int64_div"
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Pervasives.(/)}. *)
+
+external rem : int64 -> int64 -> int64 = "%int64_mod"
+(** Integer remainder.  If [y] is not zero, the result
+   of [Int64.rem x y] satisfies the following property:
+   [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)].
+   If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *)
+
+val succ : int64 -> int64
+(** Successor.  [Int64.succ x] is [Int64.add x Int64.one]. *)
+
+val pred : int64 -> int64
+(** Predecessor.  [Int64.pred x] is [Int64.sub x Int64.one]. *)
+
+val abs : int64 -> int64
+(** Return the absolute value of its argument. *)
+
+val max_int : int64
+(** The greatest representable 64-bit integer, 2{^63} - 1. *)
+
+val min_int : int64
+(** The smallest representable 64-bit integer, -2{^63}. *)
+
+external logand : int64 -> int64 -> int64 = "%int64_and"
+(** Bitwise logical and. *)
+
+external logor : int64 -> int64 -> int64 = "%int64_or"
+(** Bitwise logical or. *)
+
+external logxor : int64 -> int64 -> int64 = "%int64_xor"
+(** Bitwise logical exclusive or. *)
+
+val lognot : int64 -> int64
+(** Bitwise logical negation *)
+
+external shift_left : int64 -> int -> int64 = "%int64_lsl"
+(** [Int64.shift_left x y] shifts [x] to the left by [y] bits.
+   The result is unspecified if [y < 0] or [y >= 64]. *)
+
+external shift_right : int64 -> int -> int64 = "%int64_asr"
+(** [Int64.shift_right x y] shifts [x] to the right by [y] bits.
+   This is an arithmetic shift: the sign bit of [x] is replicated
+   and inserted in the vacated bits.
+   The result is unspecified if [y < 0] or [y >= 64]. *)
+
+external shift_right_logical : int64 -> int -> int64 = "%int64_lsr"
+(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits.
+   This is a logical shift: zeroes are inserted in the vacated bits
+   regardless of the sign of [x].
+   The result is unspecified if [y < 0] or [y >= 64]. *)
+
+external of_int : int -> int64 = "%int64_of_int"
+(** Convert the given integer (type [int]) to a 64-bit integer
+    (type [int64]). *)
+
+external to_int : int64 -> int = "%int64_to_int"
+(** Convert the given 64-bit integer (type [int64]) to an
+   integer (type [int]).  On 64-bit platforms, the 64-bit integer
+   is taken modulo 2{^63}, i.e. the high-order bit is lost
+   during the conversion.  On 32-bit platforms, the 64-bit integer
+   is taken modulo 2{^31}, i.e. the top 33 bits are lost
+   during the conversion. *)
+
+external of_float : float -> int64
+  = "caml_int64_of_float" "caml_int64_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** 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
+  = "caml_int64_to_float" "caml_int64_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** Convert the given 64-bit integer to a floating-point number. *)
+
+
+external of_int32 : int32 -> int64 = "%int64_of_int32"
+(** Convert the given 32-bit integer (type [int32])
+   to a 64-bit integer (type [int64]). *)
+
+external to_int32 : int64 -> int32 = "%int64_to_int32"
+(** Convert the given 64-bit integer (type [int64]) to a
+   32-bit integer (type [int32]). The 64-bit integer
+   is taken modulo 2{^32}, i.e. the top 32 bits are lost
+   during the conversion.  *)
+
+external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"
+(** Convert the given native integer (type [nativeint])
+   to a 64-bit integer (type [int64]). *)
+
+external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
+(** Convert the given 64-bit integer (type [int64]) to a
+   native integer.  On 32-bit platforms, the 64-bit integer
+   is taken modulo 2{^32}.  On 64-bit platforms,
+   the conversion is exact. *)
+
+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, or if the integer represented
+   exceeds the range of integers representable in type [int64]. *)
+
+val of_string_opt: string -> int64 option
+(** Same as [of_string], but return [None] instead of raising.
+    @since 4.05 *)
+
+val to_string : int64 -> string
+(** Return the string representation of its argument, in decimal. *)
+
+external bits_of_float : float -> int64
+  = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** 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
+  = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+  [@@unboxed] [@@noalloc]
+(** Return the floating-point number whose internal representation,
+   according to the IEEE 754 floating-point 'double format' bit layout,
+   is the given [int64]. *)
+
+type t = int64
+(** An alias for the type of 64-bit integers. *)
+
+val compare: t -> t -> int
+(** The comparison function for 64-bit integers, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [Int64] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equal function for int64s.
+    @since 4.03.0 *)
+
+(**/**)
+
+(** {6 Deprecated functions} *)
+
+external format : string -> int64 -> string = "caml_int64_format"
+(** Do not use this deprecated function.  Instead,
+   used {!Printf.sprintf} with a [%L...] format. *)
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
new file mode 100644
index 00000000..65269613
--- /dev/null
+++ b/stdlib/lazy.ml
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Lazy]: deferred computations *)
+
+
+(*
+   WARNING: some purple magic is going on here.  Do not take this file
+   as an example of how to program in OCaml.
+*)
+
+
+(* We make use of two special tags provided by the runtime:
+   [lazy_tag] and [forward_tag].
+
+   A value of type ['a Lazy.t] can be one of three things:
+   1. A block of size 1 with tag [lazy_tag].  Its field is a closure of
+      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 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.
+*)
+
+type 'a t = 'a lazy_t
+
+exception Undefined = CamlinternalLazy.Undefined
+
+external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward"
+
+external force : 'a t -> 'a = "%lazy_force"
+
+(* let force = force *)
+
+let force_val = CamlinternalLazy.force_val
+
+let from_fun (f : unit -> 'arg) =
+  let x = Obj.new_block Obj.lazy_tag 1 in
+  Obj.set_field x 0 (Obj.repr f);
+  (Obj.obj x : 'arg t)
+
+
+let 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 is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag
+
+let lazy_from_fun = from_fun
+
+let lazy_from_val = from_val
+
+let lazy_is_val = is_val
diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
new file mode 100644
index 00000000..ee10366e
--- /dev/null
+++ b/stdlib/lazy.mli
@@ -0,0 +1,95 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Deferred computations. *)
+
+type 'a t = 'a lazy_t
+(** A value of type ['a Lazy.t] is a deferred computation, called
+   a suspension, that has a result of type ['a].  The special
+   expression syntax [lazy (expr)] makes a suspension of the
+   computation of [expr], without computing [expr] itself yet.
+   "Forcing" the suspension will then compute [expr] and return its
+   result.
+
+   Note: [lazy_t] is the built-in type constructor used by the compiler
+   for the [lazy] keyword.  You should not use it directly.  Always use
+   [Lazy.t] instead.
+
+   Note: [Lazy.force] is not thread-safe.  If you use this module in
+   a multi-threaded program, you will need to add some locks.
+
+   Note: if the program is compiled with the [-rectypes] option,
+   ill-founded recursive definitions of the form [let rec x = lazy x]
+   or [let rec x = lazy(lazy(...(lazy x)))] are accepted by the type-checker
+   and lead, when forced, to ill-formed values that trigger infinite
+   loops in the garbage collector and other parts of the run-time system.
+   Without the [-rectypes] option, such ill-founded recursive definitions
+   are rejected by the type-checker.
+*)
+
+
+exception Undefined
+
+(* val force : 'a t -> 'a  *)
+external force : 'a t -> 'a = "%lazy_force"
+(** [force x] forces the suspension [x] and returns its result.
+   If [x] has already been forced, [Lazy.force x] returns the
+   same value again without recomputing it.  If it raised an exception,
+   the same exception is raised again.
+   Raise {!Undefined} if the forcing of [x] tries to force [x] itself
+   recursively.
+*)
+
+val force_val : 'a t -> 'a
+(** [force_val x] forces the suspension [x] and returns its
+    result.  If [x] has already been forced, [force_val x]
+    returns the same value again without recomputing it.
+    Raise {!Undefined} if the forcing of [x] tries to force [x] itself
+    recursively.
+    If the computation of [x] raises an exception, it is unspecified
+    whether [force_val x] raises the same exception or {!Undefined}.
+*)
+
+val from_fun : (unit -> 'a) -> 'a t
+(** [from_fun f] is the same as [lazy (f ())] but slightly more efficient.
+
+    [from_fun] should only be used if the function [f] is already defined.
+    In particular it is always less efficient to write
+    [from_fun (fun () -> expr)] than [lazy expr].
+
+    @since 4.00.0 *)
+
+val from_val : 'a -> 'a t
+(** [from_val v] returns an already-forced suspension of [v].
+    This is for special purposes only and should not be confused with
+    [lazy (v)].
+    @since 4.00.0 *)
+
+val is_val : 'a t -> bool
+(** [is_val x] returns [true] if [x] has already been forced and
+    did not raise an exception.
+    @since 4.00.0 *)
+
+val lazy_from_fun : (unit -> 'a) -> 'a t
+  [@@ocaml.deprecated "Use Lazy.from_fun instead."]
+(** @deprecated synonym for [from_fun]. *)
+
+val lazy_from_val : 'a -> 'a t
+  [@@ocaml.deprecated "Use Lazy.from_val instead."]
+(** @deprecated synonym for [from_val]. *)
+
+val lazy_is_val : 'a t -> bool
+  [@@ocaml.deprecated "Use Lazy.is_val instead."]
+(** @deprecated synonym for [is_val]. *)
diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
new file mode 100644
index 00000000..2c2633d4
--- /dev/null
+++ b/stdlib/lexing.ml
@@ -0,0 +1,231 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The run-time library for lexers generated by camllex *)
+
+type position = {
+  pos_fname : string;
+  pos_lnum : int;
+  pos_bol : int;
+  pos_cnum : int;
+}
+
+let dummy_pos = {
+  pos_fname = "";
+  pos_lnum = 0;
+  pos_bol = 0;
+  pos_cnum = -1;
+}
+
+type lexbuf =
+  { refill_buff : lexbuf -> unit;
+    mutable lex_buffer : bytes;
+    mutable lex_buffer_len : int;
+    mutable lex_abs_pos : int;
+    mutable lex_start_pos : int;
+    mutable lex_curr_pos : int;
+    mutable lex_last_pos : int;
+    mutable lex_last_action : int;
+    mutable lex_eof_reached : bool;
+    mutable lex_mem : int array;
+    mutable lex_start_p : position;
+    mutable lex_curr_p : position;
+  }
+
+type lex_tables =
+  { lex_base: string;
+    lex_backtrk: string;
+    lex_default: string;
+    lex_trans: string;
+    lex_check: string;
+    lex_base_code : string;
+    lex_backtrk_code : string;
+    lex_default_code : string;
+    lex_trans_code : string;
+    lex_check_code : string;
+    lex_code: string;}
+
+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
+  if result >= 0 then begin
+    buf.lex_start_p <- buf.lex_curr_p;
+    buf.lex_curr_p <- {buf.lex_curr_p
+                       with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
+  end;
+  result
+
+
+let new_engine tbl state buf =
+  let result = c_new_engine tbl state buf in
+  if result >= 0 then begin
+    buf.lex_start_p <- buf.lex_curr_p;
+    buf.lex_curr_p <- {buf.lex_curr_p
+                       with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
+  end;
+  result
+
+
+let lex_refill read_fun aux_buffer lexbuf =
+  let read =
+    read_fun aux_buffer (Bytes.length aux_buffer) in
+  let n =
+    if read > 0
+    then read
+    else (lexbuf.lex_eof_reached <- true; 0) in
+  (* Current state of the buffer:
+        <-------|---------------------|----------->
+        |  junk |      valid data     |   junk    |
+        ^       ^                     ^           ^
+        0    start_pos             buffer_end    Bytes.length buffer
+  *)
+  if lexbuf.lex_buffer_len + n > Bytes.length lexbuf.lex_buffer then begin
+    (* There is not enough space at the end of the buffer *)
+    if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n
+       <= Bytes.length lexbuf.lex_buffer
+    then begin
+      (* But there is enough space if we reclaim the junk at the beginning
+         of the buffer *)
+      Bytes.blit lexbuf.lex_buffer lexbuf.lex_start_pos
+                  lexbuf.lex_buffer 0
+                  (lexbuf.lex_buffer_len - lexbuf.lex_start_pos)
+    end else begin
+      (* We must grow the buffer.  Doubling its size will provide enough
+         space since n <= String.length aux_buffer <= String.length buffer.
+         Watch out for string length overflow, though. *)
+      let newlen =
+        min (2 * Bytes.length lexbuf.lex_buffer) Sys.max_string_length in
+      if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen
+      then failwith "Lexing.lex_refill: cannot grow buffer";
+      let newbuf = Bytes.create newlen in
+      (* Copy the valid data to the beginning of the new buffer *)
+      Bytes.blit lexbuf.lex_buffer lexbuf.lex_start_pos
+                  newbuf 0
+                  (lexbuf.lex_buffer_len - lexbuf.lex_start_pos);
+      lexbuf.lex_buffer <- newbuf
+    end;
+    (* Reallocation or not, we have shifted the data left by
+       start_pos characters; update the positions *)
+    let s = lexbuf.lex_start_pos in
+    lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos + s;
+    lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - s;
+    lexbuf.lex_start_pos <- 0;
+    lexbuf.lex_last_pos <- lexbuf.lex_last_pos - s;
+    lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len - s ;
+    let t = lexbuf.lex_mem in
+    for i = 0 to Array.length t-1 do
+      let v = t.(i) in
+      if v >= 0 then
+        t.(i) <- v-s
+    done
+  end;
+  (* There is now enough space at the end of the buffer *)
+  Bytes.blit aux_buffer 0 lexbuf.lex_buffer lexbuf.lex_buffer_len n;
+  lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len + n
+
+let zero_pos = {
+  pos_fname = "";
+  pos_lnum = 1;
+  pos_bol = 0;
+  pos_cnum = 0;
+}
+
+let from_function f =
+  { refill_buff = lex_refill f (Bytes.create 512);
+    lex_buffer = Bytes.create 1024;
+    lex_buffer_len = 0;
+    lex_abs_pos = 0;
+    lex_start_pos = 0;
+    lex_curr_pos = 0;
+    lex_last_pos = 0;
+    lex_last_action = 0;
+    lex_mem = [||];
+    lex_eof_reached = false;
+    lex_start_p = zero_pos;
+    lex_curr_p = zero_pos;
+  }
+
+let from_channel ic =
+  from_function (fun buf n -> input ic buf 0 n)
+
+let from_string s =
+  { refill_buff = (fun lexbuf -> lexbuf.lex_eof_reached <- true);
+    lex_buffer = Bytes.of_string s; (* have to make a copy for compatibility
+                                       with unsafe-string mode *)
+    lex_buffer_len = String.length s;
+    lex_abs_pos = 0;
+    lex_start_pos = 0;
+    lex_curr_pos = 0;
+    lex_last_pos = 0;
+    lex_last_action = 0;
+    lex_mem = [||];
+    lex_eof_reached = true;
+    lex_start_p = zero_pos;
+    lex_curr_p = zero_pos;
+  }
+
+let lexeme lexbuf =
+  let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in
+  Bytes.sub_string lexbuf.lex_buffer lexbuf.lex_start_pos len
+
+let sub_lexeme lexbuf i1 i2 =
+  let len = i2-i1 in
+  Bytes.sub_string lexbuf.lex_buffer i1 len
+
+let sub_lexeme_opt lexbuf i1 i2 =
+  if i1 >= 0 then begin
+    let len = i2-i1 in
+    Some (Bytes.sub_string lexbuf.lex_buffer i1 len)
+  end else begin
+    None
+  end
+
+let sub_lexeme_char lexbuf i = Bytes.get lexbuf.lex_buffer i
+
+let sub_lexeme_char_opt lexbuf i =
+  if i >= 0 then
+    Some (Bytes.get lexbuf.lex_buffer i)
+  else
+    None
+
+
+let lexeme_char lexbuf i =
+  Bytes.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i)
+
+let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum
+let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum
+
+let lexeme_start_p lexbuf = lexbuf.lex_start_p
+let lexeme_end_p lexbuf = lexbuf.lex_curr_p
+
+let new_line lexbuf =
+  let lcp = lexbuf.lex_curr_p in
+  lexbuf.lex_curr_p <- { lcp with
+    pos_lnum = lcp.pos_lnum + 1;
+    pos_bol = lcp.pos_cnum;
+  }
+
+
+
+(* Discard data left in lexer buffer. *)
+
+let flush_input lb =
+  lb.lex_curr_pos <- 0;
+  lb.lex_abs_pos <- 0;
+  lb.lex_curr_p <- {lb.lex_curr_p with pos_cnum = 0};
+  lb.lex_buffer_len <- 0;
diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
new file mode 100644
index 00000000..31f15ce8
--- /dev/null
+++ b/stdlib/lexing.mli
@@ -0,0 +1,176 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The run-time library for lexers generated by [ocamllex]. *)
+
+(** {6 Positions} *)
+
+type position = {
+  pos_fname : string;
+  pos_lnum : int;
+  pos_bol : int;
+  pos_cnum : int;
+}
+(** A value of type [position] describes a point in a source file.
+   [pos_fname] is the file name; [pos_lnum] is the line number;
+   [pos_bol] is the offset of the beginning of the line (number
+   of characters between the beginning of the lexbuf and the beginning
+   of the line); [pos_cnum] is the offset of the position (number of
+   characters between the beginning of the lexbuf and the position).
+   The difference between [pos_cnum] and [pos_bol] is the character
+   offset within the line (i.e. the column number, assuming each
+   character is one column wide).
+
+   See the documentation of type [lexbuf] for information about
+   how the lexing engine will manage positions.
+ *)
+
+val dummy_pos : position
+(** A value of type [position], guaranteed to be different from any
+   valid position.
+ *)
+
+
+(** {6 Lexer buffers} *)
+
+
+type lexbuf =
+  { refill_buff : lexbuf -> unit;
+    mutable lex_buffer : bytes;
+    mutable lex_buffer_len : int;
+    mutable lex_abs_pos : int;
+    mutable lex_start_pos : int;
+    mutable lex_curr_pos : int;
+    mutable lex_last_pos : int;
+    mutable lex_last_action : int;
+    mutable lex_eof_reached : bool;
+    mutable lex_mem : int array;
+    mutable lex_start_p : position;
+    mutable lex_curr_p : position;
+  }
+(** The type of lexer buffers. A lexer buffer is the argument passed
+   to the scanning functions defined by the generated scanners.
+   The lexer buffer holds the current state of the scanner, plus
+   a function to refill the buffer from the input.
+
+   At each token, the lexing engine will copy [lex_curr_p] to
+   [lex_start_p], then change the [pos_cnum] field
+   of [lex_curr_p] by updating it with the number of characters read
+   since the start of the [lexbuf].  The other fields are left
+   unchanged by the lexing engine.  In order to keep them
+   accurate, they must be initialised before the first use of the
+   lexbuf, and updated by the relevant lexer actions (i.e. at each
+   end of line -- see also [new_line]).
+ *)
+
+val from_channel : in_channel -> lexbuf
+(** Create a lexer buffer on the given input channel.
+   [Lexing.from_channel inchan] returns a lexer buffer which reads
+   from the input channel [inchan], at the current reading position. *)
+
+val from_string : string -> lexbuf
+(** Create a lexer buffer which reads from
+   the given string. Reading starts from the first character in
+   the string. An end-of-input condition is generated when the
+   end of the string is reached. *)
+
+val from_function : (bytes -> int -> int) -> lexbuf
+(** Create a lexer buffer with the given function as its reading method.
+   When the scanner needs more characters, it will call the given
+   function, giving it a byte sequence [s] and a byte
+   count [n]. The function should put [n] bytes or fewer in [s],
+   starting at index 0, and return the number of bytes
+   provided. A return value of 0 means end of input. *)
+
+
+(** {6 Functions for lexer semantic actions} *)
+
+
+(** The following functions can be called from the semantic actions
+   of lexer definitions (the ML code enclosed in braces that
+   computes the value returned by lexing functions). They give
+   access to the character string matched by the regular expression
+   associated with the semantic action. These functions must be
+   applied to the argument [lexbuf], which, in the code generated by
+   [ocamllex], is bound to the lexer buffer passed to the parsing
+   function. *)
+
+val lexeme : lexbuf -> string
+(** [Lexing.lexeme lexbuf] returns the string matched by
+           the regular expression. *)
+
+val lexeme_char : lexbuf -> int -> char
+(** [Lexing.lexeme_char lexbuf i] returns character number [i] in
+   the matched string. *)
+
+val lexeme_start : lexbuf -> int
+(** [Lexing.lexeme_start lexbuf] returns the offset in the
+   input stream of the first character of the matched string.
+   The first character of the stream has offset 0. *)
+
+val lexeme_end : lexbuf -> int
+(** [Lexing.lexeme_end lexbuf] returns the offset in the input stream
+   of the character following the last character of the matched
+   string. The first character of the stream has offset 0. *)
+
+val lexeme_start_p : lexbuf -> position
+(** Like [lexeme_start], but return a complete [position] instead
+    of an offset. *)
+
+val lexeme_end_p : lexbuf -> position
+(** Like [lexeme_end], but return a complete [position] instead
+    of an offset. *)
+
+val new_line : lexbuf -> unit
+(** Update the [lex_curr_p] field of the lexbuf to reflect the start
+    of a new line.  You can call this function in the semantic action
+    of the rule that matches the end-of-line character.
+    @since 3.11.0
+*)
+
+(** {6 Miscellaneous functions} *)
+
+val flush_input : lexbuf -> unit
+(** Discard the contents of the buffer and reset the current
+    position to 0.  The next use of the lexbuf will trigger a
+    refill. *)
+
+(**/**)
+
+(** {6  } *)
+
+(** The following definitions are used by the generated scanners only.
+   They are not intended to be used directly by user programs. *)
+
+val sub_lexeme : lexbuf -> int -> int -> string
+val sub_lexeme_opt : lexbuf -> int -> int -> string option
+val sub_lexeme_char : lexbuf -> int -> char
+val sub_lexeme_char_opt : lexbuf -> int -> char option
+
+type lex_tables =
+  { lex_base : string;
+    lex_backtrk : string;
+    lex_default : string;
+    lex_trans : string;
+    lex_check : string;
+    lex_base_code : string;
+    lex_backtrk_code : string;
+    lex_default_code : string;
+    lex_trans_code : string;
+    lex_check_code : string;
+    lex_code: string;}
+
+val engine : lex_tables -> int -> lexbuf -> int
+val new_engine : lex_tables -> int -> lexbuf -> int
diff --git a/stdlib/list.ml b/stdlib/list.ml
new file mode 100644
index 00000000..73b7d834
--- /dev/null
+++ b/stdlib/list.ml
@@ -0,0 +1,468 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* List operations *)
+
+let rec length_aux len = function
+    [] -> len
+  | _::l -> length_aux (len + 1) l
+
+let length l = length_aux 0 l
+
+let cons a l = a::l
+
+let hd = function
+    [] -> failwith "hd"
+  | a::_ -> a
+
+let tl = function
+    [] -> failwith "tl"
+  | _::l -> l
+
+let nth l n =
+  if n < 0 then invalid_arg "List.nth" else
+  let rec nth_aux l n =
+    match l with
+    | [] -> failwith "nth"
+    | a::l -> if n = 0 then a else nth_aux l (n-1)
+  in nth_aux l n
+
+let nth_opt l n =
+  if n < 0 then invalid_arg "List.nth" else
+  let rec nth_aux l n =
+    match l with
+    | [] -> None
+    | a::l -> if n = 0 then Some a else nth_aux l (n-1)
+  in nth_aux l n
+
+let append = (@)
+
+let rec rev_append l1 l2 =
+  match l1 with
+    [] -> l2
+  | a :: l -> rev_append l (a :: l2)
+
+let rev l = rev_append l []
+
+let rec flatten = function
+    [] -> []
+  | l::r -> l @ flatten r
+
+let concat = flatten
+
+let rec map f = function
+    [] -> []
+  | a::l -> let r = f a in r :: map f l
+
+let rec mapi i f = function
+    [] -> []
+  | a::l -> let r = f i a in r :: mapi (i + 1) f l
+
+let mapi f l = mapi 0 f l
+
+let rev_map f l =
+  let rec rmap_f accu = function
+    | [] -> accu
+    | a::l -> rmap_f (f a :: accu) l
+  in
+  rmap_f [] l
+
+
+let rec iter f = function
+    [] -> ()
+  | a::l -> f a; iter f l
+
+let rec iteri i f = function
+    [] -> ()
+  | a::l -> f i a; iteri (i + 1) f l
+
+let iteri f l = iteri 0 f l
+
+let rec fold_left f accu l =
+  match l with
+    [] -> accu
+  | a::l -> fold_left f (f accu a) l
+
+let rec fold_right f l accu =
+  match l with
+    [] -> accu
+  | a::l -> f a (fold_right f l accu)
+
+let rec map2 f l1 l2 =
+  match (l1, l2) with
+    ([], []) -> []
+  | (a1::l1, a2::l2) -> let r = f a1 a2 in r :: map2 f l1 l2
+  | (_, _) -> invalid_arg "List.map2"
+
+let rev_map2 f l1 l2 =
+  let rec rmap2_f accu l1 l2 =
+    match (l1, l2) with
+    | ([], []) -> accu
+    | (a1::l1, a2::l2) -> rmap2_f (f a1 a2 :: accu) l1 l2
+    | (_, _) -> invalid_arg "List.rev_map2"
+  in
+  rmap2_f [] l1 l2
+
+
+let rec iter2 f l1 l2 =
+  match (l1, l2) with
+    ([], []) -> ()
+  | (a1::l1, a2::l2) -> f a1 a2; iter2 f l1 l2
+  | (_, _) -> invalid_arg "List.iter2"
+
+let rec fold_left2 f accu l1 l2 =
+  match (l1, l2) with
+    ([], []) -> accu
+  | (a1::l1, a2::l2) -> fold_left2 f (f accu a1 a2) l1 l2
+  | (_, _) -> invalid_arg "List.fold_left2"
+
+let rec fold_right2 f l1 l2 accu =
+  match (l1, l2) with
+    ([], []) -> accu
+  | (a1::l1, a2::l2) -> f a1 a2 (fold_right2 f l1 l2 accu)
+  | (_, _) -> invalid_arg "List.fold_right2"
+
+let rec for_all p = function
+    [] -> true
+  | a::l -> p a && for_all p l
+
+let rec exists p = function
+    [] -> false
+  | a::l -> p a || exists p l
+
+let rec for_all2 p l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (a1::l1, a2::l2) -> p a1 a2 && for_all2 p l1 l2
+  | (_, _) -> invalid_arg "List.for_all2"
+
+let rec exists2 p l1 l2 =
+  match (l1, l2) with
+    ([], []) -> false
+  | (a1::l1, a2::l2) -> p a1 a2 || exists2 p l1 l2
+  | (_, _) -> invalid_arg "List.exists2"
+
+let rec mem x = function
+    [] -> false
+  | a::l -> compare a x = 0 || mem x l
+
+let rec memq x = function
+    [] -> false
+  | a::l -> a == x || memq x l
+
+let rec assoc x = function
+    [] -> raise Not_found
+  | (a,b)::l -> if compare a x = 0 then b else assoc x l
+
+let rec assoc_opt x = function
+    [] -> None
+  | (a,b)::l -> if compare a x = 0 then Some b else assoc_opt x l
+
+let rec assq x = function
+    [] -> raise Not_found
+  | (a,b)::l -> if a == x then b else assq x l
+
+let rec assq_opt x = function
+    [] -> None
+  | (a,b)::l -> if a == x then Some b else assq_opt x l
+
+let rec mem_assoc x = function
+  | [] -> false
+  | (a, _) :: l -> compare a x = 0 || mem_assoc x l
+
+let rec mem_assq x = function
+  | [] -> false
+  | (a, _) :: l -> a == x || mem_assq x l
+
+let rec remove_assoc x = function
+  | [] -> []
+  | (a, _ as pair) :: l ->
+      if compare a x = 0 then l else pair :: remove_assoc x l
+
+let rec remove_assq x = function
+  | [] -> []
+  | (a, _ as pair) :: l -> if a == x then l else pair :: remove_assq x l
+
+let rec find p = function
+  | [] -> raise Not_found
+  | x :: l -> if p x then x else find p l
+
+let rec find_opt p = function
+  | [] -> None
+  | x :: l -> if p x then Some x else find_opt p l
+
+let find_all p =
+  let rec find accu = function
+  | [] -> rev accu
+  | x :: l -> if p x then find (x :: accu) l else find accu l in
+  find []
+
+let filter = find_all
+
+let partition p l =
+  let rec part yes no = function
+  | [] -> (rev yes, rev no)
+  | x :: l -> if p x then part (x :: yes) no l else part yes (x :: no) l in
+  part [] [] l
+
+let rec split = function
+    [] -> ([], [])
+  | (x,y)::l ->
+      let (rx, ry) = split l in (x::rx, y::ry)
+
+let rec combine l1 l2 =
+  match (l1, l2) with
+    ([], []) -> []
+  | (a1::l1, a2::l2) -> (a1, a2) :: combine l1 l2
+  | (_, _) -> invalid_arg "List.combine"
+
+(** sorting *)
+
+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 rec chop k l =
+  if k = 0 then l else begin
+    match l with
+    | _::t -> chop (k-1) t
+    | _ -> assert false
+  end
+
+
+let stable_sort cmp l =
+  let rec rev_merge l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> rev_append l2 accu
+    | l1, [] -> rev_append 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 -> rev_append l2 accu
+    | l1, [] -> rev_append 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 = length l in
+  if len < 2 then l else sort len l
+
+
+let sort = stable_sort
+let fast_sort = stable_sort
+
+(* Note: on a list of length between about 100000 (depending on the minor
+   heap size and the type of the list) and Sys.max_array_size, it is
+   actually faster to use the following, but it might also use more memory
+   because the argument list cannot be deallocated incrementally.
+
+   Also, there seems to be a bug in this code or in the
+   implementation of 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
+  let rec loop accu n p =
+    if p <= 0 then accu else begin
+      if p = n then begin
+        obj_truncate 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-1000) l
+
+
+let stable_sort cmp l =
+  let a = Array.of_list l in
+  Array.stable_sort cmp a;
+  array_to_list_in_place a
+
+*)
+
+
+(** sorting + removing duplicates *)
+
+let sort_uniq cmp l =
+  let rec rev_merge l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> rev_append l2 accu
+    | l1, [] -> rev_append l1 accu
+    | h1::t1, h2::t2 ->
+        let c = cmp h1 h2 in
+        if c = 0 then rev_merge t1 t2 (h1::accu)
+        else if c < 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 -> rev_append l2 accu
+    | l1, [] -> rev_append l1 accu
+    | h1::t1, h2::t2 ->
+        let c = cmp h1 h2 in
+        if c = 0 then rev_merge_rev t1 t2 (h1::accu)
+        else if c > 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 :: _ ->
+       let c = cmp x1 x2 in
+       if c = 0 then [x1]
+       else if c < 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       let c = cmp x1 x2 in
+       if c = 0 then begin
+         let c = cmp x2 x3 in
+         if c = 0 then [x2]
+         else if c < 0 then [x2; x3] else [x3; x2]
+       end else if c < 0 then begin
+         let c = cmp x2 x3 in
+         if c = 0 then [x1; x2]
+         else if c < 0 then [x1; x2; x3]
+         else let c = cmp x1 x3 in
+         if c = 0 then [x1; x2]
+         else if c < 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         let c = cmp x1 x3 in
+         if c = 0 then [x2; x1]
+         else if c < 0 then [x2; x1; x3]
+         else let c = cmp x2 x3 in
+         if c = 0 then [x2; x1]
+         else if c < 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 :: _ ->
+       let c = cmp x1 x2 in
+       if c = 0 then [x1]
+       else if c > 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       let c = cmp x1 x2 in
+       if c = 0 then begin
+         let c = cmp x2 x3 in
+         if c = 0 then [x2]
+         else if c > 0 then [x2; x3] else [x3; x2]
+       end else if c > 0 then begin
+         let c = cmp x2 x3 in
+         if c = 0 then [x1; x2]
+         else if c > 0 then [x1; x2; x3]
+         else let c = cmp x1 x3 in
+         if c = 0 then [x1; x2]
+         else if c > 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         let c = cmp x1 x3 in
+         if c = 0 then [x2; x1]
+         else if c > 0 then [x2; x1; x3]
+         else let c = cmp x2 x3 in
+         if c = 0 then [x2; x1]
+         else if c > 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 = length l in
+  if len < 2 then l else sort len l
+
+let rec compare_lengths l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _ -> -1
+  | _, [] -> 1
+  | _ :: l1, _ :: l2 -> compare_lengths l1 l2
+;;
+
+let rec compare_length_with l n =
+  match l, n with
+  | [], 0 -> 0
+  | [], _ -> if n > 0 then -1 else 1
+  | _, 0 -> 1
+  | _ :: l, n -> compare_length_with l (n-1)
+;;
diff --git a/stdlib/list.mli b/stdlib/list.mli
new file mode 100644
index 00000000..e8d6d392
--- /dev/null
+++ b/stdlib/list.mli
@@ -0,0 +1,340 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** List operations.
+
+   Some functions are flagged as not tail-recursive.  A tail-recursive
+   function uses constant stack space, while a non-tail-recursive function
+   uses stack space proportional to the length of its list argument, which
+   can be a problem with very long lists.  When the function takes several
+   list arguments, an approximate formula giving stack usage (in some
+   unspecified constant unit) is shown in parentheses.
+
+   The above considerations can usually be ignored if your lists are not
+   longer than about 10000 elements.
+*)
+
+val length : 'a list -> int
+(** Return the length (number of elements) of the given list. *)
+
+val compare_lengths : 'a list -> 'b list -> int
+(** Compare the lengths of two lists. [compare_lengths l1 l2] is
+   equivalent to [compare (length l1) (length l2)], except that
+   the computation stops after itering on the shortest list.
+   @since 4.05.0
+ *)
+
+val compare_length_with : 'a list -> int -> int
+(** Compare the length of a list to an integer. [compare_length_with l n] is
+   equivalent to [compare (length l) n], except that
+   the computation stops after at most [n] iterations on the list.
+   @since 4.05.0
+*)
+
+val cons : 'a -> 'a list -> 'a list
+(** [cons x xs] is [x :: xs]
+    @since 4.03.0
+*)
+
+val hd : 'a list -> 'a
+(** Return the first element of the given list. Raise
+   [Failure "hd"] if the list is empty. *)
+
+val tl : 'a list -> 'a list
+(** Return the given list without its first element. Raise
+    [Failure "tl"] if the list is empty. *)
+
+val nth: 'a list -> int -> 'a
+(** Return the [n]-th element of the given list.
+   The first element (head of the list) is at position 0.
+   Raise [Failure "nth"] if the list is too short.
+   Raise [Invalid_argument "List.nth"] if [n] is negative. *)
+
+val nth_opt: 'a list -> int -> 'a option
+(** Return the [n]-th element of the given list.
+    The first element (head of the list) is at position 0.
+    Return [None] if the list is too short.
+    Raise [Invalid_argument "List.nth"] if [n] is negative.
+    @since 4.05
+*)
+
+val rev : 'a list -> 'a list
+(** List reversal. *)
+
+val append : 'a list -> 'a list -> 'a list
+(** Concatenate two lists.  Same as the infix operator [@].
+   Not tail-recursive (length of the first argument).  *)
+
+val rev_append : 'a list -> 'a list -> 'a list
+(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
+   This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
+   tail-recursive and more efficient. *)
+
+val concat : 'a list list -> 'a list
+(** Concatenate a list of lists.  The elements of the argument are all
+   concatenated together (in the same order) to give the result.
+   Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+val flatten : 'a list list -> 'a list
+(** An alias for [concat]. *)
+
+
+(** {6 Iterators} *)
+
+
+val iter : ('a -> unit) -> 'a list -> unit
+(** [List.iter f [a1; ...; an]] applies function [f] in turn to
+   [a1; ...; an]. It is equivalent to
+   [begin f a1; f a2; ...; f an; () end]. *)
+
+val iteri : (int -> 'a -> unit) -> 'a list -> unit
+(** Same as {!List.iter}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
+val map : ('a -> 'b) -> 'a list -> 'b list
+(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+   and builds the list [[f a1; ...; f an]]
+   with the results returned by [f].  Not tail-recursive. *)
+
+val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+(** Same as {!List.map}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.  Not tail-recursive.
+   @since 4.00.0
+*)
+
+val rev_map : ('a -> 'b) -> 'a list -> 'b list
+(** [List.rev_map f l] gives the same result as
+   {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+(** [List.fold_left f a [b1; ...; bn]] is
+   [f (... (f (f a b1) b2) ...) bn]. *)
+
+val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+(** [List.fold_right f [a1; ...; an] b] is
+   [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
+
+
+(** {6 Iterators on two lists} *)
+
+
+val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
+   [f a1 b1; ...; f an bn].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
+   [[f a1 b1; ...; f an bn]].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths.  Not tail-recursive. *)
+
+val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.rev_map2 f l1 l2] gives the same result as
+   {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
+   [f (... (f (f a b1 c1) b2 c2) ...) bn cn].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
+   [f a1 b1 (f a2 b2 (... (f an bn c) ...))].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths.  Not tail-recursive. *)
+
+
+(** {6 List scanning} *)
+
+
+val for_all : ('a -> bool) -> 'a list -> bool
+(** [for_all p [a1; ...; an]] checks if all elements of the list
+   satisfy the predicate [p]. That is, it returns
+   [(p a1) && (p a2) && ... && (p an)]. *)
+
+val exists : ('a -> bool) -> 'a list -> bool
+(** [exists p [a1; ...; an]] checks if at least one element of
+   the list satisfies the predicate [p]. That is, it returns
+   [(p a1) || (p a2) || ... || (p an)]. *)
+
+val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!List.for_all}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!List.exists}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val mem : 'a -> 'a list -> bool
+(** [mem a l] is true if and only if [a] is equal
+   to an element of [l]. *)
+
+val memq : 'a -> 'a list -> bool
+(** Same as {!List.mem}, but uses physical equality instead of structural
+   equality to compare list elements. *)
+
+
+(** {6 List searching} *)
+
+
+val find : ('a -> bool) -> 'a list -> 'a
+(** [find p l] returns the first element of the list [l]
+   that satisfies the predicate [p].
+   Raise [Not_found] if there is no value that satisfies [p] in the
+   list [l]. *)
+
+val find_opt: ('a -> bool) -> 'a list -> 'a option
+(** [find_opt p l] returns the first element of the list [l] that
+    satisfies the predicate [p], or [None] if there is no value that
+    satisfies [p] in the list [l].
+    @since 4.05 *)
+
+val filter : ('a -> bool) -> 'a list -> 'a list
+(** [filter p l] returns all the elements of the list [l]
+   that satisfy the predicate [p].  The order of the elements
+   in the input list is preserved.  *)
+
+val find_all : ('a -> bool) -> 'a list -> 'a list
+(** [find_all] is another name for {!List.filter}. *)
+
+val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+(** [partition p l] returns a pair of lists [(l1, l2)], where
+   [l1] is the list of all the elements of [l] that
+   satisfy the predicate [p], and [l2] is the list of all the
+   elements of [l] that do not satisfy [p].
+   The order of the elements in the input list is preserved. *)
+
+
+(** {6 Association lists} *)
+
+
+val assoc : 'a -> ('a * 'b) list -> 'b
+(** [assoc a l] returns the value associated with key [a] in the list of
+   pairs [l]. That is,
+   [assoc a [ ...; (a,b); ...] = b]
+   if [(a,b)] is the leftmost binding of [a] in list [l].
+   Raise [Not_found] if there is no value associated with [a] in the
+   list [l]. *)
+
+val assoc_opt: 'a -> ('a * 'b) list -> 'b option
+(** [assoc_opt a l] returns the value associated with key [a] in the list of
+   pairs [l]. That is,
+   [assoc_opt a [ ...; (a,b); ...] = b]
+   if [(a,b)] is the leftmost binding of [a] in list [l].
+   Returns [None] if there is no value associated with [a] in the
+   list [l].
+   @since 4.05 *)
+
+val assq : 'a -> ('a * 'b) list -> 'b
+(** Same as {!List.assoc}, but uses physical equality instead of structural
+   equality to compare keys. *)
+
+val assq_opt : 'a -> ('a * 'b) list -> 'b option
+(** Same as {!List.assoc_opt}, but uses physical equality instead of structural
+    equality to compare keys.
+    @since 4.05 *)
+
+val mem_assoc : 'a -> ('a * 'b) list -> bool
+(** Same as {!List.assoc}, but simply return true if a binding exists,
+   and false if no bindings exist for the given key. *)
+
+val mem_assq : 'a -> ('a * 'b) list -> bool
+(** Same as {!List.mem_assoc}, but uses physical equality instead of
+   structural equality to compare keys. *)
+
+val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** [remove_assoc a l] returns the list of
+   pairs [l] without the first pair with key [a], if any.
+   Not tail-recursive. *)
+
+val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** Same as {!List.remove_assoc}, but uses physical equality instead
+   of structural equality to compare keys.  Not tail-recursive. *)
+
+
+(** {6 Lists of pairs} *)
+
+
+val split : ('a * 'b) list -> 'a list * 'b list
+(** Transform a list of pairs into a pair of lists:
+   [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
+   Not tail-recursive.
+*)
+
+val combine : 'a list -> 'b list -> ('a * 'b) list
+(** Transform a pair of lists into a list of pairs:
+   [combine [a1; ...; an] [b1; ...; bn]] is
+   [[(a1,b1); ...; (an,bn)]].
+   Raise [Invalid_argument] if the two lists
+   have different lengths.  Not tail-recursive. *)
+
+
+(** {6 Sorting} *)
+
+
+val sort : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Sort a list in increasing order according to a comparison
+   function.  The comparison function must return 0 if its arguments
+   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.
+   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
+   stack space.
+
+   The current implementation uses Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
+
+val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort}, but the sorting algorithm is guaranteed to
+   be stable (i.e. elements that compare equal are kept in their
+   original order) .
+
+   The current implementation uses Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
+
+val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster
+    on typical input. *)
+
+val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort}, but also remove duplicates.
+    @since 4.02.0 *)
+
+val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+(** Merge two lists:
+    Assuming that [l1] and [l2] are sorted according to the
+    comparison function [cmp], [merge cmp l1 l2] will return a
+    sorted list containting all the elements of [l1] and [l2].
+    If several elements compare equal, the elements of [l1] will be
+    before the elements of [l2].
+    Not tail-recursive (sum of the lengths of the arguments).
+*)
diff --git a/stdlib/listLabels.ml b/stdlib/listLabels.ml
new file mode 100644
index 00000000..d782261b
--- /dev/null
+++ b/stdlib/listLabels.ml
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [ListLabels]: labelled List module *)
+
+include List
diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
new file mode 100644
index 00000000..52ded3f9
--- /dev/null
+++ b/stdlib/listLabels.mli
@@ -0,0 +1,346 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** List operations.
+
+   Some functions are flagged as not tail-recursive.  A tail-recursive
+   function uses constant stack space, while a non-tail-recursive function
+   uses stack space proportional to the length of its list argument, which
+   can be a problem with very long lists.  When the function takes several
+   list arguments, an approximate formula giving stack usage (in some
+   unspecified constant unit) is shown in parentheses.
+
+   The above considerations can usually be ignored if your lists are not
+   longer than about 10000 elements.
+*)
+
+val length : 'a list -> int
+(** Return the length (number of elements) of the given list. *)
+
+val hd : 'a list -> 'a
+(** Return the first element of the given list. Raise
+   [Failure "hd"] if the list is empty. *)
+
+val compare_lengths : 'a list -> 'b list -> int
+(** Compare the lengths of two lists. [compare_lengths l1 l2] is
+   equivalent to [compare (length l1) (length l2)], except that
+   the computation stops after itering on the shortest list.
+   @since 4.05.0
+ *)
+
+val compare_length_with : 'a list -> len:int -> int
+(** Compare the length of a list to an integer. [compare_length_with l n] is
+   equivalent to [compare (length l) n], except that
+   the computation stops after at most [n] iterations on the list.
+   @since 4.05.0
+*)
+
+val cons : 'a -> 'a list -> 'a list
+(** [cons x xs] is [x :: xs]
+    @since 4.05.0
+*)
+
+val tl : 'a list -> 'a list
+(** Return the given list without its first element. Raise
+   [Failure "tl"] if the list is empty. *)
+
+val nth : 'a list -> int -> 'a
+(** Return the [n]-th element of the given list.
+   The first element (head of the list) is at position 0.
+   Raise [Failure "nth"] if the list is too short.
+   Raise [Invalid_argument "List.nth"] if [n] is negative. *)
+
+val nth_opt: 'a list -> int -> 'a option
+(** Return the [n]-th element of the given list.
+    The first element (head of the list) is at position 0.
+    Return [None] if the list is too short.
+    Raise [Invalid_argument "List.nth"] if [n] is negative.
+    @since 4.05
+*)
+
+val rev : 'a list -> 'a list
+(** List reversal. *)
+
+val append : 'a list -> 'a list -> 'a list
+(** Catenate two lists.  Same function as the infix operator [@].
+   Not tail-recursive (length of the first argument).  The [@]
+   operator is not tail-recursive either. *)
+
+val rev_append : 'a list -> 'a list -> 'a list
+(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
+   This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
+   tail-recursive and more efficient. *)
+
+val concat : 'a list list -> 'a list
+(** Concatenate a list of lists.  The elements of the argument are all
+   concatenated together (in the same order) to give the result.
+   Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+val flatten : 'a list list -> 'a list
+(** Same as [concat].  Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+
+(** {6 Iterators} *)
+
+
+val iter : f:('a -> unit) -> 'a list -> unit
+(** [List.iter f [a1; ...; an]] applies function [f] in turn to
+   [a1; ...; an]. It is equivalent to
+   [begin f a1; f a2; ...; f an; () end]. *)
+
+val iteri : f:(int -> 'a -> unit) -> 'a list -> unit
+(** Same as {!List.iter}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
+val map : f:('a -> 'b) -> 'a list -> 'b list
+(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+   and builds the list [[f a1; ...; f an]]
+   with the results returned by [f].  Not tail-recursive. *)
+
+val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list
+(** Same as {!List.map}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
+val rev_map : f:('a -> 'b) -> 'a list -> 'b list
+(** [List.rev_map f l] gives the same result as
+   {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a
+(** [List.fold_left f a [b1; ...; bn]] is
+   [f (... (f (f a b1) b2) ...) bn]. *)
+
+val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
+(** [List.fold_right f [a1; ...; an] b] is
+   [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
+
+
+(** {6 Iterators on two lists} *)
+
+
+val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
+   [f a1 b1; ...; f an bn].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
+   [[f a1 b1; ...; f an bn]].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths.  Not tail-recursive. *)
+
+val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.rev_map2 f l1 l2] gives the same result as
+   {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left2 :
+  f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a
+(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
+   [f (... (f (f a b1 c1) b2 c2) ...) bn cn].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val fold_right2 :
+  f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c
+(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
+   [f a1 b1 (f a2 b2 (... (f an bn c) ...))].
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths.  Not tail-recursive. *)
+
+
+(** {6 List scanning} *)
+
+
+val for_all : f:('a -> bool) -> 'a list -> bool
+(** [for_all p [a1; ...; an]] checks if all elements of the list
+   satisfy the predicate [p]. That is, it returns
+   [(p a1) && (p a2) && ... && (p an)]. *)
+
+val exists : f:('a -> bool) -> 'a list -> bool
+(** [exists p [a1; ...; an]] checks if at least one element of
+   the list satisfies the predicate [p]. That is, it returns
+   [(p a1) || (p a2) || ... || (p an)]. *)
+
+val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!List.for_all}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!List.exists}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists are determined
+   to have different lengths. *)
+
+val mem : 'a -> set:'a list -> bool
+(** [mem a l] is true if and only if [a] is equal
+   to an element of [l]. *)
+
+val memq : 'a -> set:'a list -> bool
+(** Same as {!List.mem}, but uses physical equality instead of structural
+   equality to compare list elements. *)
+
+
+(** {6 List searching} *)
+
+
+val find : f:('a -> bool) -> 'a list -> 'a
+(** [find p l] returns the first element of the list [l]
+   that satisfies the predicate [p].
+   Raise [Not_found] if there is no value that satisfies [p] in the
+   list [l]. *)
+
+val find_opt: f:('a -> bool) -> 'a list -> 'a option
+(** [find p l] returns the first element of the list [l]
+   that satisfies the predicate [p].
+   Returns [None] if there is no value that satisfies [p] in the
+   list [l].
+   @since 4.05 *)
+
+val filter : f:('a -> bool) -> 'a list -> 'a list
+(** [filter p l] returns all the elements of the list [l]
+   that satisfy the predicate [p].  The order of the elements
+   in the input list is preserved.  *)
+
+val find_all : f:('a -> bool) -> 'a list -> 'a list
+(** [find_all] is another name for {!List.filter}. *)
+
+val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
+(** [partition p l] returns a pair of lists [(l1, l2)], where
+   [l1] is the list of all the elements of [l] that
+   satisfy the predicate [p], and [l2] is the list of all the
+   elements of [l] that do not satisfy [p].
+   The order of the elements in the input list is preserved. *)
+
+
+(** {6 Association lists} *)
+
+
+val assoc : 'a -> ('a * 'b) list -> 'b
+(** [assoc a l] returns the value associated with key [a] in the list of
+   pairs [l]. That is,
+   [assoc a [ ...; (a,b); ...] = b]
+   if [(a,b)] is the leftmost binding of [a] in list [l].
+   Raise [Not_found] if there is no value associated with [a] in the
+   list [l]. *)
+
+val assoc_opt: 'a -> ('a * 'b) list -> 'b option
+(** [assoc_opt a l] returns the value associated with key [a] in the list of
+    pairs [l]. That is,
+    [assoc a [ ...; (a,b); ...] = b]
+    if [(a,b)] is the leftmost binding of [a] in list [l].
+    Returns [None] if there is no value associated with [a] in the
+    list [l].
+    @since 4.05
+*)
+
+val assq : 'a -> ('a * 'b) list -> 'b
+(** Same as {!List.assoc}, but uses physical equality instead of
+   structural equality to compare keys. *)
+
+val assq_opt: 'a -> ('a * 'b) list -> 'b option
+(** Same as {!List.assoc_opt}, but uses physical equality instead of
+   structural equality to compare keys.
+   @since 4.05.0 *)
+
+val mem_assoc : 'a -> map:('a * 'b) list -> bool
+(** Same as {!List.assoc}, but simply return true if a binding exists,
+   and false if no bindings exist for the given key. *)
+
+val mem_assq : 'a -> map:('a * 'b) list -> bool
+(** Same as {!List.mem_assoc}, but uses physical equality instead of
+   structural equality to compare keys. *)
+
+val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** [remove_assoc a l] returns the list of
+   pairs [l] without the first pair with key [a], if any.
+   Not tail-recursive. *)
+
+val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** Same as {!List.remove_assoc}, but uses physical equality instead
+   of structural equality to compare keys.  Not tail-recursive. *)
+
+
+(** {6 Lists of pairs} *)
+
+
+val split : ('a * 'b) list -> 'a list * 'b list
+(** Transform a list of pairs into a pair of lists:
+   [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
+   Not tail-recursive.
+*)
+
+val combine : 'a list -> 'b list -> ('a * 'b) list
+(** Transform a pair of lists into a list of pairs:
+   [combine [a1; ...; an] [b1; ...; bn]] is
+   [[(a1,b1); ...; (an,bn)]].
+   Raise [Invalid_argument] if the two lists
+   have different lengths.  Not tail-recursive. *)
+
+
+(** {6 Sorting} *)
+
+
+val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Sort a list in increasing order according to a comparison
+   function.  The comparison function must return 0 if its arguments
+   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.
+   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
+   stack space.
+
+   The current implementation uses Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
+
+val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort}, but the sorting algorithm is guaranteed to
+   be stable (i.e. elements that compare equal are kept in their
+   original order) .
+
+   The current implementation uses Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
+
+val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort} or {!List.stable_sort}, whichever is
+    faster on typical input. *)
+
+val sort_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort}, but also remove duplicates.
+    @since 4.03.0 *)
+
+val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+(** Merge two lists:
+    Assuming that [l1] and [l2] are sorted according to the
+    comparison function [cmp], [merge cmp l1 l2] will return a
+    sorted list containting all the elements of [l1] and [l2].
+    If several elements compare equal, the elements of [l1] will be
+    before the elements of [l2].
+    Not tail-recursive (sum of the lengths of the arguments).
+*)
diff --git a/stdlib/map.ml b/stdlib/map.ml
new file mode 100644
index 00000000..18659c49
--- /dev/null
+++ b/stdlib/map.ml
@@ -0,0 +1,459 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type key
+    type +'a t
+    val empty: 'a t
+    val is_empty: 'a t -> bool
+    val mem:  key -> 'a t -> bool
+    val add: key -> 'a -> 'a t -> 'a t
+    val singleton: key -> 'a -> 'a t
+    val remove: key -> 'a t -> 'a t
+    val merge:
+          (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all: (key -> 'a -> bool) -> 'a t -> bool
+    val exists: (key -> 'a -> bool) -> 'a t -> bool
+    val filter: (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal: 'a t -> int
+    val bindings: 'a t -> (key * 'a) list
+    val min_binding: 'a t -> (key * 'a)
+    val min_binding_opt: 'a t -> (key * 'a) option
+    val max_binding: 'a t -> (key * 'a)
+    val max_binding_opt: 'a t -> (key * 'a) option
+    val choose: 'a t -> (key * 'a)
+    val choose_opt: 'a t -> (key * 'a) option
+    val split: key -> 'a t -> 'a t * 'a option * 'a t
+    val find: key -> 'a t -> 'a
+    val find_opt: key -> 'a t -> 'a option
+    val find_first: (key -> bool) -> 'a t -> key * 'a
+    val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option
+    val find_last: (key -> bool) -> 'a t -> key * 'a
+    val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option
+    val map: ('a -> 'b) -> 'a t -> 'b t
+    val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
+  end
+
+module Make(Ord: OrderedType) = struct
+
+    type key = Ord.t
+
+    type 'a t =
+        Empty
+      | Node of 'a t * key * 'a * 'a t * int
+
+    let height = function
+        Empty -> 0
+      | Node(_,_,_,_,h) -> h
+
+    let create l x d r =
+      let hl = height l and hr = height r in
+      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let singleton x d = Node(Empty, x, d, Empty, 1)
+
+    let bal l x d r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Map.bal"
+        | Node(ll, lv, ld, lr, _) ->
+            if height ll >= height lr then
+              create ll lv ld (create lr x d r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Map.bal"
+              | Node(lrl, lrv, lrd, lrr, _)->
+                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Map.bal"
+        | Node(rl, rv, rd, rr, _) ->
+            if height rr >= height rl then
+              create (create l x d rl) rv rd rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Map.bal"
+              | Node(rll, rlv, rld, rlr, _) ->
+                  create (create l x d rll) rlv rld (create rlr rv rd rr)
+            end
+      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)
+      | Node(l, v, d, r, h) as m ->
+          let c = Ord.compare x v in
+          if c = 0 then
+            if d == data then m else Node(l, x, data, r, h)
+          else if c < 0 then
+            let ll = add x data l in
+            if l == ll then m else bal ll v d r
+          else
+            let rr = add x data r in
+            if r == rr then m else bal l v d rr
+
+    let rec find x = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then d
+          else find x (if c < 0 then l else r)
+
+    let rec find_first_aux v0 d0 f = function
+        Empty ->
+          (v0, d0)
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_first_aux v d f l
+          else
+            find_first_aux v0 d0 f r
+
+    let rec find_first f = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_first_aux v d f l
+          else
+            find_first f r
+
+    let rec find_first_opt_aux v0 d0 f = function
+        Empty ->
+          Some (v0, d0)
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_first_opt_aux v d f l
+          else
+            find_first_opt_aux v0 d0 f r
+
+    let rec find_first_opt f = function
+        Empty ->
+          None
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_first_opt_aux v d f l
+          else
+            find_first_opt f r
+
+    let rec find_last_aux v0 d0 f = function
+        Empty ->
+          (v0, d0)
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_last_aux v d f r
+          else
+            find_last_aux v0 d0 f l
+
+    let rec find_last f = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_last_aux v d f r
+          else
+            find_last f l
+
+    let rec find_last_opt_aux v0 d0 f = function
+        Empty ->
+          Some (v0, d0)
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_last_opt_aux v d f r
+          else
+            find_last_opt_aux v0 d0 f l
+
+    let rec find_last_opt f = function
+        Empty ->
+          None
+      | Node(l, v, d, r, _) ->
+          if f v then
+            find_last_opt_aux v d f r
+          else
+            find_last_opt f l
+
+    let rec find_opt x = function
+        Empty ->
+          None
+      | Node(l, v, d, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then Some d
+          else find_opt x (if c < 0 then l else r)
+
+    let rec mem x = function
+        Empty ->
+          false
+      | Node(l, v, _, r, _) ->
+          let c = Ord.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec min_binding = function
+        Empty -> raise Not_found
+      | Node(Empty, x, d, _, _) -> (x, d)
+      | Node(l, _, _, _, _) -> min_binding l
+
+    let rec min_binding_opt = function
+        Empty -> None
+      | Node(Empty, x, d, _, _) -> Some (x, d)
+      | Node(l, _, _, _, _) -> min_binding_opt l
+
+    let rec max_binding = function
+        Empty -> raise Not_found
+      | Node(_, x, d, Empty, _) -> (x, d)
+      | Node(_, _, _, r, _) -> max_binding r
+
+    let rec max_binding_opt = function
+        Empty -> None
+      | Node(_, x, d, Empty, _) -> Some (x, d)
+      | Node(_, _, _, r, _) -> max_binding_opt r
+
+    let rec remove_min_binding = function
+        Empty -> invalid_arg "Map.remove_min_elt"
+      | Node(Empty, _, _, r, _) -> r
+      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+    let merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) ->
+          let (x, d) = min_binding t2 in
+          bal t1 x d (remove_min_binding t2)
+
+    let rec remove x = function
+        Empty ->
+          Empty
+      | (Node(l, v, d, r, _) as t) ->
+          let c = Ord.compare x v in
+          if c = 0 then merge l r
+          else if c < 0 then
+            let ll = remove x l in if l == ll then t else bal ll v d r
+          else
+            let rr = remove x r in if r == rr then t else bal l v d rr
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, d, r, _) ->
+          iter f l; f v d; iter f r
+
+    let rec map f = function
+        Empty ->
+          Empty
+      | Node(l, v, d, r, h) ->
+          let l' = map f l in
+          let d' = f d in
+          let r' = map f r in
+          Node(l', v, d', r', h)
+
+    let rec mapi f = function
+        Empty ->
+          Empty
+      | Node(l, v, d, r, h) ->
+          let l' = mapi f l in
+          let d' = f v d in
+          let r' = mapi f r in
+          Node(l', v, d', r', h)
+
+    let rec fold f m accu =
+      match m with
+        Empty -> accu
+      | Node(l, v, d, r, _) ->
+          fold f r (f v d (fold f l accu))
+
+    let rec for_all p = function
+        Empty -> true
+      | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r
+
+    let rec exists p = function
+        Empty -> false
+      | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
+
+    (* Beware: those two functions assume that the added k is *strictly*
+       smaller (or bigger) than all the present keys in the tree; it
+       does not test for equality with the current min (or max) key.
+
+       Indeed, they are only used during the "join" operation which
+       respects this precondition.
+    *)
+
+    let rec add_min_binding k v = function
+      | Empty -> singleton k v
+      | Node (l, x, d, r, _) ->
+        bal (add_min_binding k v l) x d r
+
+    let rec add_max_binding k v = function
+      | Empty -> singleton k v
+      | Node (l, x, d, r, _) ->
+        bal l x d (add_max_binding k v r)
+
+    (* Same as create and bal, but no assumptions are made on the
+       relative heights of l and r. *)
+
+    let rec join l v d r =
+      match (l, r) with
+        (Empty, _) -> add_min_binding v d r
+      | (_, Empty) -> add_max_binding v d l
+      | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
+          if lh > rh + 2 then bal ll lv ld (join lr v d r) else
+          if rh > lh + 2 then bal (join l v d rl) rv rd rr else
+          create l v d r
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       No assumption on the heights of l and r. *)
+
+    let concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) ->
+          let (x, d) = min_binding t2 in
+          join t1 x d (remove_min_binding t2)
+
+    let concat_or_join t1 v d t2 =
+      match d with
+      | Some d -> join t1 v d t2
+      | None -> concat t1 t2
+
+    let rec split x = function
+        Empty ->
+          (Empty, None, Empty)
+      | Node(l, v, d, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then (l, Some d, r)
+          else if c < 0 then
+            let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
+          else
+            let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
+
+    let rec merge f s1 s2 =
+      match (s1, s2) with
+        (Empty, Empty) -> Empty
+      | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
+          let (l2, d2, r2) = split v1 s2 in
+          concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
+      | (_, Node (l2, v2, d2, r2, _)) ->
+          let (l1, d1, r1) = split v2 s1 in
+          concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
+      | _ ->
+          assert false
+
+    let rec union f s1 s2 =
+      match (s1, s2) with
+      | (Empty, s) | (s, Empty) -> s
+      | (Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2)) ->
+          if h1 >= h2 then
+            let (l2, d2, r2) = split v1 s2 in
+            let l = union f l1 l2 and r = union f r1 r2 in
+            match d2 with
+            | None -> join l v1 d1 r
+            | Some d2 -> concat_or_join l v1 (f v1 d1 d2) r
+          else
+            let (l1, d1, r1) = split v2 s1 in
+            let l = union f l1 l2 and r = union f r1 r2 in
+            match d1 with
+            | None -> join l v2 d2 r
+            | Some d1 -> concat_or_join l v2 (f v2 d1 d2) r
+
+    let rec filter p = function
+        Empty -> Empty
+      | Node(l, v, d, r, _) as t ->
+          (* call [p] in the expected left-to-right order *)
+          let l' = filter p l in
+          let pvd = p v d in
+          let r' = filter p r in
+          if pvd then if l==l' && r==r' then t else join l' v d r'
+          else concat l' r'
+
+    let rec partition p = function
+        Empty -> (Empty, Empty)
+      | Node(l, v, d, r, _) ->
+          (* call [p] in the expected left-to-right order *)
+          let (lt, lf) = partition p l in
+          let pvd = p v d in
+          let (rt, rf) = partition p r in
+          if pvd
+          then (join lt v d rt, concat lf rf)
+          else (concat lt rt, join lf v d rf)
+
+    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)
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r
+
+    let rec bindings_aux accu = function
+        Empty -> accu
+      | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l
+
+    let bindings s =
+      bindings_aux [] s
+
+    let choose = min_binding
+
+    let choose_opt = min_binding_opt
+
+end
diff --git a/stdlib/map.mli b/stdlib/map.mli
new file mode 100644
index 00000000..331e2a72
--- /dev/null
+++ b/stdlib/map.mli
@@ -0,0 +1,302 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Association tables over ordered types.
+
+   This module implements applicative association tables, also known as
+   finite maps or dictionaries, given a total ordering function
+   over the keys.
+   All operations over maps are purely applicative (no side-effects).
+   The implementation uses balanced binary trees, and therefore searching
+   and insertion take time logarithmic in the size of the map.
+
+   For instance:
+   {[
+     module IntPairs =
+       struct
+         type t = int * int
+         let compare (x0,y0) (x1,y1) =
+           match Pervasives.compare x0 x1 with
+               0 -> Pervasives.compare y0 y1
+             | c -> c
+       end
+
+     module PairsMap = Map.Make(IntPairs)
+
+     let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world")
+   ]}
+
+   This creates a new module [PairsMap], with a new type ['a PairsMap.t]
+   of maps from [int * int] to ['a]. In this example, [m] contains [string]
+   values so its type is [string PairsMap.t].
+*)
+
+module type OrderedType =
+  sig
+    type t
+      (** The type of the map keys. *)
+
+    val compare : t -> t -> int
+      (** A total ordering function over the keys.
+          This is a two-argument function [f] such that
+          [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}. *)
+  end
+(** Input signature of the functor {!Map.Make}. *)
+
+module type S =
+  sig
+    type key
+    (** The type of the map keys. *)
+
+    type (+'a) t
+    (** The type of maps from type [key] to type ['a]. *)
+
+    val empty: 'a t
+    (** The empty map. *)
+
+    val is_empty: 'a t -> bool
+    (** Test whether a map is empty or not. *)
+
+    val mem: key -> 'a t -> bool
+    (** [mem x m] returns [true] if [m] contains a binding for [x],
+       and [false] otherwise. *)
+
+    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
+       in [m] to a value that is physically equal to [y],
+       [m] is returned unchanged (the result of the function is
+       then physically equal to [m]). Otherwise, the previous binding
+       of [x] in [m] disappears.
+       @before 4.03 Physical equality was not ensured. *)
+
+    val singleton: key -> 'a -> 'a t
+    (** [singleton x y] returns the one-element map that contains a binding [y]
+        for [x].
+        @since 3.12.0
+     *)
+
+    val remove: key -> 'a t -> 'a t
+    (** [remove x m] returns a map containing the same bindings as
+       [m], except for [x] which is unbound in the returned map.
+       If [x] was not in [m], [m] is returned unchanged
+       (the result of the function is then physically equal to [m]).
+       @before 4.03 Physical equality was not ensured. *)
+
+    val merge:
+         (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1]
+        and of [m2]. The presence of each such binding, and the corresponding
+        value, is determined with the function [f].
+        In terms of the [find_opt] operation, we have
+        [find_opt x (merge f m1 m2) = f (find_opt x m1) (find_opt x m2)]
+        for any key [x], provided that [f None None = None].
+        @since 3.12.0
+     *)
+
+    val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+    (** [union f m1 m2] computes a map whose keys is the union of keys
+        of [m1] and of [m2].  When the same binding is defined in both
+        arguments, the function [f] is used to combine them.
+        This is a special case of [merge]: [union f m1 m2] is equivalent
+        to [merge f' m1 m2], where
+        - [f' None None = None]
+        - [f' (Some v) None = Some v]
+        - [f' None (Some v) = Some v]
+        - [f' (Some v1) (Some v2) = f v1 v2]
+
+        @since 4.03.0
+    *)
+
+    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. *)
+
+    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 bindings are passed to [f] in increasing
+       order with respect to the ordering over the type of the keys. *)
+
+    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]
+       (in increasing order), and [d1 ... dN] are the associated data. *)
+
+    val for_all: (key -> 'a -> bool) -> 'a t -> bool
+    (** [for_all p m] checks if all the bindings of the map
+        satisfy the predicate [p].
+        @since 3.12.0
+     *)
+
+    val exists: (key -> 'a -> bool) -> 'a t -> bool
+    (** [exists p m] checks if at least one binding of the map
+        satisfies the predicate [p].
+        @since 3.12.0
+     *)
+
+    val filter: (key -> 'a -> bool) -> 'a t -> 'a t
+    (** [filter p m] returns the map with all the bindings in [m]
+        that satisfy predicate [p]. If [p] satisfies every binding in [m],
+        [m] is returned unchanged (the result of the function is then
+        physically equal to [m])
+        @since 3.12.0
+       @before 4.03 Physical equality was not ensured.
+     *)
+
+    val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    (** [partition p m] returns a pair of maps [(m1, m2)], where
+        [m1] contains all the bindings of [s] that satisfy the
+        predicate [p], and [m2] is the map with all the bindings of
+        [s] that do not satisfy [p].
+        @since 3.12.0
+     *)
+
+    val cardinal: 'a t -> int
+    (** Return the number of bindings of a map.
+        @since 3.12.0
+     *)
+
+    val bindings: 'a t -> (key * 'a) list
+    (** Return the list of all bindings of the given map.
+       The returned list is sorted in increasing order with respect
+       to the ordering [Ord.compare], where [Ord] is the argument
+       given to {!Map.Make}.
+        @since 3.12.0
+     *)
+
+    val min_binding: 'a t -> (key * 'a)
+    (** Return the smallest binding of the given map
+       (with respect to the [Ord.compare] ordering), or raise
+       [Not_found] if the map is empty.
+        @since 3.12.0
+     *)
+
+    val min_binding_opt: 'a t -> (key * 'a) option
+    (** Return the smallest binding of the given map
+       (with respect to the [Ord.compare] ordering), or [None]
+       if the map is empty.
+        @since 4.05
+     *)
+
+    val max_binding: 'a t -> (key * 'a)
+    (** Same as {!Map.S.min_binding}, but returns the largest binding
+        of the given map.
+        @since 3.12.0
+     *)
+
+    val max_binding_opt: 'a t -> (key * 'a) option
+    (** Same as {!Map.S.min_binding_opt}, but returns the largest binding
+        of the given map.
+        @since 4.05
+     *)
+
+    val choose: 'a t -> (key * 'a)
+    (** Return one binding of the given map, or raise [Not_found] if
+       the map is empty. Which binding is chosen is unspecified,
+       but equal bindings will be chosen for equal maps.
+        @since 3.12.0
+     *)
+
+    val choose_opt: 'a t -> (key * 'a) option
+    (** Return one binding of the given map, or [None] if
+       the map is empty. Which binding is chosen is unspecified,
+       but equal bindings will be chosen for equal maps.
+        @since 4.05
+     *)
+
+    val split: key -> 'a t -> 'a t * 'a option * 'a t
+    (** [split x m] returns a triple [(l, data, r)], where
+          [l] is the map with all the bindings of [m] whose key
+        is strictly less than [x];
+          [r] is the map with all the bindings of [m] whose key
+        is strictly greater than [x];
+          [data] is [None] if [m] contains no binding for [x],
+          or [Some v] if [m] binds [v] to [x].
+        @since 3.12.0
+     *)
+
+    val find: key -> 'a t -> 'a
+    (** [find x m] returns the current binding of [x] in [m],
+       or raises [Not_found] if no such binding exists. *)
+
+    val find_opt: key -> 'a t -> 'a option
+    (** [find_opt x m] returns [Some v] if the current binding of [x]
+        in [m] is [v], or [None] if no such binding exists.
+        @since 4.05
+    *)
+
+    val find_first: (key -> bool) -> 'a t -> key * 'a
+    (** [find_first f m], where [f] is a monotonically increasing function,
+       returns the binding of [m] with the lowest key [k] such that [f k],
+       or raises [Not_found] if no such key exists.
+
+       For example, [find_first (fun k -> Ord.compare k x >= 0) m] will return
+       the first binding [k, v] of [m] where [Ord.compare k x >= 0]
+       (intuitively: [k >= x]), or raise [Not_found] if [x] is greater than any
+       element of [m].
+
+        @since 4.05
+       *)
+
+    val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option
+    (** [find_first_opt f m], where [f] is a monotonically increasing function,
+       returns an option containing the binding of [m] with the lowest key [k]
+       such that [f k], or [None] if no such key exists.
+        @since 4.05
+       *)
+
+    val find_last: (key -> bool) -> 'a t -> key * 'a
+    (** [find_last f m], where [f] is a monotonically decreasing function,
+       returns the binding of [m] with the highest key [k] such that [f k],
+       or raises [Not_found] if no such key exists.
+        @since 4.05
+       *)
+
+    val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option
+    (** [find_last_opt f m], where [f] is a monotonically decreasing function,
+       returns an option containing the binding of [m] with the highest key [k]
+       such that [f k], or [None] if no such key exists.
+        @since 4.05
+       *)
+
+    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 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
+       key and the associated value for each binding of the map. *)
+
+
+  end
+(** Output signature of the functor {!Map.Make}. *)
+
+module Make (Ord : OrderedType) : S with type key = Ord.t
+(** Functor building an implementation of the map structure
+   given a totally ordered type. *)
diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml
new file mode 100644
index 00000000..458f003b
--- /dev/null
+++ b/stdlib/marshal.ml
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type extern_flags =
+    No_sharing
+  | Closures
+  | Compat_32
+(* note: this type definition is used in 'byterun/debugger.c' *)
+
+external to_channel: out_channel -> 'a -> extern_flags list -> unit
+    = "caml_output_value"
+external to_bytes: 'a -> extern_flags list -> bytes
+    = "caml_output_value_to_string"
+external to_string: 'a -> extern_flags list -> string
+    = "caml_output_value_to_string"
+external to_buffer_unsafe:
+      bytes -> int -> int -> 'a -> extern_flags list -> int
+    = "caml_output_value_to_buffer"
+
+let to_buffer buff ofs len v flags =
+  if ofs < 0 || len < 0 || ofs > Bytes.length buff - len
+  then invalid_arg "Marshal.to_buffer: substring out of bounds"
+  else to_buffer_unsafe buff ofs len v flags
+
+(* The functions below use byte sequences as input, never using any
+   mutation. It makes sense to use non-mutated [bytes] rather than
+   [string], because we really work with sequences of bytes, not
+   a text representation.
+*)
+
+external from_channel: in_channel -> 'a = "caml_input_value"
+external from_bytes_unsafe: bytes -> int -> 'a
+                           = "caml_input_value_from_string"
+external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size"
+
+let header_size = 20
+let data_size buff ofs =
+  if ofs < 0 || ofs > Bytes.length buff - header_size
+  then invalid_arg "Marshal.data_size"
+  else data_size_unsafe buff ofs
+let total_size buff ofs = header_size + data_size buff ofs
+
+let from_bytes buff ofs =
+  if ofs < 0 || ofs > Bytes.length buff - header_size
+  then invalid_arg "Marshal.from_bytes"
+  else begin
+    let len = data_size_unsafe buff ofs in
+    if ofs > Bytes.length buff - (header_size + len)
+    then invalid_arg "Marshal.from_bytes"
+    else from_bytes_unsafe buff ofs
+  end
+
+let from_string buff ofs =
+  (* Bytes.unsafe_of_string is safe here, as the produced byte
+     sequence is never mutated *)
+  from_bytes (Bytes.unsafe_of_string buff) ofs
diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
new file mode 100644
index 00000000..2473365f
--- /dev/null
+++ b/stdlib/marshal.mli
@@ -0,0 +1,185 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Marshaling of data structures.
+
+   This module provides functions to encode arbitrary data structures
+   as sequences of bytes, which can then be written on a file or
+   sent over a pipe or network connection.  The bytes can then
+   be read back later, possibly in another process, and decoded back
+   into a data structure. The format for the byte sequences
+   is compatible across all machines for a given version of OCaml.
+
+   Warning: marshaling is currently not type-safe. The type
+   of marshaled data is not transmitted along the value of the data,
+   making it impossible to check that the data read back possesses the
+   type expected by the context. In particular, the result type of
+   the [Marshal.from_*] functions is given as ['a], but this is
+   misleading: the returned OCaml value does not possess type ['a]
+   for all ['a]; it has one, unique type which cannot be determined
+   at compile-type.  The programmer should explicitly give the expected
+   type of the returned value, using the following syntax:
+   - [(Marshal.from_channel chan : type)].
+   Anything can happen at run-time if the object in the file does not
+   belong to the given type.
+
+   Values of extensible variant types, for example exceptions (of
+   extensible type [exn]), returned by the unmarhsaller should not be
+   pattern-matched over through [match ... with] or [try ... with],
+   because unmarshalling does not preserve the information required for
+   matching their constructors. Structural equalities with other
+   extensible variant values does not work either.  Most other uses such
+   as Printexc.to_string, will still work as expected.
+
+   The representation of marshaled values is not human-readable,
+   and uses bytes that are not printable characters. Therefore,
+   input and output channels used in conjunction with [Marshal.to_channel]
+   and [Marshal.from_channel] must be opened in binary mode, using e.g.
+   [open_out_bin] or [open_in_bin]; channels opened in text mode will
+   cause unmarshaling errors on platforms where text channels behave
+   differently than binary channels, e.g. Windows.
+ *)
+
+type extern_flags =
+    No_sharing                          (** Don't preserve sharing *)
+  | Closures                            (** Send function closures *)
+  | Compat_32                           (** Ensure 32-bit compatibility *)
+(** The flags to the [Marshal.to_*] functions below. *)
+
+val to_channel : out_channel -> 'a -> extern_flags list -> unit
+(** [Marshal.to_channel chan v flags] writes the representation
+   of [v] on channel [chan]. The [flags] argument is a
+   possibly empty list of flags that governs the marshaling
+   behavior with respect to sharing, functional values, and compatibility
+   between 32- and 64-bit platforms.
+
+   If [flags] does not contain [Marshal.No_sharing], circularities
+   and sharing inside the value [v] are detected and preserved
+   in the sequence of bytes produced. In particular, this
+   guarantees that marshaling always terminates. Sharing
+   between values marshaled by successive calls to
+   [Marshal.to_channel] is neither detected nor preserved, though.
+   If [flags] contains [Marshal.No_sharing], sharing is ignored.
+   This results in faster marshaling if [v] contains no shared
+   substructures, but may cause slower marshaling and larger
+   byte representations if [v] actually contains sharing,
+   or even non-termination if [v] contains cycles.
+
+   If [flags] does not contain [Marshal.Closures], marshaling fails
+   when it encounters a functional value inside [v]: only 'pure' data
+   structures, containing neither functions nor objects, can safely be
+   transmitted between different programs. If [flags] contains
+   [Marshal.Closures], functional values will be marshaled as a the
+   position in the code of the program together with the values
+   corresponding to the free variables captured in the closure.  In
+   this case, the output of marshaling can only be read back in
+   processes that run exactly the same program, with exactly the same
+   compiled code. (This is checked at un-marshaling time, using an MD5
+   digest of the code transmitted along with the code position.)
+
+   The exact definition of which free variables are captured in a
+   closure is not specified and can vary between bytecode and native
+   code (and according to optimization flags).  In particular, a
+   function value accessing a global reference may or may not include
+   the reference in its closure.  If it does, unmarshaling the
+   corresponding closure will create a new reference, different from
+   the global one.
+
+
+   If [flags] contains [Marshal.Compat_32], marshaling fails when
+   it encounters an integer value outside the range [[-2{^30}, 2{^30}-1]]
+   of integers that are representable on a 32-bit platform.  This
+   ensures that marshaled data generated on a 64-bit platform can be
+   safely read back on a 32-bit platform.  If [flags] does not
+   contain [Marshal.Compat_32], integer values outside the
+   range [[-2{^30}, 2{^30}-1]] are marshaled, and can be read back on
+   a 64-bit platform, but will cause an error at un-marshaling time
+   when read back on a 32-bit platform.  The [Mashal.Compat_32] flag
+   only matters when marshaling is performed on a 64-bit platform;
+   it has no effect if marshaling is performed on a 32-bit platform.
+ *)
+
+external to_bytes :
+  'a -> extern_flags list -> bytes = "caml_output_value_to_string"
+(** [Marshal.to_bytes v flags] returns a byte sequence containing
+   the representation of [v].
+   The [flags] argument has the same meaning as for
+   {!Marshal.to_channel}.
+   @since 4.02.0 *)
+
+external to_string :
+  'a -> extern_flags list -> string = "caml_output_value_to_string"
+(** Same as [to_bytes] but return the result as a string instead of
+    a byte sequence. *)
+
+val to_buffer : bytes -> int -> int -> 'a -> extern_flags list -> int
+(** [Marshal.to_buffer buff ofs len v flags] marshals the value [v],
+   storing its byte representation in the sequence [buff],
+   starting at index [ofs], and writing at most
+   [len] bytes.  It returns the number of bytes
+   actually written to the sequence. If the byte representation
+   of [v] does not fit in [len] characters, the exception [Failure]
+   is raised. *)
+
+val from_channel : in_channel -> 'a
+(** [Marshal.from_channel chan] reads from channel [chan] the
+   byte representation of a structured value, as produced by
+   one of the [Marshal.to_*] functions, and reconstructs and
+   returns the corresponding value.
+
+   It raises [End_of_file] if the function has already reached the
+   end of file when starting to read from the channel, and raises
+   [Failure "input_value: truncated object"] if it reaches the end
+   of file later during the unmarshalling. *)
+
+val from_bytes : bytes -> int -> 'a
+(** [Marshal.from_bytes buff ofs] unmarshals a structured value
+   like {!Marshal.from_channel} does, except that the byte
+   representation is not read from a channel, but taken from
+   the byte sequence [buff], starting at position [ofs].
+   The byte sequence is not mutated.
+   @since 4.02.0 *)
+
+val from_string : string -> int -> 'a
+(** Same as [from_bytes] but take a string as argument instead of a
+    byte sequence. *)
+
+val header_size : int
+(** The bytes representing a marshaled value are composed of
+   a fixed-size header and a variable-sized data part,
+   whose size can be determined from the header.
+   {!Marshal.header_size} is the size, in bytes, of the header.
+   {!Marshal.data_size}[ buff ofs] is the size, in bytes,
+   of the data part, assuming a valid header is stored in
+   [buff] starting at position [ofs].
+   Finally, {!Marshal.total_size} [buff ofs] is the total size,
+   in bytes, of the marshaled value.
+   Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure]
+   if [buff], [ofs] does not contain a valid header.
+
+   To read the byte representation of a marshaled value into
+   a byte sequence, the program needs to read first
+   {!Marshal.header_size} bytes into the sequence,
+   then determine the length of the remainder of the
+   representation using {!Marshal.data_size},
+   make sure the sequence is large enough to hold the remaining
+   data, then read it, and finally call {!Marshal.from_bytes}
+   to unmarshal the value. *)
+
+val data_size : bytes -> int -> int
+(** See {!Marshal.header_size}.*)
+
+val total_size : bytes -> int -> int
+(** See {!Marshal.header_size}.*)
diff --git a/stdlib/moreLabels.ml b/stdlib/moreLabels.ml
new file mode 100644
index 00000000..7b93668a
--- /dev/null
+++ b/stdlib/moreLabels.ml
@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [MoreLabels]: meta-module for compatibility labelled libraries *)
+
+module Hashtbl = Hashtbl
+
+module Map = Map
+
+module Set = Set
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
new file mode 100644
index 00000000..824c9a23
--- /dev/null
+++ b/stdlib/moreLabels.mli
@@ -0,0 +1,197 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Extra labeled libraries.
+
+   This meta-module provides labelized version of the {!Hashtbl},
+   {!Map} and {!Set} modules.
+
+   They only differ by their labels. They are provided to help
+   porting from previous versions of OCaml.
+   The contents of this module are subject to change.
+*)
+
+module Hashtbl : sig
+  type ('a, 'b) t = ('a, 'b) Hashtbl.t
+  val create : ?random:bool -> int -> ('a, 'b) t
+  val clear : ('a, 'b) t -> unit
+  val reset : ('a, 'b) t -> unit
+  val copy : ('a, 'b) t -> ('a, 'b) t
+  val add : ('a, 'b) t -> key:'a -> data:'b -> unit
+  val find : ('a, 'b) t -> 'a -> 'b
+  val find_opt : ('a, 'b) t -> 'a -> 'b option
+  val find_all : ('a, 'b) t -> 'a -> 'b list
+  val mem : ('a, 'b) t -> 'a -> bool
+  val remove : ('a, 'b) t -> 'a -> unit
+  val replace : ('a, 'b) t -> key:'a -> data:'b -> unit
+  val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit
+  val filter_map_inplace:
+    f:(key:'a -> data:'b -> 'b option) -> ('a, 'b) t -> unit
+  val fold :
+      f:(key:'a -> data:'b -> 'c -> 'c) ->
+        ('a, 'b) t -> init:'c -> 'c
+  val length : ('a, 'b) t -> int
+  val randomize : unit -> unit
+  val is_randomized : unit -> bool
+  type statistics = Hashtbl.statistics
+  val stats : ('a, 'b) t -> statistics
+  module type HashedType = Hashtbl.HashedType
+  module type SeededHashedType = Hashtbl.SeededHashedType
+  module type S =
+    sig
+      type key
+      and 'a t
+      val create : int -> 'a t
+      val clear : 'a t -> unit
+      val reset : 'a t -> unit
+      val copy : 'a t -> 'a t
+      val add : 'a t -> key:key -> data:'a -> unit
+      val remove : 'a t -> key -> unit
+      val find : 'a t -> key -> 'a
+      val find_opt: 'a t -> key -> 'a option
+      val find_all : 'a t -> key -> 'a list
+      val replace : 'a t -> key:key -> data:'a -> unit
+      val mem : 'a t -> key -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val filter_map_inplace:
+        f:(key:key -> data:'a -> 'a option) -> 'a t -> unit
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+      val length : 'a t -> int
+      val stats: 'a t -> statistics
+    end
+  module type SeededS =
+    sig
+      type key
+      and 'a t
+      val create : ?random:bool -> int -> 'a t
+      val clear : 'a t -> unit
+      val reset : 'a t -> unit
+      val copy : 'a t -> 'a t
+      val add : 'a t -> key:key -> data:'a -> unit
+      val remove : 'a t -> key -> unit
+      val find : 'a t -> key -> 'a
+      val find_opt : 'a t -> key -> 'a option
+      val find_all : 'a t -> key -> 'a list
+      val replace : 'a t -> key:key -> data:'a -> unit
+      val mem : 'a t -> key -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val filter_map_inplace:
+        f:(key:key -> data:'a -> 'a option) -> 'a t -> unit
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+      val length : 'a t -> int
+      val stats: 'a t -> statistics
+    end
+  module Make : functor (H : HashedType) -> S with type key = H.t
+  module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
+  val hash : 'a -> int
+  val seeded_hash : int -> 'a -> int
+  val hash_param : int -> int -> 'a -> int
+  val seeded_hash_param : int -> int -> int -> 'a -> int
+end
+
+module Map : sig
+  module type OrderedType = Map.OrderedType
+  module type S =
+    sig
+      type key
+      and (+'a) t
+      val empty : 'a t
+      val is_empty: 'a t -> bool
+      val mem : key -> 'a t -> bool
+      val add : key:key -> data:'a -> 'a t -> 'a t
+      val singleton: key -> 'a -> 'a t
+      val remove : key -> 'a t -> 'a t
+      val merge:
+          f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+      val union: f:(key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+      val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
+      val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+      val for_all: f:(key -> 'a -> bool) -> 'a t -> bool
+      val exists: f:(key -> 'a -> bool) -> 'a t -> bool
+      val filter: f:(key -> 'a -> bool) -> 'a t -> 'a t
+      val partition: f:(key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+      val cardinal: 'a t -> int
+      val bindings: 'a t -> (key * 'a) list
+      val min_binding: 'a t -> (key * 'a)
+      val min_binding_opt: 'a t -> (key * 'a) option
+      val max_binding: 'a t -> (key * 'a)
+      val max_binding_opt: 'a t -> (key * 'a) option
+      val choose: 'a t -> (key * 'a)
+      val choose_opt: 'a t -> (key * 'a) option
+      val split: key -> 'a t -> 'a t * 'a option * 'a t
+      val find : key -> 'a t -> 'a
+      val find_opt: key -> 'a t -> 'a option
+      val find_first : f:(key -> bool) -> 'a t -> key * 'a
+      val find_first_opt : f:(key -> bool) -> 'a t -> (key * 'a) option
+      val find_last : f:(key -> bool) -> 'a t -> key * 'a
+      val find_last_opt : f:(key -> bool) -> 'a t -> (key * 'a) option
+      val map : f:('a -> 'b) -> 'a t -> 'b t
+      val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t
+  end
+  module Make : functor (Ord : OrderedType) -> S with type key = Ord.t
+end
+
+module Set : sig
+  module type OrderedType = Set.OrderedType
+  module type S =
+    sig
+      type elt
+      and t
+      val empty : t
+      val is_empty : t -> bool
+      val mem : elt -> t -> bool
+      val add : elt -> t -> t
+      val singleton : elt -> t
+      val remove : elt -> t -> t
+      val union : t -> t -> t
+      val inter : t -> t -> t
+      val diff : t -> t -> t
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      val subset : t -> t -> bool
+      val iter : f:(elt -> unit) -> t -> unit
+      val map : f:(elt -> elt) -> t -> t
+      val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a
+      val for_all : f:(elt -> bool) -> t -> bool
+      val exists : f:(elt -> bool) -> t -> bool
+      val filter : f:(elt -> bool) -> t -> t
+      val partition : f:(elt -> bool) -> t -> t * t
+      val cardinal : t -> int
+      val elements : t -> elt list
+      val min_elt : t -> elt
+      val min_elt_opt: t -> elt option
+      val max_elt : t -> elt
+      val max_elt_opt: t -> elt option
+      val choose : t -> elt
+      val choose_opt: t -> elt option
+      val split: elt -> t -> t * bool * t
+      val find: elt -> t -> elt
+      val find_opt: elt -> t -> elt option
+      val find_first: f:(elt -> bool) -> t -> elt
+      val find_first_opt: f:(elt -> bool) -> t -> elt option
+      val find_last: f:(elt -> bool) -> t -> elt
+      val find_last_opt: f:(elt -> bool) -> t -> elt option
+      val of_list: elt list -> t
+    end
+  module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
+end
diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
new file mode 100644
index 00000000..2f6fe780
--- /dev/null
+++ b/stdlib/nativeint.ml
@@ -0,0 +1,65 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Nativeint]: processor-native integers *)
+
+external neg: nativeint -> nativeint = "%nativeint_neg"
+external add: nativeint -> nativeint -> nativeint = "%nativeint_add"
+external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub"
+external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul"
+external div: nativeint -> nativeint -> nativeint = "%nativeint_div"
+external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod"
+external logand: nativeint -> nativeint -> nativeint = "%nativeint_and"
+external logor: nativeint -> nativeint -> nativeint = "%nativeint_or"
+external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor"
+external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl"
+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
+  = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external to_float : nativeint -> float
+  = "caml_nativeint_to_float" "caml_nativeint_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external of_int32: int32 -> nativeint = "%nativeint_of_int32"
+external to_int32: nativeint -> int32 = "%nativeint_to_int32"
+
+let zero = 0n
+let one = 1n
+let minus_one = -1n
+let succ n = add n 1n
+let pred n = sub n 1n
+let abs n = if n >= 0n then n else neg n
+let size = Sys.word_size
+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 = "caml_nativeint_format"
+let to_string n = format "%d" n
+
+external of_string: string -> nativeint = "caml_nativeint_of_string"
+
+let of_string_opt s =
+  (* TODO: expose a non-raising primitive directly. *)
+  try Some (of_string s)
+  with Failure _ -> None
+
+type t = nativeint
+
+let compare (x: t) (y: t) = Pervasives.compare x y
+let equal (x: t) (y: t) = compare x y = 0
diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
new file mode 100644
index 00000000..b733318d
--- /dev/null
+++ b/stdlib/nativeint.mli
@@ -0,0 +1,198 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Processor-native integers.
+
+   This module provides operations on the type [nativeint] of
+   signed 32-bit integers (on 32-bit platforms) or
+   signed 64-bit integers (on 64-bit platforms).
+   This integer type has exactly the same width as that of a
+   pointer type in the C compiler.  All arithmetic operations over
+   [nativeint] are taken modulo 2{^32} or 2{^64} depending
+   on the word size of the architecture.
+
+   Performance notice: values of type [nativeint] occupy more memory
+   space than values of type [int], and arithmetic operations on
+   [nativeint] are generally slower than those on [int].  Use [nativeint]
+   only when the application requires the extra bit of precision
+   over the [int] type.
+*)
+
+val zero : nativeint
+(** The native integer 0.*)
+
+val one : nativeint
+(** The native integer 1.*)
+
+val minus_one : nativeint
+(** The native integer -1.*)
+
+external neg : nativeint -> nativeint = "%nativeint_neg"
+(** Unary negation. *)
+
+external add : nativeint -> nativeint -> nativeint = "%nativeint_add"
+(** Addition. *)
+
+external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub"
+(** Subtraction. *)
+
+external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul"
+(** Multiplication. *)
+
+external div : nativeint -> nativeint -> nativeint = "%nativeint_div"
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Pervasives.(/)}. *)
+
+external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod"
+(** Integer remainder.  If [y] is not zero, the result
+   of [Nativeint.rem x y] satisfies the following properties:
+   [Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and
+   [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y)
+                      (Nativeint.rem x y)].
+   If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *)
+
+val succ : nativeint -> nativeint
+(** Successor.
+   [Nativeint.succ x] is [Nativeint.add x Nativeint.one]. *)
+
+val pred : nativeint -> nativeint
+(** Predecessor.
+   [Nativeint.pred x] is [Nativeint.sub x Nativeint.one]. *)
+
+val abs : nativeint -> nativeint
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a native integer.  This is equal to [32]
+   on a 32-bit platform and to [64] on a 64-bit platform. *)
+
+val max_int : nativeint
+(** The greatest representable native integer,
+   either 2{^31} - 1 on a 32-bit platform,
+   or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : nativeint
+(** The smallest representable native integer,
+   either -2{^31} on a 32-bit platform,
+   or -2{^63} on a 64-bit platform. *)
+
+external logand : nativeint -> nativeint -> nativeint = "%nativeint_and"
+(** Bitwise logical and. *)
+
+external logor : nativeint -> nativeint -> nativeint = "%nativeint_or"
+(** Bitwise logical or. *)
+
+external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor"
+(** Bitwise logical exclusive or. *)
+
+val lognot : nativeint -> nativeint
+(** Bitwise logical negation *)
+
+external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl"
+(** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits.
+   The result is unspecified if [y < 0] or [y >= bitsize],
+   where [bitsize] is [32] on a 32-bit platform and
+   [64] on a 64-bit platform. *)
+
+external shift_right : nativeint -> int -> nativeint = "%nativeint_asr"
+(** [Nativeint.shift_right x y] shifts [x] to the right by [y] bits.
+   This is an arithmetic shift: the sign bit of [x] is replicated
+   and inserted in the vacated bits.
+   The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+external shift_right_logical :
+  nativeint -> int -> nativeint = "%nativeint_lsr"
+(** [Nativeint.shift_right_logical x y] shifts [x] to the right
+   by [y] bits.
+   This is a logical shift: zeroes are inserted in the vacated bits
+   regardless of the sign of [x].
+   The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+
+external of_int : int -> nativeint = "%nativeint_of_int"
+(** Convert the given integer (type [int]) to a native integer
+   (type [nativeint]). *)
+
+external to_int : nativeint -> int = "%nativeint_to_int"
+(** Convert the given native integer (type [nativeint]) to an
+   integer (type [int]).  The high-order bit is lost during
+   the conversion. *)
+
+external of_float : float -> nativeint
+  = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** 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
+  = "caml_nativeint_to_float" "caml_nativeint_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+(** Convert the given native integer to a floating-point number. *)
+
+external of_int32 : int32 -> nativeint = "%nativeint_of_int32"
+(** Convert the given 32-bit integer (type [int32])
+   to a native integer. *)
+
+external to_int32 : nativeint -> int32 = "%nativeint_to_int32"
+(** Convert the given native integer to a
+   32-bit integer (type [int32]).  On 64-bit platforms,
+   the 64-bit native integer is taken modulo 2{^32},
+   i.e. the top 32 bits are lost.  On 32-bit platforms,
+   the conversion is exact. *)
+
+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, or if the integer represented
+   exceeds the range of integers representable in type [nativeint]. *)
+
+val of_string_opt: string -> nativeint option
+(** Same as [of_string], but return [None] instead of raising.
+    @since 4.05 *)
+
+val to_string : nativeint -> string
+(** Return the string representation of its argument, in decimal. *)
+
+type t = nativeint
+(** An alias for the type of native integers. *)
+
+val compare: t -> t -> int
+(** The comparison function for native integers, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [Nativeint] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equal function for native ints.
+    @since 4.03.0 *)
+
+(**/**)
+
+(** {6 Deprecated functions} *)
+
+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
+   one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
+   This function is deprecated; use {!Printf.sprintf} with a [%nx] format
+   instead. *)
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
new file mode 100644
index 00000000..35b3925a
--- /dev/null
+++ b/stdlib/obj.ml
@@ -0,0 +1,113 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on internal representations of values *)
+
+type t
+
+external repr : 'a -> t = "%identity"
+external obj : t -> 'a = "%identity"
+external magic : 'a -> 'b = "%identity"
+external is_int : t -> bool = "%obj_is_int"
+let [@inline always] is_block a = not (is_int a)
+external tag : t -> int = "caml_obj_tag"
+external set_tag : t -> int -> unit = "caml_obj_set_tag"
+external size : t -> int = "%obj_size"
+external reachable_words : t -> int = "caml_obj_reachable_words"
+external field : t -> int -> t = "%obj_field"
+external set_field : t -> int -> t -> unit = "%obj_set_field"
+external array_get: 'a array -> int -> 'a = "%array_safe_get"
+external array_set: 'a array -> int -> 'a -> unit = "%array_safe_set"
+let [@inline always] double_field x i = array_get (obj x : float array) i
+let [@inline always] set_double_field x i v =
+  array_set (obj x : float array) i v
+external new_block : int -> int -> t = "caml_obj_block"
+external dup : t -> t = "caml_obj_dup"
+external truncate : t -> int -> unit = "caml_obj_truncate"
+external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
+
+let marshal (obj : t) =
+  Marshal.to_bytes obj []
+let unmarshal str pos =
+  (Marshal.from_bytes str pos, pos + Marshal.total_size str pos)
+
+let first_non_constant_constructor_tag = 0
+let last_non_constant_constructor_tag = 245
+
+let lazy_tag = 246
+let closure_tag = 247
+let object_tag = 248
+let infix_tag = 249
+let forward_tag = 250
+
+let no_scan_tag = 251
+
+let abstract_tag = 251
+let string_tag = 252
+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
+let unaligned_tag = 1002
+
+let extension_constructor x =
+  let x = repr x in
+  let slot =
+    if (is_block x) && (tag x) <> object_tag && (size x) >= 1 then field x 0
+    else x
+  in
+  let name =
+    if (is_block slot) && (tag slot) = object_tag then field slot 0
+    else invalid_arg "Obj.extension_constructor"
+  in
+    if (tag name) = string_tag then (obj slot : extension_constructor)
+    else invalid_arg "Obj.extension_constructor"
+
+let [@inline always] extension_name (slot : extension_constructor) =
+  (obj (field (repr slot) 0) : string)
+
+let [@inline always] extension_id (slot : extension_constructor) =
+  (obj (field (repr slot) 1) : int)
+
+module Ephemeron = struct
+  type obj_t = t
+
+  type t (** ephemeron *)
+
+  external create: int -> t = "caml_ephe_create"
+
+  let length x = size(repr x) - 2
+
+  external get_key: t -> int -> obj_t option = "caml_ephe_get_key"
+  external get_key_copy: t -> int -> obj_t option = "caml_ephe_get_key_copy"
+  external set_key: t -> int -> obj_t -> unit = "caml_ephe_set_key"
+  external unset_key: t -> int -> unit = "caml_ephe_unset_key"
+  external check_key: t -> int -> bool = "caml_ephe_check_key"
+  external blit_key : t -> int -> t -> int -> int -> unit
+    = "caml_ephe_blit_key"
+
+  external get_data: t -> obj_t option = "caml_ephe_get_data"
+  external get_data_copy: t -> obj_t option = "caml_ephe_get_data_copy"
+  external set_data: t -> obj_t -> unit = "caml_ephe_set_data"
+  external unset_data: t -> unit = "caml_ephe_unset_data"
+  external check_data: t -> bool = "caml_ephe_check_data"
+  external blit_data : t -> t -> unit = "caml_ephe_blit_data"
+
+
+end
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
new file mode 100644
index 00000000..e76c7df9
--- /dev/null
+++ b/stdlib/obj.mli
@@ -0,0 +1,152 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Operations on internal representations of values.
+
+   Not for the casual user.
+*)
+
+type t
+
+external repr : 'a -> t = "%identity"
+external obj : t -> 'a = "%identity"
+external magic : 'a -> 'b = "%identity"
+val [@inline always] is_block : t -> bool
+external is_int : t -> bool = "%obj_is_int"
+external tag : t -> int = "caml_obj_tag"
+external size : t -> int = "%obj_size"
+external reachable_words : t -> int = "caml_obj_reachable_words"
+  (**
+     Computes the total size (in words, including the headers) of all
+     heap blocks accessible from the argument.  Statically
+     allocated blocks are excluded.
+
+     @Since 4.04
+  *)
+
+external field : t -> int -> t = "%obj_field"
+
+(** When using flambda:
+
+    [set_field] MUST NOT be called on immutable blocks.  (Blocks allocated
+    in C stubs, or with [new_block] below, are always considered mutable.)
+
+    The same goes for [set_double_field] and [set_tag].  However, for
+    [set_tag], in the case of immutable blocks where the middle-end optimizers
+    never see code that discriminates on their tag (for example records), the
+    operation should be safe.  Such uses are nonetheless discouraged.
+
+    For experts only:
+    [set_field] et al can be made safe by first wrapping the block in
+    {!Sys.opaque_identity}, so any information about its contents will not
+    be propagated.
+*)
+external set_field : t -> int -> t -> unit = "%obj_set_field"
+external set_tag : t -> int -> unit = "caml_obj_set_tag"
+
+val [@inline always] double_field : t -> int -> float  (* @since 3.11.2 *)
+val [@inline always] set_double_field : t -> int -> float -> unit
+  (* @since 3.11.2 *)
+external new_block : int -> int -> t = "caml_obj_block"
+external dup : t -> t = "caml_obj_dup"
+external truncate : t -> int -> unit = "caml_obj_truncate"
+external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
+         (* @since 3.12.0 *)
+
+val first_non_constant_constructor_tag : int
+val last_non_constant_constructor_tag : int
+
+val lazy_tag : int
+val closure_tag : int
+val object_tag : int
+val infix_tag : int
+val forward_tag : int
+val no_scan_tag : int
+val abstract_tag : int
+val string_tag : int   (* both [string] and [bytes] *)
+val double_tag : int
+val double_array_tag : int
+val custom_tag : int
+val final_tag : int
+  [@@ocaml.deprecated "Replaced by custom_tag."]
+
+val int_tag : int
+val out_of_heap_tag : int
+val unaligned_tag : int   (* should never happen @since 3.11.0 *)
+
+val extension_constructor : 'a -> extension_constructor
+val [@inline always] extension_name : extension_constructor -> string
+val [@inline always] extension_id : extension_constructor -> int
+
+(** The following two functions are deprecated.  Use module {!Marshal}
+    instead. *)
+
+val marshal : t -> bytes
+  [@@ocaml.deprecated "Use Marshal.to_bytes instead."]
+val unmarshal : bytes -> int -> t * int
+  [@@ocaml.deprecated "Use Marshal.from_bytes and Marshal.total_size instead."]
+
+module Ephemeron: sig
+  (** Ephemeron with arbitrary arity and untyped *)
+
+  type obj_t = t
+  (** alias for {!Obj.t} *)
+
+  type t
+  (** an ephemeron cf {!Ephemeron} *)
+
+  val create: int -> t
+  (** [create n] returns an ephemeron with [n] keys.
+      All the keys and the data are initially empty *)
+
+  val length: t -> int
+  (** return the number of keys *)
+
+  val get_key: t -> int -> obj_t option
+  (** Same as {!Ephemeron.K1.get_key} *)
+
+  val get_key_copy: t -> int -> obj_t option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+
+  val set_key: t -> int -> obj_t -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+
+  val unset_key: t -> int -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+
+  val check_key: t -> int -> bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val blit_key : t -> int -> t -> int -> int -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val get_data: t -> obj_t option
+  (** Same as {!Ephemeron.K1.get_data} *)
+
+  val get_data_copy: t -> obj_t option
+  (** Same as {!Ephemeron.K1.get_data_copy} *)
+
+  val set_data: t -> obj_t -> unit
+  (** Same as {!Ephemeron.K1.set_data} *)
+
+  val unset_data: t -> unit
+  (** Same as {!Ephemeron.K1.unset_data} *)
+
+  val check_data: t -> bool
+  (** Same as {!Ephemeron.K1.check_data} *)
+
+  val blit_data : t -> t -> unit
+  (** Same as {!Ephemeron.K1.blit_data} *)
+end
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
new file mode 100644
index 00000000..3833b972
--- /dev/null
+++ b/stdlib/oo.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let copy = CamlinternalOO.copy
+external id : < .. > -> int = "%field1"
+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
new file mode 100644
index 00000000..9be20c14
--- /dev/null
+++ b/stdlib/oo.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Operations on objects *)
+
+val copy : (< .. > as 'a) -> 'a
+(** [Oo.copy o] returns a copy of object [o], that is a fresh
+   object with the same methods and instance variables as [o]. *)
+
+external id : < .. > -> int = "%field1"
+(** Return an integer identifying this object, unique for
+    the current execution of the program. The generic comparison
+    and hashing functions are based on this integer. When an object
+    is obtained by unmarshaling, the id is refreshed, and thus
+    different from the original object. As a consequence, the internal
+    invariants of data structures such as hash table or sets containing
+    objects are broken after unmarshaling the data structures.
+  *)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+(** For internal use (CamlIDL) *)
+val new_method : string -> CamlinternalOO.tag
+val public_method_label : string -> CamlinternalOO.tag
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
new file mode 100644
index 00000000..3b779f5c
--- /dev/null
+++ b/stdlib/parsing.ml
@@ -0,0 +1,211 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The parsing engine *)
+
+open Lexing
+
+(* Internal interface to the parsing engine *)
+
+type parser_env =
+  { mutable s_stack : int array;        (* States *)
+    mutable v_stack : Obj.t array;      (* Semantic attributes *)
+    mutable symb_start_stack : position array; (* Start positions *)
+    mutable symb_end_stack : position array;   (* End positions *)
+    mutable stacksize : int;            (* Size of the stacks *)
+    mutable stackbase : int;            (* Base sp for current parse *)
+    mutable curr_char : int;            (* Last token read *)
+    mutable lval : Obj.t;               (* Its semantic attribute *)
+    mutable symb_start : position;      (* Start pos. of the current symbol*)
+    mutable symb_end : position;        (* End pos. of the current symbol *)
+    mutable asp : int;                  (* The stack pointer for attributes *)
+    mutable rule_len : int;             (* Number of rhs items in the rule *)
+    mutable rule_number : int;          (* Rule number to reduce by *)
+    mutable sp : int;                   (* Saved sp for parse_engine *)
+    mutable state : int;                (* Saved state for parse_engine *)
+    mutable errflag : int }             (* Saved error flag for parse_engine *)
+
+type parse_tables =
+  { actions : (parser_env -> Obj.t) array;
+    transl_const : int array;
+    transl_block : int array;
+    lhs : string;
+    len : string;
+    defred : string;
+    dgoto : string;
+    sindex : string;
+    rindex : string;
+    gindex : string;
+    tablesize : int;
+    table : string;
+    check : string;
+    error_function : string -> unit;
+    names_const : string;
+    names_block : string }
+
+exception YYexit of Obj.t
+exception Parse_error
+
+type parser_input =
+    Start
+  | Token_read
+  | Stacks_grown_1
+  | Stacks_grown_2
+  | Semantic_action_computed
+  | Error_detected
+
+type parser_output =
+    Read_token
+  | Raise_parse_error
+  | Grow_stacks_1
+  | Grow_stacks_2
+  | Compute_semantic_action
+  | Call_error_function
+
+(* to avoid warnings *)
+let _ = [Read_token; Raise_parse_error; Grow_stacks_1; Grow_stacks_2;
+         Compute_semantic_action; Call_error_function]
+
+external parse_engine :
+    parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output
+    = "caml_parse_engine"
+
+external set_trace: bool -> bool
+    = "caml_set_parser_trace"
+
+let env =
+  { s_stack = Array.make 100 0;
+    v_stack = Array.make 100 (Obj.repr ());
+    symb_start_stack = Array.make 100 dummy_pos;
+    symb_end_stack = Array.make 100 dummy_pos;
+    stacksize = 100;
+    stackbase = 0;
+    curr_char = 0;
+    lval = Obj.repr ();
+    symb_start = dummy_pos;
+    symb_end = dummy_pos;
+    asp = 0;
+    rule_len = 0;
+    rule_number = 0;
+    sp = 0;
+    state = 0;
+    errflag = 0 }
+
+let grow_stacks() =
+  let oldsize = env.stacksize in
+  let newsize = oldsize * 2 in
+  let new_s = Array.make newsize 0
+  and new_v = Array.make newsize (Obj.repr ())
+  and new_start = Array.make newsize dummy_pos
+  and new_end = Array.make newsize dummy_pos in
+    Array.blit env.s_stack 0 new_s 0 oldsize;
+    env.s_stack <- new_s;
+    Array.blit env.v_stack 0 new_v 0 oldsize;
+    env.v_stack <- new_v;
+    Array.blit env.symb_start_stack 0 new_start 0 oldsize;
+    env.symb_start_stack <- new_start;
+    Array.blit env.symb_end_stack 0 new_end 0 oldsize;
+    env.symb_end_stack <- new_end;
+    env.stacksize <- newsize
+
+let clear_parser() =
+  Array.fill env.v_stack 0 env.stacksize (Obj.repr ());
+  env.lval <- Obj.repr ()
+
+let current_lookahead_fun = ref (fun (_ : Obj.t) -> false)
+
+let yyparse tables start lexer lexbuf =
+  let rec loop cmd arg =
+    match parse_engine tables env cmd arg with
+      Read_token ->
+        let t = Obj.repr(lexer lexbuf) in
+        env.symb_start <- lexbuf.lex_start_p;
+        env.symb_end <- lexbuf.lex_curr_p;
+        loop Token_read t
+    | Raise_parse_error ->
+        raise Parse_error
+    | Compute_semantic_action ->
+        let (action, value) =
+          try
+            (Semantic_action_computed, tables.actions.(env.rule_number) env)
+          with Parse_error ->
+            (Error_detected, Obj.repr ()) in
+        loop action value
+    | Grow_stacks_1 ->
+        grow_stacks(); loop Stacks_grown_1 (Obj.repr ())
+    | Grow_stacks_2 ->
+        grow_stacks(); loop Stacks_grown_2 (Obj.repr ())
+    | Call_error_function ->
+        tables.error_function "syntax error";
+        loop Error_detected (Obj.repr ()) in
+  let init_asp = env.asp
+  and init_sp = env.sp
+  and init_stackbase = env.stackbase
+  and init_state = env.state
+  and init_curr_char = env.curr_char
+  and init_lval = env.lval
+  and init_errflag = env.errflag in
+  env.stackbase <- env.sp + 1;
+  env.curr_char <- start;
+  env.symb_end <- lexbuf.lex_curr_p;
+  try
+    loop Start (Obj.repr ())
+  with exn ->
+    let curr_char = env.curr_char in
+    env.asp <- init_asp;
+    env.sp <- init_sp;
+    env.stackbase <- init_stackbase;
+    env.state <- init_state;
+    env.curr_char <- init_curr_char;
+    env.lval <- init_lval;
+    env.errflag <- init_errflag;
+    match exn with
+      YYexit v ->
+        Obj.magic v
+    | _ ->
+        current_lookahead_fun :=
+          (fun tok ->
+            if Obj.is_block tok
+            then tables.transl_block.(Obj.tag tok) = curr_char
+            else tables.transl_const.(Obj.magic tok) = curr_char);
+        raise exn
+
+let peek_val env n =
+  Obj.magic env.v_stack.(env.asp - n)
+
+let symbol_start_pos () =
+  let rec loop i =
+    if i <= 0 then env.symb_end_stack.(env.asp)
+    else begin
+      let st = env.symb_start_stack.(env.asp - i + 1) in
+      let en = env.symb_end_stack.(env.asp - i + 1) in
+      if st <> en then st else loop (i - 1)
+    end
+  in
+  loop env.rule_len
+
+let symbol_end_pos () = env.symb_end_stack.(env.asp)
+let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n))
+let rhs_end_pos n = env.symb_end_stack.(env.asp - (env.rule_len - n))
+
+let symbol_start () = (symbol_start_pos ()).pos_cnum
+let symbol_end () = (symbol_end_pos ()).pos_cnum
+let rhs_start n = (rhs_start_pos n).pos_cnum
+let rhs_end n = (rhs_end_pos n).pos_cnum
+
+let is_current_lookahead tok =
+  (!current_lookahead_fun)(Obj.repr tok)
+
+let parse_error (_ : string) = ()
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
new file mode 100644
index 00000000..baeae9ab
--- /dev/null
+++ b/stdlib/parsing.mli
@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The run-time library for parsers generated by [ocamlyacc]. *)
+
+val symbol_start : unit -> int
+(** [symbol_start] and {!Parsing.symbol_end} are to be called in the
+   action part of a grammar rule only. They return the offset of the
+   string that matches the left-hand side of the rule: [symbol_start()]
+   returns the offset of the first character; [symbol_end()] returns the
+   offset after the last character. The first character in a file is at
+   offset 0. *)
+
+val symbol_end : unit -> int
+(** See {!Parsing.symbol_start}. *)
+
+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 [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. *)
+
+val rhs_end : int -> int
+(** See {!Parsing.rhs_start}. *)
+
+val symbol_start_pos : unit -> Lexing.position
+(** Same as [symbol_start], but return a [position] instead of an offset. *)
+
+val symbol_end_pos : unit -> Lexing.position
+(** Same as [symbol_end], but return a [position] instead of an offset. *)
+
+val rhs_start_pos : int -> Lexing.position
+(** Same as [rhs_start], but return a [position] instead of an offset. *)
+
+val rhs_end_pos : int -> Lexing.position
+(** Same as [rhs_end], but return a [position] instead of an offset. *)
+
+val clear_parser : unit -> unit
+(** Empty the parser stack. Call it just after a parsing function
+   has returned, to remove all pointers from the parser stack
+   to structures that were built by semantic actions during parsing.
+   This is optional, but lowers the memory requirements of the
+   programs. *)
+
+exception Parse_error
+(** Raised when a parser encounters a syntax error.
+   Can also be raised from the action part of a grammar rule,
+   to initiate error recovery. *)
+
+val set_trace: bool -> bool
+(** Control debugging support for [ocamlyacc]-generated parsers.
+    After [Parsing.set_trace true], the pushdown automaton that
+    executes the parsers prints a trace of its actions (reading a token,
+    shifting a state, reducing by a rule) on standard output.
+    [Parsing.set_trace false] turns this debugging trace off.
+    The boolean returned is the previous state of the trace flag.
+    @since 3.11.0
+*)
+
+(**/**)
+
+(** {6  } *)
+
+(** The following definitions are used by the generated parsers only.
+   They are not intended to be used directly by user programs. *)
+
+type parser_env
+
+type parse_tables =
+  { actions : (parser_env -> Obj.t) array;
+    transl_const : int array;
+    transl_block : int array;
+    lhs : string;
+    len : string;
+    defred : string;
+    dgoto : string;
+    sindex : string;
+    rindex : string;
+    gindex : string;
+    tablesize : int;
+    table : string;
+    check : string;
+    error_function : string -> unit;
+    names_const : string;
+    names_block : string }
+
+exception YYexit of Obj.t
+
+val yyparse :
+  parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b
+val peek_val : parser_env -> int -> 'a
+val is_current_lookahead : 'a -> bool
+val parse_error : string -> unit
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
new file mode 100644
index 00000000..fc7d9218
--- /dev/null
+++ b/stdlib/pervasives.ml
@@ -0,0 +1,544 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* type 'a option = None | Some of 'a *)
+
+(* Exceptions *)
+
+external register_named_value : string -> 'a -> unit
+                              = "caml_register_named_value"
+
+let () =
+  (* for asmrun/fail.c *)
+  register_named_value "Pervasives.array_bound_error"
+    (Invalid_argument "index out of bounds")
+
+
+external raise : exn -> 'a = "%raise"
+external raise_notrace : exn -> 'a = "%raise_notrace"
+
+let failwith s = raise(Failure s)
+let invalid_arg s = raise(Invalid_argument s)
+
+exception Exit
+
+(* Composition operators *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
+(* Debugging *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+
+(* Comparisons *)
+
+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 compare : 'a -> 'a -> int = "%compare"
+
+let min x y = if x <= y then x else y
+let max x y = if x >= y then x else y
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+
+(* Boolean operations *)
+
+external not : bool -> bool = "%boolnot"
+external ( & ) : bool -> bool -> bool = "%sequand"
+external ( && ) : bool -> bool -> bool = "%sequand"
+external ( or ) : bool -> bool -> bool = "%sequor"
+external ( || ) : bool -> bool -> bool = "%sequor"
+
+(* Integer operations *)
+
+external ( ~- ) : int -> int = "%negint"
+external ( ~+ ) : int -> int = "%identity"
+external succ : int -> int = "%succint"
+external pred : int -> int = "%predint"
+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"
+
+let abs x = if x >= 0 then x else -x
+
+external ( land ) : int -> int -> int = "%andint"
+external ( lor ) : int -> int -> int = "%orint"
+external ( lxor ) : int -> int -> int = "%xorint"
+
+let lnot x = x lxor (-1)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+external ( lsr ) : int -> int -> int = "%lsrint"
+external ( asr ) : int -> int -> int = "%asrint"
+
+let max_int = (-1) lsr 1
+let min_int = max_int + 1
+
+(* Floating-point operations *)
+
+external ( ~-. ) : float -> float = "%negfloat"
+external ( ~+. ) : float -> float = "%identity"
+external ( +. ) : float -> float -> float = "%addfloat"
+external ( -. ) : float -> float -> float = "%subfloat"
+external ( *. ) : float -> float -> float = "%mulfloat"
+external ( /. ) : float -> float -> float = "%divfloat"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow"
+  [@@unboxed] [@@noalloc]
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+  [@@unboxed] [@@noalloc]
+external acos : float -> float = "caml_acos_float" "acos"
+  [@@unboxed] [@@noalloc]
+external asin : float -> float = "caml_asin_float" "asin"
+  [@@unboxed] [@@noalloc]
+external atan : float -> float = "caml_atan_float" "atan"
+  [@@unboxed] [@@noalloc]
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+  [@@unboxed] [@@noalloc]
+external hypot : float -> float -> float
+               = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+external cosh : float -> float = "caml_cosh_float" "cosh"
+  [@@unboxed] [@@noalloc]
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+external log10 : float -> float = "caml_log10_float" "log10"
+  [@@unboxed] [@@noalloc]
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+  [@@unboxed] [@@noalloc]
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+external sinh : float -> float = "caml_sinh_float" "sinh"
+  [@@unboxed] [@@noalloc]
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+  [@@unboxed] [@@noalloc]
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+external tanh : float -> float = "caml_tanh_float" "tanh"
+  [@@unboxed] [@@noalloc]
+external ceil : float -> float = "caml_ceil_float" "ceil"
+  [@@unboxed] [@@noalloc]
+external floor : float -> float = "caml_floor_float" "floor"
+  [@@unboxed] [@@noalloc]
+external abs_float : float -> float = "%absfloat"
+external copysign : float -> float -> float
+                  = "caml_copysign_float" "caml_copysign"
+                  [@@unboxed] [@@noalloc]
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
+  [@@unboxed] [@@noalloc]
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+  "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+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_bits : int64 -> float
+  = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+  [@@unboxed] [@@noalloc]
+let infinity =
+  float_of_bits 0x7F_F0_00_00_00_00_00_00L
+let neg_infinity =
+  float_of_bits 0xFF_F0_00_00_00_00_00_00L
+let nan =
+  float_of_bits 0x7F_F0_00_00_00_00_00_01L
+let max_float =
+  float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
+let min_float =
+  float_of_bits 0x00_10_00_00_00_00_00_00L
+let epsilon_float =
+  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 [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+
+(* String and byte sequence operations -- more in modules String and Bytes *)
+
+external string_length : string -> int = "%string_length"
+external bytes_length : bytes -> int = "%string_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
+external string_blit : string -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
+                        = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+
+let ( ^ ) s1 s2 =
+  let l1 = string_length s1 and l2 = string_length s2 in
+  let s = bytes_create (l1 + l2) in
+  string_blit s1 0 s 0 l1;
+  string_blit s2 0 s l1 l2;
+  bytes_unsafe_to_string s
+
+(* Character operations -- more in module Char *)
+
+external int_of_char : char -> int = "%identity"
+external unsafe_char_of_int : int -> char = "%identity"
+let char_of_int n =
+  if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
+
+(* Unit operations *)
+
+external ignore : 'a -> unit = "%ignore"
+
+(* Pair operations *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+external snd : 'a * 'b -> 'b = "%field1"
+
+(* References *)
+
+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"
+
+(* Result type *)
+
+type ('a,'b) result = Ok of 'a | Error of 'b
+
+(* String conversion functions *)
+
+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"
+let bool_of_string = function
+  | "true" -> true
+  | "false" -> false
+  | _ -> invalid_arg "bool_of_string"
+
+let bool_of_string_opt = function
+  | "true" -> Some true
+  | "false" -> Some false
+  | _ -> None
+
+let string_of_int n =
+  format_int "%d" n
+
+external int_of_string : string -> int = "caml_int_of_string"
+
+let int_of_string_opt s =
+  (* TODO: provide this directly as a non-raising primitive. *)
+  try Some (int_of_string s)
+  with Failure _ -> None
+
+
+external string_get : string -> int -> char = "%string_safe_get"
+
+let valid_float_lexem s =
+  let l = string_length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match string_get s i with
+    | '0' .. '9' | '-' -> loop (i + 1)
+    | _ -> s
+  in
+  loop 0
+
+
+let string_of_float f = valid_float_lexem (format_float "%.12g" f)
+
+external float_of_string : string -> float = "caml_float_of_string"
+
+let float_of_string_opt s =
+  (* TODO: provide this directly as a non-raising primitive. *)
+  try Some (float_of_string s)
+  with Failure _ -> None
+
+(* List operations -- more in module List *)
+
+let rec ( @ ) l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd :: tl -> hd :: (tl @ l2)
+
+(* I/O operations *)
+
+type in_channel
+type out_channel
+
+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
+let stderr = open_descriptor_out 2
+
+(* General output functions *)
+
+type open_flag =
+    Open_rdonly | Open_wronly | Open_append
+  | Open_creat | Open_trunc | Open_excl
+  | Open_binary | Open_text | Open_nonblock
+
+external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
+
+external set_out_channel_name: out_channel -> string -> unit =
+  "caml_ml_set_channel_name"
+
+let open_out_gen mode perm name =
+  let c = open_descriptor_out(open_desc name mode perm) in
+  set_out_channel_name c name;
+  c
+
+let open_out name =
+  open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 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_ml_flush"
+
+external out_channels_list : unit -> out_channel list
+                           = "caml_ml_out_channels_list"
+
+let flush_all () =
+  let rec iter = function
+      [] -> ()
+    | a :: l -> (try flush a with _ -> ()); iter l
+  in iter (out_channels_list ())
+
+external unsafe_output : out_channel -> bytes -> int -> int -> unit
+                       = "caml_ml_output_bytes"
+external unsafe_output_string : out_channel -> string -> int -> int -> unit
+                              = "caml_ml_output"
+
+external output_char : out_channel -> char -> unit = "caml_ml_output_char"
+
+let output_bytes oc s =
+  unsafe_output oc s 0 (bytes_length s)
+
+let output_string oc s =
+  unsafe_output_string oc s 0 (string_length s)
+
+let output oc s ofs len =
+  if ofs < 0 || len < 0 || ofs > bytes_length s - len
+  then invalid_arg "output"
+  else unsafe_output oc s ofs len
+
+let output_substring oc s ofs len =
+  if ofs < 0 || len < 0 || ofs > string_length s - len
+  then invalid_arg "output_substring"
+  else unsafe_output_string oc s ofs len
+
+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
+     = "caml_output_value"
+let output_value chan v = marshal_to_channel chan v []
+
+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_ml_set_binary_mode"
+
+(* General input functions *)
+
+external set_in_channel_name: in_channel -> string -> unit =
+  "caml_ml_set_channel_name"
+
+let open_in_gen mode perm name =
+  let c = open_descriptor_in(open_desc name mode perm) in
+  set_in_channel_name c name;
+  c
+
+let open_in name =
+  open_in_gen [Open_rdonly; Open_text] 0 name
+
+let open_in_bin name =
+  open_in_gen [Open_rdonly; Open_binary] 0 name
+
+external input_char : in_channel -> char = "caml_ml_input_char"
+
+external unsafe_input : in_channel -> bytes -> int -> int -> int
+                      = "caml_ml_input"
+
+let input ic s ofs len =
+  if ofs < 0 || len < 0 || ofs > bytes_length s - len
+  then invalid_arg "input"
+  else unsafe_input ic s ofs len
+
+let rec unsafe_really_input ic s ofs len =
+  if len <= 0 then () else begin
+    let r = unsafe_input ic s ofs len in
+    if r = 0
+    then raise End_of_file
+    else unsafe_really_input ic s (ofs + r) (len - r)
+  end
+
+let really_input ic s ofs len =
+  if ofs < 0 || len < 0 || ofs > bytes_length s - len
+  then invalid_arg "really_input"
+  else unsafe_really_input ic s ofs len
+
+let really_input_string ic len =
+  let s = bytes_create len in
+  really_input ic s 0 len;
+  bytes_unsafe_to_string s
+
+external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
+
+let input_line chan =
+  let rec build_result buf pos = function
+    [] -> buf
+  | hd :: tl ->
+      let len = bytes_length hd in
+      bytes_blit hd 0 buf (pos - len) len;
+      build_result buf (pos - len) tl in
+  let rec scan accu len =
+    let n = input_scan_line chan in
+    if n = 0 then begin                   (* n = 0: we are at EOF *)
+      match accu with
+        [] -> raise End_of_file
+      | _  -> build_result (bytes_create len) len accu
+    end else if n > 0 then begin          (* n > 0: newline found in buffer *)
+      let res = bytes_create (n - 1) in
+      ignore (unsafe_input chan res 0 (n - 1));
+      ignore (input_char chan);           (* skip the newline *)
+      match accu with
+        [] -> res
+      |  _ -> let len = len + n - 1 in
+              build_result (bytes_create len) len (res :: accu)
+    end else begin                        (* n < 0: newline not found *)
+      let beg = bytes_create (-n) in
+      ignore(unsafe_input chan beg 0 (-n));
+      scan (beg :: accu) (len - n)
+    end
+  in bytes_unsafe_to_string (scan [] 0)
+
+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_ml_set_binary_mode"
+
+(* Output functions on standard output *)
+
+let print_char c = output_char stdout c
+let print_string s = output_string stdout s
+let print_bytes s = output_bytes stdout s
+let print_int i = output_string stdout (string_of_int i)
+let print_float f = output_string stdout (string_of_float f)
+let print_endline s =
+  output_string stdout s; output_char stdout '\n'; flush stdout
+let print_newline () = output_char stdout '\n'; flush stdout
+
+(* Output functions on standard error *)
+
+let prerr_char c = output_char stderr c
+let prerr_string s = output_string stderr s
+let prerr_bytes s = output_bytes stderr s
+let prerr_int i = output_string stderr (string_of_int i)
+let prerr_float f = output_string stderr (string_of_float f)
+let prerr_endline s =
+  output_string stderr s; output_char stderr '\n'; flush stderr
+let prerr_newline () = output_char stderr '\n'; flush stderr
+
+(* Input functions on standard input *)
+
+let read_line () = flush stdout; input_line stdin
+let read_int () = int_of_string(read_line())
+let read_int_opt () = int_of_string_opt(read_line())
+let read_float () = float_of_string(read_line())
+let read_float_opt () = float_of_string_opt(read_line())
+
+(* Operations on large files *)
+
+module LargeFile =
+  struct
+    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, 'd, 'e, 'f) format6
+   = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+   = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+               * string
+
+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+let string_of_format (Format (_fmt, str)) = str
+
+external format_of_string :
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+ ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+
+let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+  Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
+          str1 ^ "%," ^ str2)
+
+(* Miscellaneous *)
+
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let exit_function = ref flush_all
+
+let at_exit f =
+  let g = !exit_function in
+  exit_function := (fun () -> f(); g())
+
+let do_at_exit () = (!exit_function) ()
+
+let exit retcode =
+  do_at_exit ();
+  sys_exit retcode
+
+let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
new file mode 100644
index 00000000..7bf88f88
--- /dev/null
+++ b/stdlib/pervasives.mli
@@ -0,0 +1,1168 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** The initially opened module.
+
+   This module provides the basic operations over the built-in types
+   (numbers, booleans, byte sequences, strings, exceptions, references,
+   lists, arrays, input-output channels, ...).
+
+   This module is automatically opened at the beginning of each compilation.
+   All components of this module can therefore be referred by their short
+   name, without prefixing them by [Pervasives].
+*)
+
+
+(** {6 Exceptions} *)
+
+external raise : exn -> 'a = "%raise"
+(** Raise the given exception value *)
+
+external raise_notrace : exn -> 'a = "%raise_notrace"
+(** A faster version [raise] which does not record the backtrace.
+    @since 4.02.0
+*)
+
+val invalid_arg : string -> 'a
+(** Raise exception [Invalid_argument] with the given string. *)
+
+val failwith : string -> 'a
+(** Raise exception [Failure] with the given string. *)
+
+exception Exit
+(** The [Exit] exception is not raised by any library function.  It is
+    provided for use in your programs. *)
+
+
+(** {6 Comparisons} *)
+
+external ( = ) : 'a -> 'a -> bool = "%equal"
+(** [e1 = e2] tests for structural equality of [e1] and [e2].
+   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 raises [Invalid_argument].
+   Equality between cyclic data structures may not terminate. *)
+
+external ( <> ) : 'a -> 'a -> bool = "%notequal"
+(** Negation of {!Pervasives.( = )}. *)
+
+external ( < ) : 'a -> 'a -> bool = "%lessthan"
+(** See {!Pervasives.( >= )}. *)
+
+external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+(** See {!Pervasives.( >= )}. *)
+
+external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+(** See {!Pervasives.( >= )}. *)
+
+external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+(** Structural ordering functions. These functions coincide with
+   the usual orderings over integers, characters, strings, byte sequences
+   and floating-point numbers, and extend them to a
+   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 raises [Invalid_argument].
+   Comparison between cyclic structures may not terminate. *)
+
+external compare : 'a -> 'a -> int = "%compare"
+(** [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.
+    The result is unspecified if one of the arguments contains
+    the float value [nan]. *)
+
+val max : 'a -> 'a -> 'a
+(** Return the greater of the two arguments.
+    The result is unspecified if one of the arguments contains
+    the float value [nan]. *)
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+(** [e1 == e2] tests for physical equality of [e1] and [e2].
+   On mutable types such as references, arrays, byte sequences, records with
+   mutable fields and objects with mutable instance variables,
+   [e1 == e2] is true if and only if physical modification of [e1]
+   also affects [e2].
+   On non-mutable types, the behavior of [( == )] is
+   implementation-dependent; however, it is guaranteed that
+   [e1 == e2] implies [compare e1 e2 = 0]. *)
+
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+(** Negation of {!Pervasives.( == )}. *)
+
+
+(** {6 Boolean operations} *)
+
+external not : bool -> bool = "%boolnot"
+(** The boolean negation. *)
+
+external ( && ) : bool -> bool -> bool = "%sequand"
+(** The boolean 'and'. Evaluation is sequential, left-to-right:
+   in [e1 && e2], [e1] is evaluated first, and if it returns [false],
+   [e2] is not evaluated at all. *)
+
+external ( & ) : bool -> bool -> bool = "%sequand"
+  [@@ocaml.deprecated "Use (&&) instead."]
+(** @deprecated {!Pervasives.( && )} should be used instead. *)
+
+external ( || ) : bool -> bool -> bool = "%sequor"
+(** The boolean 'or'. Evaluation is sequential, left-to-right:
+   in [e1 || e2], [e1] is evaluated first, and if it returns [true],
+   [e2] is not evaluated at all. *)
+
+external ( or ) : bool -> bool -> bool = "%sequor"
+  [@@ocaml.deprecated "Use (||) instead."]
+(** @deprecated {!Pervasives.( || )} should be used instead.*)
+
+(** {6 Debugging} *)
+
+external __LOC__ : string = "%loc_LOC"
+(** [__LOC__] returns the location at which this expression appears in
+    the file currently being parsed by the compiler, with the standard
+    error format of OCaml: "File %S, line %d, characters %d-%d".
+    @since 4.02.0
+*)
+
+external __FILE__ : string = "%loc_FILE"
+(** [__FILE__] returns the name of the file currently being
+    parsed by the compiler.
+    @since 4.02.0
+*)
+
+external __LINE__ : int = "%loc_LINE"
+(** [__LINE__] returns the line number at which this expression
+    appears in the file currently being parsed by the compiler.
+    @since 4.02.0
+*)
+
+external __MODULE__ : string = "%loc_MODULE"
+(** [__MODULE__] returns the module name of the file being
+    parsed by the compiler.
+    @since 4.02.0
+*)
+
+external __POS__ : string * int * int * int = "%loc_POS"
+(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding
+    to the location at which this expression appears in the file
+    currently being parsed by the compiler. [file] is the current
+    filename, [lnum] the line number, [cnum] the character position in
+    the line and [enum] the last character position in the line.
+    @since 4.02.0
+ *)
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the
+    location of [expr] in the file currently being parsed by the
+    compiler, with the standard error format of OCaml: "File %S, line
+    %d, characters %d-%d".
+    @since 4.02.0
+*)
+
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+(** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the
+    line number at which the expression [expr] appears in the file
+    currently being parsed by the compiler.
+    @since 4.02.0
+ *)
+
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+(** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a
+    tuple [(file,lnum,cnum,enum)] corresponding to the location at
+    which the expression [expr] appears in the file currently being
+    parsed by the compiler. [file] is the current filename, [lnum] the
+    line number, [cnum] the character position in the line and [enum]
+    the last character position in the line.
+    @since 4.02.0
+ *)
+
+(** {6 Composition operators} *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+(** Reverse-application operator: [x |> f |> g] is exactly equivalent
+ to [g (f (x))].
+   @since 4.01
+*)
+
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+(** Application operator: [g @@ f @@ x] is exactly equivalent to
+ [g (f (x))].
+   @since 4.01
+*)
+
+(** {6 Integer arithmetic} *)
+
+(** Integers are 31 bits wide (or 63 bits on 64-bit processors).
+   All operations are taken modulo 2{^31} (or 2{^63}).
+   They do not fail on overflow. *)
+
+external ( ~- ) : int -> int = "%negint"
+(** Unary negation. You can also write [- e] instead of [~- e]. *)
+
+external ( ~+ ) : int -> int = "%identity"
+(** Unary addition. You can also write [+ e] instead of [~+ e].
+    @since 3.12.0
+*)
+
+external succ : int -> int = "%succint"
+(** [succ x] is [x + 1]. *)
+
+external pred : int -> int = "%predint"
+(** [pred x] is [x - 1]. *)
+
+external ( + ) : int -> int -> int = "%addint"
+(** Integer addition. *)
+
+external ( - ) : int -> int -> int = "%subint"
+(** Integer subtraction. *)
+
+external ( * ) : int -> int -> int = "%mulint"
+(** Integer multiplication. *)
+
+external ( / ) : int -> int -> int = "%divint"
+(** Integer division.
+   Raise [Division_by_zero] if the second argument is 0.
+   Integer division rounds the real quotient of its arguments towards zero.
+   More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
+   less than or equal to the real quotient of [x] by [y].  Moreover,
+   [(- x) / y = x / (- y) = - (x / y)].  *)
+
+external ( mod ) : int -> int -> int = "%modint"
+(** Integer remainder.  If [y] is not zero, the result
+   of [x mod y] satisfies the following properties:
+   [x = (x / y) * y + x mod y] and
+   [abs(x mod y) <= abs(y) - 1].
+   If [y = 0], [x mod y] raises [Division_by_zero].
+   Note that [x mod y] is negative only if [x < 0].
+   Raise [Division_by_zero] if [y] is zero. *)
+
+val abs : int -> int
+(** Return the absolute value of the argument.  Note that this may be
+  negative if the argument is [min_int]. *)
+
+val max_int : int
+(** The greatest representable integer. *)
+
+val min_int : int
+(** The smallest representable integer. *)
+
+
+(** {7 Bitwise operations} *)
+
+external ( land ) : int -> int -> int = "%andint"
+(** Bitwise logical and. *)
+
+external ( lor ) : int -> int -> int = "%orint"
+(** Bitwise logical or. *)
+
+external ( lxor ) : int -> int -> int = "%xorint"
+(** Bitwise logical exclusive or. *)
+
+val lnot : int -> int
+(** Bitwise logical negation. *)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+(** [n lsl m] shifts [n] to the left by [m] bits.
+   The result is unspecified if [m < 0] or [m >= bitsize],
+   where [bitsize] is [32] on a 32-bit platform and
+   [64] on a 64-bit platform. *)
+
+external ( lsr ) : int -> int -> int = "%lsrint"
+(** [n lsr m] shifts [n] to the right by [m] bits.
+   This is a logical shift: zeroes are inserted regardless of
+   the sign of [n].
+   The result is unspecified if [m < 0] or [m >= bitsize]. *)
+
+external ( asr ) : int -> int -> int = "%asrint"
+(** [n asr m] shifts [n] to the right by [m] bits.
+   This is an arithmetic shift: the sign bit of [n] is replicated.
+   The result is unspecified if [m < 0] or [m >= bitsize]. *)
+
+
+(** {6 Floating-point arithmetic}
+
+   OCaml's floating-point numbers follow the
+   IEEE 754 standard, using double precision (64 bits) numbers.
+   Floating-point operations never raise an exception on overflow,
+   underflow, division by zero, etc.  Instead, special IEEE numbers
+   are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
+   [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
+   for [0.0 /. 0.0].  These special numbers then propagate through
+   floating-point computations as expected: for instance,
+   [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
+   as argument returns [nan] as result.
+*)
+
+external ( ~-. ) : float -> float = "%negfloat"
+(** Unary negation. You can also write [-. e] instead of [~-. e]. *)
+
+external ( ~+. ) : float -> float = "%identity"
+(** Unary addition. You can also write [+. e] instead of [~+. e].
+    @since 3.12.0
+*)
+
+external ( +. ) : float -> float -> float = "%addfloat"
+(** Floating-point addition *)
+
+external ( -. ) : float -> float -> float = "%subfloat"
+(** Floating-point subtraction *)
+
+external ( *. ) : float -> float -> float = "%mulfloat"
+(** Floating-point multiplication *)
+
+external ( /. ) : float -> float -> float = "%divfloat"
+(** Floating-point division. *)
+
+external ( ** ) : float -> float -> float = "caml_power_float" "pow"
+  [@@unboxed] [@@noalloc]
+(** Exponentiation. *)
+
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+  [@@unboxed] [@@noalloc]
+(** Square root. *)
+
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+(** Exponential. *)
+
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+(** Natural logarithm. *)
+
+external log10 : float -> float = "caml_log10_float" "log10"
+  [@@unboxed] [@@noalloc]
+(** Base 10 logarithm. *)
+
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+  [@@unboxed] [@@noalloc]
+(** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results
+    even if [x] is close to [0.0].
+    @since 3.12.0
+*)
+
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+  [@@unboxed] [@@noalloc]
+(** [log1p x] computes [log(1.0 +. x)] (natural logarithm),
+    giving numerically-accurate results even if [x] is close to [0.0].
+    @since 3.12.0
+*)
+
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+(** Cosine.  Argument is in radians. *)
+
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+(** Sine.  Argument is in radians. *)
+
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+(** Tangent.  Argument is in radians. *)
+
+external acos : float -> float = "caml_acos_float" "acos"
+  [@@unboxed] [@@noalloc]
+(** Arc cosine.  The argument must fall within the range [[-1.0, 1.0]].
+    Result is in radians and is between [0.0] and [pi]. *)
+
+external asin : float -> float = "caml_asin_float" "asin"
+  [@@unboxed] [@@noalloc]
+(** Arc sine.  The argument must fall within the range [[-1.0, 1.0]].
+    Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+external atan : float -> float = "caml_atan_float" "atan"
+  [@@unboxed] [@@noalloc]
+(** Arc tangent.
+    Result is in radians and is between [-pi/2] and [pi/2]. *)
+
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+  [@@unboxed] [@@noalloc]
+(** [atan2 y x] returns the arc tangent of [y /. x].  The signs of [x]
+    and [y] are used to determine the quadrant of the result.
+    Result is in radians and is between [-pi] and [pi]. *)
+
+external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot"
+  [@@unboxed] [@@noalloc]
+(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
+  of the hypotenuse of a right-angled triangle with sides of length
+  [x] and [y], or, equivalently, the distance of the point [(x,y)]
+  to origin.  If one of [x] or [y] is infinite, returns [infinity]
+  even if the other is [nan].
+  @since 4.00.0  *)
+
+external cosh : float -> float = "caml_cosh_float" "cosh"
+  [@@unboxed] [@@noalloc]
+(** Hyperbolic cosine.  Argument is in radians. *)
+
+external sinh : float -> float = "caml_sinh_float" "sinh"
+  [@@unboxed] [@@noalloc]
+(** Hyperbolic sine.  Argument is in radians. *)
+
+external tanh : float -> float = "caml_tanh_float" "tanh"
+  [@@unboxed] [@@noalloc]
+(** Hyperbolic tangent.  Argument is in radians. *)
+
+external ceil : float -> float = "caml_ceil_float" "ceil"
+  [@@unboxed] [@@noalloc]
+(** Round above to an integer value.
+    [ceil f] returns the least integer value greater than or equal to [f].
+    The result is returned as a float. *)
+
+external floor : float -> float = "caml_floor_float" "floor"
+  [@@unboxed] [@@noalloc]
+(** Round below to an integer value.
+    [floor f] returns the greatest integer value less than or
+    equal to [f].
+    The result is returned as a float. *)
+
+external abs_float : float -> float = "%absfloat"
+(** [abs_float f] returns the absolute value of [f]. *)
+
+external copysign : float -> float -> float
+                  = "caml_copysign_float" "caml_copysign"
+                  [@@unboxed] [@@noalloc]
+(** [copysign x y] returns a float whose absolute value is that of [x]
+  and whose sign is that of [y].  If [x] is [nan], returns [nan].
+  If [y] is [nan], returns either [x] or [-. x], but it is not
+  specified which.
+  @since 4.00.0  *)
+
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
+  [@@unboxed] [@@noalloc]
+(** [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 = "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 [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+  "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+(** [ldexp x n] returns [x *. 2 ** n]. *)
+
+external modf : float -> float * float = "caml_modf_float"
+(** [modf f] returns the pair of the fractional and integral
+   part of [f]. *)
+
+external float : int -> float = "%floatofint"
+(** Same as {!Pervasives.float_of_int}. *)
+
+external float_of_int : int -> float = "%floatofint"
+(** Convert an integer to floating-point. *)
+
+external truncate : float -> int = "%intoffloat"
+(** Same as {!Pervasives.int_of_float}. *)
+
+external int_of_float : float -> int = "%intoffloat"
+(** Truncate the given floating-point number to an integer.
+   The result is unspecified if the argument is [nan] or falls outside the
+   range of representable integers. *)
+
+val infinity : float
+(** Positive infinity. *)
+
+val neg_infinity : float
+(** Negative infinity. *)
+
+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'.  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]. *)
+
+val min_float : float
+(** The smallest positive, non-zero, non-denormalized value of type [float]. *)
+
+val epsilon_float : float
+(** The difference between [1.0] and the smallest exactly representable
+    floating-point number greater than [1.0]. *)
+
+type fpclass =
+    FP_normal           (** Normal number, none of the below *)
+  | FP_subnormal        (** Number very close to 0.0, has reduced precision *)
+  | FP_zero             (** Number is 0.0 or -0.0 *)
+  | FP_infinite         (** Number is positive or negative infinity *)
+  | FP_nan              (** Not a number: result of an undefined operation *)
+(** The five classes of floating-point numbers, as determined by
+   the {!Pervasives.classify_float} function. *)
+
+external classify_float : (float [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+(** Return the class of the given floating-point number:
+   normal, subnormal, zero, infinite, or not a number. *)
+
+
+(** {6 String operations}
+
+   More string operations are provided in module {!String}.
+*)
+
+val ( ^ ) : string -> string -> string
+(** String concatenation. *)
+
+
+(** {6 Character operations}
+
+   More character operations are provided in module {!Char}.
+*)
+
+external int_of_char : char -> int = "%identity"
+(** Return the ASCII code of the argument. *)
+
+val char_of_int : int -> char
+(** Return the character with the given ASCII code.
+   Raise [Invalid_argument "char_of_int"] if the argument is
+   outside the range 0--255. *)
+
+
+(** {6 Unit operations} *)
+
+external ignore : 'a -> unit = "%ignore"
+(** Discard the value of its argument and return [()].
+   For instance, [ignore(f x)] discards the result of
+   the side-effecting function [f].  It is equivalent to
+   [f x; ()], except that the latter may generate a
+   compiler warning; writing [ignore(f x)] instead
+   avoids the warning. *)
+
+
+(** {6 String conversion functions} *)
+
+val string_of_bool : bool -> string
+(** Return the string representation of a boolean. As the returned values
+   may be shared, the user should not modify them directly.
+*)
+
+val bool_of_string : string -> bool
+(** Convert the given string to a boolean.
+   Raise [Invalid_argument "bool_of_string"] if the string is not
+   ["true"] or ["false"]. *)
+
+val bool_of_string_opt: string -> bool option
+(** Convert the given string to a boolean.
+    Return [None] if the string is not
+    ["true"] or ["false"].
+    @since 4.05
+*)
+
+val string_of_int : int -> string
+(** Return the string representation of an integer, in decimal. *)
+
+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), in hexadecimal (if it
+   begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]),
+   or in binary (if it begins with [0b] or [0B]).
+   The [_] (underscore) character can appear anywhere in the string
+   and is ignored.
+   Raise [Failure "int_of_string"] if the given string is not
+   a valid representation of an integer, or if the integer represented
+   exceeds the range of integers representable in type [int]. *)
+
+
+val int_of_string_opt: string -> int option
+(** Same as [int_of_string], but returs [None] instead of raising.
+    @since 4.05
+*)
+
+val string_of_float : float -> string
+(** Return the string representation of a floating-point number. *)
+
+external float_of_string : string -> float = "caml_float_of_string"
+(** Convert the given string to a float.  The string is read in decimal
+   (by default) or in hexadecimal (marked by [0x] or [0X]).
+   The format of decimal floating-point numbers is
+   [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit.
+   The format of hexadecimal floating-point numbers is
+   [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an
+   hexadecimal digit and [d] for a decimal digit.
+   In both cases, at least one of the integer and fractional parts must be
+   given; the exponent part is optional.
+   The [_] (underscore) character can appear anywhere in the string
+   and is ignored.
+   Depending on the execution platforms, other representations of
+   floating-point numbers can be accepted, but should not be relied upon.
+   Raise [Failure "float_of_string"] if the given string is not a valid
+   representation of a float. *)
+
+val float_of_string_opt: string -> float option
+(** Same as [float_of_string], but returns [None] instead of raising.
+    @since 4.05
+*)
+
+(** {6 Pair operations} *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+(** Return the first component of a pair. *)
+
+external snd : 'a * 'b -> 'b = "%field1"
+(** Return the second component of a pair. *)
+
+
+(** {6 List operations}
+
+   More list operations are provided in module {!List}.
+*)
+
+val ( @ ) : 'a list -> 'a list -> 'a list
+(** List concatenation.  Not tail-recursive (length of the first argument). *)
+
+
+(** {6 Input/output}
+    Note: all input/output functions can raise [Sys_error] when the system
+    calls they invoke fail. *)
+
+type in_channel
+(** The type of input channel. *)
+
+type out_channel
+(** The type of output channel. *)
+
+val stdin : in_channel
+(** The standard input for the process. *)
+
+val stdout : out_channel
+(** The standard output for the process. *)
+
+val stderr : out_channel
+(** The standard error output for the process. *)
+
+
+(** {7 Output functions on standard output} *)
+
+val print_char : char -> unit
+(** Print a character on standard output. *)
+
+val print_string : string -> unit
+(** Print a string on standard output. *)
+
+val print_bytes : bytes -> unit
+(** Print a byte sequence on standard output.
+   @since 4.02.0 *)
+
+val print_int : int -> unit
+(** Print an integer, in decimal, on standard output. *)
+
+val print_float : float -> unit
+(** Print a floating-point number, in decimal, on standard output. *)
+
+val print_endline : string -> unit
+(** Print a string, followed by a newline character, on
+   standard output and flush standard output. *)
+
+val print_newline : unit -> unit
+(** Print a newline character on standard output, and flush
+   standard output. This can be used to simulate line
+   buffering of standard output. *)
+
+
+(** {7 Output functions on standard error} *)
+
+val prerr_char : char -> unit
+(** Print a character on standard error. *)
+
+val prerr_string : string -> unit
+(** Print a string on standard error. *)
+
+val prerr_bytes : bytes -> unit
+(** Print a byte sequence on standard error.
+   @since 4.02.0 *)
+
+val prerr_int : int -> unit
+(** Print an integer, in decimal, on standard error. *)
+
+val prerr_float : float -> unit
+(** Print a floating-point number, in decimal, on standard error. *)
+
+val prerr_endline : string -> unit
+(** Print a string, followed by a newline character on standard
+   error and flush standard error. *)
+
+val prerr_newline : unit -> unit
+(** Print a newline character on standard error, and flush
+   standard error. *)
+
+
+(** {7 Input functions on standard input} *)
+
+val read_line : unit -> string
+(** Flush standard output, then read characters from standard input
+   until a newline character is encountered. Return the string of
+   all characters read, without the newline character at the end. *)
+
+val read_int : unit -> int
+(** Flush standard output, then read one line from standard input
+   and convert it to an integer. Raise [Failure "int_of_string"]
+   if the line read is not a valid representation of an integer. *)
+
+val read_int_opt: unit -> int option
+(** Same as [read_int_opt], but returs [None] instead of raising.
+    @since 4.05
+*)
+
+val read_float : unit -> float
+(** Flush standard output, then read one line from standard input
+   and convert it to a floating-point number.
+   The result is unspecified if the line read is not a valid
+   representation of a floating-point number. *)
+
+val read_float_opt: unit -> float option
+(** Flush standard output, then read one line from standard input
+    and convert it to a floating-point number.
+    Returns [None] if the line read is not a valid
+    representation of a floating-point number.
+    @since 4.05.0 *)
+
+
+(** {7 General output functions} *)
+
+type open_flag =
+    Open_rdonly      (** open for reading. *)
+  | Open_wronly      (** open for writing. *)
+  | Open_append      (** open for appending: always write at end of file. *)
+  | Open_creat       (** create the file if it does not exist. *)
+  | Open_trunc       (** empty the file if it already exists. *)
+  | Open_excl        (** fail if Open_creat and the file already exists. *)
+  | Open_binary      (** open in binary mode (no conversion). *)
+  | Open_text        (** open in text mode (may perform conversions). *)
+  | Open_nonblock    (** open in non-blocking mode. *)
+(** Opening modes for {!Pervasives.open_out_gen} and
+  {!Pervasives.open_in_gen}. *)
+
+val open_out : string -> out_channel
+(** Open the named file for writing, and return a new output channel
+   on that file, positioned at the beginning of the file. The
+   file is truncated to zero length if it already exists. It
+   is created if it does not already exists. *)
+
+val open_out_bin : string -> out_channel
+(** Same as {!Pervasives.open_out}, but the file is opened in binary mode,
+   so that no translation takes place during writes. On operating
+   systems that do not distinguish between text mode and binary
+   mode, this function behaves like {!Pervasives.open_out}. *)
+
+val open_out_gen : open_flag list -> int -> string -> out_channel
+(** [open_out_gen mode perm filename] opens the named file for writing,
+   as described above. The extra argument [mode]
+   specifies the opening mode. The extra argument [perm] specifies
+   the file permissions, in case the file must be created.
+   {!Pervasives.open_out} and {!Pervasives.open_out_bin} are special
+   cases of this function. *)
+
+val flush : out_channel -> unit
+(** Flush the buffer associated with the given output channel,
+   performing all pending writes on that channel.
+   Interactive programs must be careful about flushing standard
+   output and standard error at the right time. *)
+
+val flush_all : unit -> unit
+(** Flush all open output channels; ignore errors. *)
+
+val output_char : out_channel -> char -> unit
+(** Write the character on the given output channel. *)
+
+val output_string : out_channel -> string -> unit
+(** Write the string on the given output channel. *)
+
+val output_bytes : out_channel -> bytes -> unit
+(** Write the byte sequence on the given output channel.
+   @since 4.02.0 *)
+
+val output : out_channel -> bytes -> int -> int -> unit
+(** [output oc buf pos len] writes [len] characters from byte sequence [buf],
+   starting at offset [pos], to the given output channel [oc].
+   Raise [Invalid_argument "output"] if [pos] and [len] do not
+   designate a valid range of [buf]. *)
+
+val output_substring : out_channel -> string -> int -> int -> unit
+(** Same as [output] but take a string as argument instead of
+   a byte sequence.
+   @since 4.02.0 *)
+
+val output_byte : out_channel -> int -> unit
+(** Write one 8-bit integer (as the single character with that code)
+   on the given output channel. The given integer is taken modulo
+   256. *)
+
+val output_binary_int : out_channel -> int -> unit
+(** 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 OCaml. *)
+
+val output_value : out_channel -> 'a -> unit
+(** Write the representation of a structured value of any type
+   to a channel. Circularities and sharing inside the value
+   are detected and preserved. The object can be read back,
+   by the function {!Pervasives.input_value}. See the description of module
+   {!Marshal} for more information. {!Pervasives.output_value} is equivalent
+   to {!Marshal.to_channel} with an empty list of flags. *)
+
+val seek_out : out_channel -> int -> unit
+(** [seek_out chan pos] sets the current writing position to [pos]
+   for channel [chan]. This works only for regular files. On
+   files of other kinds (such as terminals, pipes and sockets),
+   the behavior is unspecified. *)
+
+val pos_out : out_channel -> int
+(** 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 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.
+   Output functions raise a [Sys_error] exception when they are
+   applied to a closed output channel, except [close_out] and [flush],
+   which do nothing when applied to an already closed channel.
+   Note that [close_out] may raise [Sys_error] if the operating
+   system signals an error when flushing or closing. *)
+
+val close_out_noerr : out_channel -> unit
+(** Same as [close_out], but ignore all errors. *)
+
+val set_binary_mode_out : out_channel -> bool -> unit
+(** [set_binary_mode_out oc true] sets the channel [oc] to binary
+   mode: no translations take place during output.
+   [set_binary_mode_out oc false] sets the channel [oc] to text
+   mode: depending on the operating system, some translations
+   may take place during output.  For instance, under Windows,
+   end-of-lines will be translated from [\n] to [\r\n].
+   This function has no effect under operating systems that
+   do not distinguish between text mode and binary mode. *)
+
+
+(** {7 General input functions} *)
+
+val open_in : string -> in_channel
+(** Open the named file for reading, and return a new input channel
+   on that file, positioned at the beginning of the file. *)
+
+val open_in_bin : string -> in_channel
+(** Same as {!Pervasives.open_in}, but the file is opened in binary mode,
+   so that no translation takes place during reads. On operating
+   systems that do not distinguish between text mode and binary
+   mode, this function behaves like {!Pervasives.open_in}. *)
+
+val open_in_gen : open_flag list -> int -> string -> in_channel
+(** [open_in_gen mode perm filename] opens the named file for reading,
+   as described above. The extra arguments
+   [mode] and [perm] specify the opening mode and file permissions.
+   {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special
+   cases of this function. *)
+
+val input_char : in_channel -> char
+(** Read one character from the given input channel.
+   Raise [End_of_file] if there are no more characters to read. *)
+
+val input_line : in_channel -> string
+(** Read characters from the given input channel, until a
+   newline character is encountered. Return the string of
+   all characters read, without the newline character at the end.
+   Raise [End_of_file] if the end of the file is reached
+   at the beginning of line. *)
+
+val input : in_channel -> bytes -> int -> int -> int
+(** [input ic buf pos len] reads up to [len] characters from
+   the given channel [ic], storing them in byte sequence [buf], starting at
+   character number [pos].
+   It returns the actual number of characters read, between 0 and
+   [len] (inclusive).
+   A return value of 0 means that the end of file was reached.
+   A return value between 0 and [len] exclusive means that
+   not all requested [len] characters were read, either because
+   no more characters were available at that time, or because
+   the implementation found it convenient to do a partial read;
+   [input] must be called again to read the remaining characters,
+   if desired.  (See also {!Pervasives.really_input} for reading
+   exactly [len] characters.)
+   Exception [Invalid_argument "input"] is raised if [pos] and [len]
+   do not designate a valid range of [buf]. *)
+
+val really_input : in_channel -> bytes -> int -> int -> unit
+(** [really_input ic buf pos len] reads [len] characters from channel [ic],
+   storing them in byte sequence [buf], starting at character number [pos].
+   Raise [End_of_file] if the end of file is reached before [len]
+   characters have been read.
+   Raise [Invalid_argument "really_input"] if
+   [pos] and [len] do not designate a valid range of [buf]. *)
+
+val really_input_string : in_channel -> int -> string
+(** [really_input_string ic len] reads [len] characters from channel [ic]
+   and returns them in a new string.
+   Raise [End_of_file] if the end of file is reached before [len]
+   characters have been read.
+   @since 4.02.0 *)
+
+val input_byte : in_channel -> int
+(** Same as {!Pervasives.input_char}, but return the 8-bit integer representing
+   the character.
+   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 (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. *)
+
+val input_value : in_channel -> 'a
+(** Read the representation of a structured value, as produced
+   by {!Pervasives.output_value}, and return the corresponding value.
+   This function is identical to {!Marshal.from_channel};
+   see the description of module {!Marshal} for more information,
+   in particular concerning the lack of type safety. *)
+
+val seek_in : in_channel -> int -> unit
+(** [seek_in chan pos] sets the current reading position to [pos]
+   for channel [chan]. This works only for regular files. On
+   files of other kinds, the behavior is unspecified. *)
+
+val pos_in : in_channel -> int
+(** Return the current reading position for the given channel. *)
+
+val in_channel_length : in_channel -> int
+(** 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]
+  exception when they are applied to a closed input channel,
+  except [close_in], which does nothing when applied to an already
+  closed channel. *)
+
+val close_in_noerr : in_channel -> unit
+(** Same as [close_in], but ignore all errors. *)
+
+val set_binary_mode_in : in_channel -> bool -> unit
+(** [set_binary_mode_in ic true] sets the channel [ic] to binary
+   mode: no translations take place during input.
+   [set_binary_mode_out ic false] sets the channel [ic] to text
+   mode: depending on the operating system, some translations
+   may take place during input.  For instance, under Windows,
+   end-of-lines will be translated from [\r\n] to [\n].
+   This function has no effect under operating systems that
+   do not distinguish between text mode and binary mode. *)
+
+
+(** {7 Operations on large files} *)
+
+module LargeFile :
+  sig
+    val seek_out : out_channel -> int64 -> unit
+    val pos_out : out_channel -> int64
+    val out_channel_length : out_channel -> int64
+    val seek_in : in_channel -> int64 -> unit
+    val pos_in : in_channel -> int64
+    val in_channel_length : in_channel -> int64
+  end
+(** Operations on large files.
+  This sub-module provides 64-bit variants of the channel functions
+  that manipulate file positions and file sizes.  By representing
+  positions and sizes by 64-bit integers (type [int64]) instead of
+  regular integers (type [int]), these alternate functions allow
+  operating on files whose sizes are greater than [max_int]. *)
+
+
+(** {6 References} *)
+
+type 'a ref = { mutable contents : 'a }
+(** The type of references (mutable indirection cells) containing
+   a value of type ['a]. *)
+
+external ref : 'a -> 'a ref = "%makemutable"
+(** Return a fresh reference containing the given value. *)
+
+external ( ! ) : 'a ref -> 'a = "%field0"
+(** [!r] returns the current contents of reference [r].
+   Equivalent to [fun r -> r.contents]. *)
+
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+(** [r := a] stores the value of [a] in reference [r].
+   Equivalent to [fun r v -> r.contents <- v]. *)
+
+external incr : int ref -> unit = "%incr"
+(** Increment the integer contained in the given reference.
+   Equivalent to [fun r -> r := succ !r]. *)
+
+external decr : int ref -> unit = "%decr"
+(** Decrement the integer contained in the given reference.
+   Equivalent to [fun r -> r := pred !r]. *)
+
+(** {6 Result type} *)
+
+(** @since 4.03.0 *)
+type ('a,'b) result = Ok of 'a | Error of 'b
+
+(** {6 Operations on format strings} *)
+
+(** Format strings are character strings with special lexical conventions
+  that defines the functionality of formatted input/output functions. Format
+  strings are used to read data with formatted input functions from module
+  {!Scanf} and to print data with formatted output functions from modules
+  {!Printf} and {!Format}.
+
+  Format strings are made of three kinds of entities:
+  - {e conversions specifications}, introduced by the special character ['%']
+    followed by one or more characters specifying what kind of argument to
+    read or print,
+  - {e formatting indications}, introduced by the special character ['@']
+    followed by one or more characters specifying how to read or print the
+    argument,
+  - {e plain characters} that are regular characters with usual lexical
+    conventions. Plain characters specify string literals to be read in the
+    input or printed in the output.
+
+  There is an additional lexical rule to escape the special characters ['%']
+  and ['@'] in format strings: if a special character follows a ['%']
+  character, it is treated as a plain character. In other words, ["%%"] is
+  considered as a plain ['%'] and ["%@"] as a plain ['@'].
+
+  For more information about conversion specifications and formatting
+  indications available, read the documentation of modules {!Scanf},
+  {!Printf} and {!Format}.
+*)
+
+(** Format strings have a general and highly polymorphic type
+    [('a, 'b, 'c, 'd, 'e, 'f) format6].
+    The two simplified types, [format] and [format4] below are
+    included for backward compatibility with earlier releases of
+    OCaml.
+
+    The meaning of format string type parameters is as follows:
+
+    - ['a] is the type of the parameters of the format for formatted output
+      functions ([printf]-style functions);
+      ['a] is the type of the values read by the format for formatted input
+      functions ([scanf]-style functions).
+
+    - ['b] is the type of input source for formatted input functions and the
+      type of output target for formatted output functions.
+      For [printf]-style functions from module {!Printf}, ['b] is typically
+      [out_channel];
+      for [printf]-style functions from module {!Format}, ['b] is typically
+      {!Format.formatter};
+      for [scanf]-style functions from module {!Scanf}, ['b] is typically
+      {!Scanf.Scanning.in_channel}.
+
+      Type argument ['b] is also the type of the first argument given to
+      user's defined printing functions for [%a] and [%t] conversions,
+      and user's defined reading functions for [%r] conversion.
+
+    - ['c] is the type of the result of the [%a] and [%t] printing
+      functions, and also the type of the argument transmitted to the
+      first argument of [kprintf]-style functions or to the
+      [kscanf]-style functions.
+
+    - ['d] is the type of parameters for the [scanf]-style functions.
+
+    - ['e] is the type of the receiver function for the [scanf]-style functions.
+
+    - ['f] is the final result type of a formatted input/output function
+      invocation: for the [printf]-style functions, it is typically [unit];
+      for the [scanf]-style functions, it is typically the result type of the
+      receiver function.
+*)
+
+type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+  ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+
+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+
+type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+
+val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string
+(** Converts a format string into a string. *)
+
+external format_of_string :
+  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+  ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+(** [format_of_string s] returns a format string read from the string
+    literal [s].
+    Note: [format_of_string] can not convert a string argument that is not a
+    literal. If you need this functionality, use the more general
+    {!Scanf.format_from_string} function.
+*)
+
+val ( ^^ ) :
+  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+  ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
+  ('a, 'b, 'c, 'd, 'g, 'h) format6
+(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
+  format string that behaves as the concatenation of format strings [f1] and
+  [f2]: in case of formatted output, it accepts arguments from [f1], then
+  arguments from [f2]; in case of formatted input, it returns results from
+  [f1], then results from [f2].
+*)
+
+
+(** {6 Program termination} *)
+
+val exit : int -> 'a
+(** Terminate the process, returning the given status code
+   to the operating system: usually 0 to indicate no errors,
+   and a small positive integer to indicate failure.
+   All open output channels are flushed with [flush_all].
+   An implicit [exit 0] is performed each time a program
+   terminates normally.  An implicit [exit 2] is performed if the program
+   terminates early because of an uncaught exception. *)
+
+val at_exit : (unit -> unit) -> unit
+(** Register the given function to be called at program
+   termination time. The functions registered with [at_exit]
+   will be called when the program executes {!Pervasives.exit},
+   or terminates, either normally or because of an uncaught exception.
+   The functions are called in 'last in, first out' order:
+   the function most recently added with [at_exit] is called first. *)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+val valid_float_lexem : string -> string
+
+val unsafe_really_input : in_channel -> bytes -> int -> int -> unit
+
+val do_at_exit : unit -> unit
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
new file mode 100644
index 00000000..90214d9f
--- /dev/null
+++ b/stdlib/printexc.ml
@@ -0,0 +1,324 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+let printers = ref []
+
+let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s"
+
+let field x i =
+  let f = Obj.field x i in
+  if not (Obj.is_block f) then
+    sprintf "%d" (Obj.magic f : int)           (* can also be a char *)
+  else if Obj.tag f = Obj.string_tag then
+    sprintf "%S" (Obj.magic f : string)
+  else if Obj.tag f = Obj.double_tag then
+    string_of_float (Obj.magic f : float)
+  else
+    "_"
+
+let rec other_fields x i =
+  if i >= Obj.size x then ""
+  else sprintf ", %s%s" (field x i) (other_fields x (i+1))
+
+let fields x =
+  match Obj.size x with
+  | 0 -> ""
+  | 1 -> ""
+  | 2 -> sprintf "(%s)" (field x 1)
+  | _ -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
+
+let to_string x =
+  let rec conv = function
+    | hd :: tl ->
+        (match try hd x with _ -> None with
+        | Some s -> s
+        | None -> conv tl)
+    | [] ->
+        match x with
+        | Out_of_memory -> "Out of memory"
+        | Stack_overflow -> "Stack overflow"
+        | Match_failure(file, line, char) ->
+            sprintf locfmt file line char (char+5) "Pattern matching failed"
+        | Assert_failure(file, line, char) ->
+            sprintf locfmt file line char (char+6) "Assertion failed"
+        | Undefined_recursive_module(file, line, char) ->
+            sprintf locfmt file line char (char+6) "Undefined recursive module"
+        | _ ->
+            let x = Obj.repr x in
+            if Obj.tag x <> 0 then
+              (Obj.magic (Obj.field x 0) : string)
+            else
+              let constructor =
+                (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
+              constructor ^ (fields x) in
+  conv !printers
+
+let print fct arg =
+  try
+    fct arg
+  with x ->
+    eprintf "Uncaught exception: %s\n" (to_string x);
+    flush stderr;
+    raise x
+
+let catch fct arg =
+  try
+    fct arg
+  with x ->
+    flush stdout;
+    eprintf "Uncaught exception: %s\n" (to_string x);
+    exit 2
+
+type raw_backtrace_slot
+type raw_backtrace
+
+external get_raw_backtrace:
+  unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
+
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+  = "%raise_with_backtrace"
+
+type backtrace_slot =
+  | Known_location of {
+      is_raise    : bool;
+      filename    : string;
+      line_number : int;
+      start_char  : int;
+      end_char    : int;
+      is_inline   : bool;
+    }
+  | Unknown_location of {
+      is_raise : bool
+    }
+
+(* to avoid warning *)
+let _ = [Known_location { is_raise = false; filename = "";
+                          line_number = 0; start_char = 0; end_char = 0;
+                          is_inline = false };
+         Unknown_location { is_raise = false }]
+
+external convert_raw_backtrace_slot:
+  raw_backtrace_slot -> backtrace_slot = "caml_convert_raw_backtrace_slot"
+
+external convert_raw_backtrace:
+  raw_backtrace -> backtrace_slot array = "caml_convert_raw_backtrace"
+
+let convert_raw_backtrace bt =
+  try Some (convert_raw_backtrace bt)
+  with Failure _ -> None
+
+let format_backtrace_slot pos slot =
+  let info is_raise =
+    if is_raise then
+      if pos = 0 then "Raised at" else "Re-raised at"
+    else
+      if pos = 0 then "Raised by primitive operation at" else "Called from"
+  in
+  match slot with
+  | Unknown_location l ->
+      if l.is_raise then
+        (* compiler-inserted re-raise, skipped *) None
+      else
+        Some (sprintf "%s unknown location" (info false))
+  | Known_location l ->
+      Some (sprintf "%s file \"%s\"%s, line %d, characters %d-%d"
+              (info l.is_raise) l.filename
+              (if l.is_inline then " (inlined)" else "")
+              l.line_number l.start_char l.end_char)
+
+let print_exception_backtrace outchan backtrace =
+  match backtrace with
+  | None ->
+      fprintf outchan
+        "(Program not linked with -g, cannot print stack backtrace)\n"
+  | Some a ->
+      for i = 0 to Array.length a - 1 do
+        match format_backtrace_slot i a.(i) with
+          | None -> ()
+          | Some str -> fprintf outchan "%s\n" str
+      done
+
+let print_raw_backtrace outchan raw_backtrace =
+  print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
+
+(* confusingly named: prints the global current backtrace *)
+let print_backtrace outchan =
+  print_raw_backtrace outchan (get_raw_backtrace ())
+
+let backtrace_to_string backtrace =
+  match backtrace with
+  | None ->
+     "(Program not linked with -g, cannot print stack backtrace)\n"
+  | Some a ->
+      let b = Buffer.create 1024 in
+      for i = 0 to Array.length a - 1 do
+        match format_backtrace_slot i a.(i) with
+          | None -> ()
+          | Some str -> bprintf b "%s\n" str
+      done;
+      Buffer.contents b
+
+let raw_backtrace_to_string raw_backtrace =
+  backtrace_to_string (convert_raw_backtrace raw_backtrace)
+
+let backtrace_slot_is_raise = function
+  | Known_location l -> l.is_raise
+  | Unknown_location l -> l.is_raise
+
+let backtrace_slot_is_inline = function
+  | Known_location l -> l.is_inline
+  | Unknown_location _ -> false
+
+type location = {
+  filename : string;
+  line_number : int;
+  start_char : int;
+  end_char : int;
+}
+
+let backtrace_slot_location = function
+  | Unknown_location _ -> None
+  | Known_location l ->
+    Some {
+      filename    = l.filename;
+      line_number = l.line_number;
+      start_char  = l.start_char;
+      end_char    = l.end_char;
+    }
+
+let backtrace_slots raw_backtrace =
+  (* The documentation of this function guarantees that Some is
+     returned only if a part of the trace is usable. This gives us
+     a bit more work than just convert_raw_backtrace, but it makes the
+     API more user-friendly -- otherwise most users would have to
+     reimplement the "Program not linked with -g, sorry" logic
+     themselves. *)
+  match convert_raw_backtrace raw_backtrace with
+    | None -> None
+    | Some backtrace ->
+      let usable_slot = function
+        | Unknown_location _ -> false
+        | Known_location _ -> true in
+      let rec exists_usable = function
+        | (-1) -> false
+        | i -> usable_slot backtrace.(i) || exists_usable (i - 1) in
+      if exists_usable (Array.length backtrace - 1)
+      then Some backtrace
+      else None
+
+module Slot = struct
+  type t = backtrace_slot
+  let format = format_backtrace_slot
+  let is_raise = backtrace_slot_is_raise
+  let is_inline = backtrace_slot_is_inline
+  let location = backtrace_slot_location
+end
+
+external raw_backtrace_length :
+  raw_backtrace -> int = "caml_raw_backtrace_length" [@@noalloc]
+
+external get_raw_backtrace_slot :
+  raw_backtrace -> int -> raw_backtrace_slot = "caml_raw_backtrace_slot"
+
+external get_raw_backtrace_next_slot :
+  raw_backtrace_slot -> raw_backtrace_slot option
+  = "caml_raw_backtrace_next_slot"
+
+(* confusingly named:
+   returns the *string* corresponding to the global current backtrace *)
+let get_backtrace () = raw_backtrace_to_string (get_raw_backtrace ())
+
+external record_backtrace: bool -> unit = "caml_record_backtrace"
+external backtrace_status: unit -> bool = "caml_backtrace_status"
+
+let register_printer fn =
+  printers := fn :: !printers
+
+external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
+
+let exn_slot x =
+  let x = Obj.repr x in
+  if Obj.tag x = 0 then Obj.field x 0 else x
+
+let exn_slot_id x =
+  let slot = exn_slot x in
+  (Obj.obj (Obj.field slot 1) : int)
+
+let exn_slot_name x =
+  let slot = exn_slot x in
+  (Obj.obj (Obj.field slot 0) : string)
+
+
+let uncaught_exception_handler = ref None
+
+let set_uncaught_exception_handler fn = uncaught_exception_handler := Some fn
+
+let empty_backtrace : raw_backtrace = Obj.obj (Obj.new_block Obj.abstract_tag 0)
+
+let try_get_raw_backtrace () =
+  try
+    get_raw_backtrace ()
+  with _ (* Out_of_memory? *) ->
+    empty_backtrace
+
+let handle_uncaught_exception' exn debugger_in_use =
+  try
+    (* Get the backtrace now, in case one of the [at_exit] function
+       destroys it. *)
+    let raw_backtrace =
+      if debugger_in_use (* Same test as in [byterun/printexc.c] *) then
+        empty_backtrace
+      else
+        try_get_raw_backtrace ()
+    in
+    (try Pervasives.do_at_exit () with _ -> ());
+    match !uncaught_exception_handler with
+    | None ->
+        eprintf "Fatal error: exception %s\n" (to_string exn);
+        print_raw_backtrace stderr raw_backtrace;
+        flush stderr
+    | Some handler ->
+        try
+          handler exn raw_backtrace
+        with exn' ->
+          let raw_backtrace' = try_get_raw_backtrace () in
+          eprintf "Fatal error: exception %s\n" (to_string exn);
+          print_raw_backtrace stderr raw_backtrace;
+          eprintf "Fatal error in uncaught exception handler: exception %s\n"
+            (to_string exn');
+          print_raw_backtrace stderr raw_backtrace';
+          flush stderr
+  with
+    | Out_of_memory ->
+        prerr_endline
+          "Fatal error: out of memory in uncaught exception handler"
+
+(* This function is called by [caml_fatal_uncaught_exception] in
+   [byterun/printexc.c] which expects no exception is raised. *)
+let handle_uncaught_exception exn debugger_in_use =
+  try
+    handle_uncaught_exception' exn debugger_in_use
+  with _ ->
+    (* There is not much we can do at this point *)
+    ()
+
+external register_named_value : string -> 'a -> unit
+  = "caml_register_named_value"
+
+let () =
+  register_named_value "Printexc.handle_uncaught_exception"
+    handle_uncaught_exception
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
new file mode 100644
index 00000000..cc865085
--- /dev/null
+++ b/stdlib/printexc.mli
@@ -0,0 +1,342 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Facilities for printing exceptions and inspecting current call stack. *)
+
+val to_string: exn -> string
+(** [Printexc.to_string e] returns a string representation of
+   the exception [e]. *)
+
+val print: ('a -> 'b) -> 'a -> 'b
+(** [Printexc.print fn x] applies [fn] to [x] and returns the result.
+   If the evaluation of [fn x] raises any exception, the
+   name of the exception is printed on standard error output,
+   and the exception is raised again.
+   The typical use is to catch and report exceptions that
+   escape a function application. *)
+
+val catch: ('a -> 'b) -> 'a -> 'b
+(** [Printexc.catch fn x] is similar to {!Printexc.print}, but
+   aborts the program with exit code 2 after printing the
+   uncaught exception.  This function is deprecated: the runtime
+   system is now able to print uncaught exceptions as precisely
+   as [Printexc.catch] does.  Moreover, calling [Printexc.catch]
+   makes it harder to track the location of the exception
+   using the debugger or the stack backtrace facility.
+   So, do not use [Printexc.catch] in new code.  *)
+
+val print_backtrace: out_channel -> unit
+(** [Printexc.print_backtrace oc] prints an exception backtrace
+    on the output channel [oc].  The backtrace lists the program
+    locations where the most-recently raised exception was raised
+    and where it was propagated through function calls.
+
+    If the call is not inside an exception handler, the returned
+    backtrace is unspecified. If the call is after some
+    exception-catching code (before in the handler, or in a when-guard
+    during the matching of the exception handler), the backtrace may
+    correspond to a later exception than the handled one.
+
+    @since 3.11.0
+*)
+
+val get_backtrace: unit -> string
+(** [Printexc.get_backtrace ()] returns a string containing the
+    same exception backtrace that [Printexc.print_backtrace] would
+    print. Same restriction usage than {!print_backtrace}.
+    @since 3.11.0
+*)
+
+val record_backtrace: bool -> unit
+(** [Printexc.record_backtrace b] turns recording of exception backtraces
+    on (if [b = true]) or off (if [b = false]).  Initially, backtraces
+    are not recorded, unless the [b] flag is given to the program
+    through the [OCAMLRUNPARAM] variable.
+    @since 3.11.0
+*)
+
+val backtrace_status: unit -> bool
+(** [Printexc.backtrace_status()] returns [true] if exception
+    backtraces are currently recorded, [false] if not.
+    @since 3.11.0
+*)
+
+val register_printer: (exn -> string option) -> unit
+(** [Printexc.register_printer fn] registers [fn] as an exception
+    printer.  The printer should return [None] or raise an exception
+    if it does not know how to convert the passed exception, and [Some
+    s] with [s] the resulting string if it can convert the passed
+    exception. Exceptions raised by the printer are ignored.
+
+    When converting an exception into a string, the printers will be invoked
+    in the reverse order of their registrations, until a printer returns
+    a [Some s] value (if no such printer exists, the runtime will use a
+    generic printer).
+
+    When using this mechanism, one should be aware that an exception backtrace
+    is attached to the thread that saw it raised, rather than to the exception
+    itself. Practically, it means that the code related to [fn] should not use
+    the backtrace if it has itself raised an exception before.
+    @since 3.11.2
+*)
+
+(** {6 Raw backtraces} *)
+
+type raw_backtrace
+(** The abstract type [raw_backtrace] stores a backtrace in
+    a low-level format, instead of directly exposing them as string as
+    the [get_backtrace()] function does.
+
+    This allows delaying the formatting of backtraces to when they are
+    actually printed, which may be useful if you record more
+    backtraces than you print.
+
+    Raw backtraces cannot be marshalled. If you need marshalling, you
+    should use the array returned by the [backtrace_slots] function of
+    the next section.
+
+    @since 4.01.0
+*)
+
+val get_raw_backtrace: unit -> raw_backtrace
+(** [Printexc.get_raw_backtrace ()] returns the same exception
+    backtrace that [Printexc.print_backtrace] would print, but in
+    a raw format. Same restriction usage than {!print_backtrace}.
+
+    @since 4.01.0
+*)
+
+val print_raw_backtrace: out_channel -> raw_backtrace -> unit
+(** Print a raw backtrace in the same format
+    [Printexc.print_backtrace] uses.
+
+    @since 4.01.0
+*)
+
+val raw_backtrace_to_string: raw_backtrace -> string
+(** Return a string from a raw backtrace, in the same format
+    [Printexc.get_backtrace] uses.
+
+    @since 4.01.0
+*)
+
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+  = "%raise_with_backtrace"
+(** Reraise the exception using the given raw_backtrace for the
+    origin of the exception
+
+    @since 4.05.0
+*)
+
+(** {6 Current call stack} *)
+
+val get_callstack: int -> raw_backtrace
+(** [Printexc.get_callstack n] returns a description of the top of the
+    call stack on the current program point (for the current thread),
+    with at most [n] entries.  (Note: this function is not related to
+    exceptions at all, despite being part of the [Printexc] module.)
+
+    @since 4.01.0
+*)
+
+(** {6 Uncaught exceptions} *)
+
+val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
+(** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler
+    for uncaught exceptions. The default handler prints the exception and
+    backtrace on standard error output.
+
+    Note that when [fn] is called all the functions registered with
+    {!Pervasives.at_exit} have already been called. Because of this you must
+    make sure any output channel [fn] writes on is flushed.
+
+    Also note that exceptions raised by user code in the interactive toplevel
+    are not passed to this function as they are caught by the toplevel itself.
+
+    If [fn] raises an exception, both the exceptions passed to [fn] and raised
+    by [fn] will be printed with their respective backtrace.
+
+    @since 4.02.0
+*)
+
+
+(** {6 Manipulation of backtrace information}
+
+    These functions are used to traverse the slots of a raw backtrace
+    and extract information from them in a programmer-friendly format.
+*)
+
+type backtrace_slot
+(** The abstract type [backtrace_slot] represents a single slot of
+    a backtrace.
+
+    @since 4.02
+*)
+
+val backtrace_slots : raw_backtrace -> backtrace_slot array option
+(** Returns the slots of a raw backtrace, or [None] if none of them
+    contain useful information.
+
+    In the return array, the slot at index [0] corresponds to the most
+    recent function call, raise, or primitive [get_backtrace] call in
+    the trace.
+
+    Some possible reasons for returning [None] are as follow:
+    - none of the slots in the trace come from modules compiled with
+    debug information ([-g])
+    - the program is a bytecode program that has not been linked with
+    debug information enabled ([ocamlc -g])
+
+    @since 4.02.0
+*)
+
+type location = {
+  filename : string;
+  line_number : int;
+  start_char : int;
+  end_char : int;
+}
+(** The type of location information found in backtraces. [start_char]
+    and [end_char] are positions relative to the beginning of the
+    line.
+
+    @since 4.02
+*)
+
+(** @since 4.02.0 *)
+module Slot : sig
+  type t = backtrace_slot
+
+  val is_raise : t -> bool
+  (** [is_raise slot] is [true] when [slot] refers to a raising
+      point in the code, and [false] when it comes from a simple
+      function call.
+
+      @since 4.02
+  *)
+
+  val is_inline : t -> bool
+  (** [is_inline slot] is [true] when [slot] refers to a call
+      that got inlined by the compiler, and [false] when it comes from
+      any other context.
+
+      @since 4.04.0
+  *)
+
+  val location : t -> location option
+  (** [location slot] returns the location information of the slot,
+      if available, and [None] otherwise.
+
+      Some possible reasons for failing to return a location are as follow:
+      - the slot corresponds to a compiler-inserted raise
+      - the slot corresponds to a part of the program that has not been
+      compiled with debug information ([-g])
+
+      @since 4.02
+  *)
+
+  val format : int -> t -> string option
+  (** [format pos slot] returns the string representation of [slot] as
+      [raw_backtrace_to_string] would format it, assuming it is the
+      [pos]-th element of the backtrace: the [0]-th element is
+      pretty-printed differently than the others.
+
+      Whole-backtrace printing functions also skip some uninformative
+      slots; in that case, [format pos slot] returns [None].
+
+      @since 4.02
+  *)
+end
+
+
+(** {6 Raw backtrace slots} *)
+
+type raw_backtrace_slot
+(** This type allows direct access to raw backtrace slots, without any
+    conversion in an OCaml-usable data-structure. Being
+    process-specific, they must absolutely not be marshalled, and are
+    unsafe to use for this reason (marshalling them may not fail, but
+    un-marshalling and using the result will result in
+    undefined behavior).
+
+    Elements of this type can still be compared and hashed: when two
+    elements are equal, then they represent the same source location
+    (the converse is not necessarily true in presence of inlining,
+    for example).
+
+    @since 4.02.0
+*)
+
+val raw_backtrace_length : raw_backtrace -> int
+(** [raw_backtrace_length bckt] returns the number of slots in the
+    backtrace [bckt].
+
+    @since 4.02
+*)
+
+val get_raw_backtrace_slot : raw_backtrace -> int -> raw_backtrace_slot
+(** [get_raw_backtrace_slot bckt pos] returns the slot in position [pos] in the
+    backtrace [bckt].
+
+    @since 4.02
+*)
+
+val convert_raw_backtrace_slot : raw_backtrace_slot -> backtrace_slot
+(** Extracts the user-friendly [backtrace_slot] from a low-level
+    [raw_backtrace_slot].
+
+    @since 4.02
+*)
+
+
+val get_raw_backtrace_next_slot :
+    raw_backtrace_slot -> raw_backtrace_slot option
+(** [get_raw_backtrace_next_slot slot] returns the next slot inlined, if any.
+
+    Sample code to iterate over all frames (inlined and non-inlined):
+    {[
+      (* Iterate over inlined frames *)
+      let rec iter_raw_backtrace_slot f slot =
+        f slot;
+        match get_raw_backtrace_next_slot slot with
+        | None -> ()
+        | Some slot' -> iter_raw_backtrace_slot f slot'
+
+      (* Iterate over stack frames *)
+      let iter_raw_backtrace f bt =
+        for i = 0 to raw_backtrace_length bt - 1 do
+          iter_raw_backtrace_slot f (get_raw_backtrace_slot bt i)
+        done
+    ]}
+
+    @since 4.04.0
+*)
+
+(** {6 Exception slots} *)
+
+val exn_slot_id: exn -> int
+(** [Printexc.exn_slot_id] returns an integer which uniquely identifies
+    the constructor used to create the exception value [exn]
+    (in the current runtime).
+
+    @since 4.02.0
+*)
+
+val exn_slot_name: exn -> string
+(** [Printexc.exn_slot_name exn] returns the internal name of the constructor
+    used to create the exception value [exn].
+
+    @since 4.02.0
+*)
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
new file mode 100644
index 00000000..136cbe56
--- /dev/null
+++ b/stdlib/printf.ml
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy and Pierre Weis, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open CamlinternalFormatBasics
+open CamlinternalFormat
+
+let kfprintf k o (Format (fmt, _)) =
+  make_printf (fun o acc -> output_acc o acc; k o) o End_of_acc fmt
+let kbprintf k b (Format (fmt, _)) =
+  make_printf (fun b acc -> bufput_acc b acc; k b) b End_of_acc fmt
+let ikfprintf k oc (Format (fmt, _)) =
+  make_iprintf k oc fmt
+
+let fprintf oc fmt = kfprintf ignore oc fmt
+let bprintf b fmt = kbprintf ignore b fmt
+let ifprintf oc fmt = ikfprintf ignore oc fmt
+let printf fmt = fprintf stdout fmt
+let eprintf fmt = fprintf stderr fmt
+
+let ksprintf k (Format (fmt, _)) =
+  let k' () acc =
+    let buf = Buffer.create 64 in
+    strput_acc buf acc;
+    k (Buffer.contents buf) in
+  make_printf k' () End_of_acc fmt
+
+let sprintf fmt = ksprintf (fun s -> s) fmt
+
+let kprintf = ksprintf
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
new file mode 100644
index 00000000..92a3b16e
--- /dev/null
+++ b/stdlib/printf.mli
@@ -0,0 +1,172 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Xavier Leroy and Pierre Weis, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Formatted output functions. *)
+
+val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
+(** [fprintf outchan format arg1 ... argN] formats the arguments
+   [arg1] to [argN] according to the format string [format], and
+   outputs the resulting string on the channel [outchan].
+
+   The format string is a character string which contains two types of
+   objects: plain characters, which are simply copied to the output
+   channel, and conversion specifications, each of which causes
+   conversion and printing of arguments.
+
+   Conversion specifications have the following form:
+
+   [% [flags] [width] [.precision] type]
+
+   In short, a conversion specification consists in the [%] character,
+   followed by optional modifiers and a type which is made of one or
+   two characters.
+
+   The types and their meanings are:
+
+   - [d], [i]: convert an integer argument to signed decimal.
+   - [u], [n], [l], [L], or [N]: convert an integer argument to
+     unsigned decimal.  Warning: [n], [l], [L], and [N] are
+     used for [scanf], and should not be used for [printf].
+   - [x]: convert an integer argument to unsigned hexadecimal,
+     using lowercase letters.
+   - [X]: convert an integer argument to unsigned hexadecimal,
+     using uppercase letters.
+   - [o]: convert an integer argument to unsigned octal.
+   - [s]: insert a string argument.
+   - [S]: convert a string argument to OCaml syntax (double quotes, escapes).
+   - [c]: insert a character argument.
+   - [C]: convert a character argument to OCaml syntax
+     (single quotes, escapes).
+   - [f]: convert a floating-point argument to decimal notation,
+     in the style [dddd.ddd].
+   - [F]: convert a floating-point argument to OCaml syntax ([dddd.]
+     or [dddd.ddd] or [d.ddd e+-dd]).
+   - [e] or [E]: convert a floating-point argument to decimal notation,
+     in the style [d.ddd e+-dd] (mantissa and exponent).
+   - [g] or [G]: convert a floating-point argument to decimal notation,
+     in style [f] or [e], [E] (whichever is more compact).
+   - [h] or [H]: convert a floating-point argument to hexadecimal notation,
+     in the style [0xh.hhhh e+-dd] (hexadecimal mantissa, exponent in
+     decimal and denotes a power of 2).
+   - [B]: convert a boolean argument to the string [true] or [false]
+   - [b]: convert a boolean argument (deprecated; do not use in new
+     programs).
+   - [ld], [li], [lu], [lx], [lX], [lo]: convert an [int32] argument to
+     the format specified by the second letter (decimal, hexadecimal, etc).
+   - [nd], [ni], [nu], [nx], [nX], [no]: convert a [nativeint] argument to
+     the format specified by the second letter.
+   - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to
+     the format specified by the second letter.
+   - [a]: user-defined printer. Take two arguments and apply the
+     first one to [outchan] (the current output channel) and to the
+     second argument. The first argument must therefore have type
+     [out_channel -> 'b -> unit] and the second ['b].
+     The output produced by the function is inserted in the output of
+     [fprintf] at the current point.
+   - [t]: same as [%a], but take only one argument (with type
+     [out_channel -> unit]) and apply it to [outchan].
+   - [\{ fmt %\}]: convert a format string argument to its type digest.
+     The argument must have the same type as the internal format string
+     [fmt].
+   - [( fmt %)]: format string substitution. Take a format string
+     argument and substitute it to the internal format string [fmt]
+     to print following arguments. The argument must have the same
+     type as the internal format string [fmt].
+   - [!]: take no argument and flush the output.
+   - [%]: take no argument and output one [%] character.
+   - [\@]: take no argument and output one [\@] character.
+   - [,]: take no argument and output nothing: a no-op delimiter for
+     conversion specifications.
+
+   The optional [flags] are:
+   - [-]: left-justify the output (default is right justification).
+   - [0]: for numerical conversions, pad with zeroes instead of spaces.
+   - [+]: for signed numerical conversions, prefix number with a [+]
+     sign if positive.
+   - space: for signed numerical conversions, prefix number with a
+     space if positive.
+   - [#]: request an alternate formatting style for the hexadecimal
+     and octal integer types ([x], [X], [o], [lx], [lX], [lo], [Lx],
+     [LX], [Lo]).
+
+   The optional [width] is an integer indicating the minimal
+   width of the result. For instance, [%6d] prints an integer,
+   prefixing it with spaces to fill at least 6 characters.
+
+   The optional [precision] is a dot [.] followed by an integer
+   indicating how many digits follow the decimal point in the [%f],
+   [%e], and [%E] conversions. For instance, [%.4f] prints a [float] with
+   4 fractional digits.
+
+   The integer in a [width] or [precision] can also be specified as
+   [*], in which case an extra integer argument is taken to specify
+   the corresponding [width] or [precision]. This integer argument
+   precedes immediately the argument to print.
+   For instance, [%.*f] prints a [float] with as many fractional
+   digits as the value of the argument given before the float. *)
+
+val printf : ('a, out_channel, unit) format -> 'a
+(** Same as {!Printf.fprintf}, but output on [stdout]. *)
+
+val eprintf : ('a, out_channel, unit) format -> 'a
+(** Same as {!Printf.fprintf}, but output on [stderr]. *)
+
+val sprintf : ('a, unit, string) format -> 'a
+(** Same as {!Printf.fprintf}, but instead of printing on an output channel,
+   return a string containing the result of formatting the arguments. *)
+
+val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a
+(** Same as {!Printf.fprintf}, but instead of printing on an output channel,
+   append the formatted arguments to the given extensible buffer
+   (see module {!Buffer}). *)
+
+val ifprintf : 'b -> ('a, 'b, 'c, unit) format4 -> 'a
+(** Same as {!Printf.fprintf}, but does not print anything.
+    Useful to ignore some material when conditionally printing.
+    @since 3.10.0
+*)
+
+(** Formatted output functions with continuations. *)
+
+val kfprintf : (out_channel -> 'd) -> out_channel ->
+              ('a, out_channel, unit, 'd) format4 -> 'a
+(** Same as [fprintf], but instead of returning immediately,
+   passes the out channel to its first argument at the end of printing.
+   @since 3.09.0
+*)
+
+val ikfprintf : ('b -> 'd) -> 'b -> ('a, 'b, 'c, 'd) format4 -> 'a
+(** Same as [kfprintf] above, but does not print anything.
+   Useful to ignore some material when conditionally printing.
+   @since 4.01.0
+*)
+
+val ksprintf : (string -> 'd) -> ('a, unit, string, 'd) format4 -> 'a
+(** Same as [sprintf] above, but instead of returning the string,
+   passes it to the first argument.
+   @since 3.09.0
+*)
+
+val kbprintf : (Buffer.t -> 'd) -> Buffer.t ->
+              ('a, Buffer.t, unit, 'd) format4 -> 'a
+(** Same as [bprintf], but instead of returning immediately,
+   passes the buffer to its first argument at the end of printing.
+   @since 3.10.0
+*)
+
+(** Deprecated *)
+
+val kprintf : (string -> 'b) -> ('a, unit, string, 'b) format4 -> 'a
+(** A deprecated synonym for [ksprintf]. *)
diff --git a/stdlib/queue.ml b/stdlib/queue.ml
new file mode 100644
index 00000000..ffda7a46
--- /dev/null
+++ b/stdlib/queue.ml
@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Francois Pottier, projet Cristal, INRIA Rocquencourt           *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Empty
+
+type 'a cell =
+  | Nil
+  | Cons of { content: 'a; mutable next: 'a cell }
+
+type 'a t = {
+  mutable length: int;
+  mutable first: 'a cell;
+  mutable last: 'a cell
+}
+
+let create () = {
+  length = 0;
+  first = Nil;
+  last = Nil
+}
+
+let clear q =
+  q.length <- 0;
+  q.first <- Nil;
+  q.last <- Nil
+
+let add x q =
+  let cell = Cons {
+    content = x;
+    next = Nil
+  } in
+  match q.last with
+  | Nil ->
+    q.length <- 1;
+    q.first <- cell;
+    q.last <- cell
+  | Cons last ->
+    q.length <- q.length + 1;
+    last.next <- cell;
+    q.last <- cell
+
+let push =
+  add
+
+let peek q =
+  match q.first with
+  | Nil -> raise Empty
+  | Cons { content } -> content
+
+let top =
+  peek
+
+let take q =
+  match q.first with
+  | Nil -> raise Empty
+  | Cons { content; next = Nil } ->
+    clear q;
+    content
+  | Cons { content; next } ->
+    q.length <- q.length - 1;
+    q.first <- next;
+    content
+
+let pop =
+  take
+
+let copy =
+  let rec copy q_res prev cell =
+    match cell with
+    | Nil -> q_res.last <- prev; q_res
+    | Cons { content; next } ->
+      let res = Cons { content; next = Nil } in
+      begin match prev with
+      | Nil -> q_res.first <- res
+      | Cons p -> p.next <- res
+      end;
+      copy q_res res next
+  in
+  fun q -> copy { length = q.length; first = Nil; last = Nil } Nil q.first
+
+let is_empty q =
+  q.length = 0
+
+let length q =
+  q.length
+
+let iter =
+  let rec iter f cell =
+    match cell with
+    | Nil -> ()
+    | Cons { content; next } ->
+      f content;
+      iter f next
+  in
+  fun f q -> iter f q.first
+
+let fold =
+  let rec fold f accu cell =
+    match cell with
+    | Nil -> accu
+    | Cons { content; next } ->
+      let accu = f accu content in
+      fold f accu next
+  in
+  fun f accu q -> fold f accu q.first
+
+let transfer q1 q2 =
+  if q1.length > 0 then
+    match q2.last with
+    | Nil ->
+      q2.length <- q1.length;
+      q2.first <- q1.first;
+      q2.last <- q1.last;
+      clear q1
+    | Cons last ->
+      q2.length <- q2.length + q1.length;
+      last.next <- q1.first;
+      q2.last <- q1.last;
+      clear q1
diff --git a/stdlib/queue.mli b/stdlib/queue.mli
new file mode 100644
index 00000000..46e48fd0
--- /dev/null
+++ b/stdlib/queue.mli
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** First-in first-out queues.
+
+   This module implements queues (FIFOs), with in-place modification.
+
+   {b Warning} This module is not thread-safe: each {!Queue.t} value
+   must be protected from concurrent access (e.g. with a [Mutex.t]).
+   Failure to do so can lead to a crash.
+*)
+
+type 'a t
+(** The type of queues containing elements of type ['a]. *)
+
+
+exception Empty
+(** Raised when {!Queue.take} or {!Queue.peek} is applied to an empty queue. *)
+
+
+val create : unit -> 'a t
+(** Return a new queue, initially empty. *)
+
+val add : 'a -> 'a t -> unit
+(** [add x q] adds the element [x] at the end of the queue [q]. *)
+
+val push : 'a -> 'a t -> unit
+(** [push] is a synonym for [add]. *)
+
+val take : 'a t -> 'a
+(** [take q] removes and returns the first element in queue [q],
+   or raises {!Empty} if the queue is empty. *)
+
+val pop : 'a t -> 'a
+(** [pop] is a synonym for [take]. *)
+
+val peek : 'a t -> 'a
+(** [peek q] returns the first element in queue [q], without removing
+   it from the queue, or raises {!Empty} if the queue is empty. *)
+
+val top : 'a t -> 'a
+(** [top] is a synonym for [peek]. *)
+
+val clear : 'a t -> unit
+(** Discard all elements from a queue. *)
+
+val copy : 'a t -> 'a t
+(** Return a copy of the given queue. *)
+
+val is_empty : 'a t -> bool
+(** Return [true] if the given queue is empty, [false] otherwise. *)
+
+val length : 'a t -> int
+(** Return the number of elements in a queue. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f q] applies [f] in turn to all elements of [q],
+   from the least recently entered to the most recently entered.
+   The queue itself is unchanged. *)
+
+val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+(** [fold f accu q] is equivalent to [List.fold_left f accu l],
+   where [l] is the list of [q]'s elements. The queue remains
+   unchanged. *)
+
+val transfer : 'a t -> 'a t -> unit
+(** [transfer q1 q2] adds all of [q1]'s elements at the end of
+   the queue [q2], then clears [q1]. It is equivalent to the
+   sequence [iter (fun x -> add x q2) q1; clear q1], but runs
+   in constant time. *)
diff --git a/stdlib/random.ml b/stdlib/random.ml
new file mode 100644
index 00000000..76e9fa17
--- /dev/null
+++ b/stdlib/random.ml
@@ -0,0 +1,277 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Pseudo-random number generator
+   This is a lagged-Fibonacci F(55, 24, +) with a modified addition
+   function to enhance the mixing of bits.
+   If we use normal addition, the low-order bit fails tests 1 and 7
+   of the Diehard test suite, and bits 1 and 2 also fail test 7.
+   If we use multiplication as suggested by Marsaglia, it doesn't fare
+   much better.
+   By mixing the bits of one of the numbers before addition (XOR the
+   5 high-order bits into the low-order bits), we get a generator that
+   passes all the Diehard tests.
+*)
+
+external random_seed: unit -> int array = "caml_sys_random_seed"
+
+module State = struct
+
+  type t = { st : int array; mutable idx : int }
+
+  let new_state () = { st = Array.make 55 0; idx = 0 }
+  let assign st1 st2 =
+    Array.blit st2.st 0 st1.st 0 55;
+    st1.idx <- st2.idx
+
+
+  let full_init s seed =
+    let combine accu x = Digest.string (accu ^ string_of_int x) in
+    let extract d =
+      Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16)
+      + (Char.code d.[3] lsl 24)
+    in
+    let seed = if Array.length seed = 0 then [| 0 |] else seed in
+    let l = Array.length seed in
+    for i = 0 to 54 do
+      s.st.(i) <- i;
+    done;
+    let accu = ref "x" in
+    for i = 0 to 54 + max 55 l do
+      let j = i mod 55 in
+      let k = i mod l in
+      accu := combine !accu seed.(k);
+      s.st.(j) <- (s.st.(j) lxor extract !accu) land 0x3FFFFFFF;  (* PR#5575 *)
+    done;
+    s.idx <- 0
+
+
+  let make seed =
+    let result = new_state () in
+    full_init result seed;
+    result
+
+
+  let make_self_init () = make (random_seed ())
+
+  let copy s =
+    let result = new_state () in
+    assign result s;
+    result
+
+
+  (* Returns 30 random bits as an integer 0 <= x < 1073741824 *)
+  let bits s =
+    s.idx <- (s.idx + 1) mod 55;
+    let curval = s.st.(s.idx) in
+    let newval = s.st.((s.idx + 24) mod 55)
+                 + (curval lxor ((curval lsr 25) land 0x1F)) in
+    let newval30 = newval land 0x3FFFFFFF in  (* PR#5575 *)
+    s.st.(s.idx) <- newval30;
+    newval30
+
+
+  let rec intaux s n =
+    let r = bits s in
+    let v = r mod n in
+    if r - v > 0x3FFFFFFF - n + 1 then intaux s n else v
+
+  let int s bound =
+    if bound > 0x3FFFFFFF || bound <= 0
+    then invalid_arg "Random.int"
+    else intaux s bound
+
+
+  let rec int32aux s n =
+    let b1 = Int32.of_int (bits s) in
+    let b2 = Int32.shift_left (Int32.of_int (bits s land 1)) 30 in
+    let r = Int32.logor b1 b2 in
+    let v = Int32.rem r n in
+    if Int32.sub r v > Int32.add (Int32.sub Int32.max_int n) 1l
+    then int32aux s n
+    else v
+
+  let int32 s bound =
+    if bound <= 0l
+    then invalid_arg "Random.int32"
+    else int32aux s bound
+
+
+  let rec int64aux s n =
+    let b1 = Int64.of_int (bits s) in
+    let b2 = Int64.shift_left (Int64.of_int (bits s)) 30 in
+    let b3 = Int64.shift_left (Int64.of_int (bits s land 7)) 60 in
+    let r = Int64.logor b1 (Int64.logor b2 b3) in
+    let v = Int64.rem r n in
+    if Int64.sub r v > Int64.add (Int64.sub Int64.max_int n) 1L
+    then int64aux s n
+    else v
+
+  let int64 s bound =
+    if bound <= 0L
+    then invalid_arg "Random.int64"
+    else int64aux s bound
+
+
+  let nativeint =
+    if Nativeint.size = 32
+    then fun s bound -> Nativeint.of_int32 (int32 s (Nativeint.to_int32 bound))
+    else fun s bound -> Int64.to_nativeint (int64 s (Int64.of_nativeint bound))
+
+
+  (* Returns a float 0 <= x <= 1 with at most 60 bits of precision. *)
+  let rawfloat s =
+    let scale = 1073741824.0  (* 2^30 *)
+    and r1 = Pervasives.float (bits s)
+    and r2 = Pervasives.float (bits s)
+    in (r1 /. scale +. r2) /. scale
+
+
+  let float s bound = rawfloat s *. bound
+
+  let bool s = (bits s land 1 = 0)
+
+end
+
+(* This is the state you get with [init 27182818] and then applying
+   the "land 0x3FFFFFFF" filter to them.  See #5575, #5793, #5977. *)
+let default = {
+  State.st = [|
+      0x3ae2522b; 0x1d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x3b086c47;
+      0x16d467d6; 0x101d91c7; 0x321df177; 0x0176c193; 0x1ff72bf1; 0x1e889109;
+      0x0b464b18; 0x2b86b97c; 0x0891da48; 0x03137463; 0x085ac5a1; 0x15d61f2f;
+      0x3bced359; 0x29c1c132; 0x3a86766e; 0x366d8c86; 0x1f5b6222; 0x3ce1b59f;
+      0x2ebf78e1; 0x27cd1b86; 0x258f3dc3; 0x389a8194; 0x02e4c44c; 0x18c43f7d;
+      0x0f6e534f; 0x1e7df359; 0x055d0b7e; 0x10e84e7e; 0x126198e4; 0x0e7722cb;
+      0x1cbede28; 0x3391b964; 0x3d40e92a; 0x0c59933d; 0x0b8cd0b7; 0x24efff1c;
+      0x2803fdaa; 0x08ebc72e; 0x0f522e32; 0x05398edc; 0x2144a04c; 0x0aef3cbd;
+      0x01ad4719; 0x35b93cd6; 0x2a559d4f; 0x1e6fd768; 0x26e27f36; 0x186f18c3;
+      0x2fbf967a;
+    |];
+  State.idx = 0;
+}
+
+let bits () = State.bits default
+let int bound = State.int default bound
+let int32 bound = State.int32 default bound
+let nativeint bound = State.nativeint default bound
+let int64 bound = State.int64 default bound
+let float scale = State.float default scale
+let bool () = State.bool default
+
+let full_init seed = State.full_init default seed
+let init seed = State.full_init default [| seed |]
+let self_init () = full_init (random_seed())
+
+(* Manipulating the current state. *)
+
+let get_state () = State.copy default
+let set_state s = State.assign default s
+
+(********************
+
+(* Test functions.  Not included in the library.
+   The [chisquare] function should be called with n > 10r.
+   It returns a triple (low, actual, high).
+   If low <= actual <= high, the [g] function passed the test,
+   otherwise it failed.
+
+  Some results:
+
+init 27182818; chisquare int 100000 1000
+init 27182818; chisquare int 100000 100
+init 27182818; chisquare int 100000 5000
+init 27182818; chisquare int 1000000 1000
+init 27182818; chisquare int 100000 1024
+init 299792643; chisquare int 100000 1024
+init 14142136; chisquare int 100000 1024
+init 27182818; init_diff 1024; chisquare diff 100000 1024
+init 27182818; init_diff 100; chisquare diff 100000 100
+init 27182818; init_diff2 1024; chisquare diff2 100000 1024
+init 27182818; init_diff2 100; chisquare diff2 100000 100
+init 14142136; init_diff2 100; chisquare diff2 100000 100
+init 299792643; init_diff2 100; chisquare diff2 100000 100
+- : float * float * float = (936.754446796632465, 997.5, 1063.24555320336754)
+# - : float * float * float = (80., 89.7400000000052387, 120.)
+# - : float * float * float = (4858.57864376269, 5045.5, 5141.42135623731)
+# - : float * float * float =
+(936.754446796632465, 944.805999999982305, 1063.24555320336754)
+# - : float * float * float = (960., 1019.19744000000355, 1088.)
+# - : float * float * float = (960., 1059.31776000000536, 1088.)
+# - : float * float * float = (960., 1039.98463999999512, 1088.)
+# - : float * float * float = (960., 1054.38207999999577, 1088.)
+# - : float * float * float = (80., 90.096000000005, 120.)
+# - : float * float * float = (960., 1076.78720000000612, 1088.)
+# - : float * float * float = (80., 85.1760000000067521, 120.)
+# - : float * float * float = (80., 85.2160000000003492, 120.)
+# - : float * float * float = (80., 80.6220000000030268, 120.)
+
+*)
+
+(* Return the sum of the squares of v[i0,i1[ *)
+let rec sumsq v i0 i1 =
+  if i0 >= i1 then 0.0
+  else if i1 = i0 + 1 then Pervasives.float v.(i0) *. Pervasives.float v.(i0)
+  else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1
+
+
+let chisquare g n r =
+  if n <= 10 * r then invalid_arg "chisquare";
+  let f = Array.make r 0 in
+  for i = 1 to n do
+    let t = g r in
+    f.(t) <- f.(t) + 1
+  done;
+  let t = sumsq f 0 r
+  and r = Pervasives.float r
+  and n = Pervasives.float n in
+  let sr = 2.0 *. sqrt r in
+  (r -. sr,   (r *. t /. n) -. n,   r +. sr)
+
+
+(* This is to test for linear dependencies between successive random numbers.
+*)
+let st = ref 0
+let init_diff r = st := int r
+let diff r =
+  let x1 = !st
+  and x2 = int r
+  in
+  st := x2;
+  if x1 >= x2 then
+    x1 - x2
+  else
+    r + x1 - x2
+
+
+let st1 = ref 0
+and st2 = ref 0
+
+
+(* This is to test for quadratic dependencies between successive random
+   numbers.
+*)
+let init_diff2 r = st1 := int r; st2 := int r
+let diff2 r =
+  let x1 = !st1
+  and x2 = !st2
+  and x3 = int r
+  in
+  st1 := x2;
+  st2 := x3;
+  (x3 - x2 - x2 + x1 + 2*r) mod r
+
+
+********************)
diff --git a/stdlib/random.mli b/stdlib/random.mli
new file mode 100644
index 00000000..0cbaace3
--- /dev/null
+++ b/stdlib/random.mli
@@ -0,0 +1,107 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Pseudo-random number generators (PRNG). *)
+
+(** {6 Basic functions} *)
+
+val init : int -> unit
+(** Initialize the generator, using the argument as a seed.
+     The same seed will always yield the same sequence of numbers. *)
+
+val full_init : int array -> unit
+(** Same as {!Random.init} but takes more data as seed. *)
+
+val self_init : unit -> unit
+(** Initialize the generator with a random seed chosen
+   in a system-dependent way.  If [/dev/urandom] is available on
+   the host machine, it is used to provide a highly random initial
+   seed.  Otherwise, a less random seed is computed from system
+   parameters (current time, process IDs). *)
+
+val bits : unit -> int
+(** Return 30 random bits in a nonnegative integer.
+    @before 3.12.0 used a different algorithm (affects all the following
+                   functions)
+*)
+
+val int : int -> int
+(** [Random.int bound] returns a random integer between 0 (inclusive)
+     and [bound] (exclusive).  [bound] must be greater than 0 and less
+     than 2{^30}. *)
+
+val int32 : Int32.t -> Int32.t
+(** [Random.int32 bound] returns a random integer between 0 (inclusive)
+     and [bound] (exclusive).  [bound] must be greater than 0. *)
+
+val nativeint : Nativeint.t -> Nativeint.t
+(** [Random.nativeint bound] returns a random integer between 0 (inclusive)
+     and [bound] (exclusive).  [bound] must be greater than 0. *)
+
+val int64 : Int64.t -> Int64.t
+(** [Random.int64 bound] returns a random integer between 0 (inclusive)
+     and [bound] (exclusive).  [bound] must be greater than 0. *)
+
+val float : float -> float
+(** [Random.float bound] returns a random floating-point number
+   between 0 and [bound] (inclusive).  If [bound] is
+   negative, the result is negative or zero.  If [bound] is 0,
+   the result is 0. *)
+
+val bool : unit -> bool
+(** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *)
+
+
+(** {6 Advanced functions} *)
+
+(** The functions from module {!State} manipulate the current state
+    of the random generator explicitly.
+    This allows using one or several deterministic PRNGs,
+    even in a multi-threaded program, without interference from
+    other parts of the program.
+*)
+
+module State : sig
+  type t
+  (** The type of PRNG states. *)
+
+  val make : int array -> t
+  (** Create a new state and initialize it with the given seed. *)
+
+  val make_self_init : unit -> t
+  (** Create a new state and initialize it with a system-dependent
+      low-entropy seed. *)
+
+  val copy : t -> t
+  (** Return a copy of the given state. *)
+
+  val bits : t -> int
+  val int : t -> int -> int
+  val int32 : t -> Int32.t -> Int32.t
+  val nativeint : t -> Nativeint.t -> Nativeint.t
+  val int64 : t -> Int64.t -> Int64.t
+  val float : t -> float -> float
+  val bool : t -> bool
+  (** These functions are the same as the basic functions, except that they
+      use (and update) the given PRNG state instead of the default one.
+  *)
+end
+
+
+val get_state : unit -> State.t
+(** Return the current state of the generator used by the basic functions. *)
+
+val set_state : State.t -> unit
+(** Set the state of the generator used by the basic functions. *)
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
new file mode 100644
index 00000000..7be353a1
--- /dev/null
+++ b/stdlib/scanf.ml
@@ -0,0 +1,1574 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open CamlinternalFormatBasics
+open CamlinternalFormat
+
+(* alias to avoid warning for ambiguity between
+   Pervasives.format6
+   and CamlinternalFormatBasics.format6
+
+   (the former is in fact an alias for the latter,
+    but the ambiguity warning doesn't care)
+*)
+type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+  ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6
+
+
+(* The run-time library for scanners. *)
+
+(* Scanning buffers. *)
+module type SCANNING = sig
+
+  type in_channel
+
+  type scanbuf = in_channel
+
+  type file_name = string
+
+  val stdin : in_channel
+  (* The scanning buffer reading from [Pervasives.stdin].
+     [stdib] is equivalent to [Scanning.from_channel Pervasives.stdin]. *)
+
+  val stdib : in_channel
+  (* An alias for [Scanf.stdin], the scanning buffer reading from
+     [Pervasives.stdin]. *)
+
+  val next_char : scanbuf -> char
+  (* [Scanning.next_char ib] advance the scanning buffer for
+     one character.
+     If no more character can be read, sets a end of file condition and
+     returns '\000'. *)
+
+  val invalidate_current_char : scanbuf -> unit
+  (* [Scanning.invalidate_current_char ib] mark the current_char as already
+     scanned. *)
+
+  val peek_char : scanbuf -> char
+  (* [Scanning.peek_char ib] returns the current char available in
+     the buffer or reads one if necessary (when the current character is
+     already scanned).
+     If no character can be read, sets an end of file condition and
+     returns '\000'. *)
+
+  val checked_peek_char : scanbuf -> char
+  (* Same as [Scanning.peek_char] 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 : int -> scanbuf -> char -> int
+  (* [Scanning.store_char lim ib c] adds [c] to the token buffer
+     of the scanning buffer [ib]. It also advances the scanning buffer for
+     one character and returns [lim - 1], indicating the new limit for the
+     length of the current token. *)
+
+  val skip_char : int -> scanbuf -> int
+  (* [Scanning.skip_char lim ib] ignores the current character. *)
+
+  val ignore_char : int -> scanbuf -> int
+  (* [Scanning.ignore_char ib lim] ignores the current character and
+     decrements the limit. *)
+
+  val token : scanbuf -> string
+  (* [Scanning.token ib] returns the string stored into the token
+     buffer of the scanning buffer: it returns the token matched by the
+     format. *)
+
+  val reset_token : scanbuf -> unit
+  (* [Scanning.reset_token ib] resets the token buffer of
+     the given scanning buffer. *)
+
+  val char_count : scanbuf -> int
+  (* [Scanning.char_count ib] returns the number of characters
+     read so far from the given buffer. *)
+
+  val line_count : scanbuf -> int
+  (* [Scanning.line_count ib] returns the number of new line
+     characters read so far from the given buffer. *)
+
+  val token_count : scanbuf -> int
+  (* [Scanning.token_count ib] returns the number of tokens read
+     so far from [ib]. *)
+
+  val eof : scanbuf -> bool
+  (* [Scanning.eof ib] returns the end of input condition
+     of the given buffer. *)
+
+  val end_of_input : scanbuf -> bool
+  (* [Scanning.end_of_input ib] tests the end of input condition
+     of the given buffer (if no char has ever been read, an attempt to
+     read one is performed). *)
+
+  val beginning_of_input : scanbuf -> bool
+  (* [Scanning.beginning_of_input ib] tests the beginning of input
+     condition of the given buffer. *)
+
+  val name_of_input : scanbuf -> string
+  (* [Scanning.name_of_input ib] returns the name of the character
+     source for input buffer [ib]. *)
+
+  val open_in : file_name -> in_channel
+  val open_in_bin : file_name -> in_channel
+  val from_file : file_name -> in_channel
+  val from_file_bin : file_name -> in_channel
+  val from_string : string -> in_channel
+  val from_function : (unit -> char) -> in_channel
+  val from_channel : Pervasives.in_channel -> in_channel
+
+  val close_in : in_channel -> unit
+
+  val memo_from_channel : Pervasives.in_channel -> in_channel
+  (* Obsolete. *)
+
+end
+
+
+module Scanning : SCANNING = struct
+
+  (* The run-time library for scanf. *)
+
+  type file_name = string
+
+  type in_channel_name =
+    | From_channel of Pervasives.in_channel
+    | From_file of file_name * Pervasives.in_channel
+    | From_function
+    | From_string
+
+
+  type in_channel = {
+    mutable ic_eof : bool;
+    mutable ic_current_char : char;
+    mutable ic_current_char_is_valid : bool;
+    mutable ic_char_count : int;
+    mutable ic_line_count : int;
+    mutable ic_token_count : int;
+    mutable ic_get_next_char : unit -> char;
+    ic_token_buffer : Buffer.t;
+    ic_input_name : in_channel_name;
+  }
+
+
+  type scanbuf = in_channel
+
+  let null_char = '\000'
+
+  (* 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
+      let c = ib.ic_get_next_char () in
+      ib.ic_current_char <- c;
+      ib.ic_current_char_is_valid <- true;
+      ib.ic_char_count <- succ ib.ic_char_count;
+      if c = '\n' then ib.ic_line_count <- succ ib.ic_line_count;
+      c with
+    | End_of_file ->
+      let c = null_char in
+      ib.ic_current_char <- c;
+      ib.ic_current_char_is_valid <- false;
+      ib.ic_eof <- true;
+      c
+
+
+  let peek_char ib =
+    if ib.ic_current_char_is_valid
+    then ib.ic_current_char
+    else next_char ib
+
+
+  (* Returns a valid current char for the input buffer. In particular
+     no irrelevant null character (as set by [next_char] in case of end
+     of input) is returned, since [End_of_file] is raised when
+     [next_char] sets the end of file condition while trying to read a
+     new character. *)
+  let checked_peek_char ib =
+    let c = peek_char ib in
+    if ib.ic_eof then raise End_of_file;
+    c
+
+
+  let end_of_input ib =
+    ignore (peek_char ib);
+    ib.ic_eof
+
+
+  let eof ib = ib.ic_eof
+
+  let beginning_of_input ib = ib.ic_char_count = 0
+
+  let name_of_input ib =
+    match ib.ic_input_name with
+    | From_channel _ic -> "unnamed Pervasives input channel"
+    | From_file (fname, _ic) -> fname
+    | From_function -> "unnamed function"
+    | From_string -> "unnamed character string"
+
+
+  let char_count ib =
+    if ib.ic_current_char_is_valid
+    then ib.ic_char_count - 1
+    else ib.ic_char_count
+
+
+  let line_count ib = ib.ic_line_count
+
+  let reset_token ib = Buffer.reset ib.ic_token_buffer
+
+  let invalidate_current_char ib = ib.ic_current_char_is_valid <- false
+
+  let token ib =
+    let token_buffer = ib.ic_token_buffer in
+    let tok = Buffer.contents token_buffer in
+    Buffer.clear token_buffer;
+    ib.ic_token_count <- succ ib.ic_token_count;
+    tok
+
+
+  let token_count ib = ib.ic_token_count
+
+  let skip_char width ib =
+    invalidate_current_char ib;
+    width
+
+
+  let ignore_char width ib = skip_char (width - 1) ib
+
+  let store_char width ib c =
+    Buffer.add_char ib.ic_token_buffer c;
+    ignore_char width ib
+
+
+  let default_token_buffer_size = 1024
+
+  let create iname next = {
+    ic_eof = false;
+    ic_current_char = null_char;
+    ic_current_char_is_valid = false;
+    ic_char_count = 0;
+    ic_line_count = 0;
+    ic_token_count = 0;
+    ic_get_next_char = next;
+    ic_token_buffer = Buffer.create default_token_buffer_size;
+    ic_input_name = iname;
+  }
+
+
+  let from_string s =
+    let i = ref 0 in
+    let len = String.length s in
+    let next () =
+      if !i >= len then raise End_of_file else
+      let c = s.[!i] in
+      incr i;
+      c in
+    create From_string next
+
+
+  let from_function = create From_function
+
+  (* Scanning from an input channel. *)
+
+  (* Position of the problem:
+
+     We cannot prevent the scanning mechanism to use one lookahead character,
+     if needed by the semantics of the format string specifications (e.g. a
+     trailing 'skip space' specification in the format string); in this case,
+     the mandatory lookahead character is indeed read from the input and not
+     used to return the token read. It is thus mandatory to be able to store
+     an unused lookahead character somewhere to get it as the first character
+     of the next scan.
+
+     To circumvent this problem, all the scanning functions get a low level
+     input buffer argument where they store the lookahead character when
+     needed; additionally, the input buffer is the only source of character of
+     a scanner. The [scanbuf] input buffers are defined in module {!Scanning}.
+
+     Now we understand that it is extremely important that related and
+     successive calls to scanners indeed read from the same input buffer.
+     In effect, if a scanner [scan1] is reading from [ib1] and stores an
+     unused lookahead character [c1] into its input buffer [ib1], then
+     another scanner [scan2] not reading from the same buffer [ib1] will miss
+     the character [c1], seemingly vanished in the air from the point of view
+     of [scan2].
+
+     This mechanism works perfectly to read from strings, from files, and from
+     functions, since in those cases, allocating two buffers reading from the
+     same source is unnatural.
+
+     Still, there is a difficulty in the case of scanning from an input
+     channel. In effect, when scanning from an input channel [ic], this channel
+     may not have been allocated from within this library. Hence, it may be
+     shared (two functions of the user's program may successively read from
+     [ic]). This is highly error prone since, one of the function may seek the
+     input channel, while the other function has still an unused lookahead
+     character in its input buffer. In conclusion, you should never mix direct
+     low level reading and high level scanning from the same input channel.
+
+  *)
+
+  (* Perform bufferized input to improve efficiency. *)
+  let file_buffer_size = ref 1024
+
+  (* The scanner closes the input channel at end of input. *)
+  let scan_close_at_end ic = Pervasives.close_in ic; raise End_of_file
+
+  (* The scanner does not close the input channel at end of input:
+     it just raises [End_of_file]. *)
+  let scan_raise_at_end _ic = raise End_of_file
+
+  let from_ic scan_close_ic iname ic =
+    let len = !file_buffer_size in
+    let buf = Bytes.create len in
+    let i = ref 0 in
+    let lim = ref 0 in
+    let eof = ref false in
+    let next () =
+      if !i < !lim then begin let c = Bytes.get buf !i in incr i; c end else
+      if !eof then raise End_of_file else begin
+        lim := input ic buf 0 len;
+        if !lim = 0 then begin eof := true; scan_close_ic ic end else begin
+          i := 1;
+          Bytes.get buf 0
+        end
+      end in
+    create iname next
+
+
+  let from_ic_close_at_end = from_ic scan_close_at_end
+  let from_ic_raise_at_end = from_ic scan_raise_at_end
+
+  (* The scanning buffer reading from [Pervasives.stdin].
+     One could try to define [stdib] as a scanning buffer reading a character
+     at a time (no bufferization at all), but unfortunately the top-level
+     interaction would be wrong. This is due to some kind of
+     'race condition' when reading from [Pervasives.stdin],
+     since the interactive compiler and [Scanf.scanf] will simultaneously
+     read the material they need from [Pervasives.stdin]; then, confusion
+     will result from what should be read by the top-level and what should be
+     read by [Scanf.scanf].
+     This is even more complicated by the one character lookahead that
+     [Scanf.scanf] is sometimes obliged to maintain: the lookahead character
+     will be available for the next [Scanf.scanf] entry, seemingly coming from
+     nowhere.
+     Also no [End_of_file] is raised when reading from stdin: if not enough
+     characters have been read, we simply ask to read more. *)
+  let stdin =
+    from_ic scan_raise_at_end
+      (From_file ("-", Pervasives.stdin)) Pervasives.stdin
+
+
+  let stdib = stdin
+
+  let open_in_file open_in fname =
+    match fname with
+    | "-" -> stdin
+    | fname ->
+      let ic = open_in fname in
+      from_ic_close_at_end (From_file (fname, ic)) ic
+
+
+  let open_in = open_in_file Pervasives.open_in
+  let open_in_bin = open_in_file Pervasives.open_in_bin
+
+  let from_file = open_in
+  let from_file_bin = open_in_bin
+
+  let from_channel ic =
+    from_ic_raise_at_end (From_channel ic) ic
+
+
+  let close_in ib =
+    match ib.ic_input_name with
+    | From_channel ic ->
+      Pervasives.close_in ic
+    | From_file (_fname, ic) -> Pervasives.close_in ic
+    | From_function | From_string -> ()
+
+
+  (*
+     Obsolete: a memo [from_channel] version to build a [Scanning.in_channel]
+     scanning buffer out of a [Pervasives.in_channel].
+     This function was used to try to preserve the scanning
+     semantics for the (now obsolete) function [fscanf].
+     Given that all scanner must read from a [Scanning.in_channel] scanning
+     buffer, [fscanf] must read from one!
+     More precisely, given [ic], all successive calls [fscanf ic] must read
+     from the same scanning buffer.
+     This obliged this library to allocated scanning buffers that were
+     not properly garbbage collectable, hence leading to memory leaks.
+     If you need to read from a [Pervasives.in_channel] input channel
+     [ic], simply define a [Scanning.in_channel] formatted input channel as in
+     [let ib = Scanning.from_channel ic], then use [Scanf.bscanf ib] as usual.
+  *)
+  let memo_from_ic =
+    let memo = ref [] in
+    (fun scan_close_ic ic ->
+     try List.assq ic !memo with
+     | Not_found ->
+       let ib =
+         from_ic scan_close_ic (From_channel ic) ic in
+       memo := (ic, ib) :: !memo;
+       ib)
+
+
+  (* Obsolete: see {!memo_from_ic} above. *)
+  let memo_from_channel = memo_from_ic scan_raise_at_end
+
+end
+
+
+(* Formatted input functions. *)
+
+type ('a, 'b, 'c, 'd) scanner =
+     ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c
+
+
+(* Reporting errors. *)
+exception Scan_failure of string
+
+let bad_input s = raise (Scan_failure s)
+
+let bad_input_escape c =
+  bad_input (Printf.sprintf "illegal escape character %C" c)
+
+
+let bad_token_length message =
+  bad_input
+    (Printf.sprintf
+       "scanning of %s failed: \
+        the specified length was too short for token"
+       message)
+
+
+let bad_end_of_input message =
+  bad_input
+    (Printf.sprintf
+       "scanning of %s failed: \
+        premature end of file occurred before end of token"
+       message)
+
+
+let bad_float () =
+  bad_input "no dot or exponent part found in float token"
+
+
+let bad_hex_float () =
+  bad_input "not a valid float in hexadecimal notation"
+
+
+let character_mismatch_err c ci =
+  Printf.sprintf "looking for %C, found %C" c ci
+
+
+let character_mismatch c ci =
+  bad_input (character_mismatch_err c ci)
+
+
+let rec skip_whites ib =
+  let c = Scanning.peek_char ib in
+  if not (Scanning.eof ib) then begin
+    match c with
+    | ' ' | '\t' | '\n' | '\r' ->
+      Scanning.invalidate_current_char ib; skip_whites ib
+    | _ -> ()
+  end
+
+
+(* Checking that [c] is indeed in the input, then skips it.
+   In this case, the character [c] has been explicitly specified in the
+   format as being mandatory in the input; hence we should fail with
+   [End_of_file] in case of end_of_input.
+   (Remember that [Scan_failure] is raised only when (we can prove by
+   evidence) that the input does not match the format string given. We must
+   thus differentiate [End_of_file] as an error due to lack of input, and
+   [Scan_failure] which is due to provably wrong input. I am not sure this is
+   worth the burden: it is complex and somehow subliminal; should be clearer
+   to fail with Scan_failure "Not enough input to complete scanning"!)
+
+   That's why, waiting for a better solution, we use checked_peek_char here.
+   We are also careful to treat "\r\n" in the input as an end of line marker:
+   it always matches a '\n' specification in the input format string. *)
+let rec check_char ib c =
+  match c with
+  | ' ' -> skip_whites ib
+  | '\n' -> check_newline ib
+  | c -> check_this_char ib c
+
+and check_this_char ib c =
+  let ci = Scanning.checked_peek_char ib in
+  if ci = c then Scanning.invalidate_current_char ib else
+  character_mismatch c ci
+
+and check_newline ib =
+  let ci = Scanning.checked_peek_char ib in
+  match ci with
+  | '\n' -> Scanning.invalidate_current_char ib
+  | '\r' -> Scanning.invalidate_current_char ib; check_this_char ib '\n'
+  | _ -> character_mismatch '\n' ci
+
+
+(* Extracting tokens from the output token buffer. *)
+
+let token_char ib = (Scanning.token ib).[0]
+
+let token_string = Scanning.token
+
+let token_bool ib =
+  match Scanning.token ib with
+  | "true" -> true
+  | "false" -> false
+  | s -> bad_input (Printf.sprintf "invalid boolean '%s'" s)
+
+
+(* The type of integer conversions. *)
+type integer_conversion =
+  | B_conversion (* Unsigned binary conversion *)
+  | D_conversion (* Signed decimal conversion *)
+  | I_conversion (* Signed integer conversion *)
+  | O_conversion (* Unsigned octal conversion *)
+  | U_conversion (* Unsigned decimal conversion *)
+  | X_conversion (* Unsigned hexadecimal conversion *)
+
+
+let integer_conversion_of_char = function
+  | 'b' -> B_conversion
+  | 'd' -> D_conversion
+  | 'i' -> I_conversion
+  | 'o' -> O_conversion
+  | 'u' -> U_conversion
+  | 'x' | 'X' -> X_conversion
+  | _ -> assert false
+
+
+(* Extract an integer literal token.
+   Since the functions Pervasives.*int*_of_string do not accept a leading +,
+   we skip it if necessary. *)
+let token_int_literal conv ib =
+  let tok =
+    match conv with
+    | D_conversion | I_conversion -> Scanning.token ib
+    | U_conversion -> "0u" ^ Scanning.token ib
+    | O_conversion -> "0o" ^ Scanning.token ib
+    | X_conversion -> "0x" ^ Scanning.token ib
+    | B_conversion -> "0b" ^ Scanning.token ib in
+  let l = String.length tok in
+  if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1)
+
+
+(* All the functions that convert a string to a number raise the exception
+   Failure when the conversion is not possible.
+   This exception is then trapped in [kscanf]. *)
+let token_int conv ib = int_of_string (token_int_literal conv ib)
+
+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].
+   However, we can bind and use the corresponding primitives that are
+   available in the runtime. *)
+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)
+let token_int64 conv ib = int64_of_string (token_int_literal conv ib)
+
+(* Scanning numbers. *)
+
+(* 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.
+
+   Put it in another way, the digits scanning functions scan for 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 valid digit is
+   available before calling one of the digit scanning functions). *)
+
+(* The decimal case is treated especially for optimization purposes. *)
+let rec scan_decimal_digit_star width ib =
+  if width = 0 then width else
+  let c = Scanning.peek_char ib in
+  if Scanning.eof ib then width else
+  match c with
+  | '0' .. '9' as c ->
+    let width = Scanning.store_char width ib c in
+    scan_decimal_digit_star width ib
+  | '_' ->
+    let width = Scanning.ignore_char width ib in
+    scan_decimal_digit_star width ib
+  | _ -> width
+
+
+let scan_decimal_digit_plus width ib =
+  if width = 0 then bad_token_length "decimal digits" else
+  let c = Scanning.checked_peek_char ib in
+  match c with
+  | '0' .. '9' ->
+    let width = Scanning.store_char width ib c in
+    scan_decimal_digit_star width ib
+  | c ->
+    bad_input (Printf.sprintf "character %C is not a decimal digit" c)
+
+
+(* To scan numbers from other bases, we use a predicate argument to
+   scan digits. *)
+let scan_digit_star digitp width ib =
+  let rec scan_digits width ib =
+    if width = 0 then width else
+    let c = Scanning.peek_char ib in
+    if Scanning.eof ib then width else
+    match c with
+    | c when digitp c ->
+      let width = Scanning.store_char width ib c in
+      scan_digits width ib
+    | '_' ->
+      let width = Scanning.ignore_char width ib in
+      scan_digits width ib
+    | _ -> width in
+  scan_digits width ib
+
+
+let scan_digit_plus basis digitp width ib =
+  (* Ensure we have got enough width left,
+     and read at list one digit. *)
+  if width = 0 then bad_token_length "digits" else
+  let c = Scanning.checked_peek_char ib in
+  if digitp c then
+    let width = Scanning.store_char width ib c in
+    scan_digit_star digitp width ib
+  else
+    bad_input (Printf.sprintf "character %C is not a valid %s digit" c basis)
+
+
+let is_binary_digit = function
+  | '0' .. '1' -> true
+  | _ -> false
+
+
+let scan_binary_int = scan_digit_plus "binary" is_binary_digit
+
+let is_octal_digit = function
+  | '0' .. '7' -> true
+  | _ -> false
+
+
+let scan_octal_int = scan_digit_plus "octal" is_octal_digit
+
+let is_hexa_digit = function
+  | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
+  | _ -> false
+
+
+let scan_hexadecimal_int = scan_digit_plus "hexadecimal" is_hexa_digit
+
+(* Scan a decimal integer. *)
+let scan_unsigned_decimal_int = scan_decimal_digit_plus
+
+let scan_sign width ib =
+  let c = Scanning.checked_peek_char ib in
+  match c with
+  | '+' -> Scanning.store_char width ib c
+  | '-' -> Scanning.store_char width ib c
+  | _ -> width
+
+
+let scan_optionally_signed_decimal_int width ib =
+  let width = scan_sign width ib in
+  scan_unsigned_decimal_int width ib
+
+
+(* Scan an unsigned integer that could be given in any (common) basis.
+   If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is
+   assumed to be written respectively in hexadecimal, hexadecimal,
+   octal, or binary. *)
+let scan_unsigned_int width ib =
+  match Scanning.checked_peek_char ib with
+  | '0' as c ->
+    let width = Scanning.store_char width ib c in
+    if width = 0 then width else
+    let c = Scanning.peek_char ib in
+    if Scanning.eof ib then width else
+    begin match c with
+    | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char width ib c) ib
+    | 'o' -> scan_octal_int (Scanning.store_char width ib c) ib
+    | 'b' -> scan_binary_int (Scanning.store_char width ib c) ib
+    | _ -> scan_decimal_digit_star width ib end
+  | _ -> scan_unsigned_decimal_int width ib
+
+
+let scan_optionally_signed_int width ib =
+  let width = scan_sign width ib in
+  scan_unsigned_int width ib
+
+
+let scan_int_conversion conv width ib =
+  match conv with
+  | B_conversion -> scan_binary_int width ib
+  | D_conversion -> scan_optionally_signed_decimal_int width ib
+  | I_conversion -> scan_optionally_signed_int width ib
+  | O_conversion -> scan_octal_int width ib
+  | U_conversion -> scan_unsigned_decimal_int width ib
+  | X_conversion -> scan_hexadecimal_int width ib
+
+
+(* Scanning floating point numbers. *)
+
+(* Fractional part is optional and can be reduced to 0 digits. *)
+let scan_fractional_part width ib =
+  if width = 0 then width else
+  let c = Scanning.peek_char ib in
+  if Scanning.eof ib then width else
+  match c with
+  | '0' .. '9' as c ->
+    scan_decimal_digit_star (Scanning.store_char width ib c) ib
+  | _ -> width
+
+
+(* Exp part is optional and can be reduced to 0 digits. *)
+let scan_exponent_part width ib =
+  if width = 0 then width else
+  let c = Scanning.peek_char ib in
+  if Scanning.eof ib then width else
+  match c with
+  | 'e' | 'E' as c ->
+    scan_optionally_signed_decimal_int (Scanning.store_char width ib c) ib
+  | _ -> width
+
+
+(* Scan the integer part of a floating point number, (not using the
+   OCaml lexical convention since the integer part can be empty):
+   an optional sign, followed by a possibly empty sequence of decimal
+   digits (e.g. -.1). *)
+let scan_integer_part width ib =
+  let width = scan_sign width ib in
+  scan_decimal_digit_star width ib
+
+
+(*
+   For the time being we have (as found in scanf.mli):
+   the field width is composed of an optional integer literal
+   indicating the maximal width of the token to read.
+   Unfortunately, the type-checker let the user write an optional precision,
+   since this is valid for printf format strings.
+
+   Thus, the next step for Scanf is to support a full width and precision
+   indication, more or less similar to the one for printf, possibly extended
+   to the specification of a [max, min] range for the width of the token read
+   for strings. Something like the following spec for scanf.mli:
+
+   The optional [width] is an integer indicating the maximal
+   width of the token read. For instance, [%6d] reads an integer,
+   having at most 6 characters.
+
+   The optional [precision] is a dot [.] followed by an integer:
+
+   - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E],
+   and [%F] conversions, the [precision] indicates the maximum number of
+   digits that may follow the decimal point. For instance, [%.4f] reads a
+   [float] with at most 4 fractional digits,
+
+   - in the string conversions ([%s], [%S], [%\[ range \]]), and in the
+   integer number conversions ([%i], [%d], [%u], [%x], [%o], and their
+   [int32], [int64], and [native_int] correspondent), the [precision]
+   indicates the required minimum width of the token read,
+
+   - on all other conversions, the width and precision specify the [max, min]
+   range for the width of the token read.
+*)
+let scan_float width precision ib =
+  let width = scan_integer_part width ib in
+  if width = 0 then width, precision else
+  let c = Scanning.peek_char ib in
+  if Scanning.eof ib then width, precision else
+  match c with
+  | '.' ->
+    let width = Scanning.store_char width ib c in
+    let precision = min width precision in
+    let width = width - (precision - scan_fractional_part precision ib) in
+    scan_exponent_part width ib, precision
+  | _ ->
+    scan_exponent_part width ib, precision
+
+
+let check_case_insensitive_string width ib error str =
+  let lowercase c =
+    match c with
+    | 'A' .. 'Z' ->
+      char_of_int (int_of_char c - int_of_char 'A' + int_of_char 'a')
+    | _ -> c in
+  let len = String.length str in
+  let width = ref width in
+  for i = 0 to len - 1 do
+    let c = Scanning.peek_char ib in
+    if lowercase c <> lowercase str.[i] then error ();
+    if !width = 0 then error ();
+    width := Scanning.store_char !width ib c;
+  done;
+  !width
+
+
+let scan_hex_float width precision ib =
+  if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+  let width = scan_sign width ib in
+  if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+  match Scanning.peek_char ib with
+  | '0' as c -> (
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+    let width = check_case_insensitive_string width ib bad_hex_float "x" in
+    if width = 0 || Scanning.end_of_input ib then width else
+      let width = match Scanning.peek_char ib with
+        | '.' | 'p' | 'P' -> width
+        | _ -> scan_hexadecimal_int width ib in
+      if width = 0 || Scanning.end_of_input ib then width else
+        let width = match Scanning.peek_char ib with
+          | '.' as c -> (
+            let width = Scanning.store_char width ib c in
+            if width = 0 || Scanning.end_of_input ib then width else
+              match Scanning.peek_char ib with
+              | 'p' | 'P' -> width
+              | _ ->
+                let precision = min width precision in
+                width - (precision - scan_hexadecimal_int precision ib)
+          )
+          | _ -> width in
+        if width = 0 || Scanning.end_of_input ib then width else
+          match Scanning.peek_char ib with
+          | 'p' | 'P' as c ->
+            let width = Scanning.store_char width ib c in
+            if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+            scan_optionally_signed_decimal_int width ib
+          | _ -> width
+  )
+  | 'n' | 'N' as c ->
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+    check_case_insensitive_string width ib bad_hex_float "an"
+  | 'i' | 'I' as c ->
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+    check_case_insensitive_string width ib bad_hex_float "nfinity"
+  | _ -> bad_hex_float ()
+
+
+let scan_caml_float_rest width precision ib =
+  if width = 0 || Scanning.end_of_input ib then bad_float ();
+  let width = scan_decimal_digit_star width ib in
+  if width = 0 || Scanning.end_of_input ib then bad_float ();
+  let c = Scanning.peek_char ib in
+  match c with
+  | '.' ->
+    let width = Scanning.store_char width ib c in
+    (* The effective width available for scanning the fractional part is
+       the minimum of declared precision and width left. *)
+    let precision = min width precision in
+    (* After scanning the fractional part with [precision] provisional width,
+       [width_precision] is left. *)
+    let width_precision = scan_fractional_part precision ib in
+    (* Hence, scanning the fractional part took exactly
+       [precision - width_precision] chars. *)
+    let frac_width = precision - width_precision in
+    (* And new provisional width is [width - width_precision. *)
+    let width = width - frac_width in
+    scan_exponent_part width ib
+  | 'e' | 'E' ->
+    scan_exponent_part width ib
+  | _ -> bad_float ()
+
+
+let scan_caml_float width precision ib =
+  if width = 0 || Scanning.end_of_input ib then bad_float ();
+  let width = scan_sign width ib in
+  if width = 0 || Scanning.end_of_input ib then bad_float ();
+  match Scanning.peek_char ib with
+  | '0' as c -> (
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_float ();
+    match Scanning.peek_char ib with
+    | 'x' | 'X' as c -> (
+      let width = Scanning.store_char width ib c in
+      if width = 0 || Scanning.end_of_input ib then bad_float ();
+      let width = scan_hexadecimal_int width ib in
+      if width = 0 || Scanning.end_of_input ib then bad_float ();
+      let width = match Scanning.peek_char ib with
+        | '.' as c -> (
+          let width = Scanning.store_char width ib c in
+          if width = 0 || Scanning.end_of_input ib then width else
+            match Scanning.peek_char ib with
+            | 'p' | 'P' -> width
+            | _ ->
+              let precision = min width precision in
+              width - (precision - scan_hexadecimal_int precision ib)
+        )
+        | 'p' | 'P' -> width
+        | _ -> bad_float () in
+      if width = 0 || Scanning.end_of_input ib then width else
+        match Scanning.peek_char ib with
+        | 'p' | 'P' as c ->
+          let width = Scanning.store_char width ib c in
+          if width = 0 || Scanning.end_of_input ib then bad_hex_float ();
+          scan_optionally_signed_decimal_int width ib
+        | _ -> width
+    )
+    | _ ->
+      scan_caml_float_rest width precision ib
+  )
+  | '1' .. '9' as c ->
+    let width = Scanning.store_char width ib c in
+    if width = 0 || Scanning.end_of_input ib then bad_float ();
+    scan_caml_float_rest width precision ib
+(* Special case of nan and infinity:
+  | 'i' ->
+  | 'n' ->
+*)
+  | _ -> bad_float ()
+
+
+(* Scan a regular string:
+   stops when encountering a space, if no scanning indication has been given;
+   otherwise, stops when encountering the characters in the scanning
+   indication [stp].
+   It also stops at end of file or when the maximum number of characters has
+   been read. *)
+let scan_string stp width ib =
+  let rec loop width =
+    if width = 0 then width else
+    let c = Scanning.peek_char ib in
+    if Scanning.eof ib then width else
+      match stp with
+      | Some c' when c = c' -> Scanning.skip_char width ib
+      | Some _ -> loop (Scanning.store_char width ib c)
+      | None ->
+        match c with
+        | ' ' | '\t' | '\n' | '\r' -> width
+        | _ -> loop (Scanning.store_char width ib c) in
+  loop width
+
+
+(* Scan a char: peek strictly one character in the input, whatsoever. *)
+let scan_char width ib =
+  (* The case width = 0 could not happen here, since it is tested before
+     calling scan_char, in the main scanning function.
+    if width = 0 then bad_token_length "a character" else *)
+  Scanning.store_char width ib (Scanning.checked_peek_char ib)
+
+
+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 decimal_value_of_char c = int_of_char c - int_of_char '0'
+
+let char_for_decimal_code c0 c1 c2 =
+  let c =
+    100 * decimal_value_of_char c0 +
+     10 * decimal_value_of_char c1 +
+          decimal_value_of_char c2 in
+  if c < 0 || c > 255 then
+    bad_input
+      (Printf.sprintf
+         "bad character decimal encoding \\%c%c%c" c0 c1 c2) else
+  char_of_int c
+
+
+(* The integer value corresponding to the facial value of a valid
+   hexadecimal digit character. *)
+let hexadecimal_value_of_char c =
+  let d = int_of_char c in
+  (* Could also be:
+    if d <= int_of_char '9' then d - int_of_char '0' else
+    if d <= int_of_char 'F' then 10 + d - int_of_char 'A' else
+    if d <= int_of_char 'f' then 10 + d - int_of_char 'a' else assert false
+  *)
+  if d >= int_of_char 'a' then
+    d - 87 (* 10 + int_of_char c - int_of_char 'a' *) else
+  if d >= int_of_char 'A' then
+    d - 55  (* 10 + int_of_char c - int_of_char 'A' *) else
+    d - int_of_char '0'
+
+
+let char_for_hexadecimal_code c1 c2 =
+  let c =
+    16 * hexadecimal_value_of_char c1 +
+         hexadecimal_value_of_char c2 in
+  if c < 0 || c > 255 then
+    bad_input
+      (Printf.sprintf "bad character hexadecimal encoding \\%c%c" c1 c2) else
+  char_of_int c
+
+
+(* Called in particular when encountering '\\' as starter of a char.
+   Stops before the corresponding '\''. *)
+let check_next_char message width ib =
+  if width = 0 then bad_token_length message else
+  let c = Scanning.peek_char ib in
+  if Scanning.eof ib then bad_end_of_input message else
+  c
+
+
+let check_next_char_for_char = check_next_char "a Char"
+let check_next_char_for_string = check_next_char "a String"
+
+let scan_backslash_char width ib =
+  match check_next_char_for_char width ib with
+  | '\\' | '\'' | '\"' | 'n' | 't' | 'b' | 'r' as c ->
+    Scanning.store_char width ib (char_for_backslash c)
+  | '0' .. '9' as c ->
+    let get_digit () =
+      let c = Scanning.next_char ib in
+      match c with
+      | '0' .. '9' as c -> c
+      | c -> bad_input_escape c in
+    let c0 = c in
+    let c1 = get_digit () in
+    let c2 = get_digit () in
+    Scanning.store_char (width - 2) ib (char_for_decimal_code c0 c1 c2)
+  | 'x' ->
+    let get_digit () =
+      let c = Scanning.next_char ib in
+      match c with
+      | '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' as c -> c
+      | c -> bad_input_escape c in
+    let c1 = get_digit () in
+    let c2 = get_digit () in
+    Scanning.store_char (width - 2) ib (char_for_hexadecimal_code c1 c2)
+  | c ->
+    bad_input_escape c
+
+
+(* Scan a character (an OCaml token). *)
+let scan_caml_char width ib =
+
+  let rec find_start width =
+    match Scanning.checked_peek_char ib with
+    | '\'' -> find_char (Scanning.ignore_char width ib)
+    | c -> character_mismatch '\'' c
+
+  and find_char width =
+    match check_next_char_for_char width ib with
+    | '\\' ->
+      find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib)
+    | c ->
+      find_stop (Scanning.store_char width ib c)
+
+  and find_stop width =
+    match check_next_char_for_char width ib with
+    | '\'' -> Scanning.ignore_char width ib
+    | c -> character_mismatch '\'' c in
+
+  find_start width
+
+
+(* Scan a delimited string (an OCaml token). *)
+let scan_caml_string width ib =
+
+  let rec find_start width =
+    match Scanning.checked_peek_char ib with
+    | '\"' -> find_stop (Scanning.ignore_char width ib)
+    | c -> character_mismatch '\"' c
+
+  and find_stop width =
+    match check_next_char_for_string width ib with
+    | '\"' -> Scanning.ignore_char width ib
+    | '\\' -> scan_backslash (Scanning.ignore_char width ib)
+    | c -> find_stop (Scanning.store_char width ib c)
+
+  and scan_backslash width =
+    match check_next_char_for_string width ib with
+    | '\r' -> skip_newline (Scanning.ignore_char width ib)
+    | '\n' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop (scan_backslash_char width ib)
+
+  and skip_newline width =
+    match check_next_char_for_string width ib with
+    | '\n' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop (Scanning.store_char width ib '\r')
+
+  and skip_spaces width =
+    match check_next_char_for_string width ib with
+    | ' ' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop width in
+
+  find_start width
+
+
+(* Scan a boolean (an OCaml token). *)
+let scan_bool ib =
+  let c = Scanning.checked_peek_char ib in
+  let m =
+    match c with
+    | 't' -> 4
+    | 'f' -> 5
+    | c ->
+      bad_input
+        (Printf.sprintf "the character %C cannot start a boolean" c) in
+  scan_string None m ib
+
+
+(* Scan a string containing elements in char_set and terminated by scan_indic
+   if provided. *)
+let scan_chars_in_char_set char_set scan_indic width ib =
+  let rec scan_chars i stp =
+    let c = Scanning.peek_char ib in
+    if i > 0 && not (Scanning.eof ib) &&
+       is_in_char_set char_set c &&
+       int_of_char c <> stp then
+      let _ = Scanning.store_char max_int ib c in
+      scan_chars (i - 1) stp in
+  match scan_indic with
+  | None -> scan_chars width (-1);
+  | Some c ->
+    scan_chars width (int_of_char c);
+    if not (Scanning.eof ib) then
+      let ci = Scanning.peek_char ib in
+      if c = ci
+      then Scanning.invalidate_current_char ib
+      else character_mismatch c ci
+
+
+(* The global error report function for [Scanf]. *)
+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)
+  | x -> raise x
+
+
+(* Get the content of a counter from an input buffer. *)
+let get_counter ib counter =
+  match counter with
+  | Line_counter -> Scanning.line_count ib
+  | Char_counter -> Scanning.char_count ib
+  | Token_counter -> Scanning.token_count ib
+
+
+(* Compute the width of a padding option (see "%42{" and "%123("). *)
+let width_of_pad_opt pad_opt = match pad_opt with
+  | None -> max_int
+  | Some width -> width
+
+
+let stopper_of_formatting_lit fmting =
+  if fmting = Escaped_percent then '%', "" else
+    let str = string_of_formatting_lit fmting in
+    let stp = str.[1] in
+    let sub_str = String.sub str 2 (String.length str - 2) in
+    stp, sub_str
+
+
+(******************************************************************************)
+                           (* Readers managment *)
+
+(* A call to take_format_readers on a format is evaluated into functions
+   taking readers as arguments and aggregate them into an heterogeneous list *)
+(* When all readers are taken, finally pass the list of the readers to the
+   continuation k. *)
+let rec take_format_readers : type a c d e f .
+    ((d, e) heter_list -> e) -> (a, Scanning.in_channel, c, d, e, f) fmt ->
+    d =
+fun k fmt -> match fmt with
+  | Reader fmt_rest ->
+    fun reader ->
+      let new_k readers_rest = k (Cons (reader, readers_rest)) in
+      take_format_readers new_k fmt_rest
+  | Char rest                        -> take_format_readers k rest
+  | Caml_char rest                   -> take_format_readers k rest
+  | String (_, rest)                 -> take_format_readers k rest
+  | Caml_string (_, rest)            -> take_format_readers k rest
+  | Int (_, _, _, rest)              -> take_format_readers k rest
+  | Int32 (_, _, _, rest)            -> take_format_readers k rest
+  | Nativeint (_, _, _, rest)        -> take_format_readers k rest
+  | Int64 (_, _, _, rest)            -> take_format_readers k rest
+  | Float (_, _, _, rest)            -> take_format_readers k rest
+  | Bool rest                        -> take_format_readers k rest
+  | Alpha rest                       -> take_format_readers k rest
+  | Theta rest                       -> take_format_readers k rest
+  | Flush rest                       -> take_format_readers k rest
+  | String_literal (_, rest)         -> take_format_readers k rest
+  | Char_literal (_, rest)           -> take_format_readers k rest
+  | Custom (_, _, rest)              -> take_format_readers k rest
+
+  | Scan_char_set (_, _, rest)       -> take_format_readers k rest
+  | Scan_get_counter (_, rest)       -> take_format_readers k rest
+  | Scan_next_char rest              -> take_format_readers k rest
+
+  | Formatting_lit (_, rest)         -> take_format_readers k rest
+  | Formatting_gen (Open_tag (Format (fmt, _)), rest) ->
+      take_format_readers k (concat_fmt fmt rest)
+  | Formatting_gen (Open_box (Format (fmt, _)), rest) ->
+      take_format_readers k (concat_fmt fmt rest)
+
+  | Format_arg (_, _, rest)          -> take_format_readers k rest
+  | Format_subst (_, fmtty, rest)    ->
+     take_fmtty_format_readers k (erase_rel (symm fmtty)) rest
+  | Ignored_param (ign, rest)        -> take_ignored_format_readers k ign rest
+
+  | End_of_format                    -> k Nil
+
+(* Take readers associated to an fmtty coming from a Format_subst "%(...%)". *)
+and take_fmtty_format_readers : type x y a c d e f .
+    ((d, e) heter_list -> e) -> (a, Scanning.in_channel, c, d, x, y) fmtty ->
+      (y, Scanning.in_channel, c, x, e, f) fmt -> d =
+fun k fmtty fmt -> match fmtty with
+  | Reader_ty fmt_rest ->
+    fun reader ->
+      let new_k readers_rest = k (Cons (reader, readers_rest)) in
+      take_fmtty_format_readers new_k fmt_rest fmt
+  | Ignored_reader_ty fmt_rest ->
+    fun reader ->
+      let new_k readers_rest = k (Cons (reader, readers_rest)) in
+      take_fmtty_format_readers new_k fmt_rest fmt
+  | Char_ty rest                -> take_fmtty_format_readers k rest fmt
+  | String_ty rest              -> take_fmtty_format_readers k rest fmt
+  | Int_ty rest                 -> take_fmtty_format_readers k rest fmt
+  | Int32_ty rest               -> take_fmtty_format_readers k rest fmt
+  | Nativeint_ty rest           -> take_fmtty_format_readers k rest fmt
+  | Int64_ty rest               -> take_fmtty_format_readers k rest fmt
+  | Float_ty rest               -> take_fmtty_format_readers k rest fmt
+  | Bool_ty rest                -> take_fmtty_format_readers k rest fmt
+  | Alpha_ty rest               -> take_fmtty_format_readers k rest fmt
+  | Theta_ty rest               -> take_fmtty_format_readers k rest fmt
+  | Any_ty rest                 -> take_fmtty_format_readers k rest fmt
+  | Format_arg_ty (_, rest)     -> take_fmtty_format_readers k rest fmt
+  | End_of_fmtty                -> take_format_readers k fmt
+  | Format_subst_ty (ty1, ty2, rest) ->
+    let ty = trans (symm ty1) ty2 in
+    take_fmtty_format_readers k (concat_fmtty ty rest) fmt
+
+(* Take readers associated to an ignored parameter. *)
+and take_ignored_format_readers : type x y a c d e f .
+    ((d, e) heter_list -> e) -> (a, Scanning.in_channel, c, d, x, y) ignored ->
+      (y, Scanning.in_channel, c, x, e, f) fmt -> d =
+fun k ign fmt -> match ign with
+  | Ignored_reader ->
+    fun reader ->
+      let new_k readers_rest = k (Cons (reader, readers_rest)) in
+      take_format_readers new_k fmt
+  | Ignored_char                    -> take_format_readers k fmt
+  | Ignored_caml_char               -> take_format_readers k fmt
+  | Ignored_string _                -> take_format_readers k fmt
+  | Ignored_caml_string _           -> take_format_readers k fmt
+  | Ignored_int (_, _)              -> take_format_readers k fmt
+  | Ignored_int32 (_, _)            -> take_format_readers k fmt
+  | Ignored_nativeint (_, _)        -> take_format_readers k fmt
+  | Ignored_int64 (_, _)            -> take_format_readers k fmt
+  | Ignored_float (_, _)            -> take_format_readers k fmt
+  | Ignored_bool                    -> take_format_readers k fmt
+  | Ignored_format_arg _            -> take_format_readers k fmt
+  | Ignored_format_subst (_, fmtty) -> take_fmtty_format_readers k fmtty fmt
+  | Ignored_scan_char_set _         -> take_format_readers k fmt
+  | Ignored_scan_get_counter _      -> take_format_readers k fmt
+  | Ignored_scan_next_char          -> take_format_readers k fmt
+
+(******************************************************************************)
+                          (* Generic scanning *)
+
+(* Make a generic scanning function. *)
+(* Scan a stream according to a format and readers obtained by
+   take_format_readers, and aggegate scanned values into an
+   heterogeneous list. *)
+(* Return the heterogeneous list of scanned values. *)
+let rec make_scanf : type a c d e f.
+    Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt ->
+      (d, e) heter_list -> (a, f) heter_list =
+fun ib fmt readers -> match fmt with
+  | Char rest ->
+    let _ = scan_char 0 ib in
+    let c = token_char ib in
+    Cons (c, make_scanf ib rest readers)
+  | Caml_char rest ->
+    let _ = scan_caml_char 0 ib in
+    let c = token_char ib in
+    Cons (c, make_scanf ib rest readers)
+
+  | String (pad, Formatting_lit (fmting_lit, rest)) ->
+    let stp, str = stopper_of_formatting_lit fmting_lit in
+    let scan width _ ib = scan_string (Some stp) width ib in
+    let str_rest = String_literal (str, rest) in
+    pad_prec_scanf ib str_rest readers pad No_precision scan token_string
+  | String (pad, Formatting_gen (Open_tag (Format (fmt', _)), rest)) ->
+    let scan width _ ib = scan_string (Some '{') width ib in
+    pad_prec_scanf ib (concat_fmt fmt' rest) readers pad No_precision scan
+                   token_string
+  | String (pad, Formatting_gen (Open_box (Format (fmt', _)), rest)) ->
+    let scan width _ ib = scan_string (Some '[') width ib in
+    pad_prec_scanf ib (concat_fmt fmt' rest) readers pad No_precision scan
+                   token_string
+  | String (pad, rest) ->
+    let scan width _ ib = scan_string None width ib in
+    pad_prec_scanf ib rest readers pad No_precision scan token_string
+
+  | Caml_string (pad, rest) ->
+    let scan width _ ib = scan_caml_string width ib in
+    pad_prec_scanf ib rest readers pad No_precision scan token_string
+  | Int (iconv, pad, prec, rest) ->
+    let c = integer_conversion_of_char (char_of_iconv iconv) in
+    let scan width _ ib = scan_int_conversion c width ib in
+    pad_prec_scanf ib rest readers pad prec scan (token_int c)
+  | Int32 (iconv, pad, prec, rest) ->
+    let c = integer_conversion_of_char (char_of_iconv iconv) in
+    let scan width _ ib = scan_int_conversion c width ib in
+    pad_prec_scanf ib rest readers pad prec scan (token_int32 c)
+  | Nativeint (iconv, pad, prec, rest) ->
+    let c = integer_conversion_of_char (char_of_iconv iconv) in
+    let scan width _ ib = scan_int_conversion c width ib in
+    pad_prec_scanf ib rest readers pad prec scan (token_nativeint c)
+  | Int64 (iconv, pad, prec, rest) ->
+    let c = integer_conversion_of_char (char_of_iconv iconv) in
+    let scan width _ ib = scan_int_conversion c width ib in
+    pad_prec_scanf ib rest readers pad prec scan (token_int64 c)
+  | Float (Float_F, pad, prec, rest) ->
+    pad_prec_scanf ib rest readers pad prec scan_caml_float token_float
+  | Float ((Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se
+               | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg
+               | Float_G | Float_pG | Float_sG), pad, prec, rest) ->
+    pad_prec_scanf ib rest readers pad prec scan_float token_float
+  | Float ((Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH),
+           pad, prec, rest) ->
+    pad_prec_scanf ib rest readers pad prec scan_hex_float token_float
+  | Bool rest ->
+    let _ = scan_bool ib in
+    let b = token_bool ib in
+    Cons (b, make_scanf ib rest readers)
+  | Alpha _ ->
+    invalid_arg "scanf: bad conversion \"%a\""
+  | Theta _ ->
+    invalid_arg "scanf: bad conversion \"%t\""
+  | Custom _ ->
+    invalid_arg "scanf: bad conversion \"%?\" (custom converter)"
+  | Reader fmt_rest ->
+    begin match readers with
+    | Cons (reader, readers_rest) ->
+        let x = reader ib in
+        Cons (x, make_scanf ib fmt_rest readers_rest)
+    | Nil -> 
+        invalid_arg "scanf: missing reader"
+    end
+  | Flush rest ->
+    if Scanning.end_of_input ib then make_scanf ib rest readers
+    else bad_input "end of input not found"
+
+  | String_literal (str, rest) ->
+    String.iter (check_char ib) str;
+    make_scanf ib rest readers
+  | Char_literal (chr, rest) ->
+    check_char ib chr;
+    make_scanf ib rest readers
+
+  | Format_arg (pad_opt, fmtty, rest) ->
+    let _ = scan_caml_string (width_of_pad_opt pad_opt) ib in
+    let s = token_string ib in
+    let fmt =
+      try format_of_string_fmtty s fmtty
+      with Failure msg -> bad_input msg
+    in
+    Cons (fmt, make_scanf ib rest readers)
+  | Format_subst (pad_opt, fmtty, rest) ->
+    let _ = scan_caml_string (width_of_pad_opt pad_opt) ib in
+    let s = token_string ib in
+    let fmt, fmt' =
+      try
+        let Fmt_EBB fmt = fmt_ebb_of_string s in
+        let Fmt_EBB fmt' = fmt_ebb_of_string s in
+        (* TODO: find a way to avoid reparsing twice *)
+
+        (* TODO: these type-checks below *can* fail because of type
+           ambiguity in presence of ignored-readers: "%_r%d" and "%d%_r"
+           are typed in the same way.
+
+           # Scanf.sscanf "\"%_r%d\"3" "%(%d%_r%)" ignore
+             (fun fmt n -> string_of_format fmt, n)
+           Exception: CamlinternalFormat.Type_mismatch.
+
+           We should properly catch this exception.
+        *)
+        type_format fmt (erase_rel fmtty),
+        type_format fmt' (erase_rel (symm fmtty))
+      with Failure msg -> bad_input msg
+    in
+    Cons (Format (fmt, s),
+          make_scanf ib (concat_fmt fmt' rest) readers)
+
+  | Scan_char_set (width_opt, char_set, Formatting_lit (fmting_lit, rest)) ->
+    let stp, str = stopper_of_formatting_lit fmting_lit in
+    let width = width_of_pad_opt width_opt in
+    scan_chars_in_char_set char_set (Some stp) width ib;
+    let s = token_string ib in
+    let str_rest = String_literal (str, rest) in
+    Cons (s, make_scanf ib str_rest readers)
+  | Scan_char_set (width_opt, char_set, rest) ->
+    let width = width_of_pad_opt width_opt in
+    scan_chars_in_char_set char_set None width ib;
+    let s = token_string ib in
+    Cons (s, make_scanf ib rest readers)
+  | Scan_get_counter (counter, rest) ->
+    let count = get_counter ib counter in
+    Cons (count, make_scanf ib rest readers)
+  | Scan_next_char rest ->
+    let c = Scanning.checked_peek_char ib in
+    Cons (c, make_scanf ib rest readers)
+
+  | Formatting_lit (formatting_lit, rest) ->
+    String.iter (check_char ib) (string_of_formatting_lit formatting_lit);
+    make_scanf ib rest readers
+  | Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
+    check_char ib '@'; check_char ib '{';
+    make_scanf ib (concat_fmt fmt' rest) readers
+  | Formatting_gen (Open_box (Format (fmt', _)), rest) ->
+    check_char ib '@'; check_char ib '[';
+    make_scanf ib (concat_fmt fmt' rest) readers
+
+  | Ignored_param (ign, rest) ->
+    let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in
+    begin match make_scanf ib fmt' readers with
+    | Cons (_, arg_rest) -> arg_rest
+    | Nil -> assert false
+    end
+
+  | End_of_format ->
+    Nil
+
+(* Case analysis on padding and precision. *)
+(* Reject formats containing "%*" or "%.*". *)
+(* Pass padding and precision to the generic scanner `scan'. *)
+and pad_prec_scanf : type a c d e f x y z t .
+    Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt ->
+      (d, e) heter_list -> (x, y) padding -> (y, z -> a) precision ->
+      (int -> int -> Scanning.in_channel -> t) ->
+      (Scanning.in_channel -> z) ->
+      (x, f) heter_list =
+fun ib fmt readers pad prec scan token -> match pad, prec with
+  | No_padding, No_precision ->
+    let _ = scan max_int max_int ib in
+    let x = token ib in
+    Cons (x, make_scanf ib fmt readers)
+  | No_padding, Lit_precision p ->
+    let _ = scan max_int p ib in
+    let x = token ib in
+    Cons (x, make_scanf ib fmt readers)
+  | Lit_padding ((Right | Zeros), w), No_precision ->
+    let _ = scan w max_int ib in
+    let x = token ib in
+    Cons (x, make_scanf ib fmt readers)
+  | Lit_padding ((Right | Zeros), w), Lit_precision p ->
+    let _ = scan w p ib in
+    let x = token ib in
+    Cons (x, make_scanf ib fmt readers)
+  | Lit_padding (Left, _), _ ->
+    invalid_arg "scanf: bad conversion \"%-\""
+  | Lit_padding ((Right | Zeros), _), Arg_precision ->
+    invalid_arg "scanf: bad conversion \"%*\""
+  | Arg_padding _, _ ->
+    invalid_arg "scanf: bad conversion \"%*\""
+  | No_padding, Arg_precision ->
+    invalid_arg "scanf: bad conversion \"%*\""
+
+(******************************************************************************)
+            (* Defining [scanf] and various flavors of [scanf] *)
+
+type 'a kscanf_result = Args of 'a | Exc of exn
+
+let kscanf ib ef (Format (fmt, str)) =
+  let rec apply : type a b . a -> (a, b) heter_list -> b =
+    fun f args -> match args with
+    | Cons (x, r) -> apply (f x) r
+    | Nil -> f
+  in
+  let k readers f =
+    Scanning.reset_token ib;
+    match try Args (make_scanf ib fmt readers) with
+      | (Scan_failure _ | Failure _ | End_of_file) as exc -> Exc exc
+      | Invalid_argument msg ->
+        invalid_arg (msg ^ " in format \"" ^ String.escaped str ^ "\"")
+    with
+      | Args args -> apply f args
+      | Exc exc -> ef ib exc
+  in
+  take_format_readers k fmt
+
+(***)
+
+let kbscanf = kscanf
+let bscanf ib fmt = kbscanf ib scanf_bad_input fmt
+
+let ksscanf s ef fmt = kbscanf (Scanning.from_string s) ef fmt
+let sscanf s fmt = kbscanf (Scanning.from_string s) scanf_bad_input fmt
+
+let scanf fmt = kscanf Scanning.stdib scanf_bad_input fmt
+
+(***)
+
+(* Scanning format strings. *)
+let bscanf_format :
+  Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+  (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g =
+  fun ib format f ->
+    let _ = scan_caml_string max_int ib in
+    let str = token_string ib in
+    let fmt' =
+      try format_of_string_format str format
+      with Failure msg -> bad_input msg in
+    f fmt'
+
+
+let sscanf_format :
+  string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+  (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g =
+  fun s format f -> bscanf_format (Scanning.from_string s) format f
+
+
+let string_to_String s =
+  let l = String.length s in
+  let b = Buffer.create (l + 2) in
+  Buffer.add_char b '\"';
+  for i = 0 to l - 1 do
+    let c = s.[i] in
+    if c = '\"' then Buffer.add_char b '\\';
+    Buffer.add_char b c;
+  done;
+  Buffer.add_char b '\"';
+  Buffer.contents b
+
+
+let format_from_string s fmt =
+  sscanf_format (string_to_String s) fmt (fun x -> x)
+
+
+let unescaped s =
+  sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
+
+
+(* Deprecated *)
+let kfscanf ic ef fmt = kbscanf (Scanning.memo_from_channel ic) ef fmt
+let fscanf ic fmt = kscanf (Scanning.memo_from_channel ic) scanf_bad_input fmt
diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
new file mode 100644
index 00000000..ea0d4ce7
--- /dev/null
+++ b/stdlib/scanf.mli
@@ -0,0 +1,559 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Formatted input functions. *)
+
+(** {6 Introduction} *)
+
+(** {7 Functional input with format strings} *)
+
+(** The module {!Scanf} provides formatted input functions or {e scanners}.
+
+    The formatted input functions can read from any kind of input, including
+    strings, files, or anything that can return characters. The more general
+    source of characters is named a {e formatted input channel} (or {e
+    scanning buffer}) and has type {!Scanning.in_channel}. The more general
+    formatted input function reads from any scanning buffer and is named
+    [bscanf].
+
+    Generally speaking, the formatted input functions have 3 arguments:
+    - the first argument is a source of characters for the input,
+    - the second argument is a format string that specifies the values to
+      read,
+    - the third argument is a {e receiver function} that is applied to the
+      values read.
+
+    Hence, a typical call to the formatted input function {!Scanf.bscanf} is
+    [bscanf ic fmt f], where:
+
+    - [ic] is a source of characters (typically a {e
+    formatted input channel} with type {!Scanning.in_channel}),
+
+    - [fmt] is a format string (the same format strings as those used to print
+    material with module {!Printf} or {!Format}),
+
+    - [f] is a function that has as many arguments as the number of values to
+    read in the input according to [fmt].
+*)
+
+(** {7 A simple example} *)
+
+(** As suggested above, the expression [bscanf ic "%d" f] reads a decimal
+    integer [n] from the source of characters [ic] and returns [f n].
+
+    For instance,
+
+    - if we use [stdin] as the source of characters ({!Scanning.stdin} is
+    the predefined formatted input channel that reads from standard input),
+
+    - if we define the receiver [f] as [let f x = x + 1],
+
+    then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the
+    standard input and returns [f n] (that is [n + 1]). Thus, if we
+    evaluate [bscanf stdin "%d" f], and then enter [41] at the
+    keyboard, the result we get is [42].
+*)
+
+(** {7 Formatted input as a functional feature} *)
+
+(** The OCaml scanning facility is reminiscent of the corresponding C feature.
+    However, it is also largely different, simpler, and yet more powerful:
+    the formatted input functions are higher-order functionals and the
+    parameter passing mechanism is just the regular function application not
+    the variable assignment based mechanism which is typical for formatted
+    input in imperative languages; the OCaml format strings also feature
+    useful additions to easily define complex tokens; as expected within a
+    functional programming language, the formatted input functions also
+    support polymorphism, in particular arbitrary interaction with
+    polymorphic user-defined scanners. Furthermore, the OCaml formatted input
+    facility is fully type-checked at compile time.
+*)
+
+(** {6 Formatted input channel} *)
+
+module Scanning : sig
+
+type in_channel
+(** The notion of input channel for the {!Scanf} module:
+   those channels provide all the machinery necessary to read from any source
+   of characters, including a {!Pervasives.in_channel} value.
+   A Scanf.Scanning.in_channel value is also called a {i formatted input
+   channel} or equivalently a {i scanning buffer}.
+   The type {!Scanning.scanbuf} below is an alias for [Scanning.in_channel].
+   @since 3.12.0
+*)
+
+type scanbuf = in_channel
+(** The type of scanning buffers. A scanning buffer is the source from which a
+    formatted input function gets characters. The scanning buffer holds the
+    current state of the scan, plus a function to get the next char from the
+    input, and a token buffer to store the string matched so far.
+
+    Note: a scanning action may often require to examine one character in
+    advance; when this 'lookahead' character does not belong to the token
+    read, it is stored back in the scanning buffer and becomes the next
+    character yet to be read.
+*)
+
+val stdin : in_channel
+(** The standard input notion for the {!Scanf} module.
+    [Scanning.stdin] is the {!Scanning.in_channel} formatted input channel
+    attached to {!Pervasives.stdin}.
+
+    Note: in the interactive system, when input is read from
+    {!Pervasives.stdin}, the newline character that triggers evaluation is
+    part of the input; thus, the scanning specifications must properly skip
+    this additional newline character (for instance, simply add a ['\n'] as
+    the last character of the format string).
+    @since 3.12.0
+*)
+
+type file_name = string
+(** A convenient alias to designate a file name.
+    @since 4.00.0
+*)
+
+val open_in : file_name -> in_channel
+(** [Scanning.open_in fname] returns a {!Scanning.in_channel} formatted input
+    channel for bufferized reading in text mode from file [fname].
+
+    Note:
+    [open_in] returns a formatted input channel that efficiently reads
+    characters in large chunks; in contrast, [from_channel] below returns
+    formatted input channels that must read one character at a time, leading
+    to a much slower scanning rate.
+    @since 3.12.0
+*)
+
+val open_in_bin : file_name -> in_channel
+(** [Scanning.open_in_bin fname] returns a {!Scanning.in_channel} formatted
+    input channel for bufferized reading in binary mode from file [fname].
+    @since 3.12.0
+*)
+
+val close_in : in_channel -> unit
+(** Closes the {!Pervasives.in_channel} associated with the given
+  {!Scanning.in_channel} formatted input channel.
+  @since 3.12.0
+*)
+
+val from_file : file_name -> in_channel
+(** An alias for {!Scanning.open_in} above. *)
+
+val from_file_bin : string -> in_channel
+(** An alias for {!Scanning.open_in_bin} above. *)
+
+val from_string : string -> in_channel
+(** [Scanning.from_string s] returns a {!Scanning.in_channel} formatted
+    input channel which reads from the given string.
+    Reading starts from the first character in the string.
+    The end-of-input condition is set when the end of the string is reached.
+*)
+
+val from_function : (unit -> char) -> in_channel
+(** [Scanning.from_function f] returns a {!Scanning.in_channel} formatted
+    input channel with the given function as its reading method.
+
+    When scanning needs one more character, the given function is called.
+
+    When the function has no more character to provide, it {e must} signal an
+    end-of-input condition by raising the exception [End_of_file].
+*)
+
+val from_channel : Pervasives.in_channel -> in_channel
+(** [Scanning.from_channel ic] returns a {!Scanning.in_channel} formatted
+    input channel which reads from the regular {!Pervasives.in_channel} input
+    channel [ic] argument.
+    Reading starts at current reading position of [ic].
+*)
+
+val end_of_input : in_channel -> bool
+(** [Scanning.end_of_input ic] tests the end-of-input condition of the given
+    {!Scanning.in_channel} formatted input channel.
+*)
+
+val beginning_of_input : in_channel -> bool
+(** [Scanning.beginning_of_input ic] tests the beginning of input condition
+    of the given {!Scanning.in_channel} formatted input channel.
+*)
+
+val name_of_input : in_channel -> string
+(** [Scanning.name_of_input ic] returns the name of the character source
+    for the given {!Scanning.in_channel} formatted input channel.
+    @since 3.09.0
+*)
+
+val stdib : in_channel
+  [@@ocaml.deprecated "Use Scanf.Scanning.stdin instead."]
+(** A deprecated alias for {!Scanning.stdin}, the scanning buffer reading from
+    {!Pervasives.stdin}.
+*)
+
+end
+
+(** {6 Type of formatted input functions} *)
+
+type ('a, 'b, 'c, 'd) scanner =
+     ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c
+(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner]
+    is the type of a formatted input function that reads from some
+    formatted input channel according to some format string; more
+    precisely, if [scan] is some formatted input function, then [scan
+    ic fmt f] applies [f] to all the arguments specified by format
+    string [fmt], when [scan] has read those arguments from the
+    {!Scanning.in_channel} formatted input channel [ic].
+
+    For instance, the {!Scanf.scanf} function below has type
+    [('a, 'b, 'c, 'd) scanner], since it is a formatted input function that
+    reads from {!Scanning.stdin}: [scanf fmt f] applies [f] to the arguments
+    specified by [fmt], reading those arguments from [!Pervasives.stdin] as
+    expected.
+
+    If the format [fmt] has some [%r] indications, the corresponding
+    formatted input functions must be provided {e before} receiver function
+    [f]. For instance, if [read_elem] is an input function for values of type
+    [t], then [bscanf ic "%r;" read_elem f] reads a value [v] of type [t]
+    followed by a [';'] character, and returns [f v].
+    @since 3.10.0
+*)
+
+exception Scan_failure of string
+(** When the input can not be read according to the format string
+    specification, formatted input functions typically raise exception
+    [Scan_failure].
+*)
+
+(** {6 The general formatted input function} *)
+
+val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
+
+(** [bscanf ic fmt r1 ... rN f] reads characters from the
+    {!Scanning.in_channel} formatted input channel [ic] and converts them to
+    values according to format string [fmt].
+    As a final step, receiver function [f] is applied to the values read and
+    gives the result of the [bscanf] call.
+
+    For instance, if [f] is the function [fun s i -> i + 1], then
+    [Scanf.sscanf "x= 1" "%s = %i" f] returns [2].
+
+    Arguments [r1] to [rN] are user-defined input functions that read the
+    argument corresponding to the [%r] conversions specified in the format
+    string.
+*)
+
+(** {6 Format string description} *)
+
+(** The format string is a character string which contains three types of
+    objects:
+    - plain characters, which are simply matched with the characters of the
+      input (with a special case for space and line feed, see {!Scanf.space}),
+    - conversion specifications, each of which causes reading and conversion of
+      one argument for the function [f] (see {!Scanf.conversion}),
+    - scanning indications to specify boundaries of tokens
+      (see scanning {!Scanf.indication}).
+*)
+
+(** {7:space The space character in format strings} *)
+
+(** As mentioned above, a plain character in the format string is just
+    matched with the next character of the input; however, two characters are
+    special exceptions to this rule: the space character ([' '] or ASCII code
+    32) and the line feed character (['\n'] or ASCII code 10).
+    A space does not match a single space character, but any amount of
+    'whitespace' in the input. More precisely, a space inside the format
+    string matches {e any number} of tab, space, line feed and carriage
+    return characters. Similarly, a line feed character in the format string
+    matches either a single line feed or a carriage return followed by a line
+    feed.
+
+    Matching {e any} amount of whitespace, a space in the format string
+    also matches no amount of whitespace at all; hence, the call [bscanf ib
+    "Price = %d $" (fun p -> p)] succeeds and returns [1] when reading an
+    input with various whitespace in it, such as [Price = 1 $],
+    [Price  =  1    $], or even [Price=1$].
+*)
+
+(** {7:conversion Conversion specifications in format strings} *)
+
+(** Conversion specifications consist in the [%] character, followed by
+    an optional flag, an optional field width, and followed by one or
+    two conversion characters.
+
+    The conversion characters and their meanings are:
+
+    - [d]: reads an optionally signed decimal integer ([0-9]+).
+    - [i]: reads an optionally signed integer
+      (usual input conventions for decimal ([0-9]+), hexadecimal
+       ([0x[0-9a-f]+] and [0X[0-9A-F]+]), octal ([0o[0-7]+]), and binary
+       ([0b[0-1]+]) notations are understood).
+    - [u]: reads an unsigned decimal integer.
+    - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-fA-F]+]).
+    - [o]: reads an unsigned octal integer ([[0-7]+]).
+    - [s]: reads a string argument that spreads as much as possible, until the
+      following bounding condition holds: {ul
+      {- a whitespace has been found (see {!Scanf.space}),}
+      {- a scanning indication (see scanning {!Scanf.indication}) has been
+         encountered,}
+      {- the end-of-input has been reached.}}
+      Hence, this conversion always succeeds: it returns an empty
+      string if the bounding condition holds when the scan begins.
+    - [S]: reads a delimited string argument (delimiters and special
+      escaped characters follow the lexical conventions of OCaml).
+    - [c]: reads a single character. To test the current input character
+      without reading it, specify a null field width, i.e. use
+      specification [%0c]. Raise [Invalid_argument], if the field width
+      specification is greater than 1.
+    - [C]: reads a single delimited character (delimiters and special
+      escaped characters follow the lexical conventions of OCaml).
+    - [f], [e], [E], [g], [G]: reads an optionally signed
+      floating-point number in decimal notation, in the style [dddd.ddd
+      e/E+-dd].
+    - [h], [H]: reads an optionally signed floating-point number
+      in hexadecimal notation.
+    - [F]: reads a floating point number according to the lexical
+      conventions of OCaml (hence the decimal point is mandatory if the
+      exponent part is not mentioned).
+    - [B]: reads a boolean argument ([true] or [false]).
+    - [b]: reads a boolean argument (for backward compatibility; do not use
+      in new programs).
+    - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to
+      the format specified by the second letter for regular integers.
+    - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to
+      the format specified by the second letter for regular integers.
+    - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to
+      the format specified by the second letter for regular integers.
+    - [[ 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 [^]). Reads a [string] that can be
+      empty, if the next input character does not match the range. The set of
+      characters from [c1] to [c2] (inclusively) is denoted by [c1-c2].
+      Hence, [%[0-9]] returns a string representing a decimal number
+      or an empty string if no decimal digit is found; similarly,
+      [%[0-9a-f]] returns a string of hexadecimal digits.
+      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 [\]].
+      Use [%%] and [%@] to include a [%] or a [@] in a range.
+    - [r]: user-defined reader. Takes the next [ri] formatted input
+      function and applies it to the scanning buffer [ib] to read the
+      next argument. The input function [ri] must therefore have type
+      [Scanning.in_channel -> 'a] and the argument read has type ['a].
+    - [{ fmt %}]: reads a format string argument. The format string
+      read must have the same type as the format string specification
+      [fmt]. For instance, ["%{ %i %}"] reads any format string that
+      can read a value of type [int]; hence, if [s] is the string
+      ["fmt:\"number is %u\""], then [Scanf.sscanf s "fmt: %{%i%}"]
+      succeeds and returns the format string ["number is %u"].
+    - [( fmt %)]: scanning sub-format substitution.
+      Reads a format string [rf] in the input, then goes on scanning with
+      [rf] instead of scanning with [fmt].
+      The format string [rf] must have the same type as the format string
+      specification [fmt] that it replaces.
+      For instance, ["%( %i %)"] reads any format string that can read a value
+      of type [int].
+      The conversion returns the format string read [rf], and then a value
+      read using [rf].
+      Hence, if [s] is the string ["\"%4d\"1234.00"], then
+      [Scanf.sscanf s "%(%i%)" (fun fmt i -> fmt, i)] evaluates to
+      [("%4d", 1234)].
+      This behaviour is not mere format substitution, since the conversion
+      returns the format string read as additional argument. If you need
+      pure format substitution, use special flag [_] to discard the
+      extraneous argument: conversion [%_( fmt %)] reads a format string
+      [rf] and then behaves the same as format string [rf].  Hence, if [s] is
+      the string ["\"%4d\"1234.00"], then [Scanf.sscanf s "%_(%i%)"] is
+      simply equivalent to [Scanf.sscanf "1234.00" "%4d"].
+    - [l]: returns the number of lines read so far.
+    - [n]: returns the number of characters read so far.
+    - [N] or [L]: returns the number of tokens read so far.
+    - [!]: matches the end of input condition.
+    - [%]: matches one [%] character in the input.
+    - [@]: matches one [@] character in the input.
+    - [,]: does nothing.
+
+    Following the [%] character that introduces a conversion, there may be
+    the special flag [_]: the conversion that follows occurs as usual,
+    but the resulting value is discarded.
+    For instance, if [f] is the function [fun i -> i + 1], and [s] is the
+    string ["x = 1"], then [Scanf.sscanf s "%_s = %i" f] returns [2].
+
+    The field width is composed of an optional integer literal
+    indicating the maximal width of the token to read.
+    For instance, [%6d] reads an integer, having at most 6 decimal digits;
+    [%4f] reads a float with at most 4 characters; and [%8[\000-\255]]
+    returns the next 8 characters (or all the characters still available,
+    if fewer than 8 characters are available in the input).
+
+    Notes:
+
+    - as mentioned above, a [%s] conversion always succeeds, even if there is
+      nothing to read in the input: in this case, it simply returns [""].
+
+    - in addition to the relevant digits, ['_'] characters may appear
+    inside numbers (this is reminiscent to the usual OCaml lexical
+    conventions). If stricter scanning is desired, use the range
+    conversion facility instead of the number conversions.
+
+    - the [scanf] facility is not intended for heavy duty lexical
+    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.
+*)
+
+(** {7:indication Scanning indications in format strings} *)
+
+(** 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
+    plain 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
+    tab character or to the end of input. If a [@] character appears
+    anywhere else in the format string, it is treated as a plain character.
+
+    Note:
+
+    - As usual in format strings, [%] and [@] characters must be escaped
+    using [%%] and [%@]; this rule still holds within range specifications
+    and scanning indications.
+    For instance, format ["%s@%%"] reads a string up to the next [%]
+    character, and format ["%s@%@"] reads a string up to the next [@].
+    - The scanning indications introduce slight differences in the syntax of
+    {!Scanf} format strings, compared to those used for the {!Printf}
+    module. However, the scanning indications are similar to those used in
+    the {!Format} module; hence, when producing formatted text to be scanned
+    by {!Scanf.bscanf}, it is wise to use printing functions from the
+    {!Format} module (or, if you need to use functions from {!Printf}, banish
+    or carefully double check the format strings that contain ['@']
+    characters).
+*)
+
+(** {7 Exceptions during scanning} *)
+
+(** Scanners may raise the following exceptions when the input cannot be read
+    according to the format string:
+
+    - Raise {!Scanf.Scan_failure} if the input does not match the format.
+
+    - Raise [Failure] if a conversion to a number is not possible.
+
+    - Raise [End_of_file] if the end of input is encountered while some more
+      characters are needed to read the current conversion specification.
+
+    - Raise [Invalid_argument] if the format string is invalid.
+
+    Note:
+
+    - as a consequence, scanning a [%s] conversion never raises exception
+    [End_of_file]: if the end of input is reached the conversion succeeds and
+    simply returns the characters read so far, or [""] if none were ever read.
+*)
+
+(** {6 Specialised formatted input functions} *)
+
+val sscanf : string -> ('a, 'b, 'c, 'd) scanner
+(** Same as {!Scanf.bscanf}, but reads from the given string. *)
+
+val scanf : ('a, 'b, 'c, 'd) scanner
+(** Same as {!Scanf.bscanf}, but reads from the predefined formatted input
+    channel {!Scanf.Scanning.stdin} that is connected to {!Pervasives.stdin}.
+*)
+
+val kscanf :
+  Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) ->
+    ('a, 'b, 'c, 'd) scanner
+(** Same as {!Scanf.bscanf}, but takes an additional function argument
+    [ef] that is called in case of error: if the scanning process or
+    some conversion fails, the scanning function aborts and calls the
+    error handling function [ef] with the formatted input channel and the
+    exception that aborted the scanning process as arguments.
+*)
+
+val ksscanf :
+  string -> (Scanning.in_channel -> exn -> 'd) ->
+    ('a, 'b, 'c, 'd) scanner
+(** Same as {!Scanf.kscanf} but reads from the given string.
+    @since 4.02.0 *)
+
+(** {6 Reading format strings from input} *)
+
+val bscanf_format :
+  Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+    (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g
+(** [bscanf_format ic fmt f] reads a format string token from the formatted
+    input channel [ic], according to the given format string [fmt], and
+    applies [f] to the resulting format string value.
+    Raise {!Scan_failure} if the format string value read does not have the
+    same type as [fmt].
+    @since 3.09.0
+*)
+
+val sscanf_format :
+  string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+    (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g
+(** Same as {!Scanf.bscanf_format}, but reads from the given string.
+    @since 3.09.0
+*)
+
+val format_from_string :
+  string ->
+    ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6
+(** [format_from_string s fmt] converts a string argument to a format string,
+    according to the given format string [fmt].
+    Raise {!Scan_failure} if [s], considered as a format string, does not
+    have the same type as [fmt].
+    @since 3.10.0
+*)
+
+val unescaped : string -> string
+(** [unescaped s] return a copy of [s] with escape sequences (according to
+    the lexical conventions of OCaml) replaced by their corresponding special
+    characters.
+    More precisely, [Scanf.unescaped] has the following property:
+    for all string [s], [Scanf.unescaped (String.escaped s) = s].
+
+    Always return a copy of the argument, even if there is no escape sequence
+    in the argument.
+    Raise {!Scan_failure} if [s] is not properly escaped (i.e. [s] has invalid
+    escape sequences or special characters that are not properly escaped).
+    For instance, [String.unescaped "\""] will fail.
+    @since 4.00.0
+*)
+
+(** {6 Deprecated} *)
+
+val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner
+  [@@ocaml.deprecated "Use Scanning.from_channel then Scanf.bscanf."]
+(** @deprecated [Scanf.fscanf] is error prone and deprecated since 4.03.0.
+
+    This function violates the following invariant of the {!Scanf} module:
+    To preserve scanning semantics, all scanning functions defined in {!Scanf}
+    must read from a user defined {!Scanning.in_channel} formatted input
+    channel.
+
+    If you need to read from a {!Pervasives.in_channel} input channel
+    [ic], simply define a {!Scanning.in_channel} formatted input channel as in
+    [let ib = Scanning.from_channel ic],
+    then use [Scanf.bscanf ib] as usual.
+*)
+
+val kfscanf :
+  Pervasives.in_channel -> (Scanning.in_channel -> exn -> 'd) ->
+    ('a, 'b, 'c, 'd) scanner
+  [@@ocaml.deprecated "Use Scanning.from_channel then Scanf.kscanf."]
+(** @deprecated [Scanf.kfscanf] is error prone and deprecated since 4.03.0. *)
diff --git a/stdlib/set.ml b/stdlib/set.ml
new file mode 100644
index 00000000..abfa41ed
--- /dev/null
+++ b/stdlib/set.ml
@@ -0,0 +1,524 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Sets over ordered types *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type elt
+    type t
+    val empty: t
+    val is_empty: t -> bool
+    val mem: elt -> t -> bool
+    val add: elt -> t -> t
+    val singleton: elt -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val compare: t -> t -> int
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val iter: (elt -> unit) -> t -> unit
+    val map: (elt -> elt) -> t -> t
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all: (elt -> bool) -> t -> bool
+    val exists: (elt -> bool) -> t -> bool
+    val filter: (elt -> bool) -> t -> t
+    val partition: (elt -> bool) -> t -> t * t
+    val cardinal: t -> int
+    val elements: t -> elt list
+    val min_elt: t -> elt
+    val min_elt_opt: t -> elt option
+    val max_elt: t -> elt
+    val max_elt_opt: t -> elt option
+    val choose: t -> elt
+    val choose_opt: t -> elt option
+    val split: elt -> t -> t * bool * t
+    val find: elt -> t -> elt
+    val find_opt: elt -> t -> elt option
+    val find_first: (elt -> bool) -> t -> elt
+    val find_first_opt: (elt -> bool) -> t -> elt option
+    val find_last: (elt -> bool) -> t -> elt
+    val find_last_opt: (elt -> bool) -> t -> elt option
+    val of_list: elt list -> t
+  end
+
+module Make(Ord: OrderedType) =
+  struct
+    type elt = Ord.t
+    type t = Empty | Node of t * elt * t * int
+
+    (* Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+    let height = function
+        Empty -> 0
+      | Node(_, _, _, h) -> h
+
+    (* Creates a new node with left son l, value v and right son r.
+       We must have all elements of l < v < all elements of r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+    let create l v r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced and | height l - height r | <= 3.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+    let bal l v r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Set.bal"
+        | Node(ll, lv, lr, _) ->
+            if height ll >= height lr then
+              create ll lv (create lr v r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrv, lrr, _)->
+                  create (create ll lv lrl) lrv (create lrr v r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Set.bal"
+        | Node(rl, rv, rr, _) ->
+            if height rr >= height rl then
+              create (create l v rl) rv rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlv, rlr, _) ->
+                  create (create l v rll) rlv (create rlr rv rr)
+            end
+      end else
+        Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Insertion of one element *)
+
+    let rec add x = function
+        Empty -> Node(Empty, x, Empty, 1)
+      | Node(l, v, r, _) as t ->
+          let c = Ord.compare x v in
+          if c = 0 then t else
+          if c < 0 then
+            let ll = add x l in
+            if l == ll then t else bal ll v r
+          else
+            let rr = add x r in
+            if r == rr then t else bal l v rr
+
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    (* Beware: those two functions assume that the added v is *strictly*
+       smaller (or bigger) than all the present elements in the tree; it
+       does not test for equality with the current min (or max) element.
+       Indeed, they are only used during the "join" operation which
+       respects this precondition.
+    *)
+
+    let rec add_min_element v = function
+      | Empty -> singleton v
+      | Node (l, x, r, _h) ->
+        bal (add_min_element v l) x r
+
+    let rec add_max_element v = function
+      | Empty -> singleton v
+      | Node (l, x, r, _h) ->
+        bal l x (add_max_element v r)
+
+    (* Same as create and bal, but no assumptions are made on the
+       relative heights of l and r. *)
+
+    let rec join l v r =
+      match (l, r) with
+        (Empty, _) -> add_min_element v r
+      | (_, Empty) -> add_max_element v l
+      | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
+          if lh > rh + 2 then bal ll lv (join lr v r) else
+          if rh > lh + 2 then bal (join l v rl) rv rr else
+          create l v r
+
+    (* Smallest and greatest element of a set *)
+
+    let rec min_elt = function
+        Empty -> raise Not_found
+      | Node(Empty, v, _, _) -> v
+      | Node(l, _, _, _) -> min_elt l
+
+    let rec min_elt_opt = function
+        Empty -> None
+      | Node(Empty, v, _, _) -> Some v
+      | Node(l, _, _, _) -> min_elt_opt l
+
+    let rec max_elt = function
+        Empty -> raise Not_found
+      | Node(_, v, Empty, _) -> v
+      | Node(_, _, r, _) -> max_elt r
+
+    let rec max_elt_opt = function
+        Empty -> None
+      | Node(_, v, Empty, _) -> Some v
+      | Node(_, _, r, _) -> max_elt_opt r
+
+    (* Remove the smallest element of the given set *)
+
+    let rec remove_min_elt = function
+        Empty -> invalid_arg "Set.remove_min_elt"
+      | Node(Empty, _, r, _) -> r
+      | Node(l, v, r, _) -> bal (remove_min_elt l) v r
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assume | height l - height r | <= 2. *)
+
+    let merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2)
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       No assumption on the heights of l and r. *)
+
+    let concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2)
+
+    (* Splitting.  split x s returns a triple (l, present, r) where
+        - l is the set of elements of s that are < x
+        - r is the set of elements of s that are > x
+        - present is false if s contains no element equal to x,
+          or true if s contains an element equal to x. *)
+
+    let rec split x = function
+        Empty ->
+          (Empty, false, Empty)
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then (l, true, r)
+          else if c < 0 then
+            let (ll, pres, rl) = split x l in (ll, pres, join rl v r)
+          else
+            let (lr, pres, rr) = split x r in (join l v lr, pres, rr)
+
+    (* Implementation of the set operations *)
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let rec mem x = function
+        Empty -> false
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec remove x = function
+        Empty -> Empty
+      | (Node(l, v, r, _) as t) ->
+          let c = Ord.compare x v in
+          if c = 0 then merge l r
+          else
+            if c < 0 then
+              let ll = remove x l in
+              if l == ll then t
+              else bal ll v r
+            else
+              let rr = remove x r in
+              if r == rr then t
+              else bal l v rr
+
+    let rec union s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> t2
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          if h1 >= h2 then
+            if h2 = 1 then add v2 s1 else begin
+              let (l2, _, r2) = split v1 s2 in
+              join (union l1 l2) v1 (union r1 r2)
+            end
+          else
+            if h1 = 1 then add v1 s2 else begin
+              let (l1, _, r1) = split v2 s1 in
+              join (union l1 l2) v2 (union r1 r2)
+            end
+
+    let rec inter s1 s2 =
+      match (s1, s2) with
+        (Empty, _) -> Empty
+      | (_, Empty) -> Empty
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, false, r2) ->
+              concat (inter l1 l2) (inter r1 r2)
+          | (l2, true, r2) ->
+              join (inter l1 l2) v1 (inter r1 r2)
+
+    let rec diff s1 s2 =
+      match (s1, s2) with
+        (Empty, _) -> Empty
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, false, r2) ->
+              join (diff l1 l2) v1 (diff r1 r2)
+          | (l2, true, r2) ->
+              concat (diff l1 l2) (diff r1 r2)
+
+    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 (cons_enum r1 e1) (cons_enum r2 e2)
+
+    let compare s1 s2 =
+      compare_aux (cons_enum s1 End) (cons_enum s2 End)
+
+    let equal s1 s2 =
+      compare s1 s2 = 0
+
+    let rec subset s1 s2 =
+      match (s1, s2) with
+        Empty, _ ->
+          true
+      | _, Empty ->
+          false
+      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+          let c = Ord.compare v1 v2 in
+          if c = 0 then
+            subset l1 l2 && subset r1 r2
+          else if c < 0 then
+            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+          else
+            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+    let rec fold f s accu =
+      match s with
+        Empty -> accu
+      | Node(l, v, r, _) -> fold f r (f v (fold f l accu))
+
+    let rec for_all p = function
+        Empty -> true
+      | Node(l, v, r, _) -> p v && for_all p l && for_all p r
+
+    let rec exists p = function
+        Empty -> false
+      | Node(l, v, r, _) -> p v || exists p l || exists p r
+
+    let rec filter p = function
+        Empty -> Empty
+      | (Node(l, v, r, _)) as t ->
+          (* call [p] in the expected left-to-right order *)
+          let l' = filter p l in
+          let pv = p v in
+          let r' = filter p r in
+          if pv then
+            if l==l' && r==r' then t else join l' v r'
+          else concat l' r'
+
+    let rec partition p = function
+        Empty -> (Empty, Empty)
+      | Node(l, v, r, _) ->
+          (* call [p] in the expected left-to-right order *)
+          let (lt, lf) = partition p l in
+          let pv = p v in
+          let (rt, rf) = partition p r in
+          if pv
+          then (join lt v rt, concat lf rf)
+          else (concat lt rt, join lf v rf)
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, _, r, _) -> cardinal l + 1 + cardinal r
+
+    let rec elements_aux accu = function
+        Empty -> accu
+      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+    let elements s =
+      elements_aux [] s
+
+    let choose = min_elt
+
+    let choose_opt = min_elt_opt
+
+    let rec find x = function
+        Empty -> raise Not_found
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then v
+          else find x (if c < 0 then l else r)
+
+    let rec find_first_aux v0 f = function
+        Empty ->
+          v0
+      | Node(l, v, r, _) ->
+          if f v then
+            find_first_aux v f l
+          else
+            find_first_aux v0 f r
+
+    let rec find_first f = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, r, _) ->
+          if f v then
+            find_first_aux v f l
+          else
+            find_first f r
+
+    let rec find_first_opt_aux v0 f = function
+        Empty ->
+          Some v0
+      | Node(l, v, r, _) ->
+          if f v then
+            find_first_opt_aux v f l
+          else
+            find_first_opt_aux v0 f r
+
+    let rec find_first_opt f = function
+        Empty ->
+          None
+      | Node(l, v, r, _) ->
+          if f v then
+            find_first_opt_aux v f l
+          else
+            find_first_opt f r
+
+    let rec find_last_aux v0 f = function
+        Empty ->
+          v0
+      | Node(l, v, r, _) ->
+          if f v then
+            find_last_aux v f r
+          else
+            find_last_aux v0 f l
+
+    let rec find_last f = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, r, _) ->
+          if f v then
+            find_last_aux v f r
+          else
+            find_last f l
+
+    let rec find_last_opt_aux v0 f = function
+        Empty ->
+          Some v0
+      | Node(l, v, r, _) ->
+          if f v then
+            find_last_opt_aux v f r
+          else
+            find_last_opt_aux v0 f l
+
+    let rec find_last_opt f = function
+        Empty ->
+          None
+      | Node(l, v, r, _) ->
+          if f v then
+            find_last_opt_aux v f r
+          else
+            find_last_opt f l
+
+    let rec find_opt x = function
+        Empty -> None
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then Some v
+          else find_opt x (if c < 0 then l else r)
+
+    let try_join l v r =
+      (* [join l v r] can only be called when (elements of l < v <
+         elements of r); use [try_join l v r] when this property may
+         not hold, but you hope it does hold in the common case *)
+      if (l = Empty || Ord.compare (max_elt l) v < 0)
+      && (r = Empty || Ord.compare v (min_elt r) < 0)
+      then join l v r
+      else union l (add v r)
+
+    let rec map f = function
+      | Empty -> Empty
+      | Node (l, v, r, _) as t ->
+         (* enforce left-to-right evaluation order *)
+         let l' = map f l in
+         let v' = f v in
+         let r' = map f r in
+         if l == l' && v == v' && r == r' then t
+         else try_join l' v' r'
+
+    let of_sorted_list l =
+      let rec sub n l =
+        match n, l with
+        | 0, l -> Empty, l
+        | 1, x0 :: l -> Node (Empty, x0, Empty, 1), l
+        | 2, x0 :: x1 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Empty, 2), l
+        | 3, x0 :: x1 :: x2 :: l ->
+            Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2),l
+        | n, l ->
+          let nl = n / 2 in
+          let left, l = sub nl l in
+          match l with
+          | [] -> assert false
+          | mid :: l ->
+            let right, l = sub (n - nl - 1) l in
+            create left mid right, l
+      in
+      fst (sub (List.length l) l)
+
+    let of_list l =
+      match l with
+      | [] -> empty
+      | [x0] -> singleton x0
+      | [x0; x1] -> add x1 (singleton x0)
+      | [x0; x1; x2] -> add x2 (add x1 (singleton x0))
+      | [x0; x1; x2; x3] -> add x3 (add x2 (add x1 (singleton x0)))
+      | [x0; x1; x2; x3; x4] -> add x4 (add x3 (add x2 (add x1 (singleton x0))))
+      | _ -> of_sorted_list (List.sort_uniq Ord.compare l)
+  end
diff --git a/stdlib/set.mli b/stdlib/set.mli
new file mode 100644
index 00000000..ef61e1a7
--- /dev/null
+++ b/stdlib/set.mli
@@ -0,0 +1,266 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Sets over ordered types.
+
+   This module implements the set data structure, given a total ordering
+   function over the set elements. All operations over sets
+   are purely applicative (no side-effects).
+   The implementation uses balanced binary trees, and is therefore
+   reasonably efficient: insertion and membership take time
+   logarithmic in the size of the set, for instance.
+
+   The {!Make} functor constructs implementations for any type, given a
+   [compare] function.
+   For instance:
+   {[
+     module IntPairs =
+       struct
+         type t = int * int
+         let compare (x0,y0) (x1,y1) =
+           match Pervasives.compare x0 x1 with
+               0 -> Pervasives.compare y0 y1
+             | c -> c
+       end
+
+     module PairsSet = Set.Make(IntPairs)
+
+     let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13))
+   ]}
+
+   This creates a new module [PairsSet], with a new type [PairsSet.t]
+   of sets of [int * int].
+*)
+
+module type OrderedType =
+  sig
+    type t
+      (** The type of the set elements. *)
+
+    val compare : t -> t -> int
+      (** A total ordering function over the set elements.
+          This is a two-argument function [f] such that
+          [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}. *)
+  end
+(** Input signature of the functor {!Set.Make}. *)
+
+module type S =
+  sig
+    type elt
+    (** The type of the set elements. *)
+
+    type t
+    (** The type of sets. *)
+
+    val empty: t
+    (** The empty set. *)
+
+    val is_empty: t -> bool
+    (** Test whether a set is empty or not. *)
+
+    val mem: elt -> t -> bool
+    (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+    val add: elt -> t -> t
+    (** [add x s] returns a set containing all elements of [s],
+       plus [x]. If [x] was already in [s], [s] is returned unchanged
+       (the result of the function is then physically equal to [s]).
+       @before 4.03 Physical equality was not ensured. *)
+
+    val singleton: elt -> t
+    (** [singleton x] returns the one-element set containing only [x]. *)
+
+    val remove: elt -> t -> t
+    (** [remove x s] returns a set containing all elements of [s],
+       except [x]. If [x] was not in [s], [s] is returned unchanged
+       (the result of the function is then physically equal to [s]).
+       @before 4.03 Physical equality was not ensured. *)
+
+    val union: t -> t -> t
+    (** Set union. *)
+
+    val inter: t -> t -> t
+    (** Set intersection. *)
+
+    val diff: t -> t -> t
+    (** Set difference. *)
+
+    val compare: t -> t -> int
+    (** Total ordering between sets. Can be used as the ordering function
+       for doing sets of sets. *)
+
+    val equal: t -> t -> bool
+    (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+       equal, that is, contain equal elements. *)
+
+    val subset: t -> t -> bool
+    (** [subset s1 s2] tests whether the set [s1] is a subset of
+       the set [s2]. *)
+
+    val iter: (elt -> unit) -> t -> unit
+    (** [iter f s] applies [f] in turn to all elements of [s].
+       The elements of [s] are presented to [f] in increasing order
+       with respect to the ordering over the type of the elements. *)
+
+    val map: (elt -> elt) -> t -> t
+    (** [map f s] is the set whose elements are [f a0],[f a1]... [f
+        aN], where [a0],[a1]...[aN] are the elements of [s].
+
+       The elements are passed to [f] in increasing order
+       with respect to the ordering over the type of the elements.
+
+       If no element of [s] is changed by [f], [s] is returned
+       unchanged. (If each output of [f] is physically equal to its
+       input, the returned set is physically equal to [s].)
+       @since 4.04.0 *)
+
+    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], in increasing order. *)
+
+    val for_all: (elt -> bool) -> t -> bool
+    (** [for_all p s] checks if all elements of the set
+       satisfy the predicate [p]. *)
+
+    val exists: (elt -> bool) -> t -> bool
+    (** [exists p s] checks if at least one element of
+       the set satisfies the predicate [p]. *)
+
+    val filter: (elt -> bool) -> t -> t
+    (** [filter p s] returns the set of all elements in [s]
+       that satisfy predicate [p]. If [p] satisfies every element in [s],
+       [s] is returned unchanged (the result of the function is then
+       physically equal to [s]).
+       @before 4.03 Physical equality was not ensured.*)
+
+    val partition: (elt -> bool) -> t -> t * t
+    (** [partition p s] returns a pair of sets [(s1, s2)], where
+       [s1] is the set of all the elements of [s] that satisfy the
+       predicate [p], and [s2] is the set of all the elements of
+       [s] that do not satisfy [p]. *)
+
+    val cardinal: t -> int
+    (** Return the number of elements of a set. *)
+
+    val elements: t -> elt list
+    (** Return the list of all elements of the given set.
+       The returned list is sorted in increasing order with respect
+       to the ordering [Ord.compare], where [Ord] is the argument
+       given to {!Set.Make}. *)
+
+    val min_elt: t -> elt
+    (** Return the smallest element of the given set
+       (with respect to the [Ord.compare] ordering), or raise
+       [Not_found] if the set is empty. *)
+
+    val min_elt_opt: t -> elt option
+    (** Return the smallest element of the given set
+       (with respect to the [Ord.compare] ordering), or [None]
+       if the set is empty.
+        @since 4.05
+    *)
+
+    val max_elt: t -> elt
+    (** Same as {!Set.S.min_elt}, but returns the largest element of the
+       given set. *)
+
+    val max_elt_opt: t -> elt option
+    (** Same as {!Set.S.min_elt_opt}, but returns the largest element of the
+        given set.
+        @since 4.05
+    *)
+
+    val choose: t -> elt
+    (** 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 choose_opt: t -> elt option
+    (** Return one element of the given set, or [None] if
+        the set is empty. Which element is chosen is unspecified,
+        but equal elements will be chosen for equal sets.
+        @since 4.05
+    *)
+
+    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]. *)
+
+    val find: elt -> t -> elt
+    (** [find x s] returns the element of [s] equal to [x] (according
+        to [Ord.compare]), or raise [Not_found] if no such element
+        exists.
+        @since 4.01.0 *)
+
+    val find_opt: elt -> t -> elt option
+    (** [find_opt x s] returns the element of [s] equal to [x] (according
+        to [Ord.compare]), or [None] if no such element
+        exists.
+        @since 4.05 *)
+
+    val find_first: (elt -> bool) -> t -> elt
+    (** [find_first f s], where [f] is a monotonically increasing function,
+       returns the lowest element [e] of [s] such that [f e],
+       or raises [Not_found] if no such element exists.
+
+       For example, [find_first (fun e -> Ord.compare e x >= 0) s] will return
+       the first element [e] of [s] where [Ord.compare e x >= 0] (intuitively:
+       [e >= x]), or raise [Not_found] if [x] is greater than any element of
+       [s].
+
+        @since 4.05
+       *)
+
+    val find_first_opt: (elt -> bool) -> t -> elt option
+    (** [find_first_opt f s], where [f] is a monotonically increasing function,
+       returns an option containing the lowest element [e] of [s] such that
+       [f e], or [None] if no such element exists.
+        @since 4.05
+       *)
+
+    val find_last: (elt -> bool) -> t -> elt
+    (** [find_last f s], where [f] is a monotonically decreasing function,
+       returns the highest element [e] of [s] such that [f e],
+       or raises [Not_found] if no such element exists.
+        @since 4.05
+       *)
+
+    val find_last_opt: (elt -> bool) -> t -> elt option
+    (** [find_last_opt f s], where [f] is a monotonically decreasing function,
+       returns an option containing the highest element [e] of [s] such that
+       [f e], or [None] if no such element exists.
+        @since 4.05
+       *)
+
+    val of_list: elt list -> t
+    (** [of_list l] creates a set from a list of elements.
+        This is usually more efficient than folding [add] over the list,
+        except perhaps for lists with many duplicated elements.
+        @since 4.02.0 *)
+  end
+(** Output signature of the functor {!Set.Make}. *)
+
+module Make (Ord : OrderedType) : S with type elt = Ord.t
+(** Functor building an implementation of the set structure
+   given a totally ordered type. *)
diff --git a/stdlib/sort.ml b/stdlib/sort.ml
new file mode 100644
index 00000000..3e3b12e0
--- /dev/null
+++ b/stdlib/sort.ml
@@ -0,0 +1,99 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Merging and sorting *)
+
+open Array
+
+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 list order l =
+  let rec initlist = function
+      [] -> []
+    | [e] -> [[e]]
+    | e1::e2::rest ->
+        (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in
+  let rec merge2 = function
+      l1::l2::rest -> merge order l1 l2 :: merge2 rest
+    | x -> x in
+  let rec mergeall = function
+      [] -> []
+    | [l] -> l
+    | llist -> mergeall (merge2 llist) in
+  mergeall(initlist l)
+
+let swap arr i j =
+  let tmp = unsafe_get arr i in
+  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
+      let mid = (lo + hi) lsr 1 in
+      (* Select median value from among LO, MID, and HI. Rearrange
+         LO and HI so the three values are sorted. This lowers the
+         probability of picking a pathological pivot.  It also
+         avoids extra comparisons on i and j in the two tight "while"
+         loops below. *)
+      if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo;
+      if cmp (unsafe_get arr hi) (unsafe_get arr mid) then begin
+        swap arr mid hi;
+        if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo
+      end;
+      let pivot = unsafe_get arr mid in
+      let i = ref (lo + 1) and j = ref (hi - 1) in
+      if not (cmp pivot (unsafe_get arr hi))
+         || not (cmp (unsafe_get arr lo) pivot)
+      then raise (Invalid_argument "Sort.array");
+      while !i < !j do
+        while not (cmp pivot (unsafe_get arr !i)) do incr i done;
+        while not (cmp (unsafe_get arr !j) pivot) do decr j done;
+        if !i < !j then swap arr !i !j;
+        incr i; decr j
+      done;
+      (* Recursion on smaller half, tail-call on larger half *)
+      if !j - lo <= hi - !i then begin
+        qsort lo !j; qsort !i hi
+      end else begin
+        qsort !i hi; qsort lo !j
+      end
+    end in
+  qsort 0 (Array.length arr - 1);
+  (* Finish sorting by insertion sort *)
+  for i = 1 to Array.length arr - 1 do
+    let val_i = (unsafe_get arr i) in
+    if not (cmp (unsafe_get arr (i - 1)) val_i) then begin
+      unsafe_set arr i (unsafe_get arr (i - 1));
+      let j = ref (i - 1) in
+      while !j >= 1 && not (cmp (unsafe_get arr (!j - 1)) val_i) do
+        unsafe_set arr !j (unsafe_get arr (!j - 1));
+        decr j
+      done;
+      unsafe_set arr !j val_i
+    end
+  done
diff --git a/stdlib/sort.mli b/stdlib/sort.mli
new file mode 100644
index 00000000..80ebad26
--- /dev/null
+++ b/stdlib/sort.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Sorting and merging lists.
+
+   @deprecated This module is obsolete and exists only for backward
+   compatibility.
+   The sorting functions in {!Array} and {!List} should be used instead.
+   The new functions are faster and use less memory.
+*)
+
+val list : ('a -> 'a -> bool) -> 'a list -> 'a list
+  [@@ocaml.deprecated "Use List.sort instead."]
+(** Sort a list in increasing order according to an ordering predicate.
+   The predicate should return [true] if its first argument is
+   less than or equal to its second argument. *)
+
+val array : ('a -> 'a -> bool) -> 'a array -> unit
+  [@@ocaml.deprecated "Use Array.sort instead."]
+(** Sort an array in increasing order according to an
+   ordering predicate.
+   The predicate should return [true] if its first argument is
+   less than or equal to its second argument.
+   The array is sorted in place. *)
+
+val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
+  [@@ocaml.deprecated "Use List.merge instead."]
+(** Merge two lists according to the given predicate.
+   Assuming the two argument lists are sorted according to the
+   predicate, [merge] returns a sorted list containing the elements
+   from the two lists. The behavior is undefined if the two
+   argument lists were not sorted. *)
diff --git a/stdlib/spacetime.ml b/stdlib/spacetime.ml
new file mode 100644
index 00000000..3e8abe1d
--- /dev/null
+++ b/stdlib/spacetime.ml
@@ -0,0 +1,91 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+external spacetime_enabled : unit -> bool
+  = "caml_spacetime_enabled" [@@noalloc]
+
+let enabled = spacetime_enabled ()
+
+let if_spacetime_enabled f =
+  if enabled then f () else ()
+
+module Series = struct
+  type t = {
+    channel : out_channel;
+    mutable closed : bool;
+  }
+
+  external write_magic_number : out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_write_magic_number"
+
+  external register_channel_for_spacetime : out_channel -> unit
+    = "caml_register_channel_for_spacetime"
+
+  let create ~path =
+    if spacetime_enabled () then begin
+      let channel = open_out path in
+      register_channel_for_spacetime channel;
+      let t =
+        { channel = channel;
+          closed = false;
+        }
+      in
+      write_magic_number t.channel;
+      t
+    end else begin
+      { channel = stdout;  (* arbitrary value *)
+        closed = true;
+      }
+    end
+
+  external save_event : ?time:float -> out_channel -> event_name:string -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_save_event"
+
+  let save_event ?time t ~event_name =
+    if_spacetime_enabled (fun () ->
+      save_event ?time t.channel ~event_name)
+
+  external save_trie : ?time:float -> out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_save_trie"
+
+  let save_and_close ?time t =
+    if_spacetime_enabled (fun () ->
+      if t.closed then failwith "Series is closed";
+      save_trie ?time t.channel;
+      close_out t.channel;
+      t.closed <- true)
+end
+
+module Snapshot = struct
+  external take : ?time:float -> out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_take_snapshot"
+
+  let take ?time { Series.closed; channel } =
+    if_spacetime_enabled (fun () ->
+      if closed then failwith "Series is closed";
+      Gc.minor ();
+      take ?time channel)
+end
+
+external save_event_for_automatic_snapshots : event_name:string -> unit
+  = "caml_spacetime_only_works_for_native_code"
+    "caml_spacetime_save_event_for_automatic_snapshots"
+
+let save_event_for_automatic_snapshots ~event_name =
+  if_spacetime_enabled (fun () ->
+    save_event_for_automatic_snapshots ~event_name)
diff --git a/stdlib/spacetime.mli b/stdlib/spacetime.mli
new file mode 100644
index 00000000..d0bbac8b
--- /dev/null
+++ b/stdlib/spacetime.mli
@@ -0,0 +1,99 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Profiling of a program's space behaviour over time.
+    Currently only supported on x86-64 platforms running 64-bit code.
+
+    To use the functions in this module you must:
+    - configure the compiler with "-spacetime";
+    - compile to native code.
+    Without these conditions being satisfied the functions in this module
+    will have no effect.
+
+    Instead of manually taking profiling heap snapshots with this module it is
+    possible to use an automatic snapshot facility that writes profiling
+    information at fixed intervals to a file. To enable this, all that needs to
+    be done is to build the relevant program using a compiler configured with
+    -spacetime; and set the environment variable OCAML_SPACETIME_INTERVAL to an
+    integer number of milliseconds giving the interval between profiling heap
+    snapshots. This interval should not be made excessively small relative to
+    the running time of the program. A typical interval to start with might be
+    1/100 of the running time of the program.  The program must exit "normally"
+    (i.e. by calling [exit], with whatever exit code, rather than being
+    abnormally terminated by a signal) so that the snapshot file is
+    correctly completed.
+
+    When using the automatic snapshot mode the profiling output is written
+    to a file called "spacetime-<pid>" where <pid> is the process ID of the
+    program.  (If the program forks and continues executing then multiple
+    files may be produced with different pid numbers.)  The profiling output
+    is by default written to the current working directory when the program
+    starts.  This may be customised by setting the OCAML_SPACETIME_SNAPSHOT_DIR
+    environment variable to the name of the desired directory.
+
+    If using automatic snapshots the presence of the
+    [save_event_for_automatic_snapshots] function, below, should be noted.
+
+    The functions in this module are thread safe.
+
+    For functions to decode the information recorded by the profiler,
+    see the Spacetime offline library in otherlibs/. *)
+
+(** [enabled] is [true] if the compiler is configured with spacetime and [false]
+    otherwise *)
+val enabled : bool
+
+module Series : sig
+  (** Type representing a file that will hold a series of heap snapshots
+      together with additional information required to interpret those
+      snapshots. *)
+  type t
+
+  (** [create ~path] creates a series file at [path]. *)
+  val create : path:string -> t
+
+  (** [save_event] writes an event, which is an arbitrary string, into the
+      given series file.  This may be used for identifying particular points
+      during program execution when analysing the profile.
+      The optional [time] parameter is as for {!Snapshot.take}.
+  *)
+  val save_event : ?time:float -> t -> event_name:string -> unit
+
+  (** [save_and_close series] writes information into [series] required for
+      interpeting the snapshots that [series] contains and then closes the
+      [series] file. This function must be called to produce a valid series
+      file.
+      The optional [time] parameter is as for {!Snapshot.take}.
+  *)
+  val save_and_close : ?time:float -> t -> unit
+end
+
+module Snapshot : sig
+  (** [take series] takes a snapshot of the profiling annotations on the values
+      in the minor and major heaps, together with GC stats, and write the
+      result to the [series] file.  This function triggers a minor GC but does
+      not allocate any memory itself.
+      If the optional [time] is specified, it will be used instead of the
+      result of {!Sys.time} as the timestamp of the snapshot.  Such [time]s
+      should start from zero and be monotonically increasing.  This parameter
+      is intended to be used so that snapshots can be correlated against wall
+      clock time (which is not supported in the standard library) rather than
+      elapsed CPU time.
+  *)
+  val take : ?time:float -> Series.t -> unit
+end
+
+(** Like {!Series.save_event}, but writes to the automatic snapshot file.
+    This function is a no-op if OCAML_SPACETIME_INTERVAL was not set. *)
+val save_event_for_automatic_snapshots : event_name:string -> unit
diff --git a/stdlib/stack.ml b/stdlib/stack.ml
new file mode 100644
index 00000000..21dad3e8
--- /dev/null
+++ b/stdlib/stack.ml
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type 'a t = { mutable c : 'a list; mutable len : int; }
+
+exception Empty
+
+let create () = { c = []; len = 0; }
+
+let clear s = s.c <- []; s.len <- 0
+
+let copy s = { c = s.c; len = s.len; }
+
+let push x s = s.c <- x :: s.c; s.len <- s.len + 1
+
+let pop s =
+  match s.c with
+  | hd::tl -> s.c <- tl; s.len <- s.len - 1; hd
+  | []     -> raise Empty
+
+let top s =
+  match s.c with
+  | hd::_ -> hd
+  | []     -> raise Empty
+
+let is_empty s = (s.c = [])
+
+let length s = s.len
+
+let iter f s = List.iter f s.c
+
+let fold f acc s = List.fold_left f acc s.c
diff --git a/stdlib/stack.mli b/stdlib/stack.mli
new file mode 100644
index 00000000..4ce89953
--- /dev/null
+++ b/stdlib/stack.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Last-in first-out stacks.
+
+   This module implements stacks (LIFOs), with in-place modification.
+*)
+
+type 'a t
+(** The type of stacks containing elements of type ['a]. *)
+
+exception Empty
+(** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *)
+
+
+val create : unit -> 'a t
+(** Return a new stack, initially empty. *)
+
+val push : 'a -> 'a t -> unit
+(** [push x s] adds the element [x] at the top of stack [s]. *)
+
+val pop : 'a t -> 'a
+(** [pop s] removes and returns the topmost element in stack [s],
+   or raises {!Empty} if the stack is empty. *)
+
+val top : 'a t -> 'a
+(** [top s] returns the topmost element in stack [s],
+   or raises {!Empty} if the stack is empty. *)
+
+val clear : 'a t -> unit
+(** Discard all elements from a stack. *)
+
+val copy : 'a t -> 'a t
+(** Return a copy of the given stack. *)
+
+val is_empty : 'a t -> bool
+(** Return [true] if the given stack is empty, [false] otherwise. *)
+
+val length : 'a t -> int
+(** Return the number of elements in a stack. Time complexity O(1) *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f s] applies [f] in turn to all elements of [s],
+   from the element at the top of the stack to the element at the
+   bottom of the stack. The stack itself is unchanged. *)
+
+val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+(** [fold f accu s] is [(f (... (f (f accu x1) x2) ...) xn)]
+    where [x1] is the top of the stack, [x2] the second element,
+    and [xn] the bottom element. The stack is unchanged.
+    @since 4.03 *)
diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml
new file mode 100644
index 00000000..664472b1
--- /dev/null
+++ b/stdlib/stdLabels.ml
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [StdLabels]: meta-module for labelled libraries *)
+
+module Array = ArrayLabels
+
+module List = ListLabels
+
+module String = StringLabels
+
+module Bytes = BytesLabels
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
new file mode 100644
index 00000000..4b24fd2b
--- /dev/null
+++ b/stdlib/stdLabels.mli
@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Standard labeled libraries.
+
+   This meta-module provides labelized version of the {!Array},
+   {!Bytes}, {!List} and {!String} modules.
+
+   They only differ by their labels. Detailed interfaces can be found
+   in [arrayLabels.mli], [bytesLabels.mli], [listLabels.mli]
+   and [stringLabels.mli].
+*)
+
+module Array = ArrayLabels
+module Bytes = BytesLabels
+module List = ListLabels
+module String = StringLabels
diff --git a/stdlib/std_exit.ml b/stdlib/std_exit.ml
new file mode 100644
index 00000000..1b97652d
--- /dev/null
+++ b/stdlib/std_exit.ml
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Ensure that [at_exit] functions are called at the end of every program *)
+
+let _ = do_at_exit()
diff --git a/stdlib/stream.ml b/stdlib/stream.ml
new file mode 100644
index 00000000..e9b5e611
--- /dev/null
+++ b/stdlib/stream.ml
@@ -0,0 +1,233 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt       *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type 'a t = 'a cell option
+and 'a cell = { mutable count : int; mutable data : 'a data }
+and 'a data =
+    Sempty
+  | Scons of 'a * 'a data
+  | Sapp of 'a data * 'a data
+  | Slazy of 'a data Lazy.t
+  | Sgen of 'a gen
+  | Sbuffio : buffio -> char data
+and 'a gen = { mutable curr : 'a option option; func : int -> 'a option }
+and buffio =
+  { ic : in_channel; buff : bytes; mutable len : int; mutable ind : int }
+
+exception Failure
+exception Error of string
+
+let count = function
+  | None -> 0
+  | Some { count } -> count
+let data = function
+  | None -> Sempty
+  | Some { data } -> data
+
+let fill_buff b =
+  b.len <- input b.ic b.buff 0 (Bytes.length b.buff); b.ind <- 0
+
+
+let rec get_data : type v. int -> v data -> v data = fun count d -> match d with
+ (* Returns either Sempty or Scons(a, _) even when d is a generator
+    or a buffer. In those cases, the item a is seen as extracted from
+ the generator/buffer.
+ The count parameter is used for calling `Sgen-functions'.  *)
+   Sempty | Scons (_, _) -> d
+ | Sapp (d1, d2) ->
+     begin match get_data count d1 with
+       Scons (a, d11) -> Scons (a, Sapp (d11, d2))
+     | Sempty -> get_data count d2
+     | _ -> assert false
+     end
+ | Sgen {curr = Some None} -> Sempty
+ | Sgen ({curr = Some(Some a)} as g) ->
+     g.curr <- None; Scons(a, d)
+ | Sgen g ->
+     begin match g.func count with
+       None -> g.curr <- Some(None); Sempty
+     | Some a -> Scons(a, d)
+         (* Warning: anyone using g thinks that an item has been read *)
+     end
+ | Sbuffio b ->
+     if b.ind >= b.len then fill_buff b;
+     if b.len == 0 then Sempty else
+       let r = Bytes.unsafe_get b.buff b.ind in
+       (* Warning: anyone using g thinks that an item has been read *)
+       b.ind <- succ b.ind; Scons(r, d)
+ | Slazy f -> get_data count (Lazy.force f)
+
+
+let rec peek_data : type v. v cell -> v option = fun s ->
+ (* consult the first item of s *)
+ match s.data with
+   Sempty -> None
+ | Scons (a, _) -> Some a
+ | Sapp (_, _) ->
+     begin match get_data s.count s.data with
+       Scons(a, _) as d -> s.data <- d; Some a
+     | Sempty -> None
+     | _ -> assert false
+     end
+ | Slazy f -> s.data <- (Lazy.force f); peek_data s
+ | Sgen {curr = Some a} -> a
+ | Sgen g -> let x = g.func s.count in g.curr <- Some x; x
+ | Sbuffio b ->
+     if b.ind >= b.len then fill_buff b;
+     if b.len == 0 then begin s.data <- Sempty; None end
+     else Some (Bytes.unsafe_get b.buff b.ind)
+
+
+let peek = function
+  | None -> None
+  | Some s -> peek_data s
+
+
+let rec junk_data : type v. v cell -> unit = fun s ->
+  match s.data with
+    Scons (_, d) -> s.count <- (succ s.count); s.data <- d
+  | Sgen ({curr = Some _} as g) -> s.count <- (succ s.count); g.curr <- None
+  | Sbuffio b -> s.count <- (succ s.count); b.ind <- succ b.ind
+  | _ ->
+      match peek_data s with
+        None -> ()
+      | Some _ -> junk_data s
+
+
+let junk = function
+  | None -> ()
+  | Some data -> junk_data data
+
+let rec nget_data n s =
+  if n <= 0 then [], s.data, 0
+  else
+    match peek_data s with
+      Some a ->
+        junk_data s;
+        let (al, d, k) = nget_data (pred n) s in a :: al, Scons (a, d), succ k
+    | None -> [], s.data, 0
+
+
+let npeek_data n s =
+  let (al, d, len) = nget_data n s in
+  s.count <- (s.count - len);
+  s.data <- d;
+  al
+
+
+let npeek n = function
+  | None -> []
+  | Some d -> npeek_data n d
+
+let next s =
+  match peek s with
+    Some a -> junk s; a
+  | None -> raise Failure
+
+
+let empty s =
+  match peek s with
+    Some _ -> raise Failure
+  | None -> ()
+
+
+let iter f strm =
+  let rec do_rec () =
+    match peek strm with
+      Some a -> junk strm; ignore(f a); do_rec ()
+    | None -> ()
+  in
+  do_rec ()
+
+
+(* Stream building functions *)
+
+let from f = Some {count = 0; data = Sgen {curr = None; func = f}}
+
+let of_list l =
+  Some {count = 0; data = List.fold_right (fun x l -> Scons (x, l)) l Sempty}
+
+
+let of_string s =
+  let count = ref 0 in
+  from (fun _ ->
+    (* We cannot use the index passed by the [from] function directly
+       because it returns the current stream count, with absolutely no
+       guarantee that it will start from 0. For example, in the case
+       of [Stream.icons 'c' (Stream.from_string "ab")], the first
+       access to the string will be made with count [1] already.
+    *)
+    let c = !count in
+    if c < String.length s
+    then (incr count; Some s.[c])
+    else None)
+
+
+let of_bytes s =
+  let count = ref 0 in
+  from (fun _ ->
+    let c = !count in
+    if c < Bytes.length s
+    then (incr count; Some (Bytes.get s c))
+    else None)
+
+
+let of_channel ic =
+  Some {count = 0;
+        data = Sbuffio {ic = ic; buff = Bytes.create 4096; len = 0; ind = 0}}
+
+
+(* Stream expressions builders *)
+
+let iapp i s = Some {count = 0; data = Sapp (data i, data s)}
+let icons i s = Some {count = 0; data = Scons (i, data s)}
+let ising i = Some {count = 0; data = Scons (i, Sempty)}
+
+let lapp f s =
+  Some {count = 0; data = Slazy (lazy(Sapp (data (f ()), data s)))}
+
+let lcons f s = Some {count = 0; data = Slazy (lazy(Scons (f (), data s)))}
+let lsing f = Some {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))}
+
+let sempty = None
+let slazy f = Some {count = 0; data = Slazy (lazy(data (f ())))}
+
+(* For debugging use *)
+
+let rec dump : type v. (v -> unit) -> v t -> unit = fun f s ->
+  print_string "{count = ";
+  print_int (count s);
+  print_string "; data = ";
+  dump_data f (data s);
+  print_string "}";
+  print_newline ()
+and dump_data : type v. (v -> unit) -> v data -> unit = fun f ->
+  function
+    Sempty -> print_string "Sempty"
+  | Scons (a, d) ->
+      print_string "Scons (";
+      f a;
+      print_string ", ";
+      dump_data f d;
+      print_string ")"
+  | Sapp (d1, d2) ->
+      print_string "Sapp (";
+      dump_data f d1;
+      print_string ", ";
+      dump_data f d2;
+      print_string ")"
+  | Slazy _ -> print_string "Slazy"
+  | Sgen _ -> print_string "Sgen"
+  | Sbuffio _ -> print_string "Sbuffio"
diff --git a/stdlib/stream.mli b/stdlib/stream.mli
new file mode 100644
index 00000000..03b34a04
--- /dev/null
+++ b/stdlib/stream.mli
@@ -0,0 +1,110 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt       *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Streams and parsers. *)
+
+type 'a t
+(** The type of streams holding values of type ['a]. *)
+
+exception Failure
+(** Raised by parsers when none of the first components of the stream
+   patterns is accepted. *)
+
+exception Error of string
+(** Raised by parsers when the first component of a stream pattern is
+   accepted, but one of the following components is rejected. *)
+
+
+(** {6 Stream builders} *)
+
+val from : (int -> 'a option) -> 'a t
+(** [Stream.from f] returns a stream built from the function [f].
+   To create a new stream element, the function [f] is called with
+   the current stream count. The user function [f] must return either
+   [Some <value>] for a value or [None] to specify the end of the
+   stream.
+
+   Do note that the indices passed to [f] may not start at [0] in the
+   general case. For example, [[< '0; '1; Stream.from f >]] would call
+   [f] the first time with count [2].
+*)
+
+val of_list : 'a list -> 'a t
+(** Return the stream holding the elements of the list in the same
+   order. *)
+
+val of_string : string -> char t
+(** Return the stream of the characters of the string parameter. *)
+
+val of_bytes : bytes -> char t
+(** Return the stream of the characters of the bytes parameter.
+    @since 4.02.0 *)
+
+val of_channel : in_channel -> char t
+(** Return the stream of the characters read from the input channel. *)
+
+
+(** {6 Stream iterator} *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [Stream.iter f s] scans the whole stream s, applying function [f]
+   in turn to each stream element encountered. *)
+
+
+(** {6 Predefined parsers} *)
+
+val next : 'a t -> 'a
+(** Return the first element of the stream and remove it from the
+   stream. Raise {!Stream.Failure} if the stream is empty. *)
+
+val empty : 'a t -> unit
+(** Return [()] if the stream is empty, else raise {!Stream.Failure}. *)
+
+
+(** {6 Useful functions} *)
+
+val peek : 'a t -> 'a option
+(** Return [Some] of "the first element" of the stream, or [None] if
+   the stream is empty. *)
+
+val junk : 'a t -> unit
+(** Remove the first element of the stream, possibly unfreezing
+   it before. *)
+
+val count : 'a t -> int
+(** Return the current count of the stream elements, i.e. the number
+   of the stream elements discarded. *)
+
+val npeek : int -> 'a t -> 'a list
+(** [npeek n] returns the list of the [n] first elements of
+   the stream, or all its remaining elements if less than [n]
+   elements are available. *)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+val iapp : 'a t -> 'a t -> 'a t
+val icons : 'a -> 'a t -> 'a t
+val ising : 'a -> 'a t
+
+val lapp : (unit -> 'a t) -> 'a t -> 'a t
+val lcons : (unit -> 'a) -> 'a t -> 'a t
+val lsing : (unit -> 'a) -> 'a t
+
+val sempty : 'a t
+val slazy : (unit -> 'a t) -> 'a t
+
+val dump : ('a -> unit) -> 'a t -> unit
diff --git a/stdlib/string.ml b/stdlib/string.ml
new file mode 100644
index 00000000..9a4b533f
--- /dev/null
+++ b/stdlib/string.ml
@@ -0,0 +1,226 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* String operations, based on byte sequence operations *)
+
+(* WARNING: Some functions in this file are duplicated in bytes.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in bytes.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
+external length : string -> int = "%string_length"
+external get : string -> int -> char = "%string_safe_get"
+external set : bytes -> int -> char -> unit = "%string_safe_set"
+external create : int -> bytes = "caml_create_string"
+external unsafe_get : string -> int -> char = "%string_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external unsafe_blit : string -> int ->  bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+external unsafe_fill : bytes -> int -> int -> char -> unit
+                     = "caml_fill_string" [@@noalloc]
+
+module B = Bytes
+
+let bts = B.unsafe_to_string
+let bos = B.unsafe_of_string
+
+let make n c =
+  B.make n c |> bts
+let init n f =
+  B.init n f |> bts
+let copy s =
+  B.copy (bos s) |> bts
+let sub s ofs len =
+  B.sub (bos s) ofs len |> bts
+let fill =
+  B.fill
+let blit =
+  B.blit_string
+
+let ensure_ge (x:int) y = if x >= y then x else invalid_arg "String.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
+
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
+  | hd :: tl ->
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> ""
+  | l -> let seplen = length sep in bts @@
+          unsafe_blits
+            (B.create (sum_lengths 0 seplen l))
+            0 sep seplen l
+
+(* duplicated in bytes.ml *)
+let iter f s =
+  for i = 0 to length s - 1 do f (unsafe_get s i) done
+
+(* duplicated in bytes.ml *)
+let iteri f s =
+  for i = 0 to length s - 1 do f i (unsafe_get s i) done
+
+let map f s =
+  B.map f (bos s) |> bts
+let mapi f s =
+  B.mapi f (bos s) |> bts
+
+(* Beware: we cannot use B.trim or B.escape because they always make a
+   copy, but String.mli spells out some cases where we are not allowed
+   to make a copy. *)
+
+let is_space = function
+  | ' ' | '\012' | '\n' | '\r' | '\t' -> true
+  | _ -> false
+
+let trim s =
+  if s = "" then s
+  else if is_space (unsafe_get s 0) || is_space (unsafe_get s (length s - 1))
+    then bts (B.trim (bos s))
+  else s
+
+let escaped s =
+  let rec needs_escape i =
+    if i >= length s then false else
+      match unsafe_get s i with
+      | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> true
+      | ' ' .. '~' -> needs_escape (i+1)
+      | _ -> true
+  in
+  if needs_escape 0 then
+    bts (B.escaped (bos s))
+  else
+    s
+
+(* duplicated in bytes.ml *)
+let rec index_rec s lim i c =
+  if i >= lim then raise Not_found else
+  if unsafe_get s i = c then i else index_rec s lim (i + 1) c
+
+(* duplicated in bytes.ml *)
+let index s c = index_rec s (length s) 0 c
+
+(* duplicated in bytes.ml *)
+let rec index_rec_opt s lim i c =
+  if i >= lim then None else
+  if unsafe_get s i = c then Some i else index_rec_opt s lim (i + 1) c
+
+(* duplicated in bytes.ml *)
+let index_opt s c = index_rec_opt s (length s) 0 c
+
+(* duplicated in bytes.ml *)
+let index_from s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
+    index_rec s l i c
+
+(* duplicated in bytes.ml *)
+let index_from_opt s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from_opt / Bytes.index_from_opt" else
+  index_rec_opt s l i c
+
+(* duplicated in bytes.ml *)
+let rec rindex_rec s i c =
+  if i < 0 then raise Not_found else
+  if unsafe_get s i = c then i else rindex_rec s (i - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex s c = rindex_rec s (length s - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex_from s i c =
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from / Bytes.rindex_from"
+  else
+    rindex_rec s i c
+
+(* duplicated in bytes.ml *)
+let rec rindex_rec_opt s i c =
+  if i < 0 then None else
+  if unsafe_get s i = c then Some i else rindex_rec_opt s (i - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex_opt s c = rindex_rec_opt s (length s - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex_from_opt s i c =
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from_opt / Bytes.rindex_from_opt"
+  else
+    rindex_rec_opt s i c
+
+(* duplicated in bytes.ml *)
+let contains_from s i c =
+  let l = length s in
+  if i < 0 || i > l then
+    invalid_arg "String.contains_from / Bytes.contains_from"
+  else
+    try ignore (index_rec s l i c); true with Not_found -> false
+
+(* duplicated in bytes.ml *)
+let contains s c = contains_from s 0 c
+
+(* duplicated in bytes.ml *)
+let rcontains_from s i c =
+  if i < 0 || i >= length s then
+    invalid_arg "String.rcontains_from / Bytes.rcontains_from"
+  else
+    try ignore (rindex_rec s i c); true with Not_found -> false
+
+let uppercase_ascii s =
+  B.uppercase_ascii (bos s) |> bts
+let lowercase_ascii s =
+  B.lowercase_ascii (bos s) |> bts
+let capitalize_ascii s =
+  B.capitalize_ascii (bos s) |> bts
+let uncapitalize_ascii s =
+  B.uncapitalize_ascii (bos s) |> bts
+
+type t = string
+
+let compare (x: t) (y: t) = Pervasives.compare x y
+external equal : string -> string -> bool = "caml_string_equal"
+
+let split_on_char sep s =
+  let r = ref [] in
+  let j = ref (length s) in
+  for i = length s - 1 downto 0 do
+    if unsafe_get s i = sep then begin
+      r := sub s (i + 1) (!j - i - 1) :: !r;
+      j := i
+    end
+  done;
+  sub s 0 !j :: !r
+
+(* Deprecated functions implemented via other deprecated functions *)
+[@@@ocaml.warning "-3"]
+let uppercase s =
+  B.uppercase (bos s) |> bts
+let lowercase s =
+  B.lowercase (bos s) |> bts
+let capitalize s =
+  B.capitalize (bos s) |> bts
+let uncapitalize s =
+  B.uncapitalize (bos s) |> bts
diff --git a/stdlib/string.mli b/stdlib/string.mli
new file mode 100644
index 00000000..6c250ef7
--- /dev/null
+++ b/stdlib/string.mli
@@ -0,0 +1,348 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** String operations.
+
+  A string is an immutable data structure that contains a
+  fixed-length sequence of (single-byte) characters. Each character
+  can be accessed in constant time through its index.
+
+  Given a string [s] of length [l], we can access each of the [l]
+  characters of [s] via its index in the sequence. Indexes start at
+  [0], and we will call an index valid in [s] if it falls within the
+  range [[0...l-1]] (inclusive). A position is the point between two
+  characters or at the beginning or end of the string.  We call a
+  position valid in [s] if it falls within the range [[0...l]]
+  (inclusive). Note that the character at index [n] is between
+  positions [n] and [n+1].
+
+  Two parameters [start] and [len] are said to designate a valid
+  substring of [s] if [len >= 0] and [start] and [start+len] are
+  valid positions in [s].
+
+  OCaml strings used to be modifiable in place, for instance via the
+  {!String.set} and {!String.blit} functions described below. This
+  usage is deprecated and only possible when the compiler is put in
+  "unsafe-string" mode by giving the [-unsafe-string] command-line
+  option (which is currently the default for reasons of backward
+  compatibility). This is done by making the types [string] and
+  [bytes] (see module {!Bytes}) interchangeable so that functions
+  expecting byte sequences can also accept strings as arguments and
+  modify them.
+
+  All new code should avoid this feature and be compiled with the
+  [-safe-string] command-line option to enforce the separation between
+  the types [string] and [bytes].
+
+ *)
+
+external length : string -> int = "%string_length"
+(** Return the length (number of characters) of the given string. *)
+
+external get : string -> int -> char = "%string_safe_get"
+(** [String.get s n] returns the character at index [n] in string [s].
+   You can also write [s.[n]] instead of [String.get s n].
+
+   Raise [Invalid_argument] if [n] not a valid index in [s]. *)
+
+
+external set : bytes -> int -> char -> unit = "%string_safe_set"
+  [@@ocaml.deprecated "Use Bytes.set instead."]
+(** [String.set s n c] modifies byte sequence [s] in place,
+   replacing the byte at index [n] with [c].
+   You can also write [s.[n] <- c] instead of [String.set s n c].
+
+   Raise [Invalid_argument] if [n] is not a valid index in [s].
+
+   @deprecated This is a deprecated alias of {!Bytes.set}.[ ] *)
+
+external create : int -> bytes = "caml_create_string"
+  [@@ocaml.deprecated "Use Bytes.create instead."]
+(** [String.create n] returns a fresh byte sequence of length [n].
+   The sequence is uninitialized and contains arbitrary bytes.
+
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
+
+   @deprecated This is a deprecated alias of {!Bytes.create}.[ ] *)
+
+val make : int -> char -> string
+(** [String.make n c] returns a fresh string of length [n],
+   filled with the character [c].
+
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val init : int -> (int -> char) -> string
+(** [String.init n f] returns a string of length [n], with character
+    [i] initialized to the result of [f i] (called in increasing
+    index order).
+
+    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
+
+    @since 4.02.0
+*)
+
+val copy : string -> string [@@ocaml.deprecated]
+(** Return a copy of the given string.
+
+    @deprecated Because strings are immutable, it doesn't make much
+    sense to make identical copies of them. *)
+
+val sub : string -> int -> int -> string
+(** [String.sub s start len] returns a fresh string of length [len],
+   containing the substring of [s] that starts at position [start] and
+   has length [len].
+
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s]. *)
+
+val fill : bytes -> int -> int -> char -> unit
+  [@@ocaml.deprecated "Use Bytes.fill instead."]
+(** [String.fill s start len c] modifies byte sequence [s] in place,
+   replacing [len] bytes with [c], starting at [start].
+
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid range of [s].
+
+   @deprecated This is a deprecated alias of {!Bytes.fill}.[ ] *)
+
+val blit : string -> int -> bytes -> int -> int -> unit
+(** Same as {!Bytes.blit_string}. *)
+
+val concat : string -> string list -> string
+(** [String.concat sep sl] concatenates the list of strings [sl],
+    inserting the separator string [sep] between each.
+
+    Raise [Invalid_argument] if the result is longer than
+    {!Sys.max_string_length} bytes. *)
+
+val iter : (char -> unit) -> string -> unit
+(** [String.iter f s] applies function [f] in turn to all
+   the characters of [s].  It is equivalent to
+   [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
+
+val iteri : (int -> char -> unit) -> string -> unit
+(** Same as {!String.iter}, but the
+   function is applied to the index of the element as first argument
+   (counting from 0), and the character itself as second argument.
+   @since 4.00.0 *)
+
+val map : (char -> char) -> string -> string
+(** [String.map f s] applies function [f] in turn to all the
+    characters of [s] (in increasing index order) and stores the
+    results in a new string that is returned.
+    @since 4.00.0 *)
+
+val mapi : (int -> char -> char) -> string -> string
+(** [String.mapi f s] calls [f] with each character of [s] and its
+    index (in increasing index order) and stores the results in a new
+    string that is returned.
+    @since 4.02.0 *)
+
+val trim : string -> string
+(** Return a copy of the argument, without leading and trailing
+   whitespace.  The characters regarded as whitespace are: [' '],
+   ['\012'], ['\n'], ['\r'], and ['\t'].  If there is neither leading nor
+   trailing whitespace character in the argument, return the original
+   string itself, not a copy.
+   @since 4.00.0 *)
+
+val escaped : string -> string
+(** Return a copy of the argument, with special characters
+    represented by escape sequences, following the lexical
+    conventions of OCaml.
+    All characters outside the ASCII printable range (32..126) are
+    escaped, as well as backslash and double-quote.
+
+    If there is no special character in the argument that needs
+    escaping, return the original string itself, not a copy.
+
+    Raise [Invalid_argument] if the result is longer than
+    {!Sys.max_string_length} bytes.
+
+    The function {!Scanf.unescaped} is a left inverse of [escaped],
+    i.e. [Scanf.unescaped (escaped s) = s] for any string [s] (unless
+    [escape s] fails). *)
+
+val index : string -> char -> int
+(** [String.index s c] returns the index of the first
+   occurrence of character [c] in string [s].
+
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val index_opt: string -> char -> int option
+(** [String.index_opt s c] returns the index of the first
+    occurrence of character [c] in string [s], or
+    [None] if [c] does not occur in [s].
+    @since 4.05 *)
+
+val rindex : string -> char -> int
+(** [String.rindex s c] returns the index of the last
+   occurrence of character [c] in string [s].
+
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val rindex_opt: string -> char -> int option
+(** [String.rindex_opt s c] returns the index of the last occurrence
+    of character [c] in string [s], or [None] if [c] does not occur in
+    [s].
+    @since 4.05 *)
+
+val index_from : string -> int -> char -> int
+(** [String.index_from s i c] returns the index of the
+   first occurrence of character [c] in string [s] after position [i].
+   [String.index s c] is equivalent to [String.index_from s 0 c].
+
+   Raise [Invalid_argument] if [i] is not a valid position in [s].
+   Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+
+val index_from_opt: string -> int -> char -> int option
+(** [String.index_from_opt s i c] returns the index of the
+    first occurrence of character [c] in string [s] after position [i]
+    or [None] if [c] does not occur in [s] after position [i].
+
+    [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c].
+    Raise [Invalid_argument] if [i] is not a valid position in [s].
+
+    @since 4.05
+*)
+
+val rindex_from : string -> int -> char -> int
+(** [String.rindex_from s i c] returns the index of the
+   last occurrence of character [c] in string [s] before position [i+1].
+   [String.rindex s c] is equivalent to
+   [String.rindex_from s (String.length s - 1) c].
+
+   Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+   Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+
+val rindex_from_opt: string -> int -> char -> int option
+(** [String.rindex_from_opt s i c] returns the index of the
+   last occurrence of character [c] in string [s] before position [i+1]
+   or [None] if [c] does not occur in [s] before position [i+1].
+
+   [String.rindex_opt s c] is equivalent to
+   [String.rindex_from_opt s (String.length s - 1) c].
+
+   Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+
+    @since 4.05
+*)
+
+val contains : string -> char -> bool
+(** [String.contains s c] tests if character [c]
+   appears in the string [s]. *)
+
+val contains_from : string -> int -> char -> bool
+(** [String.contains_from s start c] tests if character [c]
+   appears in [s] after position [start].
+   [String.contains s c] is equivalent to
+   [String.contains_from s 0 c].
+
+   Raise [Invalid_argument] if [start] is not a valid position in [s]. *)
+
+val rcontains_from : string -> int -> char -> bool
+(** [String.rcontains_from s stop c] tests if character [c]
+   appears in [s] before position [stop+1].
+
+   Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid
+   position in [s]. *)
+
+val uppercase : string -> string
+  [@@ocaml.deprecated "Use String.uppercase_ascii instead."]
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val lowercase : string -> string
+  [@@ocaml.deprecated "Use String.lowercase_ascii instead."]
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val capitalize : string -> string
+  [@@ocaml.deprecated "Use String.capitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uncapitalize : string -> string
+  [@@ocaml.deprecated "Use String.uncapitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase_ascii : string -> string
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val lowercase_ascii : string -> string
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val capitalize_ascii : string -> string
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the US-ASCII character set.
+   @since 4.03.0 *)
+
+val uncapitalize_ascii : string -> string
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the US-ASCII character set.
+   @since 4.03.0 *)
+
+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}. *)
+
+val equal: t -> t -> bool
+(** The equal function for strings.
+    @since 4.03.0 *)
+
+val split_on_char: char -> string -> string list
+(** [String.split_on_char sep s] returns the list of all (possibly empty)
+    substrings of [s] that are delimited by the [sep] character.
+
+    The function's output is specified by the following invariants:
+
+    - The list is not empty.
+    - Concatenating its elements using [sep] as a separator returns a
+      string equal to the input ([String.concat (String.make 1 sep)
+      (String.split_on_char sep s) = s]).
+    - No string in the result contains the [sep] character.
+
+    @since 4.04.0
+*)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_get : string -> int -> char = "%string_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+  [@@ocaml.deprecated]
+external unsafe_blit :
+  string -> int -> bytes -> int -> int -> unit
+  = "caml_blit_string" [@@noalloc]
+external unsafe_fill :
+  bytes -> int -> int -> char -> unit = "caml_fill_string" [@@noalloc]
+  [@@ocaml.deprecated]
diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml
new file mode 100644
index 00000000..9675b7a2
--- /dev/null
+++ b/stdlib/stringLabels.ml
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Jacques Garrigue, Kyoto University RIMS                 *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [StringLabels]: labelled String module *)
+
+include String
diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
new file mode 100644
index 00000000..41c5951d
--- /dev/null
+++ b/stdlib/stringLabels.mli
@@ -0,0 +1,303 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** String operations. *)
+
+external length : string -> int = "%string_length"
+(** Return the length (number of characters) of the given string. *)
+
+external get : string -> int -> char = "%string_safe_get"
+(** [String.get s n] returns the character at index [n] in string [s].
+   You can also write [s.[n]] instead of [String.get s n].
+
+   Raise [Invalid_argument] if [n] not a valid index in [s]. *)
+
+external set : bytes -> int -> char -> unit = "%string_safe_set"
+  [@@ocaml.deprecated "Use BytesLabels.set instead."]
+(** [String.set s n c] modifies byte sequence [s] in place,
+   replacing the byte at index [n] with [c].
+   You can also write [s.[n] <- c] instead of [String.set s n c].
+
+   Raise [Invalid_argument] if [n] is not a valid index in [s].
+
+   @deprecated This is a deprecated alias of {!BytesLabels.set}. *)
+
+external create : int -> bytes = "caml_create_string"
+  [@@ocaml.deprecated "Use BytesLabels.create instead."]
+(** [String.create n] returns a fresh byte sequence of length [n].
+   The sequence is uninitialized and contains arbitrary bytes.
+
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
+
+   @deprecated This is a deprecated alias of {!BytesLabels.create}. *)
+
+val make : int -> char -> string
+(** [String.make n c] returns a fresh string of length [n],
+   filled with the character [c].
+
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+
+val init : int -> f:(int -> char) -> string
+(** [init n f] returns a string of length [n],
+    with character [i] initialized to the result of [f i].
+
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
+   @since 4.02.0 *)
+
+val copy : string -> string
+(** Return a copy of the given string. *)
+
+val sub : string -> pos:int -> len:int -> string
+(** [String.sub s start len] returns a fresh string of length [len],
+   containing the substring of [s] that starts at position [start] and
+   has length [len].
+
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s]. *)
+
+val fill : bytes -> pos:int -> len:int -> char -> unit
+  [@@ocaml.deprecated "Use BytesLabels.fill instead."]
+(** [String.fill s start len c] modifies byte sequence [s] in place,
+   replacing [len] bytes by [c], starting at [start].
+
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s].
+
+   @deprecated This is a deprecated alias of {!BytesLabels.fill}. *)
+
+val blit :
+  src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int
+  -> unit
+(** [String.blit src srcoff dst dstoff len] copies [len] bytes
+   from the string [src], starting at index [srcoff],
+   to byte sequence [dst], starting at character number [dstoff].
+
+   Raise [Invalid_argument] if [srcoff] and [len] do not
+   designate a valid range of [src], or if [dstoff] and [len]
+   do not designate a valid range of [dst]. *)
+
+val concat : sep:string -> string list -> string
+(** [String.concat sep sl] concatenates the list of strings [sl],
+   inserting the separator string [sep] between each. *)
+
+val iter : f:(char -> unit) -> string -> unit
+(** [String.iter f s] applies function [f] in turn to all
+   the characters of [s].  It is equivalent to
+   [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
+
+val iteri : f:(int -> char -> unit) -> string -> unit
+(** Same as {!String.iter}, but the
+   function is applied to the index of the element as first argument
+   (counting from 0), and the character itself as second argument.
+   @since 4.00.0 *)
+
+val map : f:(char -> char) -> string -> string
+(** [String.map f s] applies function [f] in turn to all
+   the characters of [s] and stores the results in a new string that
+   is returned.
+   @since 4.00.0 *)
+
+val mapi : f:(int -> char -> char) -> string -> string
+(** [String.mapi f s] calls [f] with each character of [s] and its
+    index (in increasing index order) and stores the results in a new
+    string that is returned.
+    @since 4.02.0 *)
+
+val trim : string -> string
+(** Return a copy of the argument, without leading and trailing
+   whitespace.  The characters regarded as whitespace are: [' '],
+   ['\012'], ['\n'], ['\r'], and ['\t'].  If there is no leading nor
+   trailing whitespace character in the argument, return the original
+   string itself, not a copy.
+   @since 4.00.0 *)
+
+val escaped : string -> string
+(** Return a copy of the argument, with special characters
+   represented by escape sequences, following the lexical
+   conventions of OCaml.  If there is no special
+   character in the argument, return the original string itself,
+   not a copy. Its inverse function is Scanf.unescaped. *)
+
+val index : string -> char -> int
+(** [String.index s c] returns the index of the first
+   occurrence of character [c] in string [s].
+
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val index_opt: string -> char -> int option
+(** [String.index_opt s c] returns the index of the first
+    occurrence of character [c] in string [s], or
+    [None] if [c] does not occur in [s].
+    @since 4.05 *)
+
+val rindex : string -> char -> int
+(** [String.rindex s c] returns the index of the last
+   occurrence of character [c] in string [s].
+
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val rindex_opt: string -> char -> int option
+(** [String.rindex_opt s c] returns the index of the last occurrence
+    of character [c] in string [s], or [None] if [c] does not occur in
+    [s].
+    @since 4.05 *)
+
+val index_from : string -> int -> char -> int
+(** [String.index_from s i c] returns the index of the
+   first occurrence of character [c] in string [s] after position [i].
+   [String.index s c] is equivalent to [String.index_from s 0 c].
+
+   Raise [Invalid_argument] if [i] is not a valid position in [s].
+   Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+
+val index_from_opt: string -> int -> char -> int option
+(** [String.index_from_opt s i c] returns the index of the
+    first occurrence of character [c] in string [s] after position [i]
+    or [None] if [c] does not occur in [s] after position [i].
+
+    [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c].
+    Raise [Invalid_argument] if [i] is not a valid position in [s].
+
+    @since 4.05
+*)
+
+val rindex_from : string -> int -> char -> int
+(** [String.rindex_from s i c] returns the index of the
+   last occurrence of character [c] in string [s] before position [i+1].
+   [String.rindex s c] is equivalent to
+   [String.rindex_from s (String.length s - 1) c].
+
+   Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+   Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+
+val rindex_from_opt: string -> int -> char -> int option
+(** [String.rindex_from_opt s i c] returns the index of the
+   last occurrence of character [c] in string [s] before position [i+1]
+   or [None] if [c] does not occur in [s] before position [i+1].
+
+   [String.rindex_opt s c] is equivalent to
+   [String.rindex_from_opt s (String.length s - 1) c].
+
+   Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+
+    @since 4.05
+*)
+
+val contains : string -> char -> bool
+(** [String.contains s c] tests if character [c]
+   appears in the string [s]. *)
+
+val contains_from : string -> int -> char -> bool
+(** [String.contains_from s start c] tests if character [c]
+   appears in [s] after position [start].
+   [String.contains s c] is equivalent to
+   [String.contains_from s 0 c].
+
+   Raise [Invalid_argument] if [start] is not a valid position in [s]. *)
+
+val rcontains_from : string -> int -> char -> bool
+(** [String.rcontains_from s stop c] tests if character [c]
+   appears in [s] before position [stop+1].
+
+   Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid
+   position in [s]. *)
+
+val uppercase : string -> string
+  [@@ocaml.deprecated "Use String.uppercase_ascii instead."]
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val lowercase : string -> string
+  [@@ocaml.deprecated "Use String.lowercase_ascii instead."]
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set.
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val capitalize : string -> string
+  [@@ocaml.deprecated "Use String.capitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uncapitalize : string -> string
+  [@@ocaml.deprecated "Use String.uncapitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the ISO Latin-1 (8859-1) character set..
+   @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase_ascii : string -> string
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, using the US-ASCII character set.
+   @since 4.05.0 *)
+
+val lowercase_ascii : string -> string
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, using the US-ASCII character set.
+   @since 4.05.0 *)
+
+val capitalize_ascii : string -> string
+(** Return a copy of the argument, with the first character set to uppercase,
+   using the US-ASCII character set.
+   @since 4.05.0 *)
+
+val uncapitalize_ascii : string -> string
+(** Return a copy of the argument, with the first character set to lowercase,
+   using the US-ASCII character set.
+   @since 4.05.0 *)
+
+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}. *)
+
+val equal: t -> t -> bool
+(** The equal function for strings.
+    @since 4.05.0 *)
+
+val split_on_char: sep:char -> string -> string list
+(** [String.split_on_char sep s] returns the list of all (possibly empty)
+    substrings of [s] that are delimited by the [sep] character.
+
+    The function's output is specified by the following invariants:
+
+    - The list is not empty.
+    - Concatenating its elements using [sep] as a separator returns a
+      string equal to the input ([String.concat (String.make 1 sep)
+      (String.split_on_char sep s) = s]).
+    - No string in the result contains the [sep] character.
+
+    @since 4.05.0
+*)
+
+(**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
+external unsafe_get : string -> int -> char = "%string_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+  [@@ocaml.deprecated]
+external unsafe_blit :
+  src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int ->
+    unit = "caml_blit_string" [@@noalloc]
+external unsafe_fill :
+  bytes -> pos:int -> len:int -> char -> unit = "caml_fill_string" [@@noalloc]
+  [@@ocaml.deprecated]
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
new file mode 100644
index 00000000..2359d41b
--- /dev/null
+++ b/stdlib/sys.mli
@@ -0,0 +1,329 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** System interface.
+
+  Every function in this module raises [Sys_error] with an
+  informative message when the underlying system call signal
+  an error.
+*)
+
+val argv : string array
+(** The command line arguments given to the process.
+   The first element is the command name used to invoke the program.
+   The following elements are the command-line arguments
+   given to the program. *)
+
+val executable_name : string
+(** The name of the file containing the executable currently running. *)
+
+external file_exists : string -> bool = "caml_sys_file_exists"
+(** Test if a file with the given name exists. *)
+
+external is_directory : string -> bool = "caml_sys_is_directory"
+(** Returns [true] if the given name refers to a directory,
+    [false] if it refers to another kind of file.
+    Raise [Sys_error] if no file exists with the given name.
+    @since 3.10.0
+*)
+
+external remove : string -> unit = "caml_sys_remove"
+(** Remove the given file name from the file system. *)
+
+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. 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 = "caml_sys_getenv"
+(** Return the value associated to a variable in the process
+   environment. Raise [Not_found] if the variable is unbound. *)
+
+val getenv_opt: string -> string option
+(** Return the value associated to a variable in the process
+    environment or [None] if the variable is unbound.
+    @since 4.05
+*)
+
+external command : string -> int = "caml_sys_system_command"
+(** Execute the given shell command and return its exit code. *)
+
+external time : unit -> (float [@unboxed]) =
+  "caml_sys_time" "caml_sys_time_unboxed" [@@noalloc]
+(** Return the processor time, in seconds, used by the program
+   since the beginning of execution. *)
+
+external chdir : string -> unit = "caml_sys_chdir"
+(** Change the current working directory of the process. *)
+
+external getcwd : unit -> string = "caml_sys_getcwd"
+(** Return the current working directory of the process. *)
+
+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
+   result is a file name rather than a complete path.  There is no
+   guarantee that the name strings in the resulting array will appear
+   in any specific order; they are not, in particular, guaranteed to
+   appear in alphabetical order. *)
+
+val interactive : bool ref
+(** This reference is initially set to [false] in standalone
+   programs and to [true] if the code is being executed under
+   the interactive toplevel system [ocaml]. *)
+
+val os_type : string
+(** Operating system currently executing the OCaml 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). *)
+
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string (**)
+(** Currently, the official distribution only supports [Native] and
+    [Bytecode], but it can be other backends with alternative
+    compilers, for example, javascript.
+
+    @since 4.04.0
+*)
+
+val backend_type : backend_type
+(** Backend type  currently executing the OCaml program.
+    @since 4.04.0
+ *)
+
+val unix : bool
+(** True if [Sys.os_type = "Unix"].
+    @since 4.01.0 *)
+
+val win32 : bool
+(** True if [Sys.os_type = "Win32"].
+    @since 4.01.0 *)
+
+val cygwin : bool
+(** True if [Sys.os_type = "Cygwin"].
+    @since 4.01.0 *)
+
+val word_size : int
+(** Size of one word on the machine currently executing the OCaml
+   program, in bits: 32 or 64. *)
+
+val int_size : int
+(** Size of an int.  It is 31 bits (resp. 63 bits) when using the
+    OCaml compiler on a 32 bits (resp. 64 bits) platform.  It may
+    differ for other compilers, e.g. it is 32 bits when compiling to
+    JavaScript.
+    @since 4.03.0 *)
+
+val big_endian : bool
+(** Whether the machine currently executing the Caml program is big-endian.
+    @since 4.00.0 *)
+
+val max_string_length : int
+(** Maximum length of strings and byte sequences. *)
+
+val max_array_length : int
+(** Maximum length of a normal array.  The maximum length of a float
+    array is [max_array_length/2] on 32-bit machines and
+    [max_array_length] on 64-bit machines. *)
+
+external runtime_variant : unit -> string = "caml_runtime_variant"
+(** Return the name of the runtime variant the program is running on.
+    This is normally the argument given to [-runtime-variant] at compile
+    time, but for byte-code it can be changed after compilation.
+    @since 4.03.0 *)
+
+external runtime_parameters : unit -> string = "caml_runtime_parameters"
+(** Return the value of the runtime parameters, in the same format
+    as the contents of the [OCAMLRUNPARAM] environment variable.
+    @since 4.03.0 *)
+
+
+(** {6 Signal handling} *)
+
+
+type signal_behavior =
+    Signal_default
+  | Signal_ignore
+  | Signal_handle of (int -> unit)   (** *)
+(** What to do when receiving a signal:
+   - [Signal_default]: take the default behavior
+     (usually: abort the program)
+   - [Signal_ignore]: ignore the signal
+   - [Signal_handle f]: call function [f], giving it the signal
+   number as argument. *)
+
+external 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. *)
+
+
+(** {7 Signal numbers for the standard POSIX signals.} *)
+
+val sigabrt : int
+(** Abnormal termination *)
+
+val sigalrm : int
+(** Timeout *)
+
+val sigfpe : int
+(** Arithmetic exception *)
+
+val sighup : int
+(** Hangup on controlling terminal *)
+
+val sigill : int
+(** Invalid hardware instruction *)
+
+val sigint : int
+(** Interactive interrupt (ctrl-C) *)
+
+val sigkill : int
+(** Termination (cannot be ignored) *)
+
+val sigpipe : int
+(** Broken pipe *)
+
+val sigquit : int
+(** Interactive termination *)
+
+val sigsegv : int
+(** Invalid memory reference *)
+
+val sigterm : int
+(** Termination *)
+
+val sigusr1 : int
+(** Application-defined signal 1 *)
+
+val sigusr2 : int
+(** Application-defined signal 2 *)
+
+val sigchld : int
+(** Child process terminated *)
+
+val sigcont : int
+(** Continue *)
+
+val sigstop : int
+(** Stop *)
+
+val sigtstp : int
+(** Interactive stop *)
+
+val sigttin : int
+(** Terminal read from background process *)
+
+val sigttou : int
+(** Terminal write from background process *)
+
+val sigvtalrm : int
+(** Timeout in virtual time *)
+
+val sigprof : int
+(** Profiling interrupt *)
+
+val sigbus : int
+(** Bus error
+    @since 4.03 *)
+
+val sigpoll : int
+(** Pollable event
+    @since 4.03 *)
+
+val sigsys : int
+(** Bad argument to routine
+    @since 4.03 *)
+
+val sigtrap : int
+(** Trace/breakpoint trap
+    @since 4.03 *)
+
+val sigurg : int
+(** Urgent condition on socket
+    @since 4.03 *)
+
+val sigxcpu : int
+(** Timeout in cpu time
+    @since 4.03 *)
+
+val sigxfsz : int
+(** File size limit exceeded
+    @since 4.03 *)
+
+
+exception Break
+(** Exception raised on interactive interrupt if {!Sys.catch_break}
+   is on. *)
+
+
+val catch_break : bool -> unit
+(** [catch_break] governs whether interactive interrupt (ctrl-C)
+   terminates the program or raises the [Break] exception.
+   Call [catch_break true] to enable raising [Break],
+   and [catch_break false] to let the system
+   terminate the program on user interrupt. *)
+
+
+val ocaml_version : string
+(** [ocaml_version] is the version of OCaml.
+    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. *)
+
+
+val enable_runtime_warnings: bool -> unit
+(** Control whether the OCaml runtime system can emit warnings
+    on stderr.  Currently, the only supported warning is triggered
+    when a channel created by [open_*] functions is finalized without
+    being closed.  Runtime warnings are enabled by default.
+
+    @since 4.03.0 *)
+
+val runtime_warnings_enabled: unit -> bool
+(** Return whether runtime warnings are currently enabled.
+
+    @since 4.03.0 *)
+
+(** {6 Optimization} *)
+
+external opaque_identity : 'a -> 'a = "%opaque"
+(** For the purposes of optimization, [opaque_identity] behaves like an
+    unknown (and thus possibly side-effecting) function.
+
+    At runtime, [opaque_identity] disappears altogether.
+
+    A typical use of this function is to prevent pure computations from being
+    optimized away in benchmarking loops.  For example:
+    {[
+      for _round = 1 to 100_000 do
+        ignore (Sys.opaque_identity (my_pure_computation ()))
+      done
+    ]}
+
+    @since 4.03.0
+*)
diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp
new file mode 100644
index 00000000..62c84fb1
--- /dev/null
+++ b/stdlib/sys.mlp
@@ -0,0 +1,131 @@
+#2 "stdlib/sys.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* WARNING: sys.ml is generated from sys.mlp.  DO NOT EDIT sys.ml or
+   your changes will be lost.
+*)
+
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string
+(* System interface *)
+
+external get_config: unit -> string * int * bool = "caml_sys_get_config"
+external get_argv: unit -> string * string array = "caml_sys_get_argv"
+external big_endian : unit -> bool = "%big_endian"
+external word_size : unit -> int = "%word_size"
+external int_size : unit -> int = "%int_size"
+external max_wosize : unit -> int = "%max_wosize"
+external unix : unit -> bool = "%ostype_unix"
+external win32 : unit -> bool = "%ostype_win32"
+external cygwin : unit -> bool = "%ostype_cygwin"
+external get_backend_type : unit -> backend_type = "%backend_type"
+
+let (executable_name, argv) = get_argv()
+let (os_type, _, _) = get_config()
+let backend_type = get_backend_type ()
+let big_endian = big_endian ()
+let word_size = word_size ()
+let int_size = int_size ()
+let unix = unix ()
+let win32 = win32 ()
+let cygwin = cygwin ()
+let max_array_length = max_wosize ()
+let max_string_length = word_size / 8 * max_array_length - 1
+external runtime_variant : unit -> string = "caml_runtime_variant"
+external runtime_parameters : unit -> string = "caml_runtime_parameters"
+
+external file_exists: string -> bool = "caml_sys_file_exists"
+external is_directory : string -> bool = "caml_sys_is_directory"
+external remove: string -> unit = "caml_sys_remove"
+external rename : string -> string -> unit = "caml_sys_rename"
+external getenv: string -> string = "caml_sys_getenv"
+
+let getenv_opt s =
+  (* TODO: expose a non-raising primitive directly. *)
+  try Some (getenv s)
+  with Not_found -> None
+
+external command: string -> int = "caml_sys_system_command"
+external time: unit -> (float [@unboxed]) =
+  "caml_sys_time" "caml_sys_time_unboxed" [@@noalloc]
+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
+
+type signal_behavior =
+    Signal_default
+  | Signal_ignore
+  | Signal_handle of (int -> unit)
+
+external signal : int -> signal_behavior -> signal_behavior
+                = "caml_install_signal_handler"
+
+let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh)
+
+let sigabrt = -1
+let sigalrm = -2
+let sigfpe = -3
+let sighup = -4
+let sigill = -5
+let sigint = -6
+let sigkill = -7
+let sigpipe = -8
+let sigquit = -9
+let sigsegv = -10
+let sigterm = -11
+let sigusr1 = -12
+let sigusr2 = -13
+let sigchld = -14
+let sigcont = -15
+let sigstop = -16
+let sigtstp = -17
+let sigttin = -18
+let sigttou = -19
+let sigvtalrm = -20
+let sigprof = -21
+let sigbus = -22
+let sigpoll = -23
+let sigsys = -24
+let sigtrap = -25
+let sigurg = -26
+let sigxcpu = -27
+let sigxfsz = -28
+
+exception Break
+
+let catch_break on =
+  if on then
+    set_signal sigint (Signal_handle(fun _ -> raise Break))
+  else
+    set_signal sigint Signal_default
+
+
+external enable_runtime_warnings: bool -> unit =
+  "caml_ml_enable_runtime_warnings"
+external runtime_warnings_enabled: unit -> bool =
+  "caml_ml_runtime_warnings_enabled"
+
+(* The version string is found in file ../VERSION *)
+
+let ocaml_version = "%%VERSION%%"
+
+(* Optimization *)
+
+external opaque_identity : 'a -> 'a = "%opaque"
diff --git a/stdlib/uchar.ml b/stdlib/uchar.ml
new file mode 100644
index 00000000..a2b7fe3a
--- /dev/null
+++ b/stdlib/uchar.ml
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                           Daniel C. Buenzli                            *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+external format_int : string -> int -> string = "caml_format_int"
+
+let err_no_pred = "U+0000 has no predecessor"
+let err_no_succ = "U+10FFFF has no successor"
+let err_not_sv i = format_int "%X" i ^ " is not an Unicode scalar value"
+let err_not_latin1 u = "U+" ^ format_int "%04X" u ^ " is not a latin1 character"
+
+type t = int
+
+let min = 0x0000
+let max = 0x10FFFF
+let lo_bound = 0xD7FF
+let hi_bound = 0xE000
+
+let succ u =
+  if u = lo_bound then hi_bound else
+  if u = max then invalid_arg err_no_succ else
+  u + 1
+
+let pred u =
+  if u = hi_bound then lo_bound else
+  if u = min then invalid_arg err_no_pred else
+  u - 1
+
+let is_valid i = (min <= i && i <= lo_bound) || (hi_bound <= i && i <= max)
+let of_int i = if is_valid i then i else invalid_arg (err_not_sv i)
+external unsafe_of_int : int -> t = "%identity"
+external to_int : t -> int = "%identity"
+
+let is_char u = u < 256
+let of_char c = Char.code c
+let to_char u =
+  if u > 255 then invalid_arg (err_not_latin1 u) else
+  Char.unsafe_chr u
+
+let unsafe_to_char = Char.unsafe_chr
+
+let equal : int -> int -> bool = ( = )
+let compare : int -> int -> int = Pervasives.compare
+let hash = to_int
diff --git a/stdlib/uchar.mli b/stdlib/uchar.mli
new file mode 100644
index 00000000..5ea47c9d
--- /dev/null
+++ b/stdlib/uchar.mli
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                           Daniel C. Buenzli                            *)
+(*                                                                        *)
+(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Unicode characters.
+
+    @since 4.03 *)
+
+type t
+(** The type for Unicode characters.
+
+    A value of this type represents an Unicode
+    {{:http://unicode.org/glossary/#unicode_scalar_value}scalar
+    value} which is an integer in the ranges [0x0000]...[0xD7FF] or
+    [0xE000]...[0x10FFFF]. *)
+
+val min : t
+(** [min] is U+0000. *)
+
+val max : t
+(** [max] is U+10FFFF. *)
+
+val succ : t -> t
+(** [succ u] is the scalar value after [u] in the set of Unicode scalar
+    values.
+
+    @raise Invalid_argument if [u] is {!max}. *)
+
+val pred : t -> t
+(** [pred u] is the scalar value before [u] in the set of Unicode scalar
+    values.
+
+    @raise Invalid_argument if [u] is {!min}. *)
+
+val is_valid : int -> bool
+(** [is_valid n] is [true] iff [n] is an Unicode scalar value
+    (i.e. in the ranges [0x0000]...[0xD7FF] or [0xE000]...[0x10FFFF]).*)
+
+val of_int : int -> t
+(** [of_int i] is [i] as an Unicode character.
+
+    @raise Invalid_argument if [i] does not satisfy {!is_valid}. *)
+
+(**/**)
+val unsafe_of_int : int -> t
+(**/**)
+
+val to_int : t -> int
+(** [to_int u] is [u] as an integer. *)
+
+val is_char : t -> bool
+(** [is_char u] is [true] iff [u] is a latin1 OCaml character. *)
+
+val of_char : char -> t
+(** [of_char c] is [c] as an Unicode character. *)
+
+val to_char : t -> char
+(** [to_char u] is [u] as an OCaml latin1 character.
+
+    @raise Invalid_argument if [u] does not satisfy {!is_char}. *)
+
+(**/**)
+val unsafe_to_char : t -> char
+(**/**)
+
+val equal : t -> t -> bool
+(** [equal u u'] is [u = u']. *)
+
+val compare : t -> t -> int
+(** [compare u u'] is [Pervasives.compare u u']. *)
+
+val hash : t -> int
+(** [hash u] associates a non-negative integer to [u]. *)
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
new file mode 100644
index 00000000..4ade095a
--- /dev/null
+++ b/stdlib/weak.ml
@@ -0,0 +1,336 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Weak array operations *)
+
+type 'a t
+
+external create : int -> 'a t = "caml_weak_create"
+
+(** number of additional values in a weak pointer *)
+let additional_values = 2
+
+let length x = Obj.size(Obj.repr x) - additional_values
+
+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"
+external blit : 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit"
+(* blit: src srcoff dst dstoff len *)
+
+let fill ar ofs len x =
+  if ofs < 0 || len < 0 || ofs + len > length ar
+  then raise (Invalid_argument "Weak.fill")
+  else begin
+    for i = ofs to (ofs + len - 1) do
+      set ar i x
+    done
+  end
+
+
+(** Weak hash tables *)
+
+module type S = sig
+  type data
+  type t
+  val create : int -> t
+  val clear : t -> unit
+  val merge : t -> data -> data
+  val add : t -> data -> unit
+  val remove : t -> data -> unit
+  val find : t -> data -> data
+  val find_opt : t -> data -> data option
+  val find_all : t -> data -> data list
+  val mem : t -> data -> bool
+  val iter : (data -> unit) -> t -> unit
+  val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
+  val count : t -> int
+  val stats : t -> int * int * int * int * int * int
+end
+
+module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
+
+  type 'a weak_t = 'a t
+  let weak_create = create
+  let emptybucket = weak_create 0
+
+  type data = H.t
+
+  type t = {
+    mutable table : data weak_t array;
+    mutable hashes : int array array;
+    mutable limit : int;               (* bucket size limit *)
+    mutable oversize : int;            (* number of oversize buckets *)
+    mutable rover : int;               (* for internal bookkeeping *)
+  }
+
+  let get_index t h = (h land max_int) mod (Array.length t.table)
+
+  let limit = 7
+  let over_limit = 2
+
+  let create sz =
+    let sz = if sz < 7 then 7 else sz in
+    let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
+    {
+      table = Array.make sz emptybucket;
+      hashes = Array.make sz [| |];
+      limit = limit;
+      oversize = 0;
+      rover = 0;
+    }
+
+  let clear t =
+    for i = 0 to Array.length t.table - 1 do
+      t.table.(i) <- emptybucket;
+      t.hashes.(i) <- [| |];
+    done;
+    t.limit <- limit;
+    t.oversize <- 0
+
+
+  let fold f t init =
+    let rec fold_bucket i b accu =
+      if i >= length b then accu else
+      match get b i with
+      | Some v -> fold_bucket (i+1) b (f v accu)
+      | None -> fold_bucket (i+1) b accu
+    in
+    Array.fold_right (fold_bucket 0) t.table init
+
+
+  let iter f t =
+    let rec iter_bucket i b =
+      if i >= length b then () else
+      match get b i with
+      | Some v -> f v; iter_bucket (i+1) b
+      | None -> iter_bucket (i+1) b
+    in
+    Array.iter (iter_bucket 0) t.table
+
+
+  let iter_weak f t =
+    let rec iter_bucket i j b =
+      if i >= length b then () else
+      match check b i with
+      | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
+      | false -> iter_bucket (i+1) j b
+    in
+    Array.iteri (iter_bucket 0) t.table
+
+
+  let rec count_bucket i b accu =
+    if i >= length b then accu else
+    count_bucket (i+1) b (accu + (if check b i then 1 else 0))
+
+
+  let count t =
+    Array.fold_right (count_bucket 0) t.table 0
+
+
+  let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length
+  let prev_sz n = ((n - 3) * 2 + 2) / 3
+
+  let test_shrink_bucket t =
+    let bucket = t.table.(t.rover) in
+    let hbucket = t.hashes.(t.rover) in
+    let len = length bucket in
+    let prev_len = prev_sz len in
+    let live = count_bucket 0 bucket 0 in
+    if live <= prev_len then begin
+      let rec loop i j =
+        if j >= prev_len then begin
+          if check bucket i then loop (i + 1) j
+          else if check bucket j then begin
+            blit bucket j bucket i 1;
+            hbucket.(i) <- hbucket.(j);
+            loop (i + 1) (j - 1);
+          end else loop i (j - 1);
+        end;
+      in
+      loop 0 (length bucket - 1);
+      if prev_len = 0 then begin
+        t.table.(t.rover) <- emptybucket;
+        t.hashes.(t.rover) <- [| |];
+      end else begin
+        Obj.truncate (Obj.repr bucket) (prev_len + additional_values);
+        Obj.truncate (Obj.repr hbucket) prev_len;
+      end;
+      if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+    end;
+    t.rover <- (t.rover + 1) mod (Array.length t.table)
+
+
+  let rec resize t =
+    let oldlen = Array.length t.table in
+    let newlen = next_sz oldlen in
+    if newlen > oldlen then begin
+      let newt = create newlen in
+      let add_weak ob oh oi =
+        let setter nb ni _ = blit ob oi nb ni 1 in
+        let h = oh.(oi) in
+        add_aux newt setter None h (get_index newt h);
+      in
+      iter_weak add_weak t;
+      t.table <- newt.table;
+      t.hashes <- newt.hashes;
+      t.limit <- newt.limit;
+      t.oversize <- newt.oversize;
+      t.rover <- t.rover mod Array.length newt.table;
+    end else begin
+      t.limit <- max_int;             (* maximum size already reached *)
+      t.oversize <- 0;
+    end
+
+  and add_aux t setter d h index =
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then begin
+        let newsz =
+          min (3 * sz / 2 + 3) (Sys.max_array_length - additional_values)
+        in
+        if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
+        let newbucket = weak_create newsz in
+        let newhashes = Array.make newsz 0 in
+        blit bucket 0 newbucket 0 sz;
+        Array.blit hashes 0 newhashes 0 sz;
+        setter newbucket sz d;
+        newhashes.(sz) <- h;
+        t.table.(index) <- newbucket;
+        t.hashes.(index) <- newhashes;
+        if sz <= t.limit && newsz > t.limit then begin
+          t.oversize <- t.oversize + 1;
+          for _i = 0 to over_limit do test_shrink_bucket t done;
+        end;
+        if t.oversize > Array.length t.table / over_limit then resize t;
+      end else if check bucket i then begin
+        loop (i + 1)
+      end else begin
+        setter bucket i d;
+        hashes.(i) <- h;
+      end;
+    in
+    loop 0
+
+
+  let add t d =
+    let h = H.hash d in
+    add_aux t set (Some d) h (get_index t h)
+
+
+  let find_or t d ifnotfound =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound h index
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some v -> v
+              | None -> loop (i + 1)
+              end
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+
+  let merge t d =
+    find_or t d (fun h index -> add_aux t set (Some d) h index; d)
+
+
+  let find t d = find_or t d (fun _h _index -> raise Not_found)
+
+  let find_opt t d =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then None
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some _ as v -> v
+              | None -> loop (i + 1)
+              end
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+
+  let find_shadow t d iffound ifnotfound =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d -> iffound bucket i
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+
+  let remove t d = find_shadow t d (fun w i -> set w i None) ()
+
+
+  let mem t d = find_shadow t d (fun _w _i -> true) false
+
+
+  let find_all t d =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i accu =
+      if i >= sz then accu
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some v -> loop (i + 1) (v :: accu)
+              | None -> loop (i + 1) accu
+              end
+        | _ -> loop (i + 1) accu
+      end else loop (i + 1) accu
+    in
+    loop 0 []
+
+
+  let stats t =
+    let len = Array.length t.table in
+    let lens = Array.map length t.table in
+    Array.sort compare lens;
+    let totlen = Array.fold_left ( + ) 0 lens in
+    (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1))
+
+
+end
diff --git a/stdlib/weak.mli b/stdlib/weak.mli
new file mode 100644
index 00000000..951cd9c0
--- /dev/null
+++ b/stdlib/weak.mli
@@ -0,0 +1,185 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Arrays of weak pointers and hash sets of weak pointers. *)
+
+
+(** {6 Low-level functions} *)
+
+type 'a t
+(** The type of arrays of weak pointers (weak arrays).  A weak
+   pointer is a value that the garbage collector may erase whenever
+   the value is not used any more (through normal pointers) by the
+   program.  Note that finalisation functions are run after the
+   weak pointers are erased.
+
+   A weak pointer is said to be full if it points to a value,
+   empty if the value was erased by the GC.
+
+   Notes:
+   - Integers are not allocated and cannot be stored in weak arrays.
+   - Weak arrays cannot be marshaled using {!Pervasives.output_value}
+     nor the functions of the {!Marshal} module.
+*)
+
+
+val create : int -> 'a t
+(** [Weak.create n] returns a new weak array of length [n].
+   All the pointers are initially empty.  Raise [Invalid_argument]
+   if [n] is negative or greater than {!Sys.max_array_length}[-1].*)
+
+val length : 'a t -> int
+(** [Weak.length ar] returns the length (number of elements) of
+   [ar].*)
+
+val set : 'a t -> int -> 'a option -> unit
+(** [Weak.set ar n (Some el)] sets the [n]th cell of [ar] to be a
+   (full) pointer to [el]; [Weak.set ar n None] sets the [n]th
+   cell of [ar] to empty.
+   Raise [Invalid_argument "Weak.set"] if [n] is not in the range
+   0 to {!Weak.length}[ a - 1].*)
+
+val get : 'a t -> int -> 'a option
+(** [Weak.get ar n] returns None if the [n]th cell of [ar] is
+   empty, [Some x] (where [x] is the value) if it is full.
+   Raise [Invalid_argument "Weak.get"] if [n] is not in the range
+   0 to {!Weak.length}[ a - 1].*)
+
+val get_copy : 'a t -> int -> 'a option
+(** [Weak.get_copy ar n] returns None if the [n]th cell of [ar] is
+   empty, [Some x] (where [x] is a (shallow) copy of the value) if
+   it is full.
+   In addition to pitfalls with mutable values, the interesting
+   difference with [get] is that [get_copy] does not prevent
+   the incremental GC from erasing the value in its current cycle
+   ([get] may delay the erasure to the next GC cycle).
+   Raise [Invalid_argument "Weak.get"] if [n] is not in the range
+   0 to {!Weak.length}[ a - 1].
+
+   If the element is a custom block it is not copied.
+
+*)
+
+
+val check : 'a t -> int -> bool
+(** [Weak.check ar n] returns [true] if the [n]th cell of [ar] is
+   full, [false] if it is empty.  Note that even if [Weak.check ar n]
+   returns [true], a subsequent {!Weak.get}[ ar n] can return [None].*)
+
+val fill : 'a t -> int -> int -> 'a option -> unit
+(** [Weak.fill ar ofs len el] sets to [el] all pointers of [ar] from
+   [ofs] to [ofs + len - 1].  Raise [Invalid_argument "Weak.fill"]
+   if [ofs] and [len] do not designate a valid subarray of [a].*)
+
+val blit : 'a t -> int -> 'a t -> int -> int -> unit
+(** [Weak.blit ar1 off1 ar2 off2 len] copies [len] weak pointers
+   from [ar1] (starting at [off1]) to [ar2] (starting at [off2]).
+   It works correctly even if [ar1] and [ar2] are the same.
+   Raise [Invalid_argument "Weak.blit"] if [off1] and [len] do
+   not designate a valid subarray of [ar1], or if [off2] and [len]
+   do not designate a valid subarray of [ar2].*)
+
+
+(** {6 Weak hash sets} *)
+
+(** A weak hash set is a hashed set of values.  Each value may
+    magically disappear from the set when it is not used by the
+    rest of the program any more.  This is normally used to share
+    data structures without inducing memory leaks.
+    Weak hash sets are defined on values from a {!Hashtbl.HashedType}
+    module; the [equal] relation and [hash] function are taken from that
+    module.  We will say that [v] is an instance of [x] if [equal x v]
+    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 values themselves.
+    *)
+
+module type S = sig
+  type data
+  (** The type of the elements stored in the table. *)
+
+  type t
+    (** The type of tables that contain elements of type [data].
+        Note that weak hash sets cannot be marshaled using
+        {!Pervasives.output_value} or the functions of the {!Marshal}
+        module. *)
+
+  val create : int -> t
+    (** [create n] creates a new empty weak hash set, of initial
+        size [n].  The table will grow as needed. *)
+
+  val clear : t -> unit
+  (** Remove all elements from the table. *)
+
+  val merge : t -> data -> data
+    (** [merge t x] returns an instance of [x] found in [t] if any,
+        or else adds [x] to [t] and return [x]. *)
+
+  val add : t -> data -> unit
+    (** [add t x] adds [x] to [t].  If there is already an instance
+        of [x] in [t], it is unspecified which one will be
+        returned by subsequent calls to [find] and [merge]. *)
+
+  val remove : t -> data -> unit
+    (** [remove t x] removes from [t] one instance of [x].  Does
+        nothing if there is no instance of [x] in [t]. *)
+
+  val find : t -> data -> data
+    (** [find t x] returns an instance of [x] found in [t].
+        Raise [Not_found] if there is no such element. *)
+
+  val find_opt: t -> data -> data option
+    (** [find_opt t x] returns an instance of [x] found in [t]
+        or [None] if there is no such element.
+        @since 4.05
+    *)
+
+  val find_all : t -> data -> data list
+    (** [find_all t x] returns a list of all the instances of [x]
+        found in [t]. *)
+
+  val mem : t -> data -> bool
+    (** [mem t x] returns [true] if there is at least one instance
+        of [x] in [t], false otherwise. *)
+
+  val iter : (data -> unit) -> t -> unit
+    (** [iter f t] calls [f] on each element of [t], in some unspecified
+        order.  It is not specified what happens if [f] tries to change
+        [t] itself. *)
+
+  val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
+    (** [fold f t init] computes [(f d1 (... (f dN init)))] where
+        [d1 ... dN] are the elements of [t] in some unspecified order.
+        It is not specified what happens if [f] tries to change [t]
+        itself. *)
+
+  val count : t -> int
+    (** Count the number of elements in the table.  [count t] gives the
+        same result as [fold (fun _ n -> n+1) t 0] but does not delay the
+        deallocation of the dead elements. *)
+
+  val stats : t -> int * int * int * int * int * int
+    (** Return statistics on the table.  The numbers are, in order:
+        table length, number of entries, sum of bucket lengths,
+        smallest bucket length, median bucket length, biggest bucket length. *)
+end
+(** The output signature of the functor {!Weak.Make}. *)
+
+module Make (H : Hashtbl.HashedType) : S with type data = H.t
+(** Functor building an implementation of the weak hash set structure.
+    [H.equal] can't be the physical equality, since only shallow
+    copies of the elements in the set are given to it.
+ *)
diff --git a/testsuite/HACKING.adoc b/testsuite/HACKING.adoc
new file mode 100644
index 00000000..71259057
--- /dev/null
+++ b/testsuite/HACKING.adoc
@@ -0,0 +1,11 @@
+== Running the testsuite
+
+== Creating a new test
+
+== Useful Makefile targets
+
+`make parallel`:: runs the tests in parallel using the link:https://www.gnu.org/software/parallel/[GNU parallel] tool: tests run twice as fast with no difference in output order.
+
+`make all-foo`, `make parallel-foo`:: runs only the tests in the directories whose name starts with `foo`: `parallel-typing`, `all-lib`, etc.
+
+`make one DIR=tests/foo`:: runs only the tests in the directory `tests/foo`. This is often equivalent to `cd tests/foo && make`, but sometimes the latter breaks the test makefile if it contains fragile relative filesystem paths. Such errors should be fixed if you find them, but `make one DIR=...` is the more reliable option as it runs exactly as `make all` which is heavily tested.
\ No newline at end of file
diff --git a/testsuite/Makefile b/testsuite/Makefile
new file mode 100644
index 00000000..828272b2
--- /dev/null
+++ b/testsuite/Makefile
@@ -0,0 +1,203 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR := $(shell pwd)
+NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 \
+	  && echo --no-print-directory`
+
+FIND=find
+include ../config/Makefile
+
+.PHONY: default
+default:
+	@echo "Available targets:"
+	@echo "  all             launch all tests"
+	@echo "  all-foo         launch all tests beginning with foo"
+	@echo "  parallel        launch all tests using GNU parallel"
+	@echo "  parallel-foo    launch all tests beginning with foo using \
+	GNU parallel"
+	@echo "  list FILE=f     launch the tests listed in f (one per line)"
+	@echo "  one DIR=p       launch the tests located in path p"
+	@echo "  promote DIR=p   promote the reference files for the tests in p"
+	@echo "  lib             build library modules"
+	@echo "  tools           build test tools"
+	@echo "  clean           delete generated files"
+	@echo "  report          print the report for the last execution"
+	@echo
+	@echo "all*, parallel* and list can automatically re-run failed test"
+	@echo "directories if MAX_TESTSUITE_DIR_RETRIES permits"
+	@echo "(default value = $(MAX_TESTSUITE_DIR_RETRIES))"
+
+.PHONY: all
+all: lib tools
+	@for dir in tests/*; do \
+	  $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
+	done 2>&1 | tee _log
+	@$(MAKE) $(NO_PRINT) retries
+	@$(MAKE) report
+
+.PHONY: all-%
+all-%: lib tools
+	@for dir in tests/$**; do \
+	  $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
+	done 2>&1 | tee _log
+	@$(MAKE) $(NO_PRINT) retries
+	@$(MAKE) report
+
+# The targets below use GNU parallel to paralellize tests
+# 'make all' and 'make parallel' should be equivalent
+#
+# parallel uses specific logic to make sure the output of the commands
+# run in parallel are not mangled. By default, it will reproduce
+# the output of each completed command atomically, in order of completion.
+#
+# With the --keep-order option, we ask it to save the completed output
+# and replay them in invocation order instead. In theory this costs
+# a tiny bit of performance, but I could not measure any difference.
+# In theory again, the reporting logic works fine with test outputs
+# coming in in arbitrary order (so we should not need --keep-order),
+# but keeping the output deterministic is guaranteed to make
+# someone's life easier at least once in the future.
+#
+# Finally, note that the command we run has a 2>&1 redirection, as
+# in the other make targets. If we removed the quoting around
+# "$(MAKE) ... 2>&1", the rediction would apply to the complete output
+# of parallel, and have a slightly different behavior: by default parallel
+# cleanly separates the stdout and stderr output of each completed command,
+# printing stderr first then stdout second (for each command).
+# I chose to keep the previous behavior exactly unchanged,
+# but the demangling separation is arguably nicer behavior that we might
+# want to implement at the exec-one level to also have it in the 'all' target.
+.PHONY: parallel-%
+parallel-%: lib tools
+	@echo | parallel >/dev/null 2>/dev/null \
+	 || (echo "Unable to run the GNU parallel tool;";\
+	     echo "You should install it before using the parallel* targets.";\
+	     exit 1)
+	@echo | parallel --gnu --no-notice >/dev/null 2>/dev/null \
+	 || (echo "Your 'parallel' tool seems incompatible with GNU parallel.";\
+	     echo "This target requires GNU parallel.";\
+	     exit 1)
+	@for dir in tests/$**; do echo $$dir; done \
+	 | parallel --gnu --no-notice --keep-order \
+	     "$(MAKE) $(NO_PRINT) exec-one DIR={} 2>&1" \
+	 | tee _log
+	@$(MAKE) $(NO_PRINT) retries
+	@$(MAKE) report
+
+.PHONY: parallel
+parallel: parallel-*
+
+.PHONY: list
+list: lib tools
+	@if [ -z "$(FILE)" ]; \
+	  then echo "No value set for variable 'FILE'."; \
+	  exit 1; \
+	fi
+	@while read LINE; do \
+	  $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE; \
+	done <$(FILE) 2>&1 | tee _log
+	@$(MAKE) $(NO_PRINT) retries
+	@$(MAKE) report
+
+.PHONY: one
+one: lib tools
+	@if [ -z "$(DIR)" ]; then \
+	  echo "No value set for variable 'DIR'."; \
+	  exit 1; \
+	fi
+	@if [ ! -d $(DIR) ]; then \
+	  echo "Directory '$(DIR)' does not exist."; \
+	  exit 1; \
+	fi
+	@$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR)
+
+.PHONY: exec-one
+exec-one:
+	@if [ ! -f $(DIR)/Makefile ]; then \
+	  for dir in $(DIR)/*; do \
+	    if [ -d $$dir ]; then \
+	      $(MAKE) exec-one DIR=$$dir; \
+	    fi; \
+	  done; \
+	else \
+	  echo "Running tests from '$$DIR' ..."; \
+	  cd $(DIR) && \
+	  $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) || echo '=> unexpected error'; \
+	fi
+
+.PHONY: clean-one
+clean-one:
+	@if [ ! -f $(DIR)/Makefile ]; then \
+	  for dir in $(DIR)/*; do \
+	    if [ -d $$dir ]; then \
+	      $(MAKE) clean-one DIR=$$dir; \
+	    fi; \
+	  done; \
+	else \
+	  cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) clean; \
+	fi
+
+.PHONY: promote
+promote:
+	@if [ -z "$(DIR)" ]; then \
+	  echo "No value set for variable 'DIR'."; \
+	  exit 1; \
+	fi
+	@if [ ! -d $(DIR) ]; then \
+	  echo "Directory '$(DIR)' does not exist."; \
+	  exit 1; \
+	fi
+	@cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote
+
+.PHONY: lib
+lib:
+	@cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)
+
+.PHONY: tools
+tools:
+	@cd tools && $(MAKE) -s BASEDIR=$(BASEDIR)
+
+.PHONY: clean
+clean:
+	@cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean
+	@cd tools && $(MAKE) BASEDIR=$(BASEDIR) clean
+	@for file in `$(FIND) interactive tests -name Makefile`; do \
+	  (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
+	done
+
+.PHONY: report
+report:
+	@if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi
+	@awk -f makefiles/summarize.awk <_log
+
+retry-list:
+	@while read LINE; do \
+	  if [ -n "$$LINE" ] ; then \
+	    echo re-ran $$LINE>>_log; \
+	    $(MAKE) $(NO_PRINT) clean-one DIR=$$LINE; \
+	    $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE 2>&1 | tee -a _log ; \
+	  fi \
+	done <_retries;
+	@$(MAKE) $(NO_PRINT) retries
+
+retries:
+	@awk -v retries=1 -v max_retries=$(MAX_TESTSUITE_DIR_RETRIES) \
+	     -f makefiles/summarize.awk <_log >_retries
+	@test `cat _retries | wc -l` -eq 0 || $(MAKE) $(NO_PRINT) retry-list
+	@rm -f _retries
+
+.PHONY: empty
+empty:
diff --git a/testsuite/interactive/lib-gc/Makefile b/testsuite/interactive/lib-gc/Makefile
new file mode 100644
index 00000000..9ad7bd74
--- /dev/null
+++ b/testsuite/interactive/lib-gc/Makefile
@@ -0,0 +1,27 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+default:
+	@$(OCAMLC) -o program.byte alloc.ml
+	@./program.byte
+	@$(OCAMLOPT) -o program.native alloc.ml
+	@./program.native
+
+clean: defaultclean
+	@rm -fr program.*
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml
new file mode 100644
index 00000000..cd10d2ed
--- /dev/null
+++ b/testsuite/interactive/lib-gc/alloc.ml
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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.make 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/testsuite/interactive/lib-graph-2/Makefile b/testsuite/interactive/lib-graph-2/Makefile
new file mode 100644
index 00000000..c87f2d0a
--- /dev/null
+++ b/testsuite/interactive/lib-graph-2/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=graph_test
+#ADD_COMPFLAGS=
+LIBRARIES=graphics
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-graph-2/graph_test.ml b/testsuite/interactive/lib-graph-2/graph_test.ml
new file mode 100644
index 00000000..00d776f4
--- /dev/null
+++ b/testsuite/interactive/lib-graph-2/graph_test.ml
@@ -0,0 +1,290 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the 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 OCaml
+   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 (OCaml)";;
+
+(* 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 ();;
+
+ignore (wait_next_event [Key_pressed])
diff --git a/testsuite/interactive/lib-graph-2/graph_test.reference b/testsuite/interactive/lib-graph-2/graph_test.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/interactive/lib-graph-3/Makefile b/testsuite/interactive/lib-graph-3/Makefile
new file mode 100644
index 00000000..8e9e7f1a
--- /dev/null
+++ b/testsuite/interactive/lib-graph-3/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=sorts
+ADD_COMPFLAGS=-thread
+LIBRARIES=unix threads graphics
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-graph-3/sorts.ml b/testsuite/interactive/lib-graph-3/sorts.ml
new file mode 100644
index 00000000..31a7bf86
--- /dev/null
+++ b/testsuite/interactive/lib-graph-3/sorts.ml
@@ -0,0 +1,243 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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.make 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/testsuite/interactive/lib-graph-3/sorts.reference b/testsuite/interactive/lib-graph-3/sorts.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/interactive/lib-graph/Makefile b/testsuite/interactive/lib-graph/Makefile
new file mode 100644
index 00000000..64557c70
--- /dev/null
+++ b/testsuite/interactive/lib-graph/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=graph_example
+#ADD_COMPFLAGS=
+LIBRARIES=graphics
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-graph/graph_example.ml b/testsuite/interactive/lib-graph/graph_example.ml
new file mode 100644
index 00000000..15256676
--- /dev/null
+++ b/testsuite/interactive/lib-graph/graph_example.ml
@@ -0,0 +1,146 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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/testsuite/interactive/lib-graph/graph_example.reference b/testsuite/interactive/lib-graph/graph_example.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/interactive/lib-signals/Makefile b/testsuite/interactive/lib-signals/Makefile
new file mode 100644
index 00000000..659c2216
--- /dev/null
+++ b/testsuite/interactive/lib-signals/Makefile
@@ -0,0 +1,27 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+default:
+	@$(OCAMLC) -o program.byte signals.ml
+	@./program.byte
+	@$(OCAMLOPT) -o program.native signals.ml
+	@./program.native
+
+clean: defaultclean
+	@rm -fr program.*
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-signals/signals.ml b/testsuite/interactive/lib-signals/signals.ml
new file mode 100644
index 00000000..0d737cca
--- /dev/null
+++ b/testsuite/interactive/lib-signals/signals.ml
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+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 break_handler _ =
+  print_string "Thank you for pressing ctrl-C."; print_newline();
+  print_string "Allocating a bit..."; flush stdout;
+  ignore (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 _ =
+  ignore (Sys.signal Sys.sigint (Sys.Signal_handle break_handler));
+  ignore (Sys.signal Sys.sigtstp (Sys.Signal_handle stop_handler));
+  begin try
+    print_string "Computing like crazy..."; print_newline();
+    for i = 1 to 1000 do ignore (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/testsuite/lib/Makefile b/testsuite/lib/Makefile
new file mode 100644
index 00000000..be620ffa
--- /dev/null
+++ b/testsuite/lib/Makefile
@@ -0,0 +1,31 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+.PHONY: compile
+compile: compile-targets
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+
+include ../makefiles/Makefile.common
+
+.PHONY: compile-targets
+compile-targets: testing.cmi testing.cmo
+	@if $(BYTECODE_ONLY); then : ; else \
+	  $(MAKE) testing.cmx; \
+	fi
diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml
new file mode 100644
index 00000000..662719af
--- /dev/null
+++ b/testsuite/lib/testing.ml
@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Testing auxilliaries. *)
+
+open Scanf;;
+
+let all_tests_ok = ref true;;
+
+let finish () =
+  match !all_tests_ok with
+  | true ->
+      print_endline "\nAll tests succeeded."
+  | _ ->
+      print_endline "\n\n********* Test suite failed. ***********\n";;
+
+at_exit finish;;
+
+let test_num = ref (-1);;
+
+let print_test_number () =
+  print_string " "; print_int !test_num; 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
+    ignore (f x);
+    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;;
diff --git a/testsuite/lib/testing.mli b/testsuite/lib/testing.mli
new file mode 100644
index 00000000..f13bb358
--- /dev/null
+++ b/testsuite/lib/testing.mli
@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Testing auxilliaries. *)
+
+val test : bool -> unit;;
+(** [test e] tests that [e] evaluates to [true]. *)
+val failure_test : ('a -> 'b) -> 'a -> string -> bool;;
+(** [failure_test f x s] tests that [f x] raises the exception [Failure s]. *)
+
+val test_raises_some_exc : ('a -> 'b) -> 'a -> bool;;
+(** [test_raises_some_exc f x] tests that [f x] raises an exception. *)
+
+val test_raises_this_exc : exn -> ('a -> 'b) -> 'a -> bool;;
+(** [test_raises_this_exc exc f x] tests that [f x]
+    raises the exception [exc]. *)
+
+val test_raises_exc_p : (exn -> bool) -> ('a -> 'b) -> 'a -> bool;;
+(** [test_raises_exc_p p f x] tests that [f x] raises an exception that
+    verifies predicate [p]. *)
+
+val scan_failure_test : ('a -> 'b) -> 'a -> bool;;
+(** [scan_failure_test f x] tests that [f x] raises [Scanf.Scan_failure]. *)
diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
new file mode 100644
index 00000000..0a85f959
--- /dev/null
+++ b/testsuite/makefiles/Makefile.common
@@ -0,0 +1,82 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+TOPDIR=$(BASEDIR)/..
+include $(TOPDIR)/Makefile.tools
+
+defaultpromote:
+	@for file in *.reference; do \
+	  cp `basename $$file reference`result $$file; \
+	done
+
+defaultclean:
+	@rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) *.exe
+	@rm -f *.exe.manifest
+	@for dsym in *.dSYM; do \
+	  if [ -d $$dsym ]; then \
+	    rm -fr $$dsym; \
+	  fi \
+	done
+
+.SUFFIXES:
+.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .$(O) .so .c .f
+
+.mli.cmi:
+	@$(OCAMLC) -c $(ADD_COMPFLAGS) $<
+
+.ml.cmi:
+	@$(OCAMLC) -c $(ADD_COMPFLAGS) $<
+
+.ml.cmo:
+	@if [ -f $<i ]; then $(OCAMLC) -c $(ADD_COMPFLAGS) $<i; fi
+	@$(OCAMLC) -c $(ADD_COMPFLAGS) $<
+
+.ml.cmx:
+	@$(OCAMLOPT) -c $(ADD_COMPFLAGS) $<
+
+.cmx.so:
+	@$(OCAMLOPT) -o $@ -shared $(ADD_COMPFLAGS) $<
+
+.cmxa.so:
+	@$(OCAMLOPT) -o $@ -shared -linkall $(ADD_COMPFLAGS) $<
+
+%.ml %.mli: %.mly
+	@$(OCAMLYACC) -q $< 2> /dev/null
+
+.mll.ml:
+	@$(OCAMLLEX) -q $< > /dev/null
+
+.cmm.s:
+	@$(OCAMLRUN) ./codegen -S $*.cmm
+
+.cmm.obj:
+	@$(OCAMLRUN) ./codegen $*.cmm \
+	| grep -v "_caml_\(young_ptr\|young_limit\|extra_params\
+	\|allocN\|raise_exn\|reraise_exn\)" > $*.s
+	@set -o pipefail ; \
+	$(ASM) $*.obj $*.s | tail -n +2
+
+.S.o:
+	@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S
+
+.PRECIOUS: %.s
+.s.o:
+	@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.s
+
+.c.o:
+	@$(CC) -c -I$(CTOPDIR)/byterun $*.c -o $*.$(O)
+
+.f.o:
+	@$(FORTRAN_COMPILER) -c -I$(CTOPDIR)/byterun $*.f -o $*.$(O)
diff --git a/testsuite/makefiles/Makefile.dlambda b/testsuite/makefiles/Makefile.dlambda
new file mode 100644
index 00000000..d9e88744
--- /dev/null
+++ b/testsuite/makefiles/Makefile.dlambda
@@ -0,0 +1,35 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# To avoid tests breaking each time the internal name generation
+# changes, we strip -dlambda-produced identifiers of their unique
+# identifier: "x/1234" becomes simply "x".
+
+default:
+	@for file in *.ml; do \
+	  $(OCAMLC) -dlambda -c $$file 2>&1 | \
+	  sed -e "s|\\([A-Za-z_][A-Za-z_']*\)/[0-9][0-9]*|\\1|g" \
+	      > $$file.result; \
+	done
+	@for file in *.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
diff --git a/testsuite/makefiles/Makefile.dparsetree b/testsuite/makefiles/Makefile.dparsetree
new file mode 100644
index 00000000..711e440a
--- /dev/null
+++ b/testsuite/makefiles/Makefile.dparsetree
@@ -0,0 +1,30 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                   Jeremie Dimino, Jane Street Europe                   *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default:
+	@for file in *.ml; do \
+	  $(OCAMLC) -dparsetree -c $$file 2>$$file.result >/dev/null || true; \
+	done
+	@for file in *.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
diff --git a/testsuite/makefiles/Makefile.expect b/testsuite/makefiles/Makefile.expect
new file mode 100644
index 00000000..0b219ee8
--- /dev/null
+++ b/testsuite/makefiles/Makefile.expect
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default:
+	@for file in *.ml; do \
+	  printf " ... testing '$$file':"; \
+	  TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) $$file && \
+	  TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) -principal \
+	    $$file.corrected && \
+	  mv $$file.corrected.corrected $$file.corrected && \
+	  $(DIFF) $$file $$file.corrected && \
+	  echo " => passed" || echo " => failed"; \
+	done
+
+promote:
+	@for file in *.corrected; do \
+	  cp $$file `basename $$file .corrected`; \
+	done
+
+clean: defaultclean
+	@rm -f *.corrected
diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad
new file mode 100644
index 00000000..d463181e
--- /dev/null
+++ b/testsuite/makefiles/Makefile.okbad
@@ -0,0 +1,54 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+.PHONY: default
+default: compile
+
+# See run-file in Makefile.several for the use of mktemp
+.PHONY: compile
+compile:
+	@for file in *.ml; do \
+	  printf " ... testing '$$file'"; \
+	  if [ `echo $$file | grep principal` ]; \
+	  then PRIN="-principal -w +18+19 -warn-error A"; \
+	  else PRIN=""; fi; \
+	  if [ `echo $$file | grep bad` ]; then \
+	    $(OCAMLC) -c -w a $$PRIN $$file 2>/dev/null \
+            && echo " => failed" || echo " => passed"; \
+	  else \
+	    F="`basename $$file .ml`"; \
+	    test -f $$F.mli && $(OCAMLC) -c -w a $$PRIN $$F.mli; \
+	    $(OCAMLC) -c -w a $$PRIN $$file 2>/dev/null \
+	    && if [ -f $$F.reference ]; then \
+	         test -e program.byte.exe && { \
+	           T="`mktemp -p .`"; \
+	           mv -f program.byte.exe "$$T"; \
+	           rm -f "$$T"; \
+	         } ; \
+	         rm -f program.byte program.byte.exe; \
+	         $(OCAMLC) $$F.cmo -o program.byte$(EXE) \
+	         && $(OCAMLRUN) program.byte$(EXE) >$$F.result \
+	         && $(DIFF) $$F.reference $$F.result >/dev/null; \
+	       fi \
+	    && echo " => passed" || echo " => failed"; \
+	  fi; \
+	done
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f program.byte program.byte.exe *.cm* *.result
diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one
new file mode 100644
index 00000000..c98fbb59
--- /dev/null
+++ b/testsuite/makefiles/Makefile.one
@@ -0,0 +1,104 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+CMI_FILES=$(MODULES:=.cmi)
+CMO_FILES=$(MODULES:=.cmo)
+CMX_FILES=$(MODULES:=.cmx)
+CMA_FILES=$(LIBRARIES:=.cma)
+CMXA_FILES=$(LIBRARIES:=.cmxa)
+ML_LEX_FILES=$(LEX_MODULES:=.ml)
+ML_YACC_FILES=$(YACC_MODULES:=.ml)
+MLI_YACC_FILES=$(YACC_MODULES:=.mli)
+ML_FILES=$(ML_LEX_FILES) $(ML_YACC_FILES)
+O_FILES=$(C_FILES:=.$(O))
+ADD_CMO_FILES=$(ADD_MODULES:=.cmo)
+ADD_CMX_FILES=$(ADD_MODULES:=.cmx)
+
+GENERATED_SOURCES=$(ML_LEX_FILES) $(ML_YACC_FILES) $(MLI_YACC_FILES)
+
+CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
+ADD_CFLAGS+=$(CUSTOM_FLAG)
+MYRUNTIME=`if [ -z "$(C_FILES)$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi`
+
+C_INCLUDES+=-I $(CTOPDIR)/byterun
+
+.PHONY: default
+default:
+	@$(MAKE) compile
+	@$(NATIVECODE_ONLY) && $(BYTECODE_ONLY) \
+	 && echo " ... testing => skipped" \
+	 || $(SET_LD_PATH) $(MAKE) run
+
+# See run-file in Makefile.several for the use of mktemp (included for
+# completeness; should be unnecessary)
+.PHONY: compile
+compile: $(ML_FILES)
+	@for file in $(C_FILES); do \
+	  $(OCAMLC) -c $(C_INCLUDES) $$file.c; \
+	done
+	@if $(NATIVECODE_ONLY); then : ; else \
+	  test -e program.byte.exe && { \
+	    T="`mktemp -p .`"; \
+	    mv -f program.byte.exe "$$T"; \
+	    rm -f "$$T"; \
+	  } ; \
+	  rm -f program.byte program.byte.exe; \
+	  $(MAKE) $(CMO_FILES) $(MAIN_MODULE).cmo; \
+	  $(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
+	            $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+	            $(MAIN_MODULE).cmo; \
+	fi
+	@if $(BYTECODE_ONLY); then : ; else \
+	  test -e program.native.exe && { \
+	    T="`mktemp -p .`"; \
+	    mv -f program.native.exe "$$T"; \
+	    rm -f "$$T"; \
+	  } ; \
+	  rm -f program.native program.native.exe; \
+	  $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \
+	  $(OCAMLOPT) $(ADD_COMPFLAGS) $(ADD_OPTCOMPFLAGS) \
+	              -o program.native$(EXE) $(O_FILES) \
+	              $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) \
+	              $(MAIN_MODULE).cmx; \
+	fi
+
+.PHONY: run
+run:
+	@printf " ... testing with"
+	@if $(NATIVECODE_ONLY); then : ; else \
+	   printf " ocamlc"; \
+	   FLAMBDA=$(FLAMBDA) $(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) \
+	                >$(MAIN_MODULE).result \
+	   && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
+	      >/dev/null; \
+	 fi \
+	&& if $(BYTECODE_ONLY); then : ; else \
+	     printf " ocamlopt"; \
+	     FLAMBDA=$(FLAMBDA) ./program.native$(EXE) $(EXEC_ARGS) \
+	                             > $(MAIN_MODULE).result \
+	     && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
+	                >/dev/null; \
+	   fi \
+	&& echo " => passed" || echo " => failed"
+
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result program.byte program.byte.exe \
+	       program.native program.native.exe \
+	       $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
new file mode 100644
index 00000000..e29378c7
--- /dev/null
+++ b/testsuite/makefiles/Makefile.several
@@ -0,0 +1,142 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
+FC=$(FORTAN_COMPILER)
+CMO_FILES=$(MODULES:=.cmo)
+CMX_FILES=$(MODULES:=.cmx)
+CMA_FILES=$(LIBRARIES:=.cma)
+CMXA_FILES=$(LIBRARIES:=.cmxa)
+O_FILES=$(F_FILES:=.o) $(C_FILES:=.o)
+
+CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
+ADD_CFLAGS+=$(CUSTOM_FLAG)
+MYRUNTIME=`if [ -z "$(C_FILES)$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; echo '$(ADD_BYTERUN_FLAGS)'; fi`
+FORTRAN_LIB=`if [ -n "$(F_FILES)" ]; then echo $(FORTRAN_LIBRARY); fi`
+ADD_CFLAGS+=$(FORTRAN_LIB)
+ADD_OPTFLAGS+=$(FORTRAN_LIB)
+
+C_INCLUDES+=-I $(CTOPDIR)/byterun -I $(CTOPDIR)/otherlibs/bigarray
+
+GENERATED_SOURCES=
+
+SKIP=false
+
+.PHONY: check
+check:
+	@if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then \
+	  $(SET_LD_PATH) $(MAKE) run-all; \
+	else \
+	  $(MAKE) C_FILES= F_FILES= SKIP=true run-all; \
+	fi
+
+.PHONY: run-all
+run-all:
+	@for file in $(C_FILES); do \
+	  $(OCAMLC) -c $(C_INCLUDES) -c $$file.c; \
+	done;
+	@for file in $(F_FILES); do \
+	  $(FORTRAN_COMPILER) -c $$file.f; \
+	done;
+	@for file in *.ml; do \
+	  printf " ... testing '$$file':"; \
+	  if $(SKIP) ; then \
+	    echo " => skipped"; continue; \
+	  fi; \
+	  if [ -f `basename $$file ml`precheck ]; then \
+	    if ! TOOLCHAIN=$(TOOLCHAIN) sh `basename $$file ml`precheck ; then \
+	      echo " => skipped"; \
+	      continue; \
+	    fi; \
+	  fi; \
+	  $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' \
+	          RUNTIME='$(MYRUNTIME)' \
+	          COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) \
+	                     $(CMA_FILES) -I $(OTOPDIR)/testsuite/lib \
+	                     $(CMO_FILES)' \
+	          FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) \
+	  && \
+	  if $(BYTECODE_ONLY); then : ; else \
+	    $(MAKE) run-file DESC=ocamlopt COMP='$(OCAMLOPT)' \
+	            RUNTIME= \
+	            COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_OPTFLAGS) \
+		               $(O_FILES) $(CMXA_FILES) \
+			       -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
+	            FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \
+	  fi \
+	  && \
+	  if [ -n "$(UNSAFE)" ]; then \
+	    $(MAKE) run-file DESC=ocamlc-unsafe COMP='$(OCAMLC)' \
+	            RUNTIME='$(MYRUNTIME)' \
+	            COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_CFLAGS) \
+	                       $(O_FILES) $(CMA_FILES) \
+	                       -I $(OTOPDIR)/testsuite/lib $(CMO_FILES)' \
+	            FILE=$$file \
+	    && \
+	    if $(BYTECODE_ONLY); then : ; else \
+	      $(MAKE) run-file DESC=ocamlopt-unsafe COMP='$(OCAMLOPT)' \
+	              RUNTIME= \
+	              COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_OPTFLAGS)\
+		                 $(O_FILES) $(CMXA_FILES) \
+	                         -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
+	              FILE=$$file; \
+	       fi; \
+	     fi \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+# On Windows, nefarious software (specifically Windows Defender) can prevent
+# executable files being deleted while it scans them. Unfortunately, it does
+# this by allowing the delete system call (either via rm -f or cmd /c del) to
+# complete with success but the file can linger for seconds or even minutes
+# until it suddenly disappears. During this time, the file cannot be overwritten
+# but it can be renamed, hence the odd use of mktemp. Some tests compiled with
+# flambda seem to be consistently "interesting" to Windows Defender. Note that
+# the interference doesn't appear to affect the execution of the tests.
+.PHONY: run-file
+run-file:
+	@printf " $(DESC)"
+	@test -e program.exe && { \
+	  T="`mktemp -p .`"; \
+	  mv -f program.exe "$$T"; \
+	  rm -f "$$T"; \
+	} || true
+	@rm -f program program$(EXE)
+	@$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
+	@F="`basename $(FILE) .ml`"; \
+	if [ -f $$F.runner ]; then \
+	  RUNTIME="$(RUNTIME)" sh $$F.runner; \
+	else \
+	  $(SET_LD_PATH) $(RUNTIME) ./program$(EXE) $(PROGRAM_ARGS) >$$F.result; \
+	fi \
+	&& \
+	if [ -f $$F.checker ]; then \
+	  DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker || { \
+	    printf "  Error: output checker failed!\n"; \
+	    exit 1; \
+	  }; \
+	else \
+	  $(DIFF) $$F.reference $$F.result >/dev/null || { \
+	    printf "  Error: results don't match reference output!\n"; \
+	    exit 1; \
+	  }; \
+	fi
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result program program.exe $(GENERATED_SOURCES)
diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel
new file mode 100644
index 00000000..e4d29fae
--- /dev/null
+++ b/testsuite/makefiles/Makefile.toplevel
@@ -0,0 +1,34 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default:
+	@for file in *.ml; do \
+	  TERM=dumb $(OCAML) $(TOPFLAGS) <$$file 2>&1 \
+	    | grep -v '^        OCaml version' > $$file.result; \
+	  if [ -f $$file.principal.reference ]; then \
+	    TERM=dumb $(OCAML) $(TOPFLAGS) -principal <$$file 2>&1 \
+	      | grep -v '^        OCaml version' > $$file.principal.result; \
+	  fi; \
+	done
+	@for file in *.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
diff --git a/testsuite/makefiles/summarize.awk b/testsuite/makefiles/summarize.awk
new file mode 100644
index 00000000..97f214b6
--- /dev/null
+++ b/testsuite/makefiles/summarize.awk
@@ -0,0 +1,212 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*         Damien Doligez, projet Gallium, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+function check() {
+    if (!in_test){
+        printf("error at line %d: found test result without test start\n", NR);
+        errored = 1;
+    }
+}
+
+function clear() {
+    curfile = "";
+    in_test = 0;
+}
+
+function record_pass() {
+    check();
+    if (!(key in RESULTS)) ++nresults;
+    RESULTS[key] = "p";
+    delete SKIPPED[curdir];
+    clear();
+}
+
+function record_skip() {
+    check();
+    if (!(key in RESULTS)) ++nresults;
+    RESULTS[key] = "s";
+    if (curdir in SKIPPED) SKIPPED[curdir] = 1;
+    clear();
+}
+
+# The output cares only if the test passes at least once so if a test passes,
+# but then fails in a re-run triggered by a different test, ignore it.
+function record_fail() {
+    check();
+    if (!(key in RESULTS) || RESULTS[key] == "s"){
+        if (!(key in RESULTS)) ++nresults;
+        RESULTS[key] = "f";
+    }
+    delete SKIPPED[curdir];
+    clear();
+}
+
+function record_unexp() {
+    if (!(key in RESULTS) || RESULTS[key] == "s"){
+        if (!(key in RESULTS)) ++nresults;
+        RESULTS[key] = "e";
+    }
+    delete SKIPPED[curdir];
+    clear();
+}
+
+/Running tests from '[^']*'/ {
+    if (in_test) record_unexp();
+    match($0, /Running tests from '[^']*'/);
+    curdir = substr($0, RSTART+20, RLENGTH - 21);
+    # Use SKIPPED[curdir] as a sentinel to detect no output
+    SKIPPED[curdir] = 0;
+    key = curdir;
+    DIRS[key] = key;
+    curfile = "";
+}
+
+/ ... testing.* ... testing/ {
+    printf("error at line %d: found two test results on the same line\n", NR);
+    errored = 1;
+}
+
+/^ ... testing '[^']*'/ {
+    if (in_test) record_unexp();
+    match($0, /... testing '[^']*'/);
+    curfile = substr($0, RSTART+13, RLENGTH-14);
+    if (match($0, /... testing '[^']*' with [^:=]*/)){
+        curfile = substr($0, RSTART+12, RLENGTH-12);
+    }
+    key = sprintf ("%s/%s", curdir, curfile);
+    DIRS[key] = curdir;
+    in_test = 1;
+}
+
+/^ ... testing (with|[^'])/ {
+    if (in_test) record_unexp();
+    key = curdir;
+    DIRS[key] = curdir;
+    in_test = 1;
+}
+
+/=> passed/ {
+    record_pass();
+}
+
+/=> skipped/ {
+    record_skip();
+}
+
+/=> failed/ {
+    record_fail();
+}
+
+/=> unexpected error/ {
+    record_unexp();
+}
+
+/^re-ran / {
+    if (in_test){
+        printf("error at line %d: found re-ran inside a test\n", NR);
+        errored = 1;
+    }else{
+        RERAN[substr($0, 8, length($0)-7)] += 1;
+        ++ reran;
+    }
+}
+
+END {
+    if (errored){
+        printf ("\n#### Some fatal error occurred during testing.\n\n");
+        exit (3);
+    }else{
+        if (!retries){
+            for (key in SKIPPED){
+                if (!SKIPPED[key]){
+                    ++ empty;
+                    blanks[emptyidx++] = key;
+                    delete SKIPPED[key];
+                }
+            }
+            for (key in RESULTS){
+                r = RESULTS[key];
+                if (r == "p"){
+                    ++ passed;
+                }else if (r == "f"){
+                    ++ failed;
+                    fail[failidx++] = key;
+                }else if (r == "e"){
+                    ++ unexped;
+                    unexp[unexpidx++] = key;
+                }else if (r == "s"){
+                    ++ skipped;
+                    curdir = DIRS[key];
+                    if (curdir in SKIPPED){
+                        if (SKIPPED[curdir]){
+                            SKIPPED[curdir] = 0;
+                            skips[skipidx++] = curdir;
+                        }
+                    }else{
+                        skips[skipidx++] = key;
+                    }
+                }
+            }
+            printf("\n");
+            printf("Summary:\n");
+            printf("  %3d tests passed\n", passed);
+            printf("  %3d tests skipped\n", skipped);
+            printf("  %3d tests failed\n", failed);
+            printf("  %3d unexpected errors\n", unexped);
+            printf("  %3d tests considered", nresults);
+            if (nresults == passed + skipped + failed + unexped){
+                printf ("\n");
+            }else{
+                printf (" (totals don't add up??)");
+            }
+            if (reran != 0){
+                printf("  %3d test dir re-runs\n", reran);
+            }
+            if (failed != 0){
+                printf("\nList of failed tests:\n");
+                for (i=0; i < failed; i++) printf("    %s\n", fail[i]);
+            }
+            if (unexped != 0){
+                printf("\nList of unexpected errors:\n");
+                for (i=0; i < unexped; i++) printf("    %s\n", unexp[i]);
+            }
+            if (skipped != 0){
+                printf("\nList of skipped tests:\n");
+                for (i=0; i < skipidx; i++) printf("    %s\n", skips[i]);
+            }
+            if (empty != 0){
+                printf("\nList of directories returning no results:\n");
+                for (i=0; i < empty; i++) printf("    %s\n", blanks[i]);
+            }
+            printf("\n");
+            if (failed || unexped){
+                printf("#### Something failed. Exiting with error status.\n\n");
+                exit 4;
+            }
+        }else{
+            for (key in RESULTS){
+                if (RESULTS[key] == "f" || RESULTS[key] == "e"){
+                    key = DIRS[key];
+                    if (!(key in RERUNS)){
+                        RERUNS[key] = 1;
+                        if (RERAN[key] < max_retries){
+                            printf("%s\n", key);
+                        }
+                    }
+                }
+            }
+        }
+    }
+}
diff --git a/testsuite/tests/array-functions/Makefile b/testsuite/tests/array-functions/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/array-functions/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/array-functions/test.ml b/testsuite/tests/array-functions/test.ml
new file mode 100644
index 00000000..e325724c
--- /dev/null
+++ b/testsuite/tests/array-functions/test.ml
@@ -0,0 +1,182 @@
+let () =
+  let a = [|0;1;2;3;4;5;6;7;8;9|] in
+  assert (Array.exists (fun a -> a < 10) a);
+  assert (Array.exists (fun a -> a > 0) a);
+  assert (Array.exists (fun a -> a = 0) a);
+  assert (Array.exists (fun a -> a = 1) a);
+  assert (Array.exists (fun a -> a = 2) a);
+  assert (Array.exists (fun a -> a = 3) a);
+  assert (Array.exists (fun a -> a = 4) a);
+  assert (Array.exists (fun a -> a = 5) a);
+  assert (Array.exists (fun a -> a = 6) a);
+  assert (Array.exists (fun a -> a = 7) a);
+  assert (Array.exists (fun a -> a = 8) a);
+  assert (Array.exists (fun a -> a = 9) a);
+  assert (not (Array.exists (fun a -> a < 0) a));
+  assert (not (Array.exists (fun a -> a > 9) a));
+  assert (Array.exists (fun _ -> true) a);
+;;
+
+let () =
+  let a = [|1;2;3|] in
+  assert (Array.exists (fun a -> a < 3) a);
+  assert (Array.exists (fun a -> a < 2) a);
+  assert (not (Array.exists (fun a -> a < 1) a));
+  assert (Array.exists (fun a -> a mod 2 = 0)  [|1;4;5|]);
+  assert (not (Array.exists (fun a -> a mod 2 = 0)  [|1;3;5|]));
+  assert (not (Array.exists (fun _ -> true) [||]));
+  assert (Array.exists (fun a -> a.(9) = 1) (Array.make_matrix 10 10 1));
+  let f = Array.create_float 10 in
+  Array.fill f 0 10 1.0;
+  assert (Array.exists (fun a -> a = 1.0) f);
+;;
+
+let () =
+  let a: int array = [||] in
+  assert (not (Array.exists (fun a -> a = 0) a));
+  assert (not (Array.exists (fun a -> a = 1) a));
+  assert (not (Array.exists (fun a -> a = 2) a));
+  assert (not (Array.exists (fun a -> a = 3) a));
+  assert (not (Array.exists (fun a -> a = 4) a));
+  assert (not (Array.exists (fun a -> a = 5) a));
+  assert (not (Array.exists (fun a -> a = 6) a));
+  assert (not (Array.exists (fun a -> a = 7) a));
+  assert (not (Array.exists (fun a -> a = 8) a));
+  assert (not (Array.exists (fun a -> a = 9) a));
+  assert (not (Array.exists (fun a -> a <> 0) a));
+  assert (not (Array.exists (fun a -> a <> 1) a));
+  assert (not (Array.exists (fun a -> a <> 2) a));
+  assert (not (Array.exists (fun a -> a <> 3) a));
+  assert (not (Array.exists (fun a -> a <> 4) a));
+  assert (not (Array.exists (fun a -> a <> 5) a));
+  assert (not (Array.exists (fun a -> a <> 6) a));
+  assert (not (Array.exists (fun a -> a <> 7) a));
+  assert (not (Array.exists (fun a -> a <> 8) a));
+  assert (not (Array.exists (fun a -> a <> 9) a));
+  assert (not (Array.exists (fun a -> a < 0) a));
+  assert (not (Array.exists (fun a -> a < 1) a));
+  assert (not (Array.exists (fun a -> a < 2) a));
+  assert (not (Array.exists (fun a -> a < 3) a));
+  assert (not (Array.exists (fun a -> a < 4) a));
+  assert (not (Array.exists (fun a -> a < 5) a));
+  assert (not (Array.exists (fun a -> a < 6) a));
+  assert (not (Array.exists (fun a -> a < 7) a));
+  assert (not (Array.exists (fun a -> a < 8) a));
+  assert (not (Array.exists (fun a -> a < 9) a));
+  assert (not (Array.exists (fun a -> a > 0) a));
+  assert (not (Array.exists (fun a -> a > 1) a));
+  assert (not (Array.exists (fun a -> a > 2) a));
+  assert (not (Array.exists (fun a -> a > 3) a));
+  assert (not (Array.exists (fun a -> a > 4) a));
+  assert (not (Array.exists (fun a -> a > 5) a));
+  assert (not (Array.exists (fun a -> a > 6) a));
+  assert (not (Array.exists (fun a -> a > 7) a));
+  assert (not (Array.exists (fun a -> a > 8) a));
+  assert (not (Array.exists (fun a -> a > 9) a));
+;;
+
+let () =
+  let a = [|0;1;2;3;4;5;6;7;8;9|] in
+  assert (Array.for_all (fun a -> a < 10) a);
+  assert (Array.for_all (fun a -> a >= 0) a);
+  assert (not (Array.for_all (fun a -> a = 0) a));
+  assert (not (Array.for_all (fun a -> a = 1) a));
+  assert (not (Array.for_all (fun a -> a = 2) a));
+  assert (not (Array.for_all (fun a -> a = 3) a));
+  assert (not (Array.for_all (fun a -> a = 4) a));
+  assert (not (Array.for_all (fun a -> a = 5) a));
+  assert (not (Array.for_all (fun a -> a = 6) a));
+  assert (not (Array.for_all (fun a -> a = 7) a));
+  assert (not (Array.for_all (fun a -> a = 8) a));
+  assert (not (Array.for_all (fun a -> a = 9) a));
+  assert (Array.for_all (fun a -> a <> 10) a);
+  assert (Array.for_all (fun a -> a <> (-1)) a);
+  assert (Array.for_all (fun _ -> true) a);
+;;
+
+let () =
+  assert (Array.for_all (fun x -> x mod 2 = 0) [|2;4;6|]);
+  assert (not (Array.for_all (fun x -> x mod 2 = 0) [|2;3;6|]));
+  assert (Array.for_all (fun _ -> false) [||]);
+  assert (Array.for_all (fun a -> a.(9) = 1) (Array.make_matrix 10 10 1));
+  let f = Array.create_float 10 in
+  Array.fill f 0 10 1.0;
+  assert (Array.for_all (fun a -> a = 1.0) f);
+;;
+;;
+
+let () =
+  let a = [||] in
+  assert (Array.for_all (fun a -> a < 10) a);
+  assert (Array.for_all (fun a -> a >= 0) a);
+  assert (Array.for_all (fun a -> a = 0) a);
+  assert (Array.for_all (fun a -> a = 1) a);
+  assert (Array.for_all (fun a -> a = 2) a);
+  assert (Array.for_all (fun a -> a = 3) a);
+  assert (Array.for_all (fun a -> a = 4) a);
+  assert (Array.for_all (fun a -> a = 5) a);
+  assert (Array.for_all (fun a -> a = 6) a);
+  assert (Array.for_all (fun a -> a = 7) a);
+  assert (Array.for_all (fun a -> a = 8) a);
+  assert (Array.for_all (fun a -> a = 9) a);
+  assert (Array.for_all (fun a -> a <> 10) a);
+  assert (Array.for_all (fun a -> a <> (-1)) a);
+  assert (Array.for_all (fun _ -> true) a);
+;;
+
+
+let () =
+  let a = [|1;2;3;4;5;6;7;8;9|] in
+  assert (Array.mem 1 a);
+  assert (Array.mem 2 a);
+  assert (Array.mem 3 a);
+  assert (Array.mem 4 a);
+  assert (Array.mem 5 a);
+  assert (Array.mem 6 a);
+  assert (Array.mem 7 a);
+  assert (Array.mem 8 a);
+  assert (Array.mem 9 a);
+  assert (not (Array.mem 0 a));
+  assert (not (Array.mem 10 a));
+;;
+
+let () =
+  assert (Array.mem 2 [|1;2;3|]);
+  assert (not (Array.mem 2 [||]));
+  assert (Array.mem (ref 3) [|ref 1; ref 2; ref 3|]);
+  assert (Array.mem [|1;2;3|] [|[|1;2;3|];[|2;3;4|];[|0|]|]);
+  assert (Array.mem 1 (Array.make 100 1));
+  assert (Array.mem (ref 1) (Array.make 100 (ref 1)));
+  let f = Array.create_float 10 in
+  Array.fill f 0 10 1.0;
+  assert (Array.mem 1.0 f);
+;;
+
+let () =
+  let a = [|1;2;3;4;5;6;7;8;9|] in
+  assert (Array.memq 1 a);
+  assert (Array.memq 2 a);
+  assert (Array.memq 3 a);
+  assert (Array.memq 4 a);
+  assert (Array.memq 5 a);
+  assert (Array.memq 6 a);
+  assert (Array.memq 7 a);
+  assert (Array.memq 8 a);
+  assert (Array.memq 9 a);
+  assert (not (Array.memq 0 a));
+  assert (not (Array.memq 10 a));
+;;
+
+let () =
+  assert (Array.memq 2 [|1;2;3|]);
+  assert (not (Array.memq 2 [||]));
+  assert (not (Array.memq (ref 3) [|ref 1; ref 2; ref 3|]));
+  assert (not (Array.memq [|1;2;3|] [|[|1;2;3|];[|2;3;4|];[|0|]|]));
+  assert (Array.memq 1 (Array.make 100 1));
+  assert (not (Array.memq (ref 1) (Array.make 100 (ref 1))));
+  let f = Array.create_float 10 in
+  Array.fill f 0 10 1.0;
+  assert (not (Array.memq 1.0 f));
+;;
+
+let () = print_endline "OK"
diff --git a/testsuite/tests/array-functions/test.reference b/testsuite/tests/array-functions/test.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/array-functions/test.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile
new file mode 100644
index 00000000..5ef5a2e3
--- /dev/null
+++ b/testsuite/tests/asmcomp/Makefile
@@ -0,0 +1,156 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+INCLUDES=\
+  -I $(OTOPDIR)/parsing \
+  -I $(OTOPDIR)/utils \
+  -I $(OTOPDIR)/typing \
+  -I $(OTOPDIR)/middle_end \
+  -I $(OTOPDIR)/bytecomp \
+  -I $(OTOPDIR)/asmcomp
+
+OTHEROBJS=\
+  $(OTOPDIR)/compilerlibs/ocamlcommon.cma \
+  $(OTOPDIR)/compilerlibs/ocamloptcomp.cma
+
+OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo
+
+ADD_COMPFLAGS=$(INCLUDES) -w -40 -g
+
+default:
+	@if $(BYTECODE_ONLY) || $(SKIP) ; then $(MAKE) skips ; else \
+	  $(MAKE) all; \
+	fi
+
+all:
+	@$(MAKE) arch codegen
+	@$(MAKE) tests
+
+main.cmo: parsecmm.cmo
+
+codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo
+	@$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo
+
+parsecmm.mli parsecmm.ml: parsecmm.mly
+	@$(OCAMLYACC) -q parsecmm.mly
+
+lexcmm.ml: lexcmm.mll
+	@$(OCAMLLEX) -q lexcmm.mll
+
+MLCASES=optargs staticalloc bind_tuples is_static register_typing \
+  register_typing_switch
+ARGS_optargs=-g
+ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
+MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2 \
+  static_float_array_flambda static_float_array_flambda_opaque
+ARGS_is_static_flambda=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml
+ARGS_static_float_array_flambda=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c simple_float_const.ml
+ARGS_static_float_array_flambda_opaque=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c -opaque simple_float_const_opaque.ml
+
+CASES=fib tak quicksort quicksort2 soli \
+      arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak \
+      catch-try catch-rec even-odd even-odd-spill pgcd
+ARGS_fib=-DINT_INT -DFUN=fib main.c
+ARGS_tak=-DUNIT_INT -DFUN=takmain main.c
+ARGS_quicksort=-DSORT -DFUN=quicksort main.c
+ARGS_quicksort2=-DSORT -DFUN=quicksort main.c
+ARGS_soli=-DUNIT_INT -DFUN=solitaire main.c
+ARGS_integr=-DINT_FLOAT -DFUN=test main.c
+ARGS_arith=mainarith.c
+ARGS_checkbound=-DCHECKBOUND main.c
+ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c
+ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c
+ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c
+ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c
+ARGS_staticalloc=-I $(OTOPDIR)/utils config.cmx
+ARGS_catch-try=-DINT_INT -DFUN=catch_exit main.c
+ARGS_catch-rec=-DINT_INT -DFUN=catch_fact main.c
+ARGS_even-odd=-DINT_INT -DFUN=is_even main.c
+ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c
+ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c
+
+skips:
+	@for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA); do \
+	  echo " ... testing '$$c': => skipped"; \
+	done
+
+one_ml:
+	@$(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
+	./$(NAME).exe && echo " => passed" || echo " => failed"
+
+one_ml_flambda:
+	@if $(FLAMBDA); then \
+	   $(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
+	   ./$(NAME).exe && echo " => passed" || echo " => failed"; \
+	 else \
+	   echo " => skipped"; \
+	 fi
+
+one:
+	@$(call CC,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \
+	&& echo " => passed" || echo " => failed"
+
+clean: defaultclean
+	@rm -f ./codegen *.out *.out.manifest *.$(O) *.exe
+	@rm -f parsecmm.ml parsecmm.mli lexcmm.ml
+	@rm -f $(CASES:=.s)
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+ifeq "$(CCOMPTYPE)-$(ARCH)" "msvc-amd64"
+# these tests are not ported to MSVC64 yet
+SKIP=true
+else
+SKIP=false
+endif
+
+ifeq "$(WITH_SPACETIME)" "true"
+# These tests have not been ported for Spacetime
+SKIP=true
+endif
+
+ifeq ($(CCOMPTYPE),msvc)
+CC=set -o pipefail ; $(NATIVECC) $(CFLAGS) /Fe$(1) | tail -n +2
+CFLAGS=$(NATIVECCCOMPOPTS)
+else
+CC=$(NATIVECC) $(CFLAGS) -o $(1)
+CFLAGS=$(NATIVECCCOMPOPTS) -g
+endif
+tests: $(CASES:=.$(O))
+	@for c in $(CASES); do \
+	  printf " ... testing '$$c':"; \
+	  $(MAKE) one NAME=$$c; \
+	done
+	@for c in $(MLCASES); do \
+	  printf " ... testing '$$c':"; \
+          $(MAKE) one_ml NAME=$$c; \
+        done
+	@for c in $(MLCASES_FLAMBDA); do \
+	  printf " ... testing '$$c':"; \
+          $(MAKE) one_ml_flambda NAME=$$c; \
+        done
+
+promote:
+
+arch: $(ARCH).$(O)
+
+i386.obj: i386nt.asm
+	@set -o pipefail ; \
+	$(ASM) $@ $^ | tail -n +2
diff --git a/testsuite/tests/asmcomp/alpha.S b/testsuite/tests/asmcomp/alpha.S
new file mode 100644
index 00000000..44528769
--- /dev/null
+++ b/testsuite/tests/asmcomp/alpha.S
@@ -0,0 +1,63 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+        .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/testsuite/tests/asmcomp/amd64.S b/testsuite/tests/asmcomp/amd64.S
new file mode 100644
index 00000000..bb4f9b5c
--- /dev/null
+++ b/testsuite/tests/asmcomp/amd64.S
@@ -0,0 +1,78 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifdef SYS_macosx
+#define ALIGN 4
+#else
+#define ALIGN 16
+#endif
+
+#ifdef SYS_macosx
+#define CALL_GEN_CODE _call_gen_code
+#define CAML_C_CALL _caml_c_call
+#define CAML_NEGF_MASK _caml_negf_mask
+#define CAML_ABSF_MASK _caml_absf_mask
+#else
+#define CALL_GEN_CODE call_gen_code
+#define CAML_C_CALL caml_c_call
+#define CAML_NEGF_MASK caml_negf_mask
+#define CAML_ABSF_MASK caml_absf_mask
+#endif
+
+        .globl  CALL_GEN_CODE
+        .align  ALIGN
+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  ALIGN
+CAML_C_CALL:
+        jmp     *%rax
+
+#ifdef SYS_macosx
+        .literal16
+#elif defined(SYS_mingw64) || defined(SYS_cygwin)
+        .section        .rodata.cst8
+#else
+        .section        .rodata.cst8,"aM",@progbits,8
+#endif
+        .globl  CAML_NEGF_MASK
+        .align  ALIGN
+CAML_NEGF_MASK:
+        .quad   0x8000000000000000, 0
+        .globl  CAML_ABSF_MASK
+        .align  ALIGN
+CAML_ABSF_MASK:
+        .quad   0x7FFFFFFFFFFFFFFF, 0
+
+        .comm   young_limit, 8
diff --git a/testsuite/tests/asmcomp/arith.cmm b/testsuite/tests/asmcomp/arith.cmm
new file mode 100644
index 00000000..09156568
--- /dev/null
+++ b/testsuite/tests/asmcomp/arith.cmm
@@ -0,0 +1,221 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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 (- "R" 8))
+      (addraset r 18 (- "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))
+
+      (addraset r 116 (mulh x y))
+)))))))
diff --git a/testsuite/tests/asmcomp/arm.S b/testsuite/tests/asmcomp/arm.S
new file mode 100644
index 00000000..fbbe2763
--- /dev/null
+++ b/testsuite/tests/asmcomp/arm.S
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1998 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+        .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/testsuite/tests/asmcomp/arm64.S b/testsuite/tests/asmcomp/arm64.S
new file mode 100644
index 00000000..fa49f1ae
--- /dev/null
+++ b/testsuite/tests/asmcomp/arm64.S
@@ -0,0 +1,55 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2013 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+        .globl  call_gen_code
+        .align  2
+call_gen_code:
+    /* Set up stack frame and save callee-save registers */
+        stp     x29, x30, [sp, -160]!
+        add     x29, sp, #0
+        stp     x19, x20, [sp, 16]
+        stp     x21, x22, [sp, 32]
+        stp     x23, x24, [sp, 48]
+        stp     x25, x26, [sp, 64]
+        stp     x27, x28, [sp, 80]
+        stp     d8, d9, [sp, 96]
+        stp     d10, d11, [sp, 112]
+        stp     d12, d13, [sp, 128]
+        stp     d14, d15, [sp, 144]
+    /* Shuffle arguments */
+        mov     x8, x0
+        mov     x0, x1
+        mov     x1, x2
+        mov     x2, x3
+        mov     x3, x4
+    /* Call generated asm */
+        blr     x8
+    /* Reload callee-save registers and return address */
+        ldp     x19, x20, [sp, 16]
+        ldp     x21, x22, [sp, 32]
+        ldp     x23, x24, [sp, 48]
+        ldp     x25, x26, [sp, 64]
+        ldp     x27, x28, [sp, 80]
+        ldp     d8, d9, [sp, 96]
+        ldp     d10, d11, [sp, 112]
+        ldp     d12, d13, [sp, 128]
+        ldp     d14, d15, [sp, 144]
+        ldp     x29, x30, [sp], 160
+        ret
+
+        .globl  caml_c_call
+        .align  2
+caml_c_call:
+        br      x15
diff --git a/testsuite/tests/asmcomp/bind_tuples.ml b/testsuite/tests/asmcomp/bind_tuples.ml
new file mode 100755
index 00000000..a6dd2947
--- /dev/null
+++ b/testsuite/tests/asmcomp/bind_tuples.ml
@@ -0,0 +1,28 @@
+(* Check the effectiveness of optimized compilation of tuple binding
+
+   Ref: http://caml.inria.fr/mantis/view.php?id=4800
+*)
+
+let f () =
+  let x0 = Gc.allocated_bytes () in
+  let x1 = Gc.allocated_bytes () in
+
+  let r = ref 0 in
+  for i = 1 to 20 do
+    let (x, y) =
+      try
+        if i mod 2 = 0 then (1, i * 2)
+        else if i mod 5 = 0 then raise Exit
+        else (-1, i * 3)
+      with Exit ->
+        (1, -1)
+    in
+    r := !r * x + y
+  done;
+  let x2 = Gc.allocated_bytes () in
+  print_int !r;
+  assert (!r = 82);
+  assert(x1 -. x0 = x2 -. x1) (* check no allocation between x1 and x2 *)
+  [@@inline never]
+
+let () = f ()
diff --git a/testsuite/tests/asmcomp/catch-rec.cmm b/testsuite/tests/asmcomp/catch-rec.cmm
new file mode 100644
index 00000000..69208f5f
--- /dev/null
+++ b/testsuite/tests/asmcomp/catch-rec.cmm
@@ -0,0 +1,5 @@
+(function "catch_fact" (b:int)
+  (catch (exit fact b 1)
+   with (fact c acc)
+     (if (== c 0) acc
+         (exit fact (- c 1) ( * c acc)))))
diff --git a/testsuite/tests/asmcomp/catch-try.cmm b/testsuite/tests/asmcomp/catch-try.cmm
new file mode 100644
index 00000000..bbbdc387
--- /dev/null
+++ b/testsuite/tests/asmcomp/catch-try.cmm
@@ -0,0 +1,7 @@
+
+(function "catch_exit" (b:int)
+  (+ 33
+  (catch
+    (try (exit lbl 12)
+     with var 456)
+   with (lbl x) (+ x 789))))
diff --git a/testsuite/tests/asmcomp/checkbound.cmm b/testsuite/tests/asmcomp/checkbound.cmm
new file mode 100644
index 00000000..35206f25
--- /dev/null
+++ b/testsuite/tests/asmcomp/checkbound.cmm
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(function "checkbound2" (x: int y: int)
+  (checkbound x y))
+
+(function "checkbound1" (x: int)
+  (checkbound x 2))
diff --git a/testsuite/tests/asmcomp/even-odd-spill.cmm b/testsuite/tests/asmcomp/even-odd-spill.cmm
new file mode 100644
index 00000000..0c5f0558
--- /dev/null
+++ b/testsuite/tests/asmcomp/even-odd-spill.cmm
@@ -0,0 +1,19 @@
+("format_odd": string "odd %d\n\000")
+("format_even": string "even %d\n\000")
+
+(function "force_spill" (a:int) 0)
+
+(function "is_even" (b:int)
+  (catch (exit even b)
+   with (odd v)
+     (if (== v 0) 0
+         (seq
+           (extcall "printf_int" "format_odd" v unit)
+           (let v2 (- v 1)
+             (app "force_spill" 0 int)
+             (exit even v2))))
+   and (even v)
+     (if (== v 0) 1
+         (seq
+           (extcall "printf_int" "format_even" v unit)
+           (exit odd (- v 1))))))
diff --git a/testsuite/tests/asmcomp/even-odd.cmm b/testsuite/tests/asmcomp/even-odd.cmm
new file mode 100644
index 00000000..db79f1ca
--- /dev/null
+++ b/testsuite/tests/asmcomp/even-odd.cmm
@@ -0,0 +1,8 @@
+(function "is_even" (b:int)
+  (catch (exit even b)
+   with (odd v)
+     (if (== v 0) 0
+         (exit even (- v 1)))
+   and (even v)
+     (if (== v 0) 1
+         (exit odd (- v 1)))))
\ No newline at end of file
diff --git a/testsuite/tests/asmcomp/fib.cmm b/testsuite/tests/asmcomp/fib.cmm
new file mode 100644
index 00000000..49de4ba1
--- /dev/null
+++ b/testsuite/tests/asmcomp/fib.cmm
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(function "fib" (n: int)
+  (if (< n 2)
+      1
+    (+ (app "fib" (- n 1) int)
+       (app "fib" (- n 2) int))))
diff --git a/testsuite/tests/asmcomp/hppa.S b/testsuite/tests/asmcomp/hppa.S
new file mode 100644
index 00000000..5f7455b7
--- /dev/null
+++ b/testsuite/tests/asmcomp/hppa.S
@@ -0,0 +1,161 @@
+;*********************************************************************
+;*                                                                   *
+;*                               OCaml                               *
+;*                                                                   *
+;*           Xavier Leroy, projet Cristal, INRIA 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.              *
+;*                                                                   *
+;*********************************************************************
+
+; 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/testsuite/tests/asmcomp/i386.S b/testsuite/tests/asmcomp/i386.S
new file mode 100644
index 00000000..6da92f2a
--- /dev/null
+++ b/testsuite/tests/asmcomp/i386.S
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Linux with ELF binaries does not prefix identifiers with _.
+   Linux with a.out binaries, FreeBSD, and NextStep do. */
+
+#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
+ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu)
+#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/testsuite/tests/asmcomp/i386nt.asm b/testsuite/tests/asmcomp/i386nt.asm
new file mode 100644
index 00000000..618d41c9
--- /dev/null
+++ b/testsuite/tests/asmcomp/i386nt.asm
@@ -0,0 +1,65 @@
+;*********************************************************************;
+;                                                                     ;
+;                                OCaml                                ;
+;                                                                     ;
+;            Xavier Leroy, projet Cristal, INRIA 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.               ;
+;                                                                     ;
+;*********************************************************************;
+
+        .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/testsuite/tests/asmcomp/ia64.S b/testsuite/tests/asmcomp/ia64.S
new file mode 100644
index 00000000..5c325942
--- /dev/null
+++ b/testsuite/tests/asmcomp/ia64.S
@@ -0,0 +1,119 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#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 OCaml 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/testsuite/tests/asmcomp/integr.cmm b/testsuite/tests/asmcomp/integr.cmm
new file mode 100644
index 00000000..c82d60b2
--- /dev/null
+++ b/testsuite/tests/asmcomp/integr.cmm
@@ -0,0 +1,31 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(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/testsuite/tests/asmcomp/is_in_static_data.c b/testsuite/tests/asmcomp/is_in_static_data.c
new file mode 100644
index 00000000..ccf0582c
--- /dev/null
+++ b/testsuite/tests/asmcomp/is_in_static_data.c
@@ -0,0 +1,5 @@
+#include "caml/address_class.h"
+
+value caml_is_in_static_data(value v) {
+  return(Val_bool(Is_in_static_data(v)));
+}
diff --git a/testsuite/tests/asmcomp/is_static.ml b/testsuite/tests/asmcomp/is_static.ml
new file mode 100644
index 00000000..bedc033d
--- /dev/null
+++ b/testsuite/tests/asmcomp/is_static.ml
@@ -0,0 +1,34 @@
+(* Data that should be statically allocated by the compiler (all versions) *)
+
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+(* Basic constant blocks should be static *)
+let block1 = (1,2)
+let () = assert(is_in_static_data block1)
+
+(* as pattern shouldn't prevent it *)
+let (a, b) as block2 = (1,2)
+let () = assert(is_in_static_data block2)
+
+(* Also in functions *)
+let f () =
+  let block = (1,2) in
+  assert(is_in_static_data block)
+
+let () = (f [@inlined never]) ()
+
+(* Closed functions should be static *)
+let closed_function x = x + 1 (* + is a primitive, it cannot be in the closure*)
+let () = assert(is_in_static_data closed_function)
+
+(* And functions using closed functions *)
+let almost_closed_function x =
+  (closed_function [@inlined never]) x
+let () = assert(is_in_static_data almost_closed_function)
+
+(* Recursive constant functions should be static *)
+let rec f1 a = g1 a
+and g1 a = f1 a
+let () =
+  assert(is_in_static_data f1);
+  assert(is_in_static_data g1)
diff --git a/testsuite/tests/asmcomp/is_static_flambda.ml b/testsuite/tests/asmcomp/is_static_flambda.ml
new file mode 100644
index 00000000..d4cf2756
--- /dev/null
+++ b/testsuite/tests/asmcomp/is_static_flambda.ml
@@ -0,0 +1,115 @@
+(* Data that should be statically allocated by the compiler (flambda only) *)
+
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+(* Also after inlining *)
+let g x =
+  let block = (1,x) in
+  assert(is_in_static_data block)
+
+let () = (g [@inlined always]) 2
+
+(* Toplevel immutable blocks should be static *)
+let block3 = (Sys.opaque_identity 1, Sys.opaque_identity 2)
+let () = assert(is_in_static_data block3)
+
+(* Not being bound shouldn't prevent it *)
+let () =
+  assert(is_in_static_data (Sys.opaque_identity 1, Sys.opaque_identity 2))
+
+(* Only with rounds >= 2 currently !
+(* Also after inlining *)
+let h x =
+  let block = (Sys.opaque_identity 1,x) in
+  assert(is_in_static_data block)
+
+let () = (h [@inlined always]) (Sys.opaque_identity 2)
+*)
+
+(* Recursive constant values should be static *)
+let rec a = 1 :: b
+and b = 2 :: a
+let () =
+  assert(is_in_static_data a);
+  assert(is_in_static_data b)
+
+(* And a mix *)
+type e = E : 'a -> e
+
+let rec f1 a = E (g1 a, l1)
+and g1 a = E (f1 a, l2)
+and l1 = E (f1, l2)
+and l2 = E (g1, l1)
+
+let () =
+  assert(is_in_static_data f1);
+  assert(is_in_static_data g1);
+  assert(is_in_static_data l1);
+  assert(is_in_static_data l2)
+
+(* Also in functions *)
+let i () =
+  let rec f1 a = E (g1 a, l1)
+  and g1 a = E (f1 a, l2)
+  and l1 = E (f1, l2)
+  and l2 = E (g1, l1) in
+
+  assert(is_in_static_data f1);
+  assert(is_in_static_data g1);
+  assert(is_in_static_data l1);
+  assert(is_in_static_data l2)
+
+let () = (i [@inlined never]) ()
+
+module type P = module type of Pervasives
+(* Top-level modules should be static *)
+let () = assert(is_in_static_data (module Pervasives:P))
+
+(* Not constant let rec to test extraction to initialize_symbol *)
+let r = ref 0
+let rec a = (incr r; !r) :: b
+and b = (incr r; !r) :: a
+
+let next =
+  let r = ref 0 in
+  fun () -> incr r; !r
+
+let () =
+  assert(is_in_static_data next)
+
+(* Exceptions without arguments should be static *)
+exception No_argument
+let () = assert(is_in_static_data No_argument)
+
+(* And also with constant arguments *)
+exception Some_argument of string
+let () = assert(is_in_static_data (Some_argument "some string"))
+
+(* Even when exposed by inlining *)
+let () =
+  let exn =
+    try (failwith [@inlined always]) "some other string" with exn -> exn
+  in
+  assert(is_in_static_data exn)
+
+(* Verify that approximation intersection correctly loads exported
+   approximations.
+
+   Is_static_flambda_dep.pair is a pair with 1 as first element. The
+   intersection of approximations should return a block with
+   approximation: [tag 0: [tag 0: Int 1, Unknown], Unknown] *)
+let f x =
+  let pair =
+    if Sys.opaque_identity x then
+      (1, 2), 3
+    else
+      Is_static_flambda_dep.pair, 4
+  in
+  let n = fst (fst pair) in
+  let res = n, n in
+  assert(is_in_static_data res)
+  [@@inline never]
+
+let () =
+  f true;
+  f false
diff --git a/testsuite/tests/asmcomp/is_static_flambda_dep.ml b/testsuite/tests/asmcomp/is_static_flambda_dep.ml
new file mode 100644
index 00000000..3a50f7ca
--- /dev/null
+++ b/testsuite/tests/asmcomp/is_static_flambda_dep.ml
@@ -0,0 +1 @@
+let pair = 1, 12
diff --git a/testsuite/tests/asmcomp/lexcmm.mli b/testsuite/tests/asmcomp/lexcmm.mli
new file mode 100644
index 00000000..f9fe6afa
--- /dev/null
+++ b/testsuite/tests/asmcomp/lexcmm.mli
@@ -0,0 +1,10 @@
+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/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll
new file mode 100644
index 00000000..a946f6aa
--- /dev/null
+++ b/testsuite/tests/asmcomp/lexcmm.mll
@@ -0,0 +1,241 @@
+{
+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;
+    "data", DATA;
+    "exit", EXIT;
+    "extcall", EXTCALL;
+    "float", FLOAT;
+    "float32", FLOAT32;
+    "float64", FLOAT64;
+    "floatofint", FLOATOFINT;
+    "function", FUNCTION;
+    "global", GLOBAL;
+    "half", HALF;
+    "if", IF;
+    "int", INT;
+    "int32", INT32;
+    "intoffloat", INTOFFLOAT;
+    "string", KSTRING;
+    "let", LET;
+    "load", LOAD;
+    "mod", MODI;
+    "mulh", MULH;
+    "or", OR;
+    "proj", PROJ;
+    "raise_withtrace", RAISE Cmm.Raise_withtrace;
+    "raise_notrace", RAISE Cmm.Raise_notrace;
+    "seq", SEQ;
+    "signed", SIGNED;
+    "skip", SKIP;
+    "store", STORE;
+    "switch", SWITCH;
+    "try", TRY;
+    "unit", UNIT;
+    "unsigned", UNSIGNED;
+    "val", VAL;
+    "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 = Bytes.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 >= Bytes.length (!string_buff) then begin
+    let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in
+    Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff));
+    string_buff := new_buff
+  end;
+  Bytes.unsafe_set (!string_buff) (!string_index) c;
+  incr string_index
+
+let get_stored_string () =
+  let s = Bytes.sub_string (!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"
+
+}
+
+let newline = ('\013'* '\010')
+
+rule token = parse
+    newline
+      { Lexing.new_line lexbuf; token lexbuf }
+  | [' ' '\009' '\012'] +
+      { token lexbuf }
+  | "+a" { ADDA }
+  | "+v" { ADDV }
+  | "+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 }
+  | "*" { STAR }
+  | "!=a" { NEA }
+  | "!=f" { NEF }
+  | "!=" { NEI }
+  | "]" { RBRACKET }
+  | ")" { RPAREN }
+  | "-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' ]) * '/'? (['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 }
+  | '{' ['A' - 'Z' 'a'-'z' '/' ',' '.' '-' '_' ' ''0'-'9']+
+        ':' [ '0'-'9' ]+ ',' ['0'-'9' ]+ '-' ['0'-'9' ]+ '}'
+      {
+        let loc_s = Lexing.lexeme lexbuf in
+        let pos_fname, pos_lnum, start, end_ =
+          Scanf.sscanf loc_s "{%s@:%i,%i-%i}" (fun file line start end_ ->
+              (file, line, start, end_))
+        in
+        let loc_start =
+          Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = start }
+        in
+        let loc_end =
+          Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = end_ }
+        in
+        let location = Location.{ loc_start; loc_end; loc_ghost = false } in
+        LOCATION location }
+  | _ { 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)) }
+  | newline
+      { Lexing.new_line lexbuf; comment lexbuf }
+  | _
+      { 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/testsuite/tests/asmcomp/m68k.S b/testsuite/tests/asmcomp/m68k.S
new file mode 100644
index 00000000..4d0f6a3a
--- /dev/null
+++ b/testsuite/tests/asmcomp/m68k.S
@@ -0,0 +1,57 @@
+|***********************************************************************
+|*                                                                     *
+|*                                OCaml                                *
+|*                                                                     *
+|*            Xavier Leroy, projet Cristal, INRIA 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.               *
+|*                                                                     *
+|***********************************************************************
+
+| 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/testsuite/tests/asmcomp/main.c b/testsuite/tests/asmcomp/main.c
new file mode 100644
index 00000000..5f305731
--- /dev/null
+++ b/testsuite/tests/asmcomp/main.c
@@ -0,0 +1,125 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+
+void caml_ml_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 long FUN(void);
+    extern long call_gen_code(long (*)(void));
+    printf("%ld\n", call_gen_code(FUN));
+  }
+#else
+  if (argc < 2) {
+    fprintf(stderr, "Usage: %s [int arg]\n", argv[0]);
+    exit(2);
+  }
+#ifdef INT_INT
+  { extern long FUN(long);
+    extern long call_gen_code(long (*)(long), long);
+    printf("%ld\n", call_gen_code(FUN, atoi(argv[1])));
+  }
+#endif
+#ifdef INT_FLOAT
+  { extern double FUN(long);
+    extern double call_gen_code(double (*)(long), long);
+    printf("%f\n", call_gen_code(FUN, atoi(argv[1])));
+  }
+#endif
+#ifdef SORT
+  { extern void FUN(long, long, long *);
+    extern void call_gen_code(void (*)(long, long, long *), long, long, long *);
+    long n;
+    long * a, * b;
+    long i;
+
+    srand(argc >= 3 ? atoi(argv[2]) : time((time_t *) 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(long), checkbound2(long, long);
+    extern void call_gen_code(void *, ...);
+    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/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml
new file mode 100644
index 00000000..284f7fbc
--- /dev/null
+++ b/testsuite/tests/asmcomp/main.ml
@@ -0,0 +1,66 @@
+open Clflags
+let write_asm_file = ref false
+
+let compile_file filename =
+  if !write_asm_file then begin
+    let out_name = Filename.chop_extension filename ^ ".s" in
+    Emitaux.output_channel := open_out out_name
+  end; (* otherwise, stdout *)
+  Clflags.dlcode := false;
+  Compilenv.reset ~source_provenance:(Timings.File filename) "test";
+  Emit.begin_assembly();
+  let ic = open_in filename in
+  let lb = Lexing.from_channel ic in
+  lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with pos_fname = filename };
+  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();
+        if !write_asm_file then close_out !Emitaux.output_channel
+    | Lexcmm.Error msg ->
+        close_in ic; Lexcmm.report_error lb msg
+    | Parsing.Parse_error ->
+        close_in ic;
+        let start_p = Lexing.lexeme_start_p lb in
+        let end_p = Lexing.lexeme_end_p lb in
+        Printf.eprintf "File \"%s\", line %i, characters %i-%i:\n\
+                        Syntax error.\n%!"
+          filename
+          start_p.Lexing.pos_lnum
+          (start_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
+          (end_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
+    | 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 [
+     "-S", Arg.Set write_asm_file,
+       " Output file to filename.s (default is stdout)";
+     "-g", Arg.Set Clflags.debug, "";
+     "-dcmm", Arg.Set dump_cmm, "";
+     "-dcse", Arg.Set dump_cse, "";
+     "-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, "";
+     "-dtimings", Arg.Set print_timings, "";
+    ] compile_file usage
+
+let _ = (*Printexc.catch*) Timings.(time All) main ();
+  if !Clflags.print_timings then Timings.print Format.std_formatter;
+  exit 0
diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c
new file mode 100644
index 00000000..de876bfe
--- /dev/null
+++ b/testsuite/tests/asmcomp/mainarith.c
@@ -0,0 +1,343 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <math.h>
+#include <time.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "../../../byterun/caml/config.h"
+#define FMT ARCH_INTNAT_PRINTF_FORMAT
+
+void caml_ml_array_bound_error(void)
+{
+  fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
+  exit(2);
+}
+
+intnat R[200];
+double D[40];
+intnat X, Y;
+double F, G;
+
+#define INTTEST(arg,res) \
+  { intnat result = (res); \
+    if (arg != result) \
+      printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \
+             "result %"FMT"d, expected %"FMT"d\n",                    \
+             #arg, #res, X, Y, arg, result); \
+  }
+#define INTFLOATTEST(arg,res) \
+  { intnat result = (res); \
+    if (arg != result) \
+      printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\
+             "result %"FMT"d, expected %"FMT"d\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=%"FMT"d and Y=%"FMT"d: "\
+             "result %.15g, expected %.15g\n",                       \
+             #arg, #res, X, Y, arg, result); \
+  }
+
+extern void call_gen_code(void (*)(void));
+extern void testarith(void);
+static intnat mulhs(intnat x, intnat y);
+
+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], ((intnat) ((char *)R + 8)));
+      INTTEST(R[13], ((intnat) ((char *)R + Y)));
+
+      INTTEST(R[14], (X - Y));
+      INTTEST(R[15], (X - 1));
+      INTTEST(R[16], (X - -1));
+
+      INTTEST(R[17], ((intnat) ((uintnat)R - 8)));
+      INTTEST(R[18], ((intnat) ((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], ((uintnat) X >> Y));
+      INTTEST(R[46], ((uintnat) X >> 1));
+      INTTEST(R[47], ((uintnat) 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], (intnat) 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], (intnat)(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));
+
+      INTTEST(R[116], mulhs(X, Y));
+}
+
+/* Multiply-high signed.  Hacker's Delight section 8.2 */
+
+#define HALFSIZE (4 * sizeof(intnat))
+#define HALFMASK (((intnat)1 << HALFSIZE) - 1)
+
+static intnat mulhs(intnat u, intnat v)
+{
+  uintnat u0, v0, w0;
+  intnat u1, v1, w1, w2, t;
+  u0 = u & HALFMASK; u1 = u >> HALFSIZE;
+  v0 = v & HALFMASK; v1 = v >> HALFSIZE;
+  w0 = u0*v0;
+  t = u1*v0 + (w0 >> HALFSIZE);
+  w1 = t & HALFMASK;
+  w2 = t >> HALFSIZE;
+  w1 = u0*v1 + w1;
+  return u1*v1 + w2 + (w1 >> HALFSIZE);
+}
+
+/* A simple linear congruential PRNG */
+
+#ifdef ARCH_SIXTYFOUR
+#define RAND_A 6364136223846793005ULL
+#define RAND_C 1442695040888963407ULL
+#else
+#define RAND_A 214013U
+#define RAND_C 2531011U
+#endif
+
+static intnat rnd(void)
+{
+  static uintnat seed = 0;
+  seed = seed * RAND_A + RAND_C;
+  return (intnat) seed;
+}
+
+/* Test harness */
+
+#define NUM_RANDOM_ITERATIONS 1000000
+
+int main(int argc, char **argv)
+{
+  int i;
+  double weird[4];
+
+  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;
+  }
+  printf("Testing -2...2\n");
+  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"))) {
+    printf("Testing special FP values\n");
+    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();
+      }
+    }
+  }
+  printf("Testing %d random values\n", NUM_RANDOM_ITERATIONS);
+  for (i = 0; i < NUM_RANDOM_ITERATIONS; i++) {
+    X = rnd();
+    Y = rnd();
+    F = X / 1e3;
+    G = Y / 1e3;
+    do_test();
+  }
+  return 0;
+}
diff --git a/testsuite/tests/asmcomp/mips.s b/testsuite/tests/asmcomp/mips.s
new file mode 100644
index 00000000..1549dc0a
--- /dev/null
+++ b/testsuite/tests/asmcomp/mips.s
@@ -0,0 +1,72 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+        .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/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml
new file mode 100644
index 00000000..a4f40407
--- /dev/null
+++ b/testsuite/tests/asmcomp/optargs.ml
@@ -0,0 +1,21 @@
+(* Check the effectiveness of inlining the wrapper which fills in
+   default values for optional arguments.
+
+   Ref: http://caml.inria.fr/mantis/view.php?id=6345
+*)
+
+
+let rec f ?(flag = false) ?(acc = 0) = function
+  | [] -> if flag then acc else acc + 1
+  | hd :: tl -> f ~flag ~acc:(acc + hd) tl
+
+let () =
+  let l = [1;2;3;4;5;6;7;8;9] in
+  let x0 = Gc.allocated_bytes () in
+  let x1 = Gc.allocated_bytes () in
+  for i = 1 to 1000 do
+    ignore (f l)
+  done;
+  let x2 = Gc.allocated_bytes () in
+  assert(x1 -. x0 = x2 -. x1)
+     (* check that we have not allocated anything between x1 and x2 *)
diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly
new file mode 100644
index 00000000..52a6dfad
--- /dev/null
+++ b/testsuite/tests/asmcomp/parsecmm.mly
@@ -0,0 +1,359 @@
+/* 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.make n 0 in
+  let casev = Array.of_list caselist in
+  let actv = Array.make (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, Debuginfo.none)
+
+let access_array base numelt size =
+  match numelt with
+    Cconst_int 0 -> base
+  | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none)
+  | _ -> Cop(Cadda, [base;
+                     Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)],
+                         Debuginfo.none)],
+             Debuginfo.none)
+
+%}
+
+%token ABSF
+%token ADDA
+%token ADDF
+%token ADDI
+%token ADDV
+%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 DATA
+%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 GLOBAL
+%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 <Location.t> LOCATION
+%token LPAREN
+%token LSL
+%token LSR
+%token LTA
+%token LTF
+%token LTI
+%token MODI
+%token MULF
+%token MULH
+%token MULI
+%token NEA
+%token NEF
+%token NEI
+%token OR
+%token <int> POINTER
+%token PROJ
+%token <Cmm.raise_kind> RAISE
+%token RBRACKET
+%token RPAREN
+%token SEQ
+%token SIGNED
+%token SKIP
+%token STAR
+%token STORE
+%token <string> STRING
+%token SUBF
+%token SUBI
+%token SWITCH
+%token TRY
+%token UNIT
+%token UNSIGNED
+%token VAL
+%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 fun_name 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;
+         fun_dbg = debuginfo ()} }
+;
+fun_name:
+    STRING              { $1 }
+  | IDENT               { $1 }
+params:
+    oneparam params     { $1 :: $2 }
+  | /**/                { [] }
+;
+oneparam:
+    IDENT COLON machtype { (bind_ident $1, $3) }
+;
+machtype:
+    UNIT                        { [||] }
+  | componentlist               { Array.of_list(List.rev $1) }
+;
+component:
+    VAL                         { Val }
+  | ADDR                        { Addr }
+  | INT                         { Int }
+  | FLOAT                       { Float }
+;
+componentlist:
+    component                    { [$1] }
+  | componentlist STAR component { $3 :: $1 }
+;
+expr:
+    INTCONST    { Cconst_int $1 }
+  | FLOATCONST  { Cconst_float (float_of_string $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 location expr exprlist machtype RPAREN
+                { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
+  | LPAREN EXTCALL STRING exprlist machtype RPAREN
+               {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())}
+  | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) }
+  | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) }
+  | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) }
+  | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) }
+  | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) }
+  | 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(Recursive, [0, [], Cloop body], Ctuple []) }
+  | LPAREN EXIT IDENT exprlist RPAREN
+    { Cexit(find_label $3, List.rev $4) }
+  | LPAREN CATCH sequence WITH catch_handlers RPAREN
+    { let handlers = $5 in
+      List.iter (fun (_, l, _) -> List.iter unbind_ident l) handlers;
+      Ccatch(Recursive, handlers, $3) }
+  | EXIT        { Cexit(0,[]) }
+  | LPAREN TRY sequence WITH bind_ident sequence RPAREN
+                { unbind_ident $5; Ctrywith($3, $5, $6) }
+  | LPAREN VAL expr expr RPAREN
+      { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
+          debuginfo ()) }
+  | LPAREN ADDRAREF expr expr RPAREN
+      { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
+          Debuginfo.none) }
+  | LPAREN INTAREF expr expr RPAREN
+      { Cop(Cload (Word_int, Mutable), [access_array $3 $4 Arch.size_int],
+          Debuginfo.none) }
+  | LPAREN FLOATAREF expr expr RPAREN
+      { Cop(Cload (Double_u, Mutable), [access_array $3 $4 Arch.size_float],
+          Debuginfo.none) }
+  | LPAREN ADDRASET expr expr expr RPAREN
+      { Cop(Cstore (Word_val, Assignment),
+            [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) }
+  | LPAREN INTASET expr expr expr RPAREN
+      { Cop(Cstore (Word_int, Assignment),
+            [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) }
+  | LPAREN FLOATASET expr expr expr RPAREN
+      { Cop(Cstore (Double_u, Assignment),
+            [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) }
+;
+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_int }
+  | ADDR                        { Word_val }
+  | FLOAT32                     { Single }
+  | FLOAT64                     { Double }
+  | FLOAT                       { Double_u }
+  | VAL                         { Word_val }
+;
+unaryop:
+    LOAD chunk                  { Cload ($2, Mutable) }
+  | FLOATOFINT                  { Cfloatofint }
+  | INTOFFLOAT                  { Cintoffloat }
+  | RAISE                       { Craise $1 }
+  | ABSF                        { Cabsf }
+;
+binaryop:
+    STORE chunk                 { Cstore ($2, Assignment) }
+  | ADDI                        { Caddi }
+  | SUBI                        { Csubi }
+  | STAR                        { 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 }
+  | ADDV                        { Caddv }
+  | 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 }
+  | MULH                        { Cmulhi }
+;
+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 }
+  | LPAREN DATA datalist RPAREN { List.rev $3 }
+;
+datalist:
+    datalist dataitem           { $2 :: $1 }
+  | /**/                        { [] }
+;
+dataitem:
+    STRING COLON                { Cdefine_symbol $1 }
+  | BYTE INTCONST               { Cint8 $2 }
+  | HALF INTCONST               { Cint16 $2 }
+  | INT INTCONST                { Cint(Nativeint.of_int $2) }
+  | FLOAT FLOATCONST            { Cdouble (float_of_string $2) }
+  | ADDR STRING                 { Csymbol_address $2 }
+  | VAL STRING                 { Csymbol_address $2 }
+  | KSTRING STRING              { Cstring $2 }
+  | SKIP INTCONST               { Cskip $2 }
+  | ALIGN INTCONST              { Calign $2 }
+  | GLOBAL STRING               { Cglobal_symbol $2 }
+;
+catch_handlers:
+  | catch_handler
+    { [$1] }
+  | catch_handler AND catch_handlers
+    { $1 :: $3 }
+
+catch_handler:
+  | sequence
+    { 0, [], $1 }
+  | LPAREN IDENT bind_identlist RPAREN sequence
+    { find_label $2, $3, $5 }
+
+bind_identlist:
+    /**/                        { [] }
+  | bind_ident bind_identlist   { $1 :: $2 }
+
+location:
+    /**/                        { None }
+  | LOCATION                    { Some $1 }
diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml
new file mode 100644
index 00000000..db555273
--- /dev/null
+++ b/testsuite/tests/asmcomp/parsecmmaux.ml
@@ -0,0 +1,43 @@
+(* 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 tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t)
+
+let ident_name s =
+  match String.index s '/' with
+  | exception Not_found -> s
+  | n -> String.sub s 0 n
+
+let bind_ident s =
+  let id = Ident.create (ident_name 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 find_label s =
+  try
+    Hashtbl.find tbl_label s
+  with Not_found ->
+    let lbl = Lambda.next_raise_count () in
+    Hashtbl.add tbl_label s lbl;
+    lbl
+
+let report_error = function
+    Unbound s ->
+      prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
+
+let debuginfo ?(loc=Location.symbol_rloc ()) () =
+  Debuginfo.(from_location loc)
diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli
new file mode 100644
index 00000000..f5478579
--- /dev/null
+++ b/testsuite/tests/asmcomp/parsecmmaux.mli
@@ -0,0 +1,16 @@
+(* Auxiliary functions for parsing *)
+
+val bind_ident: string -> Ident.t
+val find_ident: string -> Ident.t
+val unbind_ident: Ident.t -> unit
+
+val find_label: string -> int
+
+val debuginfo: ?loc:Location.t -> unit -> Debuginfo.t
+
+type error =
+    Unbound of string
+
+exception Error of error
+
+val report_error: error -> unit
diff --git a/testsuite/tests/asmcomp/pgcd.cmm b/testsuite/tests/asmcomp/pgcd.cmm
new file mode 100644
index 00000000..e75a149a
--- /dev/null
+++ b/testsuite/tests/asmcomp/pgcd.cmm
@@ -0,0 +1,9 @@
+(function "pgcd_30030" (a:int)
+  (catch (exit pgcd a 30030)
+   with (pgcd n m)
+     (if (> n m)
+         (exit pgcd m n)
+         (if (== n 0)
+             m
+             (let (r (mod m n))
+                     (exit pgcd r n))))))
\ No newline at end of file
diff --git a/testsuite/tests/asmcomp/power.S b/testsuite/tests/asmcomp/power.S
new file mode 100644
index 00000000..d13035a4
--- /dev/null
+++ b/testsuite/tests/asmcomp/power.S
@@ -0,0 +1,197 @@
+/*********************************************************************/
+/*                                                                   */
+/*                               OCaml                               */
+/*                                                                   */
+/*           Xavier Leroy, projet Cristal, INRIA 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.              */
+/*                                                                   */
+/*********************************************************************/
+
+#if defined(MODEL_ppc64) || defined(MODEL_ppc64le)
+#define EITHER(a,b) b
+#else
+#define EITHER(a,b) a
+#endif
+
+#define WORD EITHER(4,8)
+#define lg EITHER(lwz,ld)
+#define lgu EITHER(lwzu,ldu)
+#define stg EITHER(stw,std)
+#define stgu EITHER(stwu,stdu)
+
+#if defined(MODEL_ppc)
+#define RESERVED_STACK 16
+#define LR_SAVE_AREA 4
+#endif
+#if defined(MODEL_ppc64)
+#define RESERVED_STACK 48
+#define LR_SAVE_AREA 16
+#endif
+#if defined(MODEL_ppc64le)
+#define RESERVED_STACK 32
+#define LR_SAVE_AREA 16
+#endif
+
+/* Function definitions */
+
+#if defined(MODEL_ppc)
+#define FUNCTION(name) \
+  .section ".text"; \
+  .globl name; \
+  .type name, @function; \
+  .align 2; \
+  name:
+#endif
+
+#if defined(MODEL_ppc64)
+#define FUNCTION(name) \
+  .section ".opd","aw"; \
+  .align 3; \
+  .globl name; \
+  .type name, @function; \
+  name: .quad .L.name,.TOC.@tocbase; \
+  .text; \
+  .align 2; \
+  .L.name:
+#endif
+
+#if defined(MODEL_ppc64le)
+#define FUNCTION(name) \
+  .section ".text"; \
+  .globl name; \
+  .type name, @function; \
+  .align 2; \
+  name: ; \
+  0: addis 2, 12, (.TOC. - 0b)@ha; \
+  addi 2, 2, (.TOC. - 0b)@l; \
+  .localentry name, . - 0b
+#endif
+
+FUNCTION(call_gen_code)
+    /* Allocate and link stack frame */
+        stgu    1, -(WORD*18 + 8*18 + RESERVED_STACK)(1)
+    /* 18 saved GPRs, 18 saved FPRs */
+    /* Save return address */
+        mflr    0
+        stg     0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1)
+    /* Save all callee-save registers, starting at RESERVED_STACK */
+        addi    11, 1, RESERVED_STACK - WORD
+        stgu    14, WORD(11)
+        stgu    15, WORD(11)
+        stgu    16, WORD(11)
+        stgu    17, WORD(11)
+        stgu    18, WORD(11)
+        stgu    19, WORD(11)
+        stgu    20, WORD(11)
+        stgu    21, WORD(11)
+        stgu    22, WORD(11)
+        stgu    23, WORD(11)
+        stgu    24, WORD(11)
+        stgu    25, WORD(11)
+        stgu    26, WORD(11)
+        stgu    27, WORD(11)
+        stgu    28, WORD(11)
+        stgu    29, WORD(11)
+        stgu    30, WORD(11)
+        stgu    31, WORD(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)
+    /* Get function pointer in CTR */
+#if defined(MODEL_ppc)
+        mtctr   3
+#elif defined(MODEL_ppc64)
+        ld      0, 0(3)
+        mtctr   0
+        ld      2, 8(3)
+#elif defined(MODEL_ppc64le)
+        mtctr   3
+        mr      12, 3
+#else
+#error "wrong MODEL"
+#endif
+    /* Shuffle arguments */
+        mr      3, 4
+        mr      4, 5
+        mr      5, 6
+        mr      6, 7
+    /* Call the function */
+        bctrl
+    /* Restore callee-save registers */
+        addi    11, 1, RESERVED_STACK - WORD
+        lgu     14, WORD(11)
+        lgu     15, WORD(11)
+        lgu     16, WORD(11)
+        lgu     17, WORD(11)
+        lgu     18, WORD(11)
+        lgu     19, WORD(11)
+        lgu     20, WORD(11)
+        lgu     21, WORD(11)
+        lgu     22, WORD(11)
+        lgu     23, WORD(11)
+        lgu     24, WORD(11)
+        lgu     25, WORD(11)
+        lgu     26, WORD(11)
+        lgu     27, WORD(11)
+        lgu     28, WORD(11)
+        lgu     29, WORD(11)
+        lgu     30, WORD(11)
+        lgu     31, WORD(11)
+        lfdu    14, 8(11)
+        lfdu    15, 8(11)
+        lfdu    16, 8(11)
+        lfdu    17, 8(11)
+        lfdu    18, 8(11)
+        lfdu    19, 8(11)
+        lfdu    20, 8(11)
+        lfdu    21, 8(11)
+        lfdu    22, 8(11)
+        lfdu    23, 8(11)
+        lfdu    24, 8(11)
+        lfdu    25, 8(11)
+        lfdu    26, 8(11)
+        lfdu    27, 8(11)
+        lfdu    28, 8(11)
+        lfdu    29, 8(11)
+        lfdu    30, 8(11)
+        lfdu    31, 8(11)
+    /* Reload return address */
+        lg      0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1)
+        mtlr    0
+    /* Return */
+        addi    1, 1, (WORD*18 + 8*18 + RESERVED_STACK)
+        blr
+
+FUNCTION(caml_c_call)
+    /* Jump to C function (address in r28) */
+#if defined(MODEL_ppc)
+        mtctr   28
+#elif defined(MODEL_ppc64)
+        ld      0, 0(28)
+        mtctr   0
+        ld      2, 8(28)
+#elif defined(MODEL_ppc64le)
+        mtctr   28
+        mr      12, 28
+#else
+#error "wrong MODEL"
+#endif
+        bctr
diff --git a/testsuite/tests/asmcomp/quicksort.cmm b/testsuite/tests/asmcomp/quicksort.cmm
new file mode 100644
index 00000000..b0859415
--- /dev/null
+++ b/testsuite/tests/asmcomp/quicksort.cmm
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(function "quicksort" (lo: int hi: int a: val)
+  (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/testsuite/tests/asmcomp/quicksort2.cmm b/testsuite/tests/asmcomp/quicksort2.cmm
new file mode 100644
index 00000000..96c1fc12
--- /dev/null
+++ b/testsuite/tests/asmcomp/quicksort2.cmm
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(function "cmp" (i: int j: int)
+  (- i j))
+
+(function "quick" (lo: int hi: int a: val cmp: val)
+  (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: val)
+  (app "quick" lo hi a "cmp" unit))
diff --git a/testsuite/tests/asmcomp/register_typing.ml b/testsuite/tests/asmcomp/register_typing.ml
new file mode 100644
index 00000000..9d55d29b
--- /dev/null
+++ b/testsuite/tests/asmcomp/register_typing.ml
@@ -0,0 +1,20 @@
+type 'a typ = Int : int typ | Ptr : int list typ
+
+let f (type a) (t : a typ) (p : int list) : a =
+  match t with
+  | Int -> 100
+  | Ptr -> p
+
+let allocate_garbage () =
+  for i = 0 to 100 do
+    ignore (Array.make 200 0.0)
+  done
+
+let g (t : int list typ) x =
+  Gc.minor ();
+  let x = f t ([x; x; x; x; x]) in
+  Gc.minor ();
+  allocate_garbage ();
+  ignore (String.length (String.concat " " (List.map string_of_int x)))
+
+let () = g Ptr 5
diff --git a/testsuite/tests/asmcomp/register_typing_switch.ml b/testsuite/tests/asmcomp/register_typing_switch.ml
new file mode 100644
index 00000000..18c4416d
--- /dev/null
+++ b/testsuite/tests/asmcomp/register_typing_switch.ml
@@ -0,0 +1,21 @@
+type 'a typ = Int : int typ | Ptr : int list typ | Int2 : int typ
+
+let f (type a) (t : a typ) (p : int list) : a =
+  match t with
+  | Int -> 100
+  | Ptr -> p
+  | Int2 -> 200
+
+let allocate_garbage () =
+  for i = 0 to 100 do
+    ignore (Array.make 200 0.0)
+  done
+
+let g (t : int list typ) x =
+  Gc.minor ();
+  let x = f t ([x; x; x; x; x]) in
+  Gc.minor ();
+  allocate_garbage ();
+  ignore (String.length (String.concat " " (List.map string_of_int x)))
+
+let () = g Ptr 5
diff --git a/testsuite/tests/asmcomp/s390x.S b/testsuite/tests/asmcomp/s390x.S
new file mode 100644
index 00000000..d0b4b3c8
--- /dev/null
+++ b/testsuite/tests/asmcomp/s390x.S
@@ -0,0 +1,64 @@
+#define ALIGN 8
+
+#define CALL_GEN_CODE call_gen_code
+#define CAML_C_CALL caml_c_call
+#define CAML_NEGF_MASK caml_negf_mask
+#define CAML_ABSF_MASK caml_absf_mask
+
+        .section ".text"
+
+        .globl  CALL_GEN_CODE
+        .type   CALL_GEN_CODE, @function
+        .align  ALIGN
+CALL_GEN_CODE:
+        /* Stack space */
+        lay     %r15, -144(%r15)
+        /* Save registers */
+        stmg    %r6,%r14, 0(%r15)
+        std     %f8, 72(%r15)
+        std     %f9, 80(%r15)
+        std     %f10, 88(%r15)
+        std     %f11, 96(%r15)
+        std     %f12, 104(%r15)
+        std     %f13, 112(%r15)
+        std     %f14, 120(%r15)
+        std     %f15, 128(%r15)
+        /* Shuffle args */
+        lgr     %r1, %r2
+        lgr     %r2, %r3
+        lgr     %r3, %r4
+        lgr     %r4, %r5
+        /* Function call */
+        basr    %r14, %r1
+        /* Restore registers */
+        lmg    %r6,%r14, 0(%r15)
+        ld     %f8, 72(%r15)
+        ld     %f9, 80(%r15)
+        ld     %f10, 88(%r15)
+        ld     %f11, 96(%r15)
+        ld     %f12, 104(%r15)
+        ld     %f13, 112(%r15)
+        ld     %f14, 120(%r15)
+        ld     %f15, 128(%r15)
+        /* Return */
+        lay     %r15, 144(%r15)
+        br      %r14
+
+        .globl  CAML_C_CALL
+        .type   CAML_C_CALL, @function
+        .align  ALIGN
+CAML_C_CALL:
+        br      %r7
+
+        .section ".rodata"
+
+        .global CAML_NEGF_MASK
+        .align  ALIGN
+CAML_NEGF_MASK:
+        .quad   0x8000000000000000, 0
+        .global  CAML_ABSF_MASK
+        .align  ALIGN
+CAML_ABSF_MASK:
+        .quad   0x7FFFFFFFFFFFFFFF, 0
+
+        .comm   young_limit, 8
diff --git a/testsuite/tests/asmcomp/simple_float_const.ml b/testsuite/tests/asmcomp/simple_float_const.ml
new file mode 100644
index 00000000..1aca414f
--- /dev/null
+++ b/testsuite/tests/asmcomp/simple_float_const.ml
@@ -0,0 +1 @@
+let f = 3.14
diff --git a/testsuite/tests/asmcomp/simple_float_const_opaque.ml b/testsuite/tests/asmcomp/simple_float_const_opaque.ml
new file mode 100644
index 00000000..1aca414f
--- /dev/null
+++ b/testsuite/tests/asmcomp/simple_float_const_opaque.ml
@@ -0,0 +1 @@
+let f = 3.14
diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm
new file mode 100644
index 00000000..c8ffc5d6
--- /dev/null
+++ b/testsuite/tests/asmcomp/soli.cmm
@@ -0,0 +1,110 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+("d1": int 0 int 1
+ "d2": int 1 int 0
+ "d3": int 0 int -1
+ "d4": int -1 int 0
+ "dir": val "d1" val "d2" val "d3" val "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": val "line0" val "line1" val "line2" val "line3"
+          val "line4" val "line5" val "line6" val "line7" val "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_notrace 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/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S
new file mode 100644
index 00000000..5fd797b3
--- /dev/null
+++ b/testsuite/tests/asmcomp/sparc.S
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#if defined(SYS_solaris) || defined(SYS_linux)
+#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/testsuite/tests/asmcomp/static_float_array_flambda.ml b/testsuite/tests/asmcomp/static_float_array_flambda.ml
new file mode 100644
index 00000000..f60e530a
--- /dev/null
+++ b/testsuite/tests/asmcomp/static_float_array_flambda.ml
@@ -0,0 +1,18 @@
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+let a = [|0.; 1.|]
+let f = 1.23
+let b = [|0.; f; f|]
+let g = Sys.opaque_identity 1.23
+let c = [|0.; g|]
+let d = [|0.; Simple_float_const.f|]
+
+let () = assert(is_in_static_data a)
+let () = assert(is_in_static_data f)
+let () = assert(is_in_static_data b)
+
+let () = assert(not (is_in_static_data c))
+(* In fact this one could be static by preallocating the array then
+   patching it when g is available *)
+
+let () = assert(is_in_static_data d)
diff --git a/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml
new file mode 100644
index 00000000..518f48bc
--- /dev/null
+++ b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml
@@ -0,0 +1,21 @@
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+let a = [|0.; 1.|]
+let f = 1.23
+let b = [|0.; f; f|]
+let g = Sys.opaque_identity 1.23
+let c = [|0.; g|]
+let d = [|0.; Simple_float_const_opaque.f|]
+
+let () = assert(is_in_static_data a)
+let () = assert(is_in_static_data f)
+let () = assert(is_in_static_data b)
+
+let () = assert(not (is_in_static_data c))
+(* In fact this one could be static by preallocating the array then
+   patching it when g is available *)
+
+let () = assert(not (is_in_static_data d))
+(* The dependency Simple_float_const_opaque is built with opaque,
+   hence the value of Simple_float_const_opaque.f cannot be known
+   preventing the static allocation of d *)
diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml
new file mode 100644
index 00000000..2e7c9a16
--- /dev/null
+++ b/testsuite/tests/asmcomp/staticalloc.ml
@@ -0,0 +1,19 @@
+(* Check the effectiveness of structured constant propagation and
+   static allocation.
+
+   Ref: http://caml.inria.fr/mantis/view.php?id=5779
+*)
+
+let () =
+  let x0 = Gc.allocated_bytes () in
+  let x1 = Gc.allocated_bytes () in
+  let pair x y = (x, y) in
+  let a = pair 1 2 in
+  let b = pair a ["x";"y"] in
+  let g () = (a, fst b) in
+  assert (g () == ((1,2), (1,2)));
+  assert (fst (pair a a) == (1, 2));
+  assert (snd b != ["x"; "y"] || Config.safe_string);  (* mutable "constant", cannot be shared *)
+  let x2 = Gc.allocated_bytes () in
+  assert(x1 -. x0 = x2 -. x1)
+     (* check that we did not allocated anything between x1 and x2 *)
diff --git a/testsuite/tests/asmcomp/tagged-fib.cmm b/testsuite/tests/asmcomp/tagged-fib.cmm
new file mode 100644
index 00000000..d83afaa4
--- /dev/null
+++ b/testsuite/tests/asmcomp/tagged-fib.cmm
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(function "fib" (n: int)
+  (if (< n 5)
+      3
+    (-  (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1)))
diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm
new file mode 100644
index 00000000..b89bd508
--- /dev/null
+++ b/testsuite/tests/asmcomp/tagged-integr.cmm
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+("res_square": skip 8)
+("h": skip 8)
+("x": skip 8)
+("s": skip 8)
+("res_integr": skip 8)
+
+(function "square" (x: val)
+   (let r "res_square"
+        (store float r ( *f (load float x) (load float x)))
+        r))
+
+(function "integr" (f: val low: val high: val 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 val))))
+      (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 val)))
diff --git a/testsuite/tests/asmcomp/tagged-quicksort.cmm b/testsuite/tests/asmcomp/tagged-quicksort.cmm
new file mode 100644
index 00000000..59293aa2
--- /dev/null
+++ b/testsuite/tests/asmcomp/tagged-quicksort.cmm
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(function "quick" (lo: int hi: int a: val)
+  (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: val)
+   (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit))
diff --git a/testsuite/tests/asmcomp/tagged-tak.cmm b/testsuite/tests/asmcomp/tagged-tak.cmm
new file mode 100644
index 00000000..30c98a00
--- /dev/null
+++ b/testsuite/tests/asmcomp/tagged-tak.cmm
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(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/testsuite/tests/asmcomp/tak.cmm b/testsuite/tests/asmcomp/tak.cmm
new file mode 100644
index 00000000..2750fff3
--- /dev/null
+++ b/testsuite/tests/asmcomp/tak.cmm
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(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/testsuite/tests/asmcomp/unrolling_flambda.ml b/testsuite/tests/asmcomp/unrolling_flambda.ml
new file mode 100644
index 00000000..59dfa2a9
--- /dev/null
+++ b/testsuite/tests/asmcomp/unrolling_flambda.ml
@@ -0,0 +1,7 @@
+
+let rec f x =
+  if x > 0 then f (x - 1)
+  else 0
+[@@inline]
+
+let _ = f 0
diff --git a/testsuite/tests/asmcomp/unrolling_flambda2.ml b/testsuite/tests/asmcomp/unrolling_flambda2.ml
new file mode 100644
index 00000000..cccda47d
--- /dev/null
+++ b/testsuite/tests/asmcomp/unrolling_flambda2.ml
@@ -0,0 +1,20 @@
+
+type t = { fn : t -> t -> int -> unit -> unit }
+
+let rec foo f b n x =
+  if n < 0 then ()
+  else begin
+    foo f b (n - 1) x;
+    b.fn f b (n - 1) x
+  end
+[@@specialise always]
+
+let rec bar f b n x =
+  if n < 0 then ()
+  else begin
+    bar f b (n - 1) x;
+    f.fn f b (n - 1) x
+  end
+[@@specialise always]
+
+let () = foo {fn = foo} {fn = bar} 10 ()
diff --git a/testsuite/tests/ast-invariants/Makefile b/testsuite/tests/ast-invariants/Makefile
new file mode 100644
index 00000000..ecea4d4e
--- /dev/null
+++ b/testsuite/tests/ast-invariants/Makefile
@@ -0,0 +1,27 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                  Jeremie Dimino, Jane Street Europe                   #
+#                                                                       #
+#   Copyright 2015 Jane Street Group LLC                                #
+#                                                                       #
+#   All rights reserved.  This file is distributed under the terms of   #
+#   the GNU Lesser General Public License version 2.1, with the         #
+#   special exception on linking described in the file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
+          -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LIBRARIES=../../../compilerlibs/ocamlcommon unix
+MODULES=
+MAIN_MODULE=test
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+# This test is a bit slow and there is little value in testing both
+# versions so we run only the native code one:
+NATIVECODE_ONLY=true
diff --git a/testsuite/tests/ast-invariants/test.ml b/testsuite/tests/ast-invariants/test.ml
new file mode 100644
index 00000000..21e5e8c4
--- /dev/null
+++ b/testsuite/tests/ast-invariants/test.ml
@@ -0,0 +1,71 @@
+(* This test checks all ml files in the ocaml repository that are accepted
+   by the parser satisfy [Ast_invariants].
+
+   We don't check the invariants on the output of the parser, so this test
+   is to ensure that the parser doesn't accept more than [Ast_invariants].
+*)
+
+let root = "../../.."
+let () = assert (Sys.file_exists (Filename.concat root "VERSION"))
+
+type _ kind =
+  | Implem : Parsetree.structure kind
+  | Interf : Parsetree.signature kind
+
+let parse : type a. a kind -> Lexing.lexbuf -> a = function
+  | Implem -> Parse.implementation
+  | Interf -> Parse.interface
+
+let invariants : type a. a kind -> a -> unit = function
+  | Implem -> Ast_invariants.structure
+  | Interf -> Ast_invariants.signature
+
+let check_file kind fn =
+  Warnings.parse_options false "-a";
+  let ic = open_in fn in
+  Location.input_name := fn;
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf fn;
+  match parse kind lexbuf with
+  | exception _ ->
+    (* A few files don't parse as they are meant for the toplevel;
+       ignore them *)
+    close_in ic
+  | ast ->
+    close_in ic;
+    try
+      invariants kind ast
+    with exn ->
+      Location.report_exception Format.std_formatter exn
+
+type file_kind =
+  | Regular_file
+  | Directory
+  | Other
+
+let kind fn =
+  match Unix.lstat fn with
+  | exception _ -> Other
+  | { Unix.st_kind = Unix.S_DIR } -> Directory
+  | { Unix.st_kind = Unix.S_REG } -> Regular_file
+  | { Unix.st_kind = _          } -> Other
+
+let rec walk dir =
+  Array.iter
+    (fun fn ->
+       if fn = "" || fn.[0] = '.' then
+         ()
+       else begin
+         let fn = Filename.concat dir fn in
+         match kind fn with
+         | Other -> ()
+         | Directory -> walk fn
+         | Regular_file ->
+           if Filename.check_suffix fn ".mli" then
+             check_file Interf fn
+           else if Filename.check_suffix fn ".ml" then
+             check_file Implem fn
+       end)
+    (Sys.readdir dir)
+
+let () = walk root
diff --git a/testsuite/tests/ast-invariants/test.reference b/testsuite/tests/ast-invariants/test.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile
new file mode 100644
index 00000000..5df19fc6
--- /dev/null
+++ b/testsuite/tests/backtrace/Makefile
@@ -0,0 +1,155 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+EXECNAME=program$(EXE)
+
+ABCDFILES=backtrace.ml
+OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \
+           backtrace_deprecated.ml backtrace_slots.ml
+INLININGFILES=inline_test.ml inline_traversal_test.ml
+OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml
+OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml
+
+# Keep only filenames, lines and character ranges
+LOCATIONFILTER=grep -oE \
+               '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+'
+
+default:
+	@$(MAKE) byte
+	@if $(BYTECODE_ONLY); then $(MAKE) skip ; else $(MAKE) native; fi
+
+.PHONY: byte
+byte:
+	@for file in $(ABCDFILES); do \
+	  rm -f program program.exe; \
+	  $(OCAMLC) -g -o $(EXECNAME) $$file; \
+	  for arg in a b c d ''; do \
+	    printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \
+	    F="`basename $$file .ml`"; \
+	    (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+              $(OCAMLRUN) $(EXECNAME) $$arg || true) \
+	         >$$F.$$arg.byte.result 2>&1; \
+	    $(DIFF) $$F.$$arg.byte.reference $$F.$$arg.byte.result >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  done; \
+	done
+	@for file in $(OTHERFILES) $(OTHERFILESNOINLINING); do \
+	  rm -f program program.exe; \
+	  $(OCAMLC) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlc:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+            $(OCAMLRUN) $(EXECNAME) $$arg || true) \
+	       >$$F.byte.result 2>&1; \
+	  $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@for file in $(INLININGFILES); \
+	do \
+	  rm -f program program.exe; \
+	  $(OCAMLC) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlc:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+	  $(OCAMLRUN) $(EXECNAME) $$arg 2>&1 || true) \
+			| $(LOCATIONFILTER) >$$F.byte.result 2>&1; \
+	  $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+.PHONY: skip
+skip:
+	@for file in $(ABCDFILES); do \
+	  for arg in a b c d ''; do \
+	    echo " ... testing '$$file' with ocamlopt and argument '$$arg': \
+	=> skipped"; \
+	  done; \
+	done
+	@for file in $(OTHERFILES) $(OTHERFILESNOINLINING) \
+	             $(OTHERFILESNOINLINING_NATIVE) $(INLININGFILES); do \
+	  echo " ... testing '$$file' with ocamlopt: => skipped"; \
+	done
+
+.PHONY: native
+native:
+	@for file in $(ABCDFILES); do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+	  for arg in a b c d ''; do \
+	    printf " ... testing '$$file' with ocamlopt and argument '$$arg':";\
+	    F="`basename $$file .ml`"; \
+	    (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+              ./$(EXECNAME) $$arg || true) \
+	         >$$F.$$arg.native.result 2>&1; \
+	    $(DIFF) $$F.$$arg.native.reference $$F.$$arg.native.result \
+	            >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  done; \
+	done
+	@for file in $(OTHERFILES); do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+            ./$(EXECNAME) $$arg || true) \
+	       >$$F.native.result 2>&1; \
+	  $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@for file in $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); \
+	do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+            ./$(EXECNAME) $$arg || true) \
+	       >$$F.native.result 2>&1; \
+	  $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@for file in $(INLININGFILES); \
+	do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+	  ./$(EXECNAME) $$arg 2>&1 || true) \
+		 	| $(LOCATIONFILTER) >$$F.native.result; \
+	  $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) -O3 $$file; \
+	  printf " ... testing '$$file' with ocamlopt -O3:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+	  ./$(EXECNAME) $$arg 2>&1 || true) \
+		 	| $(LOCATIONFILTER) >$$F.O3.result; \
+	  $(DIFF) $$F.native.reference $$F.O3.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result program program.exe
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/backtrace/backtrace..byte.reference b/testsuite/tests/backtrace/backtrace..byte.reference
new file mode 100644
index 00000000..d2d69337
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace..byte.reference
@@ -0,0 +1,2 @@
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
diff --git a/testsuite/tests/backtrace/backtrace..native.reference b/testsuite/tests/backtrace/backtrace..native.reference
new file mode 100644
index 00000000..d2d69337
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace..native.reference
@@ -0,0 +1,2 @@
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
diff --git a/testsuite/tests/backtrace/backtrace.a.byte.reference b/testsuite/tests/backtrace/backtrace.a.byte.reference
new file mode 100644
index 00000000..78981922
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.a.byte.reference
@@ -0,0 +1 @@
+a
diff --git a/testsuite/tests/backtrace/backtrace.a.native.reference b/testsuite/tests/backtrace/backtrace.a.native.reference
new file mode 100644
index 00000000..78981922
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.a.native.reference
@@ -0,0 +1 @@
+a
diff --git a/testsuite/tests/backtrace/backtrace.b.byte.reference b/testsuite/tests/backtrace/backtrace.b.byte.reference
new file mode 100644
index 00000000..47375896
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.b.byte.reference
@@ -0,0 +1,11 @@
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 7, characters 21-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Re-raised at file "backtrace.ml", line 13, characters 68-71
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.b.native.reference b/testsuite/tests/backtrace/backtrace.b.native.reference
new file mode 100644
index 00000000..f1e8da87
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.b.native.reference
@@ -0,0 +1,11 @@
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 7, characters 16-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Re-raised at file "backtrace.ml", line 13, characters 62-71
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.c.byte.reference b/testsuite/tests/backtrace/backtrace.c.byte.reference
new file mode 100644
index 00000000..33cac474
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.c.byte.reference
@@ -0,0 +1,3 @@
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 14, characters 26-37
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.c.native.reference b/testsuite/tests/backtrace/backtrace.c.native.reference
new file mode 100644
index 00000000..431cd546
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.c.native.reference
@@ -0,0 +1,3 @@
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 14, characters 20-37
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.d.byte.reference b/testsuite/tests/backtrace/backtrace.d.byte.reference
new file mode 100644
index 00000000..9ba46824
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.d.byte.reference
@@ -0,0 +1,9 @@
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 7, characters 21-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.d.native.reference b/testsuite/tests/backtrace/backtrace.d.native.reference
new file mode 100644
index 00000000..d074040c
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.d.native.reference
@@ -0,0 +1,9 @@
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 7, characters 16-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.ml b/testsuite/tests/backtrace/backtrace.ml
new file mode 100644
index 00000000..ca4423e9
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.ml
@@ -0,0 +1,18 @@
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+  try
+    f msg 5
+  with Error "a" -> print_string "a"; print_newline(); 0
+     | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+     | Error "c" -> raise (Error "c")
+
+let _ =
+  Printexc.record_backtrace true;
+  ignore (g Sys.argv.(1))
diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference
new file mode 100644
index 00000000..aef38381
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.byte.reference
@@ -0,0 +1,58 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 8, characters 23-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Re-raised at file "backtrace2.ml", line 15, characters 68-71
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 16, characters 26-37
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 8, characters 23-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 22, characters 56-59
+Called from file "backtrace2.ml", line 58, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 28, characters 68-71
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 19-28
+Called from file "backtrace2.ml", line 39, characters 9-42
+Re-raised at file "backtrace2.ml", line 39, characters 67-70
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 43, characters 24-33
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 19-28
+Called from file "backtrace2.ml", line 46, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 62-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
+Called from file "backtrace2.ml", line 58, characters 11-23
diff --git a/testsuite/tests/backtrace/backtrace2.ml b/testsuite/tests/backtrace/backtrace2.ml
new file mode 100644
index 00000000..07cf5ccc
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.ml
@@ -0,0 +1,75 @@
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let test_Error msg =
+  let rec f msg n =
+    if n = 0 then raise(Error msg) else 1 + f msg (n-1) in
+  let exception_raised_internally () =
+    try Hashtbl.find (Hashtbl.create 3) 0
+    with Not_found -> false in
+  try
+    f msg 5
+  with Error "a" -> print_string "a"; print_newline(); 0
+     | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+     | Error "c" -> raise (Error "c")
+     (** [Error "d"] not caught *)
+     (** Test reraise when an exception is used in the middle of the exception
+         handler. Currently the wrong backtrace is used. *)
+     | Error "e" as exn ->
+         print_string "e"; print_newline ();
+         ignore (exception_raised_internally ()); raise exn
+     (** Test reraise of backtrace when a `when` clause use exceptions.
+         Currently the wrong backtrace is used.
+     *)
+     | Error "f" when exception_raised_internally () ->
+         assert false (** absurd: when false *)
+     | Error "f" as exn -> print_string "f"; print_newline(); raise exn
+
+let test_Not_found () =
+  let rec aux n =
+    if n = 0 then raise Not_found else 1 + aux (n-1)
+  in
+  try aux 5
+  (** Test the raise to reraise heuristic with included try_with.
+      Currently the wrong backtrace is used. *)
+  with exn ->
+    print_string "test_Not_found"; print_newline();
+    (try Hashtbl.find (Hashtbl.create 3) 0 with Not_found -> raise exn)
+
+let test_lazy =
+  let rec aux n =
+    if n = 0 then raise Not_found else 1 + aux (n-1)
+  in
+  let exception_raised_internally () =
+    try Hashtbl.find (Hashtbl.create 3) 0
+    with Not_found -> () in
+  let l = lazy (aux 5) in
+  (** Test the backtrace obtained from a lazy value.
+      Currently the second time the value is forced the
+      wrong backtrace is used. *)
+  fun () ->
+    exception_raised_internally ();
+    Lazy.force l
+
+let run g args =
+  try
+    ignore (g args.(0)); print_string "No exception\n"
+  with exn ->
+    Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn);
+    Printexc.print_backtrace stdout
+
+let _ =
+  Printexc.record_backtrace true;
+  run test_Error [| "a" |];
+  run test_Error [| "b" |];
+  run test_Error [| "c" |];
+  run test_Error [| "d" |];
+  run test_Error [| "e" |];
+  run test_Error [| "f" |];
+  run test_Error [| |];
+  run test_Not_found  [| () |];
+  run test_lazy  [| () |];
+  run test_lazy  [| () |];
+  ()
diff --git a/testsuite/tests/backtrace/backtrace2.native.reference b/testsuite/tests/backtrace/backtrace2.native.reference
new file mode 100644
index 00000000..978bc937
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.native.reference
@@ -0,0 +1,58 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 8, characters 18-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Re-raised at file "backtrace2.ml", line 15, characters 62-71
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 16, characters 20-37
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 8, characters 18-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 22, characters 50-59
+Called from file "backtrace2.ml", line 58, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 28, characters 62-71
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 13-28
+Called from file "backtrace2.ml", line 39, characters 9-42
+Re-raised at file "backtrace2.ml", line 39, characters 61-70
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 43, characters 18-33
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 13-28
+Called from file "backtrace2.ml", line 46, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 56-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
diff --git a/testsuite/tests/backtrace/backtrace3.byte.reference b/testsuite/tests/backtrace/backtrace3.byte.reference
new file mode 100644
index 00000000..5081640a
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 47-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 12-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace3.ml b/testsuite/tests/backtrace/backtrace3.ml
new file mode 100644
index 00000000..7e51aa68
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.ml
@@ -0,0 +1,39 @@
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+  match
+    f msg 5
+  with
+  | _ ->
+     (* value return does not happen *)
+     assert false
+  | exception (Error "a") ->
+      print_string "a"; print_newline(); 0
+  | exception (Error "b" as exn) ->
+      (* this should Re-raise, appending to the current backtrace *)
+      print_string "b"; print_newline(); raise exn
+  | exception (Error "c") ->
+      (* according to the current re-raise policy (a static condition),
+         this does not re-raise *)
+      raise (Error "c")
+
+let run args =
+  try
+    ignore (g args.(0)); print_string "No exception\n"
+  with exn ->
+    Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn);
+    Printexc.print_backtrace stdout
+
+let _ =
+  Printexc.record_backtrace true;
+  run [| "a" |];
+  run [| "b" |];
+  run [| "c" |];
+  run [| "d" |];
+  run [| |]
diff --git a/testsuite/tests/backtrace/backtrace3.native.reference b/testsuite/tests/backtrace/backtrace3.native.reference
new file mode 100644
index 00000000..c38a51e7
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 16-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 41-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 6-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 16-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_deprecated.byte.reference b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference
new file mode 100644
index 00000000..e3eee3d6
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 17, characters 26-37
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_deprecated.ml b/testsuite/tests/backtrace/backtrace_deprecated.ml
new file mode 100644
index 00000000..945d7730
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.ml
@@ -0,0 +1,39 @@
+
+(* A test for stack backtraces *)
+
+external get_backtrace : unit -> Printexc.backtrace_slot array option
+  = "caml_get_exception_backtrace"
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+  try
+    f msg 5
+  with Error "a" -> print_string "a"; print_newline(); 0
+     | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+     | Error "c" -> raise (Error "c")
+
+let run args =
+  try
+    ignore (g args.(0)); print_string "No exception\n"
+  with exn ->
+    Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn);
+    get_backtrace () |> function
+    | None -> ()
+    | Some trace ->
+      Array.iteri
+        (fun i slot -> match Printexc.Slot.format i slot with
+          | None -> ()
+          | Some line -> print_endline line)
+        trace
+
+let _ =
+  Printexc.record_backtrace true;
+  run [| "a" |];
+  run [| "b" |];
+  run [| "c" |];
+  run [| "d" |];
+  run [| |]
diff --git a/testsuite/tests/backtrace/backtrace_deprecated.native.reference b/testsuite/tests/backtrace/backtrace_deprecated.native.reference
new file mode 100644
index 00000000..8d6826ec
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 16, characters 62-71
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 17, characters 20-37
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_slots.byte.reference b/testsuite/tests/backtrace/backtrace_slots.byte.reference
new file mode 100644
index 00000000..bfd8f5f4
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 36, characters 21-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 42, characters 68-71
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 43, characters 26-37
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 36, characters 21-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_slots.ml b/testsuite/tests/backtrace/backtrace_slots.ml
new file mode 100644
index 00000000..877f8a5a
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.ml
@@ -0,0 +1,61 @@
+
+(* A test for stack backtraces *)
+
+let get_backtrace () =
+  let raw_backtrace = Printexc.get_raw_backtrace () in
+  let raw_slots =
+    Array.init (Printexc.raw_backtrace_length raw_backtrace)
+               (Printexc.get_raw_backtrace_slot raw_backtrace) in
+  let convert = Printexc.convert_raw_backtrace_slot in
+  let backtrace = Array.map convert raw_slots in
+  (* we'll play with raw slots a bit to check that hashing and comparison work:
+     - create a hashtable that maps slots to their index in the raw backtrace
+     - create a balanced set of all slots
+  *)
+  let table = Hashtbl.create 100 in
+  Array.iteri (fun i slot -> Hashtbl.add table slot i) raw_slots;
+  let module S = Set.Make(struct
+    type t = Printexc.raw_backtrace_slot
+    let compare = Pervasives.compare
+  end) in
+  let slots = Array.fold_right S.add raw_slots S.empty in
+  Array.iteri (fun i slot ->
+    assert (S.mem slot slots);
+    assert (Hashtbl.mem table slot);
+    let j =
+      (* position in the table of the last slot equal to [slot] *)
+      Hashtbl.find table slot in
+    assert (slot = raw_slots.(j));
+    assert (backtrace.(i) = backtrace.(j));
+  ) raw_slots;
+  backtrace
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+  try
+    f msg 5
+  with Error "a" -> print_string "a"; print_newline(); 0
+     | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+     | Error "c" -> raise (Error "c")
+
+let run args =
+  try
+    ignore (g args.(0)); print_string "No exception\n"
+  with exn ->
+    Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn);
+    get_backtrace () |> Array.iteri
+        (fun i slot -> match Printexc.Slot.format i slot with
+          | None -> ()
+          | Some line -> print_endline line)
+
+let _ =
+  Printexc.record_backtrace true;
+  run [| "a" |];
+  run [| "b" |];
+  run [| "c" |];
+  run [| "d" |];
+  run [| |]
diff --git a/testsuite/tests/backtrace/backtrace_slots.native.reference b/testsuite/tests/backtrace/backtrace_slots.native.reference
new file mode 100644
index 00000000..dd47e69d
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 36, characters 16-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 42, characters 62-71
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 43, characters 20-37
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 36, characters 16-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.ml b/testsuite/tests/backtrace/backtraces_and_finalizers.ml
new file mode 100644
index 00000000..9edf7afb
--- /dev/null
+++ b/testsuite/tests/backtrace/backtraces_and_finalizers.ml
@@ -0,0 +1,26 @@
+
+let () = Printexc.record_backtrace true
+
+let finaliser _ = try raise Exit with _ -> ()
+
+let create () =
+  let x = ref () in
+  Gc.finalise finaliser x;
+  x
+
+let f () = raise Exit
+
+let () =
+  let minor_size = (Gc.get ()).Gc.minor_heap_size in
+  for i = 1 to 100 do
+    Gc.minor ();
+    try
+      ignore (create () : unit ref);
+      f ()
+    with _ ->
+      for i = 1 to minor_size / 2 - 1 do
+        ignore (ref ())
+      done;
+      ignore (Printexc.get_backtrace () : string)
+  done;
+  Printf.printf "ok\n"
diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
new file mode 100644
index 00000000..9766475a
--- /dev/null
+++ b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
@@ -0,0 +1 @@
+ok
diff --git a/testsuite/tests/backtrace/inline_test.byte.reference b/testsuite/tests/backtrace/inline_test.byte.reference
new file mode 100644
index 00000000..0cda2efd
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.byte.reference
@@ -0,0 +1,15 @@
+inline_test.ml
+line 5
+characters 8-24
+inline_test.ml
+line 8
+characters 2-5
+inline_test.ml
+line 11
+characters 12-17
+inline_test.ml
+line 14
+characters 5-8
+inline_test.ml
+line 18
+characters 2-6
diff --git a/testsuite/tests/backtrace/inline_test.ml b/testsuite/tests/backtrace/inline_test.ml
new file mode 100644
index 00000000..ae64e2cd
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.ml
@@ -0,0 +1,18 @@
+
+(* A test for inlined stack backtraces *)
+
+let f x =
+  raise (Failure "test") + 1
+
+let g x =
+  f x + 1
+
+let h x =
+  print_int (g x); print_endline "h"
+
+let i x =
+  if h x = () then ()
+
+let () =
+  Printexc.record_backtrace true;
+  i ()
diff --git a/testsuite/tests/backtrace/inline_test.native.reference b/testsuite/tests/backtrace/inline_test.native.reference
new file mode 100644
index 00000000..644987b9
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.native.reference
@@ -0,0 +1,15 @@
+inline_test.ml
+line 5
+characters 2-24
+inline_test.ml
+line 8
+characters 2-5
+inline_test.ml
+line 11
+characters 12-17
+inline_test.ml
+line 14
+characters 5-8
+inline_test.ml
+line 18
+characters 2-6
diff --git a/testsuite/tests/backtrace/inline_traversal_test.byte.reference b/testsuite/tests/backtrace/inline_traversal_test.byte.reference
new file mode 100644
index 00000000..bcb98c34
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.byte.reference
@@ -0,0 +1,5 @@
+inline_traversal_test.ml:5
+inline_traversal_test.ml:8
+inline_traversal_test.ml:11
+inline_traversal_test.ml:14
+inline_traversal_test.ml:19
diff --git a/testsuite/tests/backtrace/inline_traversal_test.ml b/testsuite/tests/backtrace/inline_traversal_test.ml
new file mode 100644
index 00000000..1d918446
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.ml
@@ -0,0 +1,46 @@
+
+(* A test for inlined stack backtraces *)
+
+let f x =
+  raise (Failure "test") + 1
+
+let g x =
+  f x + 1
+
+let h x =
+  print_int (g x); print_endline "h"
+
+let i x =
+  if h x = () then ()
+
+let () =
+  let open Printexc in
+  record_backtrace true;
+  try i ()
+  with _ ->
+    let trace = get_raw_backtrace () in
+    let print_slot slot =
+      let x = convert_raw_backtrace_slot slot in
+      let is_raise = Slot.is_raise x in
+      let is_inline = Slot.is_inline x in
+      let location = match Slot.location x with
+        | None -> "<unknown>"
+        | Some {filename; line_number; _} ->
+            filename ^ ":" ^ string_of_int line_number
+      in
+      Printf.printf "- %s%s%s\n"
+        location
+        (if is_inline then " inlined" else "")
+        (if is_raise then ", raise" else "")
+    in
+    let rec print_slots = function
+      | None -> ()
+      | Some slot ->
+        print_slot slot;
+        print_slots (get_raw_backtrace_next_slot slot)
+    in
+    for i = 0 to raw_backtrace_length trace - 1 do
+      let slot = get_raw_backtrace_slot trace i in
+      Printf.printf "Frame %d\n" i;
+      print_slots (Some slot)
+    done
diff --git a/testsuite/tests/backtrace/inline_traversal_test.native.reference b/testsuite/tests/backtrace/inline_traversal_test.native.reference
new file mode 100644
index 00000000..bcb98c34
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.native.reference
@@ -0,0 +1,5 @@
+inline_traversal_test.ml:5
+inline_traversal_test.ml:8
+inline_traversal_test.ml:11
+inline_traversal_test.ml:14
+inline_traversal_test.ml:19
diff --git a/testsuite/tests/backtrace/pr6920_why_at.byte.reference b/testsuite/tests/backtrace/pr6920_why_at.byte.reference
new file mode 100644
index 00000000..dcc2fcc1
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.byte.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 1, characters 41-45
+Called from file "pr6920_why_at.ml", line 3, characters 2-11
+Called from file "pr6920_why_at.ml", line 9, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_at.ml b/testsuite/tests/backtrace/pr6920_why_at.ml
new file mode 100644
index 00000000..0cd9f73d
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.ml
@@ -0,0 +1,9 @@
+let why : unit -> unit = fun () -> raise Exit [@@inline never]
+let f () =
+  why @@ ();
+  ignore (3 + 2);
+  () [@@inline never]
+
+let () =
+  Printexc.record_backtrace true;
+  f ()
diff --git a/testsuite/tests/backtrace/pr6920_why_at.native.reference b/testsuite/tests/backtrace/pr6920_why_at.native.reference
new file mode 100644
index 00000000..057c3895
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.native.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 1, characters 35-45
+Called from file "pr6920_why_at.ml", line 3, characters 2-11
+Called from file "pr6920_why_at.ml", line 9, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
new file mode 100644
index 00000000..ad66532f
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.ml b/testsuite/tests/backtrace/pr6920_why_swallow.ml
new file mode 100644
index 00000000..def1d485
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.ml
@@ -0,0 +1,11 @@
+let why : unit -> unit = fun () -> raise Exit [@@inline never]
+let f () =
+  for i = 1 to 10 do
+    why @@ ();
+  done;
+  ignore (3 + 2);
+  () [@@inline never]
+
+let () =
+  Printexc.record_backtrace true;
+  f ()
diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
new file mode 100644
index 00000000..facb06dd
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
diff --git a/testsuite/tests/backtrace/raw_backtrace.byte.reference b/testsuite/tests/backtrace/raw_backtrace.byte.reference
new file mode 100644
index 00000000..ba437e33
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.byte.reference
@@ -0,0 +1,49 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 18, characters 68-71
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 19, characters 26-37
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 25, characters 39-42
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 29, characters 39-54
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22
diff --git a/testsuite/tests/backtrace/raw_backtrace.ml b/testsuite/tests/backtrace/raw_backtrace.ml
new file mode 100644
index 00000000..45822751
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.ml
@@ -0,0 +1,59 @@
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+exception Localized of exn
+
+let g msg =
+  let exception_raised_internally () =
+    try Hashtbl.find (Hashtbl.create 3) 0
+    with Not_found -> false in
+  try
+    f msg 5
+  with Error "a" -> print_string "a"; print_newline(); 0
+     | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+     | Error "c" -> raise (Error "c")
+     (** [Error "d"] not caught *)
+     | Error "e" as exn ->
+         let bt = Printexc.get_raw_backtrace () in
+         print_string "e"; print_newline ();
+         ignore (exception_raised_internally ());
+         Printexc.raise_with_backtrace exn bt
+     | Error "f" as exn ->
+         let bt = Printexc.get_raw_backtrace () in
+         print_string "f"; print_newline ();
+         Printexc.raise_with_backtrace (Localized exn) bt
+
+let backtrace args =
+  try
+    ignore (g args.(0)); None
+  with exn ->
+    let exn = Printexc.to_string exn in
+    let trace = Printexc.get_raw_backtrace () in
+    Some (exn, trace)
+
+let run args =
+  match backtrace args with
+    | None -> print_string "No exception\n"
+    | Some (exn, trace) ->
+      begin
+        (* raise another exception to stash the global backtrace *)
+        try ignore (f "c" 5); assert false with Error _ -> ();
+      end;
+      Printf.printf "Uncaught exception %s\n" exn;
+      Printexc.print_raw_backtrace stdout trace;
+      flush stdout
+
+let _ =
+  Printexc.record_backtrace true;
+  run [| "a" |];
+  run [| "b" |];
+  run [| "c" |];
+  run [| "d" |];
+  run [| "e" |];
+  run [| "f" |];
+  run [| |]
diff --git a/testsuite/tests/backtrace/raw_backtrace.native.reference b/testsuite/tests/backtrace/raw_backtrace.native.reference
new file mode 100644
index 00000000..06f4f164
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.native.reference
@@ -0,0 +1,49 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 18, characters 62-71
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 19, characters 20-37
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 25, characters 9-45
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 29, characters 9-57
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22
diff --git a/testsuite/tests/basic-float/Makefile b/testsuite/tests/basic-float/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/basic-float/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-float/tfloat_hex.ml b/testsuite/tests/basic-float/tfloat_hex.ml
new file mode 100644
index 00000000..995d50c2
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_hex.ml
@@ -0,0 +1,15 @@
+let try_float_of_string str =
+  try
+    print_float (float_of_string str);
+    print_newline ()
+  with exn ->
+    print_endline (Printexc.to_string exn)
+;;
+
+let () =
+  try_float_of_string "0x1A";
+  try_float_of_string "0x1Ap3";
+  try_float_of_string "0x";
+  try_float_of_string "0x.";
+  try_float_of_string "0xp0";
+  try_float_of_string "0x.p0";
diff --git a/testsuite/tests/basic-float/tfloat_hex.reference b/testsuite/tests/basic-float/tfloat_hex.reference
new file mode 100644
index 00000000..9fce15f2
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_hex.reference
@@ -0,0 +1,6 @@
+26.
+208.
+Failure("float_of_string")
+Failure("float_of_string")
+Failure("float_of_string")
+Failure("float_of_string")
diff --git a/testsuite/tests/basic-float/tfloat_record.ml b/testsuite/tests/basic-float/tfloat_record.ml
new file mode 100644
index 00000000..38cf230b
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_record.ml
@@ -0,0 +1,46 @@
+module Float_record : sig
+  type t = private float;;
+
+  val make : float -> t;;
+  val from : t -> float;;
+
+  type s = {f : t};;
+end = struct
+  type t = float;;
+
+  let make f = f;;
+
+  let from t = t;;
+
+  type s = {f : t};;
+end
+
+module Float_array = struct
+  let small_float_array x =
+    [|1.;2.;3.|], x
+
+  let longer_float_array x =
+    [|1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;|], x
+end
+
+let s = { Float_record.f = Float_record.make 1.0 };;
+
+print_float (Float_record.from s.Float_record.f);;
+print_newline ();;
+
+
+let b = (Float_array.small_float_array [@inlined]) 12
+let c = (Float_array.longer_float_array [@inlined]) 34
+
+let print_array a =
+  Array.iter (fun f ->
+      print_float f;
+      print_newline ()) a;
+  print_newline ()
+
+let () =
+  print_array (fst b);
+  print_array (fst c);
diff --git a/testsuite/tests/basic-float/tfloat_record.reference b/testsuite/tests/basic-float/tfloat_record.reference
new file mode 100644
index 00000000..b0ed5f4e
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_record.reference
@@ -0,0 +1,46 @@
+1.
+1.
+2.
+3.
+
+1.
+2.
+3.
+4.
+5.
+6.
+7.
+8.
+9.
+0.
+1.
+2.
+3.
+4.
+5.
+6.
+7.
+8.
+9.
+0.
+1.
+2.
+3.
+4.
+5.
+6.
+7.
+8.
+9.
+0.
+1.
+2.
+3.
+4.
+5.
+6.
+7.
+8.
+9.
+0.
+
diff --git a/testsuite/tests/basic-float/zero_sized_float_arrays.ml b/testsuite/tests/basic-float/zero_sized_float_arrays.ml
new file mode 100644
index 00000000..cc959b47
--- /dev/null
+++ b/testsuite/tests/basic-float/zero_sized_float_arrays.ml
@@ -0,0 +1,15 @@
+let non_float_array : int array = [| |]
+
+let float_array : float array = [| |]
+
+let non_float_array_from_runtime : int array =
+  Array.make 0 0
+
+let float_array_from_runtime : float array =
+  Array.make 0 0.0
+
+let () =
+  assert (Pervasives.compare non_float_array non_float_array_from_runtime = 0);
+  assert (Pervasives.compare non_float_array non_float_array_from_runtime = 0);
+  assert (Pervasives.compare float_array float_array_from_runtime = 0);
+  assert (Pervasives.compare float_array float_array_from_runtime = 0)
diff --git a/testsuite/tests/basic-float/zero_sized_float_arrays.reference b/testsuite/tests/basic-float/zero_sized_float_arrays.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic-io-2/Makefile b/testsuite/tests/basic-io-2/Makefile
new file mode 100644
index 00000000..a84f0314
--- /dev/null
+++ b/testsuite/tests/basic-io-2/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=io
+EXEC_ARGS=io.ml
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml
new file mode 100644
index 00000000..3c088d3f
--- /dev/null
+++ b/testsuite/tests/basic-io-2/io.ml
@@ -0,0 +1,103 @@
+(* 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_bin infile in
+  let oc = open_out_bin ofile in
+  let buffer = Bytes.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_bin infile in
+  let oc = open_out_bin ofile in
+  let buffer = Bytes.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_bin infile in
+  let oc = open_out_bin 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 = Bytes.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_bin 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
+  let testio = Filename.temp_file "testio" "" in
+  let lines = Filename.temp_file "lines" "" in
+  test "16-byte chunks" (copy_file 16) src testio;
+  test "256-byte chunks" (copy_file 256) src testio;
+  test "4096-byte chunks" (copy_file 4096) src testio;
+  test "65536-byte chunks" (copy_file 65536) src testio;
+  test "19-byte chunks" (copy_file 19) src testio;
+  test "263-byte chunks" (copy_file 263) src testio;
+  test "4011-byte chunks" (copy_file 4011) src testio;
+  test "0...8192 byte chunks" (copy_random 8192) src testio;
+  test "line per line, short lines" copy_line "test-file-short-lines" testio;
+  make_lines lines;
+  test "line per line, short and long lines" copy_line lines testio;
+  test "backwards, 4096-byte chunks" (copy_seek 4096) src testio;
+  test "backwards, 64-byte chunks" (copy_seek 64) src testio;
+  Sys.remove lines;
+  Sys.remove testio;
+  exit 0
diff --git a/testsuite/tests/basic-io-2/io.reference b/testsuite/tests/basic-io-2/io.reference
new file mode 100644
index 00000000..06740020
--- /dev/null
+++ b/testsuite/tests/basic-io-2/io.reference
@@ -0,0 +1,24 @@
+16-byte chunks
+passed
+256-byte chunks
+passed
+4096-byte chunks
+passed
+65536-byte chunks
+passed
+19-byte chunks
+passed
+263-byte chunks
+passed
+4011-byte chunks
+passed
+0...8192 byte chunks
+passed
+line per line, short lines
+passed
+line per line, short and long lines
+passed
+backwards, 4096-byte chunks
+passed
+backwards, 64-byte chunks
+passed
diff --git a/testsuite/tests/basic-io-2/test-file-short-lines b/testsuite/tests/basic-io-2/test-file-short-lines
new file mode 100644
index 00000000..979aa0a2
--- /dev/null
+++ b/testsuite/tests/basic-io-2/test-file-short-lines
@@ -0,0 +1,10 @@
+##
+# Host Database
+#
+# localhost is used to configure the loopback interface
+# when the system is booting.  Do not change this entry.
+##
+127.0.0.1       localhost
+255.255.255.255 broadcasthost
+::1             localhost
+fe80::1%lo0     localhost
diff --git a/testsuite/tests/basic-io/Makefile b/testsuite/tests/basic-io/Makefile
new file mode 100644
index 00000000..6e63bd8d
--- /dev/null
+++ b/testsuite/tests/basic-io/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=wc
+EXEC_ARGS=wc.ml
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-io/wc.ml b/testsuite/tests/basic-io/wc.ml
new file mode 100644
index 00000000..adec8b53
--- /dev/null
+++ b/testsuite/tests/basic-io/wc.ml
@@ -0,0 +1,55 @@
+
+(* 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/testsuite/tests/basic-io/wc.reference b/testsuite/tests/basic-io/wc.reference
new file mode 100644
index 00000000..b242e31a
--- /dev/null
+++ b/testsuite/tests/basic-io/wc.reference
@@ -0,0 +1 @@
+1199 characters, 178 words, 55 lines
diff --git a/testsuite/tests/basic-manyargs/Makefile b/testsuite/tests/basic-manyargs/Makefile
new file mode 100644
index 00000000..b387d6ec
--- /dev/null
+++ b/testsuite/tests/basic-manyargs/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=manyargs
+C_FILES=manyargsprim
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-manyargs/manyargs.ml b/testsuite/tests/basic-manyargs/manyargs.ml
new file mode 100644
index 00000000..352f3cfa
--- /dev/null
+++ b/testsuite/tests/basic-manyargs/manyargs.ml
@@ -0,0 +1,45 @@
+let manyargs a b c d e f g h i j k l m n o =
+  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();
+  print_string "l = "; print_int l; print_newline();
+  print_string "m = "; print_int m; print_newline();
+  print_string "n = "; print_int n; print_newline();
+  print_string "o = "; print_int o; print_newline();
+  print_string "---"; print_newline()
+
+let manyargs_tail1 a b c d e f g h i j k l m n o =
+  print_string "tail1:\n";
+  manyargs a b c d e f g h i j k l m n o
+
+let manyargs_tail2 a b =
+  print_string "tail2:\n";
+  manyargs a b a b a b a b a b a b a b a
+
+let manyargs_tail3 a b c d e f g h i j k l m n o =
+  print_string "tail3:\n";
+  print_string "o = "; print_int o; print_newline();
+  print_string "---"; print_newline()
+
+let _ =
+  manyargs 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15;
+  manyargs_tail1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15;
+  manyargs_tail2 0 1;
+  manyargs_tail3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+
+external manyargs_ext:
+  int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int ->
+    int
+  = "manyargs_argv" "manyargs"
+
+let _ =
+  print_string "external:\n"; flush stdout;
+  manyargs_ext 1 2 3 4 5 6 7 8 9 10 11
diff --git a/testsuite/tests/basic-manyargs/manyargs.reference b/testsuite/tests/basic-manyargs/manyargs.reference
new file mode 100644
index 00000000..24e9d3df
--- /dev/null
+++ b/testsuite/tests/basic-manyargs/manyargs.reference
@@ -0,0 +1,65 @@
+a = 1
+b = 2
+c = 3
+d = 4
+e = 5
+f = 6
+g = 7
+h = 8
+i = 9
+j = 10
+k = 11
+l = 12
+m = 13
+n = 14
+o = 15
+---
+tail1:
+a = 1
+b = 2
+c = 3
+d = 4
+e = 5
+f = 6
+g = 7
+h = 8
+i = 9
+j = 10
+k = 11
+l = 12
+m = 13
+n = 14
+o = 15
+---
+tail2:
+a = 0
+b = 1
+c = 0
+d = 1
+e = 0
+f = 1
+g = 0
+h = 1
+i = 0
+j = 1
+k = 0
+l = 1
+m = 0
+n = 1
+o = 0
+---
+tail3:
+o = 15
+---
+external:
+a = 1
+b = 2
+c = 3
+d = 4
+e = 5
+f = 6
+g = 7
+h = 8
+i = 9
+j = 10
+k = 11
diff --git a/testsuite/tests/basic-manyargs/manyargsprim.c b/testsuite/tests/basic-manyargs/manyargsprim.c
new file mode 100644
index 00000000..b8b44d87
--- /dev/null
+++ b/testsuite/tests/basic-manyargs/manyargsprim.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1995 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/mlvalues.h"
+#include "stdio.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/testsuite/tests/basic-modules/Makefile b/testsuite/tests/basic-modules/Makefile
new file mode 100644
index 00000000..1feb55aa
--- /dev/null
+++ b/testsuite/tests/basic-modules/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+MODULES=offset pr6726 pr7427
+MAIN_MODULE=main
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml
new file mode 100644
index 00000000..b9a7df8d
--- /dev/null
+++ b/testsuite/tests/basic-modules/main.ml
@@ -0,0 +1,22 @@
+(* PR#6435 *)
+
+module F (M : sig
+           type t
+           module Set : Set.S with type elt = t
+         end) =
+struct
+ let test set = Printf.printf "%d\n" (M.Set.cardinal set)
+end
+
+module M = F (Offset)
+
+let () = M.test (Offset.M.Set.singleton "42")
+let v = Pr6726.Test.v
+
+(* PR#7427 *)
+
+let () =
+  try
+    let module M = Pr7427.F () in
+    failwith "Test failed"
+  with Assert_failure _ -> ()
diff --git a/testsuite/tests/basic-modules/main.mli b/testsuite/tests/basic-modules/main.mli
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic-modules/main.reference b/testsuite/tests/basic-modules/main.reference
new file mode 100644
index 00000000..d00491fd
--- /dev/null
+++ b/testsuite/tests/basic-modules/main.reference
@@ -0,0 +1 @@
+1
diff --git a/testsuite/tests/basic-modules/offset.ml b/testsuite/tests/basic-modules/offset.ml
new file mode 100644
index 00000000..457947dc
--- /dev/null
+++ b/testsuite/tests/basic-modules/offset.ml
@@ -0,0 +1,10 @@
+module M = struct
+ type t = string
+
+ let x = 0
+ let x = 1
+
+ module Set = Set.Make(String)
+end
+
+include M
diff --git a/testsuite/tests/basic-modules/pr6726.ml b/testsuite/tests/basic-modules/pr6726.ml
new file mode 100644
index 00000000..7b503501
--- /dev/null
+++ b/testsuite/tests/basic-modules/pr6726.ml
@@ -0,0 +1,18 @@
+module ExtUnixAll = struct
+ external unused : unit -> unit = "caml_blit_string"
+ module BigEndian = struct
+   let get_uint8 str off = 33
+ end
+end
+
+module ExtUnix = struct
+ module All = ExtUnixAll
+end
+
+module Test = struct
+ open ExtUnix.All
+ let test_endian_string x =
+   let module B = BigEndian in
+   B.get_uint8 x 0
+ let v = test_endian_string 1
+end
diff --git a/testsuite/tests/basic-modules/pr7427.ml b/testsuite/tests/basic-modules/pr7427.ml
new file mode 100644
index 00000000..bb00ce93
--- /dev/null
+++ b/testsuite/tests/basic-modules/pr7427.ml
@@ -0,0 +1,7 @@
+module F() = struct
+  module M = struct
+    let aaa = assert false
+    let bbb () = assert false
+  end
+  let ccc () = M.bbb ()
+end
diff --git a/testsuite/tests/basic-more/Makefile b/testsuite/tests/basic-more/Makefile
new file mode 100644
index 00000000..a71792d6
--- /dev/null
+++ b/testsuite/tests/basic-more/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=testing
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+OCOPTFLAGS=-inline 20
diff --git a/testsuite/tests/basic-more/bounds.ml b/testsuite/tests/basic-more/bounds.ml
new file mode 100644
index 00000000..edaa0c8a
--- /dev/null
+++ b/testsuite/tests/basic-more/bounds.ml
@@ -0,0 +1,26 @@
+(* Test bound checks with ocamlopt *)
+
+let a = [| 0; 1; 2 |]
+
+let trail = ref []
+
+let test n =
+  let result =
+    try
+      trail := n :: !trail; ignore 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/testsuite/tests/basic-more/bounds.reference b/testsuite/tests/basic-more/bounds.reference
new file mode 100644
index 00000000..5d34a602
--- /dev/null
+++ b/testsuite/tests/basic-more/bounds.reference
@@ -0,0 +1,9 @@
+0: doesn't fail
+1: doesn't fail
+2: doesn't fail
+3: fails
+4: fails
+-1: fails
+Trail: -1 4 3 2 1 0
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/div_by_zero.ml b/testsuite/tests/basic-more/div_by_zero.ml
new file mode 100644
index 00000000..9dc45e7b
--- /dev/null
+++ b/testsuite/tests/basic-more/div_by_zero.ml
@@ -0,0 +1,67 @@
+
+let check f n =
+  assert (
+    try ignore ((Sys.opaque_identity f) n); false with
+      Division_by_zero -> true
+  )
+
+let div_int n  = n / 0
+let div_int32 n = Int32.div n 0l
+let div_int64 n = Int64.div n 0L
+let div_nativeint n = Nativeint.div n 0n
+
+let mod_int n  = n mod 0
+let mod_int32 n = Int32.rem n 0l
+let mod_int64 n = Int64.rem n 0L
+let mod_nativeint n = Nativeint.rem n 0n
+
+let div_int_opaque n  = n / (Sys.opaque_identity 0)
+let div_int32_opaque n = Int32.div n (Sys.opaque_identity 0l)
+let div_int64_opaque n = Int64.div n (Sys.opaque_identity 0L)
+let div_nativeint_opaque n = Nativeint.div n (Sys.opaque_identity 0n)
+
+let mod_int_opaque n  = n mod (Sys.opaque_identity 0)
+let mod_int32_opaque n = Int32.rem n (Sys.opaque_identity 0l)
+let mod_int64_opaque n = Int64.rem n (Sys.opaque_identity 0L)
+let mod_nativeint_opaque n = Nativeint.rem n (Sys.opaque_identity 0n)
+
+let () =
+  check div_int 33;
+  check div_int 0;
+  check div_int32 33l;
+  check div_int32 0l;
+  check div_int64 33L;
+  check div_int64 0L;
+  check div_nativeint 33n;
+  check div_nativeint 0n;
+
+  check mod_int 33;
+  check mod_int 0;
+  check mod_int32 33l;
+  check mod_int32 0l;
+  check mod_int64 33L;
+  check mod_int64 0L;
+  check mod_nativeint 33n;
+  check mod_nativeint 0n;
+
+  check div_int_opaque 33;
+  check div_int_opaque 0;
+  check div_int32_opaque 33l;
+  check div_int32_opaque 0l;
+  check div_int64_opaque 33L;
+  check div_int64_opaque 0L;
+  check div_nativeint_opaque 33n;
+  check div_nativeint_opaque 0n;
+
+  check mod_int_opaque 33;
+  check mod_int_opaque 0;
+  check mod_int32_opaque 33l;
+  check mod_int32_opaque 0l;
+  check mod_int64_opaque 33L;
+  check mod_int64_opaque 0L;
+  check mod_nativeint_opaque 33n;
+  check mod_nativeint_opaque 0n;
+  ()
+
+let () =
+  print_endline "***** OK *****"
diff --git a/testsuite/tests/basic-more/div_by_zero.reference b/testsuite/tests/basic-more/div_by_zero.reference
new file mode 100644
index 00000000..e6b95628
--- /dev/null
+++ b/testsuite/tests/basic-more/div_by_zero.reference
@@ -0,0 +1,3 @@
+***** OK *****
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/function_in_ref.ml b/testsuite/tests/basic-more/function_in_ref.ml
new file mode 100644
index 00000000..3df98d71
--- /dev/null
+++ b/testsuite/tests/basic-more/function_in_ref.ml
@@ -0,0 +1,9 @@
+
+let f x = x + 1
+let g x = x - 1
+
+let run () =
+  let r = ref f in
+  r := g;
+  let n = !r 1 in
+  assert(n = 0)
diff --git a/testsuite/tests/basic-more/function_in_ref.reference b/testsuite/tests/basic-more/function_in_ref.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/function_in_ref.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/if_in_if.ml b/testsuite/tests/basic-more/if_in_if.ml
new file mode 100644
index 00000000..cd1e56bb
--- /dev/null
+++ b/testsuite/tests/basic-more/if_in_if.ml
@@ -0,0 +1,44 @@
+
+let sequor b1 b2 =
+  let b1 = ref b1 in
+  let b2 = ref b2 in
+  let b1 = !b1 in
+  let b2 = !b2 in
+  if (if b1 then true else b2 && if b1 then true else b2)
+  then "true" else "false"
+
+let sequand b1 b2 =
+  let b1 = ref b1 in
+  let b2 = ref b2 in
+  let b1 = !b1 in
+  let b2 = !b2 in
+  if (if b1 then b2 else false && if b1 then b2 else false)
+  then "true" else "false"
+
+let sequor' b1 b2 =
+  let b1 = ref b1 in
+  let b2 = ref b2 in
+  let b1 = !b1 in
+  let b2 = !b2 in
+  if (if b1 then true else b2 || if b1 then true else b2)
+  then "true" else "false"
+
+let sequand' b1 b2 =
+  let b1 = ref b1 in
+  let b2 = ref b2 in
+  let b1 = !b1 in
+  let b2 = !b2 in
+  if (if b1 then b2 else false || if b1 then b2 else false)
+  then "true" else "false"
+
+let test b1 b2 =
+  assert(sequor b1 b2 = if b1 || b2 then "true" else "false");
+  assert(sequor' b1 b2 = if b1 || b2 then "true" else "false");
+  assert(sequand b1 b2 = if b1 && b2 then "true" else "false");
+  assert(sequand' b1 b2 = if b1 && b2 then "true" else "false")
+
+let () =
+  test false false;
+  test false true;
+  test true false;
+  test true true
diff --git a/testsuite/tests/basic-more/if_in_if.reference b/testsuite/tests/basic-more/if_in_if.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/if_in_if.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml
new file mode 100644
index 00000000..86b63882
--- /dev/null
+++ b/testsuite/tests/basic-more/morematch.ml
@@ -0,0 +1,1189 @@
+(**************************************************************)
+(*  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
+| _ -> assert false
+;;
+
+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 ; ()
+;;
+
+(*
+File "morematch.ml", line 73, characters 2-5:
+Warning U: this sub-pattern is unused.
+File "morematch.ml", line 74, characters 2-3:
+Warning U: this sub-pattern is unused.
+*)
+
+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
+;;
+(*
+File "morematch.ml", line 437, characters 43-44:
+Warning U: this sub-pattern is unused.
+*)
+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
+;;
+(*
+File "morematch.ml", line 459, characters 7-8:
+Warning U: this sub-pattern is unused.
+File "morematch.ml", line 460, characters 2-7:
+Warning U: this match case is unused.
+*)
+test "xyz" xyz (YC,YC,X) 6 ;
+test "xyz" xyz (YC,YB,U X) 8 ;
+test "xyz" xyz (YB,YC,X) 6 ; ()
+;;
+
+
+(* This test is for the compiler itself *)
+let eq (x,y) = x=y
+;;
+
+test "eq" eq ("coucou", "coucou") true ; ()
+;;
+
+(* Test guards, non trivial *)
+
+let is_none = function
+  | None -> true
+  | _ -> false
+
+let guard x = match x with
+| (Some _, _) when is_none (snd x) -> 1
+| (Some (pc, _), Some pc') when pc = pc' -> 2
+| _ -> 3
+;;
+
+test "guard" guard (Some (1,1),None) 1 ;
+test "guard" guard (Some (1,1),Some 1) 2 ;
+test "guard" guard (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 flatguard c =
+let x,y = c in
+match x,y with
+| (1,2)|(2,3) when y=2 -> 1
+| (1,_)|(_,3) -> 2
+| _ -> 3
+;;
+
+test "flatguard" flatguard (1,2) 1 ;
+test "flatguard" flatguard (1,3) 2 ;
+test "flatguard" flatguard (2,3) 2 ;
+test "flatguard" flatguard (2,4) 3 ; ()
+;;
+
+
+(* Jerome's bugs *)
+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_variant"
+   replicaContent2shortString (`ABSENT, `Unchanged) "        " ;
+test "jerome_variant"
+   replicaContent2shortString (`ABSENT, `Deleted) "deleted " ;
+test "jerome_variant"
+   replicaContent2shortString (`FILE, `Modified) "changed " ;
+test "jerome_variant"
+   replicaContent2shortString (`DIRECTORY, `PropsChanged) "props   " ;
+test "jerome_variant"
+   replicaContent2shortString (`FILE, `Deleted) "assert false" ;
+test "jerome_variant"
+   replicaContent2shortString (`SYMLINK, `Deleted) "assert false" ;
+test "jerome_variant"
+   replicaContent2shortString (`SYMLINK, `PropsChanged) "assert false" ;
+test "jerome_variant"
+   replicaContent2shortString (`DIRECTORY, `Deleted) "assert false" ;
+test "jerome_variant"
+   replicaContent2shortString (`ABSENT, `Created) "assert false" ;
+test "jerome_variant"
+   replicaContent2shortString (`ABSENT, `Modified) "assert false" ;
+test "jerome_variant"
+   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 ; ()
+;;
+
+
+(* Chaining interval tests *)
+
+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
+
+(*
+  Match in trywith should always have a default case
+*)
+
+exception Found of string * int
+exception Error of string
+
+
+let lucexn  e =
+  try
+    try  raise e  with Error msg -> msg
+  with Found (s,r) -> s^string_of_int r
+
+let () =
+  test "lucexn1" lucexn  (Error "coucou") "coucou" ;
+  test "lucexn2" lucexn (Found ("int: ",0)) "int: 0" ;
+  ()
+
+(*
+  PR#5758: different representations of floats
+*)
+
+let pr5758 x str =
+  match (x, str) with
+  | (1. , "A") -> "Matched A"
+  | (1.0, "B") -> "Matched B"
+  | (1. , "C") -> "Matched C"
+  | result ->
+    match result with
+    | (1., "A") -> "Failed match A then later matched"
+    | _ -> "Failed twice"
+;;
+
+let () =
+  test "pr5758" (pr5758 1.) "A" "Matched A"
+;;
diff --git a/testsuite/tests/basic-more/morematch.reference b/testsuite/tests/basic-more/morematch.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/morematch.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/opaque_prim.ml b/testsuite/tests/basic-more/opaque_prim.ml
new file mode 100644
index 00000000..1c39f236
--- /dev/null
+++ b/testsuite/tests/basic-more/opaque_prim.ml
@@ -0,0 +1,6 @@
+let f x = Sys.opaque_identity x
+
+let () =
+  assert(f f == f);
+  assert(Sys.opaque_identity 1 = 1);
+  assert(Sys.opaque_identity 1. = 1.)
diff --git a/testsuite/tests/basic-more/opaque_prim.reference b/testsuite/tests/basic-more/opaque_prim.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/opaque_prim.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml
new file mode 100644
index 00000000..f0a9d6a4
--- /dev/null
+++ b/testsuite/tests/basic-more/pr2719.ml
@@ -0,0 +1,17 @@
+open Printf
+
+let bug () =
+  let mat = [| [|false|] |]
+  and test = ref false in
+    printf "Value of test at the beginning : %b\n" !test; flush stdout;
+    (try let _ = mat.(0).(-1) in
+       (test := true;
+        printf "Am I going through this block of instructions ?\n";
+        flush stdout)
+     with Invalid_argument _ -> printf "Value of test now : %b\n" !test
+    );
+    (try if mat.(0).(-1) then ()
+     with Invalid_argument _ -> ()
+    )
+
+let () = bug ()
diff --git a/testsuite/tests/basic-more/pr2719.reference b/testsuite/tests/basic-more/pr2719.reference
new file mode 100644
index 00000000..073d0916
--- /dev/null
+++ b/testsuite/tests/basic-more/pr2719.reference
@@ -0,0 +1,4 @@
+Value of test at the beginning : false
+Value of test now : false
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/pr6216.ml b/testsuite/tests/basic-more/pr6216.ml
new file mode 100644
index 00000000..71844f14
--- /dev/null
+++ b/testsuite/tests/basic-more/pr6216.ml
@@ -0,0 +1,12 @@
+(* PR6216: wrong inlining of GADT match *)
+
+type _ t =
+ | Float : float t
+ | String : string t
+
+let f : type a . a t -> a -> unit = fun t a ->
+ match t with
+ | Float -> ()
+ | String -> ignore (String.length a : int)
+
+let _g (kind : float t) (x : float) : unit = f kind (x *. 13.)
diff --git a/testsuite/tests/basic-more/pr6216.reference b/testsuite/tests/basic-more/pr6216.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/pr6216.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/record_evaluation_order.ml b/testsuite/tests/basic-more/record_evaluation_order.ml
new file mode 100644
index 00000000..0e18af8c
--- /dev/null
+++ b/testsuite/tests/basic-more/record_evaluation_order.ml
@@ -0,0 +1,89 @@
+
+type r =
+  { a : unit;
+    b : int;
+    c : char;
+    d : float; }
+
+let r1 =
+  {
+    c = (print_endline "c1"; 'c');
+    a = print_endline "a1";
+    d = (print_endline "d1"; 1.);
+    b = (print_endline "b1"; 2);
+  }
+
+let r2 =
+  {
+    b = (print_endline "b2"; 2);
+    d = (print_endline "d2"; 1.);
+    a = print_endline "a2";
+    c = (print_endline "c2"; 'c');
+  }
+
+let r3 =
+  { (print_endline "default"; r1) with
+    d = (print_endline "d3"; 1.);
+    c = (print_endline "c3"; 'c');
+    a = print_endline "a3";
+  }
+
+let () = print_endline ""
+
+type r2 =
+  { x1 : unit;
+    x2 : unit;
+    x3 : unit;
+    x4 : unit;
+    x5 : unit;
+    x6 : unit;
+    x7 : unit;
+    x8 : unit;
+    x9 : unit; }
+
+let a =
+  {
+    x5 = print_endline "x5";
+    x6 = print_endline "x6";
+    x1 = print_endline "x1";
+    x3 = print_endline "x3";
+    x4 = print_endline "x4";
+    x9 = print_endline "x9";
+    x7 = print_endline "x7";
+    x8 = print_endline "x8";
+    x2 = print_endline "x2";
+  }
+
+let () = print_endline ""
+
+let b =
+  { a with
+    x7 = print_endline "x7";
+    x2 = print_endline "x2";
+  }
+
+let () = print_endline ""
+
+let c =
+  { a with
+    x2 = print_endline "x2";
+    x7 = print_endline "x7";
+  }
+
+let () = print_endline ""
+
+let c =
+  { a with
+    x2 = print_endline "x2";
+    x7 = print_endline "x7";
+    x5 = print_endline "x5";
+  }
+
+let () = print_endline ""
+
+let d =
+  { a with
+    x5 = print_endline "x5";
+    x7 = print_endline "x7";
+    x2 = print_endline "x2";
+  }
diff --git a/testsuite/tests/basic-more/record_evaluation_order.reference b/testsuite/tests/basic-more/record_evaluation_order.reference
new file mode 100644
index 00000000..f4186851
--- /dev/null
+++ b/testsuite/tests/basic-more/record_evaluation_order.reference
@@ -0,0 +1,38 @@
+d1
+c1
+b1
+a1
+d2
+c2
+b2
+a2
+default
+d3
+c3
+a3
+
+x9
+x8
+x7
+x6
+x5
+x4
+x3
+x2
+x1
+
+x7
+x2
+
+x7
+x2
+
+x7
+x5
+x2
+
+x7
+x5
+x2
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/sequential_and_or.ml b/testsuite/tests/basic-more/sequential_and_or.ml
new file mode 100644
index 00000000..6492ea27
--- /dev/null
+++ b/testsuite/tests/basic-more/sequential_and_or.ml
@@ -0,0 +1,122 @@
+let r = ref 0
+
+let true_effect () =
+  incr r;
+  print_int !r; print_char ' ';
+  true
+
+let false_effect () =
+  incr r;
+  print_int !r; print_char ' ';
+  false
+
+let test i f =
+  print_int i;
+  print_string ": ";
+  print_endline (string_of_bool (f ()))
+
+let s = Bytes.of_string "\000"
+let () =
+  (* ensure that the string is not constant *)
+  s.[0] <- '\001'
+
+let unknown_true =
+  Bytes.get s 0 = '\001'
+
+let unknown_false =
+  Bytes.get s 0 <> '\001'
+
+let () =
+  test 1 (fun () -> true || true);
+  test 2 (fun () -> true || false);
+  test 3 (fun () -> true || true_effect ());
+  test 4 (fun () -> true || false_effect ());
+  test 5 (fun () -> true || unknown_true);
+  test 6 (fun () -> true || unknown_false);
+  test 7 (fun () -> false || true);
+  test 8 (fun () -> false || false);
+  test 9 (fun () -> false || true_effect ());
+  test 10 (fun () -> false || false_effect ());
+  test 11 (fun () -> false || unknown_true);
+  test 12 (fun () -> false || unknown_false);
+  test 13 (fun () -> true_effect () || true);
+  test 14 (fun () -> true_effect () || false);
+  test 15 (fun () -> true_effect () || true_effect ());
+  test 16 (fun () -> true_effect () || false_effect ());
+  test 17 (fun () -> true_effect () || unknown_true);
+  test 18 (fun () -> true_effect () || unknown_false);
+  test 19 (fun () -> false_effect () || true);
+  test 20 (fun () -> false_effect () || false);
+  test 21 (fun () -> false_effect () || true_effect ());
+  test 22 (fun () -> false_effect () || false_effect ());
+  test 23 (fun () -> false_effect () || unknown_true);
+  test 24 (fun () -> false_effect () || unknown_false);
+  test 25 (fun () -> unknown_true || true);
+  test 26 (fun () -> unknown_true || false);
+  test 27 (fun () -> unknown_true || true_effect ());
+  test 28 (fun () -> unknown_true || false_effect ());
+  test 29 (fun () -> unknown_true || unknown_true);
+  test 30 (fun () -> unknown_true || unknown_false);
+  test 31 (fun () -> unknown_false || true);
+  test 32 (fun () -> unknown_false || false);
+  test 33 (fun () -> unknown_false || true_effect ());
+  test 34 (fun () -> unknown_false || false_effect ());
+  test 35 (fun () -> unknown_false || unknown_true);
+  test 36 (fun () -> unknown_false || unknown_false);
+  test 37 (fun () -> true && true);
+  test 38 (fun () -> true && false);
+  test 39 (fun () -> true && true_effect ());
+  test 40 (fun () -> true && false_effect ());
+  test 41 (fun () -> true && unknown_true);
+  test 42 (fun () -> true && unknown_false);
+  test 43 (fun () -> false && true);
+  test 44 (fun () -> false && false);
+  test 45 (fun () -> false && true_effect ());
+  test 46 (fun () -> false && false_effect ());
+  test 47 (fun () -> false && unknown_true);
+  test 48 (fun () -> false && unknown_false);
+  test 49 (fun () -> true_effect () && true);
+  test 50 (fun () -> true_effect () && false);
+  test 51 (fun () -> true_effect () && true_effect ());
+  test 52 (fun () -> true_effect () && false_effect ());
+  test 53 (fun () -> true_effect () && unknown_true);
+  test 54 (fun () -> true_effect () && unknown_false);
+  test 55 (fun () -> false_effect () && true);
+  test 56 (fun () -> false_effect () && false);
+  test 57 (fun () -> false_effect () && true_effect ());
+  test 58 (fun () -> false_effect () && false_effect ());
+  test 59 (fun () -> false_effect () && unknown_true);
+  test 60 (fun () -> false_effect () && unknown_false);
+  test 61 (fun () -> unknown_true && true);
+  test 62 (fun () -> unknown_true && false);
+  test 63 (fun () -> unknown_true && true_effect ());
+  test 64 (fun () -> unknown_true && false_effect ());
+  test 65 (fun () -> unknown_true && unknown_true);
+  test 66 (fun () -> unknown_true && unknown_false);
+  test 67 (fun () -> unknown_false && true);
+  test 68 (fun () -> unknown_false && false);
+  test 69 (fun () -> unknown_false && true_effect ());
+  test 70 (fun () -> unknown_false && false_effect ());
+  test 71 (fun () -> unknown_false && unknown_true);
+  test 72 (fun () -> unknown_false && unknown_false);
+  ()
+
+(* test generation *)
+
+(*
+let values = ["true"; "false"; "true_effect ()"; "false_effect ()";
+              "unknown_true"; "unknown_false"]
+let ops = ["||"; "&&"]
+let count = ref 0
+let f op v1 v2 =
+  incr count;
+  Printf.sprintf "  test %i (fun () -> %s %s %s);" !count v1 op v2
+
+let s =
+  List.iter (fun op ->
+      List.iter (fun v1 ->
+          List.iter (fun v2 -> print_endline (f op v1 v2))
+            values)
+        values)
+    ops
+*)
diff --git a/testsuite/tests/basic-more/sequential_and_or.reference b/testsuite/tests/basic-more/sequential_and_or.reference
new file mode 100644
index 00000000..229f1403
--- /dev/null
+++ b/testsuite/tests/basic-more/sequential_and_or.reference
@@ -0,0 +1,74 @@
+1: true
+2: true
+3: true
+4: true
+5: true
+6: true
+7: true
+8: false
+9: 1 true
+10: 2 false
+11: true
+12: false
+13: 3 true
+14: 4 true
+15: 5 true
+16: 6 true
+17: 7 true
+18: 8 true
+19: 9 true
+20: 10 false
+21: 11 12 true
+22: 13 14 false
+23: 15 true
+24: 16 false
+25: true
+26: true
+27: true
+28: true
+29: true
+30: true
+31: true
+32: false
+33: 17 true
+34: 18 false
+35: true
+36: false
+37: true
+38: false
+39: 19 true
+40: 20 false
+41: true
+42: false
+43: false
+44: false
+45: false
+46: false
+47: false
+48: false
+49: 21 true
+50: 22 false
+51: 23 24 true
+52: 25 26 false
+53: 27 true
+54: 28 false
+55: 29 false
+56: 30 false
+57: 31 false
+58: 32 false
+59: 33 false
+60: 34 false
+61: true
+62: false
+63: 35 true
+64: 36 false
+65: true
+66: false
+67: false
+68: false
+69: false
+70: false
+71: false
+72: false
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/structural_constants.ml b/testsuite/tests/basic-more/structural_constants.ml
new file mode 100644
index 00000000..4249e8c6
--- /dev/null
+++ b/testsuite/tests/basic-more/structural_constants.ml
@@ -0,0 +1,217 @@
+
+type t1 =
+  | A | B | C of t1 | D of float
+
+let a = [A; B; C A; C (C A); D 1.234]
+let () =
+  match Sys.opaque_identity a with
+  | [A; B; C A; C (C A); D 1.234] -> ()
+  | _ -> assert false
+
+let () =
+  match a with
+  | [A; B; C A; C (C A); D 1.234] -> ()
+  | _ -> assert false
+
+let b = [|A; B; C A; C (C A); D 1.234|]
+let () =
+  match Sys.opaque_identity b with
+  | [|A; B; C A; C (C A); D 1.234|] -> ()
+  | _ -> assert false
+
+let () =
+  match b with
+  | [|A; B; C A; C (C A); D 1.234|] -> ()
+  | _ -> assert false
+
+let c = [1.; 2.]
+let () =
+  match Sys.opaque_identity c with
+  | [1.; 2.] -> ()
+  | _ -> assert false
+
+let () =
+  match c with
+  | [1.; 2.] -> ()
+  | _ -> assert false
+
+let d = [|1.; 2.|]
+let () =
+  match Sys.opaque_identity d with
+  | [|1.; 2.|] -> ()
+  | _ -> assert false
+
+let () =
+  match d with
+  | [|1.; 2.|] -> ()
+  | _ -> assert false
+
+let long_array =
+  [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
+    13; 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25;
+    26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38;
+    39; 40; 41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51;
+    52; 53; 54; 55; 56; 57; 58; 59; 60; 61; 62; 63; 64;
+    65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77;
+    78; 79; 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90;
+    91; 92; 93; 94; 95; 96; 97; 98; 99; 100; 101; 102; 103;
+    104; 105; 106; 107; 108; 109; 110; 111; 112; 113; 114; 115; 116;
+    117; 118; 119; 120; 121; 122; 123; 124; 125; 126; 127; 128; 129;
+    130; 131; 132; 133; 134; 135; 136; 137; 138; 139; 140; 141; 142;
+    143; 144; 145; 146; 147; 148; 149; 150; 151; 152; 153; 154; 155;
+    156; 157; 158; 159; 160; 161; 162; 163; 164; 165; 166; 167; 168;
+    169; 170; 171; 172; 173; 174; 175; 176; 177; 178; 179; 180; 181;
+    182; 183; 184; 185; 186; 187; 188; 189; 190; 191; 192; 193; 194;
+    195; 196; 197; 198; 199; 200; 201; 202; 203; 204; 205; 206; 207;
+    208; 209; 210; 211; 212; 213; 214; 215; 216; 217; 218; 219; 220;
+    221; 222; 223; 224; 225; 226; 227; 228; 229; 230; 231; 232; 233;
+    234; 235; 236; 237; 238; 239; 240; 241; 242; 243; 244; 245; 246;
+    247; 248; 249; 250; 251; 252; 253; 254; 255; 256; 257; 258; 259;
+    260; 261; 262; 263; 264; 265; 266; 267; 268; 269; 270; 271; 272;
+    273; 274; 275; 276; 277; 278; 279; 280; 281; 282; 283; 284; 285;
+    286; 287; 288; 289; 290; 291; 292; 293; 294; 295; 296; 297; 298;
+    299; 300; 301; 302; 303; 304; 305; 306; 307; 308; 309; 310; 311;
+    312; 313; 314; 315; 316; 317; 318; 319; 320; 321; 322; 323; 324;
+    325; 326; 327; 328; 329; 330; 331; 332; 333; 334; 335; 336; 337;
+    338; 339; 340; 341; 342; 343; 344; 345; 346; 347; 348; 349; 350;
+    351; 352; 353; 354; 355; 356; 357; 358; 359; 360; 361; 362; 363;
+    364; 365; 366; 367; 368; 369; 370; 371; 372; 373; 374; 375; 376;
+    377; 378; 379; 380; 381; 382; 383; 384; 385; 386; 387; 388; 389;
+    390; 391; 392; 393; 394; 395; 396; 397; 398; 399; 400; 401; 402;
+    403; 404; 405; 406; 407; 408; 409; 410; 411; 412; 413; 414; 415;
+    416; 417; 418; 419; 420; 421; 422; 423; 424; 425; 426; 427; 428;
+    429; 430; 431; 432; 433; 434; 435; 436; 437; 438; 439; 440; 441;
+    442; 443; 444; 445; 446; 447; 448; 449; 450; 451; 452; 453; 454;
+    455; 456; 457; 458; 459; 460; 461; 462; 463; 464; 465; 466; 467;
+    468; 469; 470; 471; 472; 473; 474; 475; 476; 477; 478; 479; 480;
+    481; 482; 483; 484; 485; 486; 487; 488; 489; 490; 491; 492; 493;
+    494; 495; 496; 497; 498; 499; 500; 501; 502; 503; 504; 505; 506;
+    507; 508; 509; 510; 511; 512; 513; 514; 515; 516; 517; 518; 519;
+    520; 521; 522; 523; 524; 525; 526; 527; 528; 529; 530; 531; 532;
+    533; 534; 535; 536; 537; 538; 539; 540; 541; 542; 543; 544; 545;
+    546; 547; 548; 549; 550; 551; 552; 553; 554; 555; 556; 557; 558;
+    559; 560; 561; 562; 563; 564; 565; 566; 567; 568; 569; 570; 571;
+    572; 573; 574; 575; 576; 577; 578; 579; 580; 581; 582; 583; 584;
+    585; 586; 587; 588; 589; 590; 591; 592; 593; 594; 595; 596; 597;
+    598; 599; 600; 601; 602; 603; 604; 605; 606; 607; 608; 609; 610;
+    611; 612; 613; 614; 615; 616; 617; 618; 619; 620; 621; 622; 623;
+    624; 625; 626; 627; 628; 629; 630; 631; 632; 633; 634; 635; 636;
+    637; 638; 639; 640; 641; 642; 643; 644; 645; 646; 647; 648; 649;
+    650; 651; 652; 653; 654; 655; 656; 657; 658; 659; 660; 661; 662;
+    663; 664; 665; 666; 667; 668; 669; 670; 671; 672; 673; 674; 675;
+    676; 677; 678; 679; 680; 681; 682; 683; 684; 685; 686; 687; 688;
+    689; 690; 691; 692; 693; 694; 695; 696; 697; 698; 699; 700; 701;
+    702; 703; 704; 705; 706; 707; 708; 709; 710; 711; 712; 713; 714;
+    715; 716; 717; 718; 719; 720; 721; 722; 723; 724; 725; 726; 727;
+    728; 729; 730; 731; 732; 733; 734; 735; 736; 737; 738; 739; 740;
+    741; 742; 743; 744; 745; 746; 747; 748; 749; 750; 751; 752; 753;
+    754; 755; 756; 757; 758; 759; 760; 761; 762; 763; 764; 765; 766;
+    767; 768; 769; 770; 771; 772; 773; 774; 775; 776; 777; 778; 779;
+    780; 781; 782; 783; 784; 785; 786; 787; 788; 789; 790; 791; 792;
+    793; 794; 795; 796; 797; 798; 799; 800; 801; 802; 803; 804; 805;
+    806; 807; 808; 809; 810; 811; 812; 813; 814; 815; 816; 817; 818;
+    819; 820; 821; 822; 823; 824; 825; 826; 827; 828; 829; 830; 831;
+    832; 833; 834; 835; 836; 837; 838; 839; 840; 841; 842; 843; 844;
+    845; 846; 847; 848; 849; 850; 851; 852; 853; 854; 855; 856; 857;
+    858; 859; 860; 861; 862; 863; 864; 865; 866; 867; 868; 869; 870;
+    871; 872; 873; 874; 875; 876; 877; 878; 879; 880; 881; 882; 883;
+    884; 885; 886; 887; 888; 889; 890; 891; 892; 893; 894; 895; 896;
+    897; 898; 899; 900; 901; 902; 903; 904; 905; 906; 907; 908; 909;
+    910; 911; 912; 913; 914; 915; 916; 917; 918; 919; 920; 921; 922;
+    923; 924; 925; 926; 927; 928; 929; 930; 931; 932; 933; 934; 935;
+    936; 937; 938; 939; 940; 941; 942; 943; 944; 945; 946; 947; 948;
+    949; 950; 951; 952; 953; 954; 955; 956; 957; 958; 959; 960; 961;
+    962; 963; 964; 965; 966; 967; 968; 969; 970; 971; 972; 973; 974;
+    975; 976; 977; 978; 979; 980; 981; 982; 983; 984; 985; 986; 987;
+    988; 989; 990; 991; 992; 993; 994; 995; 996; 997; 998; 999; 1000;
+    1001; 1002; 1003; 1004; 1005; 1006; 1007; 1008; 1009; 1010; 1011; 1012; 1013;
+    1014; 1015; 1016; 1017; 1018; 1019; 1020; 1021; 1022; 1023; 1024; 1025; 1026;
+    1027; 1028; 1029; 1030; 1031; 1032; 1033; 1034; 1035; 1036; 1037; 1038; 1039;
+    1040; 1041; 1042; 1043; 1044; 1045; 1046; 1047; 1048; 1049; 1050; 1051; 1052;
+    1053; 1054; 1055; 1056; 1057; 1058; 1059; 1060; 1061; 1062; 1063; 1064; 1065;
+    1066; 1067; 1068; 1069; 1070; 1071; 1072; 1073; 1074; 1075; 1076; 1077; 1078;
+    1079; 1080; 1081; 1082; 1083; 1084; 1085; 1086; 1087; 1088; 1089; 1090; 1091;
+    1092; 1093; 1094; 1095; 1096; 1097; 1098; 1099; 1100; 1101; 1102; 1103; 1104;
+    1105; 1106; 1107; 1108; 1109; 1110; 1111; 1112; 1113; 1114; 1115; 1116; 1117;
+    1118; 1119; 1120; 1121; 1122; 1123; 1124; 1125; 1126; 1127; 1128; 1129; 1130;
+    1131; 1132; 1133; 1134; 1135; 1136; 1137; 1138; 1139; 1140; 1141; 1142; 1143;
+    1144; 1145; 1146; 1147; 1148; 1149; 1150; 1151; 1152; 1153; 1154; 1155; 1156;
+    1157; 1158; 1159; 1160; 1161; 1162; 1163; 1164; 1165; 1166; 1167; 1168; 1169;
+    1170; 1171; 1172; 1173; 1174; 1175; 1176; 1177; 1178; 1179; 1180; 1181; 1182;
+    1183; 1184; 1185; 1186; 1187; 1188; 1189; 1190; 1191; 1192; 1193; 1194; 1195;
+    1196; 1197; 1198; 1199; 1200; 1201; 1202; 1203; 1204; 1205; 1206; 1207; 1208;
+    1209; 1210; 1211; 1212; 1213; 1214; 1215; 1216; 1217; 1218; 1219; 1220; 1221;
+    1222; 1223; 1224; 1225; 1226; 1227; 1228; 1229; 1230; 1231; 1232; 1233; 1234;
+    1235; 1236; 1237; 1238; 1239; 1240; 1241; 1242; 1243; 1244; 1245; 1246; 1247;
+    1248; 1249; 1250; 1251; 1252; 1253; 1254; 1255; 1256; 1257; 1258; 1259; 1260;
+    1261; 1262; 1263; 1264; 1265; 1266; 1267; 1268; 1269; 1270; 1271; 1272; 1273;
+    1274; 1275; 1276; 1277; 1278; 1279; 1280; 1281; 1282; 1283; 1284; 1285; 1286;
+    1287; 1288; 1289; 1290; 1291; 1292; 1293; 1294; 1295; 1296; 1297; 1298; 1299;
+    1300; 1301; 1302; 1303; 1304; 1305; 1306; 1307; 1308; 1309; 1310; 1311; 1312;
+    1313; 1314; 1315; 1316; 1317; 1318; 1319; 1320; 1321; 1322; 1323; 1324; 1325;
+    1326; 1327; 1328; 1329; 1330; 1331; 1332; 1333; 1334; 1335; 1336; 1337; 1338;
+    1339; 1340; 1341; 1342; 1343; 1344; 1345; 1346; 1347; 1348; 1349; 1350; 1351;
+    1352; 1353; 1354; 1355; 1356; 1357; 1358; 1359; 1360; 1361; 1362; 1363; 1364;
+    1365; 1366; 1367; 1368; 1369; 1370; 1371; 1372; 1373; 1374; 1375; 1376; 1377;
+    1378; 1379; 1380; 1381; 1382; 1383; 1384; 1385; 1386; 1387; 1388; 1389; 1390;
+    1391; 1392; 1393; 1394; 1395; 1396; 1397; 1398; 1399; 1400; 1401; 1402; 1403;
+    1404; 1405; 1406; 1407; 1408; 1409; 1410; 1411; 1412; 1413; 1414; 1415; 1416;
+    1417; 1418; 1419; 1420; 1421; 1422; 1423; 1424; 1425; 1426; 1427; 1428; 1429;
+    1430; 1431; 1432; 1433; 1434; 1435; 1436; 1437; 1438; 1439; 1440; 1441; 1442;
+    1443; 1444; 1445; 1446; 1447; 1448; 1449; 1450; 1451; 1452; 1453; 1454; 1455;
+    1456; 1457; 1458; 1459; 1460; 1461; 1462; 1463; 1464; 1465; 1466; 1467; 1468;
+    1469; 1470; 1471; 1472; 1473; 1474; 1475; 1476; 1477; 1478; 1479; 1480; 1481;
+    1482; 1483; 1484; 1485; 1486; 1487; 1488; 1489; 1490; 1491; 1492; 1493; 1494;
+    1495; 1496; 1497; 1498; 1499; 1500; 1501; 1502; 1503; 1504; 1505; 1506; 1507;
+    1508; 1509; 1510; 1511; 1512; 1513; 1514; 1515; 1516; 1517; 1518; 1519; 1520;
+    1521; 1522; 1523; 1524; 1525; 1526; 1527; 1528; 1529; 1530; 1531; 1532; 1533;
+    1534; 1535; 1536; 1537; 1538; 1539; 1540; 1541; 1542; 1543; 1544; 1545; 1546;
+    1547; 1548; 1549; 1550; 1551; 1552; 1553; 1554; 1555; 1556; 1557; 1558; 1559;
+    1560; 1561; 1562; 1563; 1564; 1565; 1566; 1567; 1568; 1569; 1570; 1571; 1572;
+    1573; 1574; 1575; 1576; 1577; 1578; 1579; 1580; 1581; 1582; 1583; 1584; 1585;
+    1586; 1587; 1588; 1589; 1590; 1591; 1592; 1593; 1594; 1595; 1596; 1597; 1598;
+    1599; 1600; 1601; 1602; 1603; 1604; 1605; 1606; 1607; 1608; 1609; 1610; 1611;
+    1612; 1613; 1614; 1615; 1616; 1617; 1618; 1619; 1620; 1621; 1622; 1623; 1624;
+    1625; 1626; 1627; 1628; 1629; 1630; 1631; 1632; 1633; 1634; 1635; 1636; 1637;
+    1638; 1639; 1640; 1641; 1642; 1643; 1644; 1645; 1646; 1647; 1648; 1649; 1650;
+    1651; 1652; 1653; 1654; 1655; 1656; 1657; 1658; 1659; 1660; 1661; 1662; 1663;
+    1664; 1665; 1666; 1667; 1668; 1669; 1670; 1671; 1672; 1673; 1674; 1675; 1676;
+    1677; 1678; 1679; 1680; 1681; 1682; 1683; 1684; 1685; 1686; 1687; 1688; 1689;
+    1690; 1691; 1692; 1693; 1694; 1695; 1696; 1697; 1698; 1699; 1700; 1701; 1702;
+    1703; 1704; 1705; 1706; 1707; 1708; 1709; 1710; 1711; 1712; 1713; 1714; 1715;
+    1716; 1717; 1718; 1719; 1720; 1721; 1722; 1723; 1724; 1725; 1726; 1727; 1728;
+    1729; 1730; 1731; 1732; 1733; 1734; 1735; 1736; 1737; 1738; 1739; 1740; 1741;
+    1742; 1743; 1744; 1745; 1746; 1747; 1748; 1749; 1750; 1751; 1752; 1753; 1754;
+    1755; 1756; 1757; 1758; 1759; 1760; 1761; 1762; 1763; 1764; 1765; 1766; 1767;
+    1768; 1769; 1770; 1771; 1772; 1773; 1774; 1775; 1776; 1777; 1778; 1779; 1780;
+    1781; 1782; 1783; 1784; 1785; 1786; 1787; 1788; 1789; 1790; 1791; 1792; 1793;
+    1794; 1795; 1796; 1797; 1798; 1799; 1800; 1801; 1802; 1803; 1804; 1805; 1806;
+    1807; 1808; 1809; 1810; 1811; 1812; 1813; 1814; 1815; 1816; 1817; 1818; 1819;
+    1820; 1821; 1822; 1823; 1824; 1825; 1826; 1827; 1828; 1829; 1830; 1831; 1832;
+    1833; 1834; 1835; 1836; 1837; 1838; 1839; 1840; 1841; 1842; 1843; 1844; 1845;
+    1846; 1847; 1848; 1849; 1850; 1851; 1852; 1853; 1854; 1855; 1856; 1857; 1858;
+    1859; 1860; 1861; 1862; 1863; 1864; 1865; 1866; 1867; 1868; 1869; 1870; 1871;
+    1872; 1873; 1874; 1875; 1876; 1877; 1878; 1879; 1880; 1881; 1882; 1883; 1884;
+    1885; 1886; 1887; 1888; 1889; 1890; 1891; 1892; 1893; 1894; 1895; 1896; 1897;
+    1898; 1899; 1900; 1901; 1902; 1903; 1904; 1905; 1906; 1907; 1908; 1909; 1910;
+    1911; 1912; 1913; 1914; 1915; 1916; 1917; 1918; 1919; 1920; 1921; 1922; 1923;
+    1924; 1925; 1926; 1927; 1928; 1929; 1930; 1931; 1932; 1933; 1934; 1935; 1936;
+    1937; 1938; 1939; 1940; 1941; 1942; 1943; 1944; 1945; 1946; 1947; 1948; 1949;
+    1950; 1951; 1952; 1953; 1954; 1955; 1956; 1957; 1958; 1959; 1960; 1961; 1962;
+    1963; 1964; 1965; 1966; 1967; 1968; 1969; 1970; 1971; 1972; 1973; 1974; 1975;
+    1976; 1977; 1978; 1979; 1980; 1981; 1982; 1983; 1984; 1985; 1986; 1987; 1988;
+    1989; 1990; 1991; 1992; 1993; 1994; 1995; 1996; 1997; 1998; 1999; 2000; 2001;
+    2002; 2003; 2004; 2005; 2006; 2007; 2008; 2009; 2010; 2011; 2012; 2013; 2014;
+    2015; 2016; 2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025; 2026; 2027;
+    2028; 2029; 2030; 2031; 2032; 2033; 2034; 2035; 2036; 2037; 2038; 2039; 2040;
+    2041; 2042; 2043; 2044; 2045; 2046; 2047; 2048; 2049; 2050; 2051; 2052; 2053;
+    2054; 2055; 2056; 2057; 2058; 2059; 2060; 2061; 2062; 2063; 2064; 2065; 2066;
+    2067; 2068; 2069; 2070; 2071; 2072; 2073; 2074; 2075; 2076; 2077; 2078; 2079;
+    2080; 2081; 2082; 2083; 2084; 2085; 2086; 2087; 2088; 2089; 2090; 2091; 2092;
+    2093; 2094; |]
+
+let () =
+  let long_array = Sys.opaque_identity long_array in
+  for i = 0 to Array.length long_array - 1 do
+    assert(long_array.(i) = i)
+  done
diff --git a/testsuite/tests/basic-more/structural_constants.reference b/testsuite/tests/basic-more/structural_constants.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/structural_constants.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/tbuffer.ml b/testsuite/tests/basic-more/tbuffer.ml
new file mode 100644
index 00000000..b8348575
--- /dev/null
+++ b/testsuite/tests/basic-more/tbuffer.ml
@@ -0,0 +1,26 @@
+(* Dummy substitute function. *)
+
+open Testing;;
+open Buffer;;
+
+let identity s = s;;
+
+let b = Buffer.create 100;;
+
+(* Pattern with a '\\' character in it. *)
+let pat0 = "\\\\a" in
+let n0 = String.length pat0 in
+
+Buffer.add_substitute b identity pat0;
+
+test (String.length (Buffer.contents b) = n0)
+;;
+
+(* Pattern with a '\\' character at the end. *)
+let pat1 = "b\\" in
+let n1 = String.length pat1 in
+
+Buffer.clear b;
+Buffer.add_substitute b identity pat1;
+test (String.length (Buffer.contents b) = n1)
+;;
diff --git a/testsuite/tests/basic-more/tbuffer.reference b/testsuite/tests/basic-more/tbuffer.reference
new file mode 100644
index 00000000..f0f68347
--- /dev/null
+++ b/testsuite/tests/basic-more/tbuffer.reference
@@ -0,0 +1,2 @@
+ 0 1
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml
new file mode 100644
index 00000000..8a7ab475
--- /dev/null
+++ b/testsuite/tests/basic-more/testrandom.ml
@@ -0,0 +1,12 @@
+open Random
+
+let _ =
+  for i = 0 to 20 do
+    print_char ' '; print_int (int 1000);
+  done;
+  print_newline ();  print_newline ();
+  for i = 0 to 20 do
+    print_char ' '; print_float (float 1000.);
+  done
+
+let _ = exit 0
diff --git a/testsuite/tests/basic-more/testrandom.reference b/testsuite/tests/basic-more/testrandom.reference
new file mode 100644
index 00000000..943addd1
--- /dev/null
+++ b/testsuite/tests/basic-more/testrandom.reference
@@ -0,0 +1,4 @@
+ 344 685 182 641 439 500 104 20 921 370 217 885 949 678 615 412 401 606 428 869 289
+
+ 122.128067547 461.324792129 360.006556146 768.75882284 396.500946942 190.217751234 567.660068681 403.59226778 59.8488223602 363.816246826 764.705761642 172.627051105 481.861849093 399.173195422 629.424106752 391.547032203 676.701133948 174.382120878 994.425675487 585.00027757 34.3270777955
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
new file mode 100644
index 00000000..7a628ed6
--- /dev/null
+++ b/testsuite/tests/basic-more/tformat.ml
@@ -0,0 +1,21 @@
+(*
+
+A testbed file for the module Format.
+
+*)
+
+open Testing;;
+
+open Format;;
+
+(* BR#4769 *)
+let test0 () =
+  let b = Buffer.create 10 in
+  let msg = "Hello world!" in
+  Format.bprintf b "%s" msg;
+  let s = Buffer.contents b in
+  s = msg
+;;
+
+test (test0 ())
+;;
diff --git a/testsuite/tests/basic-more/tformat.reference b/testsuite/tests/basic-more/tformat.reference
new file mode 100644
index 00000000..819c5ba6
--- /dev/null
+++ b/testsuite/tests/basic-more/tformat.reference
@@ -0,0 +1,2 @@
+ 0
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/top_level_patterns.ml b/testsuite/tests/basic-more/top_level_patterns.ml
new file mode 100644
index 00000000..6b9b83f1
--- /dev/null
+++ b/testsuite/tests/basic-more/top_level_patterns.ml
@@ -0,0 +1,8 @@
+
+type t =
+  | A of (int * int * int)
+  | B of int * int
+
+let (A (a, _, b) | B (b, a)) = A (1, 2, 3)
+
+let () = print_int a; print_int b
diff --git a/testsuite/tests/basic-more/top_level_patterns.reference b/testsuite/tests/basic-more/top_level_patterns.reference
new file mode 100644
index 00000000..93efd505
--- /dev/null
+++ b/testsuite/tests/basic-more/top_level_patterns.reference
@@ -0,0 +1,2 @@
+13
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml
new file mode 100644
index 00000000..13b54a9e
--- /dev/null
+++ b/testsuite/tests/basic-more/tprintf.ml
@@ -0,0 +1,75 @@
+open Testing;;
+
+open Printf;;
+
+(* Padding floating point numbers.
+   Testing * width specifications. *)
+let test0 () =
+  sprintf "%.0f" 1.0 = "1" &&
+  sprintf "%.0f." 1.7 = "2." &&
+  sprintf "%.1f." 1.0 = "1.0." &&
+  (*sprintf "%0.1f." 12.0 = "12.0." &&*)
+    (* >> '0' w/o padding *)
+  sprintf "%3.1f." 12.0 = "12.0." &&
+  sprintf "%5.1f." 12.0 = " 12.0." &&
+  sprintf "%10.1f." 12.0 = "      12.0." &&
+  sprintf "%010.1f." 12.0 = "00000012.0." &&
+  sprintf "% 10.1f." 12.0 = "      12.0." &&
+  sprintf "%+10.1f." 12.0 = "     +12.0." &&
+  sprintf "%+10.1f." (-12.0) = "     -12.0." &&
+
+  sprintf "%010.5f." 12.0 = "0012.00000." &&
+  sprintf "%010.0f." 12.0 = "0000000012." &&
+  sprintf "% 10.0f." 12.0 = "        12." &&
+
+  (*sprintf "%0.1f." 12.0 = "12.0." &&*)
+    (* >> '0' w/o padding *)
+  sprintf "%10.1f." 1.001 = "       1.0." &&
+  sprintf "%05.1f." 1.001 = "001.0."
+;;
+
+test (test0 ());;
+
+(* Padding integers (cf bug 3955).
+   Testing * width specifications. *)
+let test1 () =
+  sprintf "%d\n" 1 = "1\n" &&
+  sprintf "%05d\n" 1 = "00001\n" &&
+  sprintf "%*d\n" 5 1 = "    1\n" &&
+  sprintf "%0*d\n" 5 1 = "00001\n";;
+
+test (test1 ());;
+
+(* FIXME: when positional specification will be OK. *)
+let test2 () = true
+(*  sprintf "%1$d\n" 5 1 = "    1\n" &&
+  sprintf "%01$d\n" 5 1 = "00001\n" *);;
+
+test (test2 ());;
+
+(* Testing meta format string printing. *)
+let test3 () =
+  sprintf "%{toto %S titi.\n%}" "Bonjour %S." = "%s" &&
+  sprintf "%{Bonjour %S.%}" "toto %S titi.\n" = "%s"
+;;
+test (test3 ());;
+
+(* Testing meta format string arguments. *)
+let test4 () =
+  sprintf "%(%s%)" "Bonjour %s" "toto" = "Bonjour toto" &&
+  sprintf "%(%s%)" "Bonjour %s." "vous" = "Bonjour vous." &&
+  sprintf "%(%s%)" "Hello %s." "you" = "Hello you."
+;;
+
+test (test4 ());;
+
+let test5 () =
+  sprintf "%(toto %s titi.\n%)"
+    "Bonjour %s." "vous" = "Bonjour vous." &&
+  sprintf "%(toto %s titi.\n%).\n"
+    "Bonjour %s" "toto" = "Bonjour toto.\n" &&
+  sprintf "%(toto %s titi.\n%)%s\n"
+    "Bonjour %s." "toto" " Ca va?" = "Bonjour toto. Ca va?\n"
+;;
+
+test (test5 ());;
diff --git a/testsuite/tests/basic-more/tprintf.reference b/testsuite/tests/basic-more/tprintf.reference
new file mode 100644
index 00000000..1fb209d4
--- /dev/null
+++ b/testsuite/tests/basic-more/tprintf.reference
@@ -0,0 +1,2 @@
+ 0 1 2 3 4 5
+All tests succeeded.
diff --git a/testsuite/tests/basic-multdef/Makefile b/testsuite/tests/basic-multdef/Makefile
new file mode 100644
index 00000000..17dc2a5f
--- /dev/null
+++ b/testsuite/tests/basic-multdef/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=multdef
+MAIN_MODULE=usemultdef
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-multdef/multdef.ml b/testsuite/tests/basic-multdef/multdef.ml
new file mode 100644
index 00000000..46869c45
--- /dev/null
+++ b/testsuite/tests/basic-multdef/multdef.ml
@@ -0,0 +1,2 @@
+let f x = x + 1
+external g : string -> int = "caml_int_of_string"
diff --git a/testsuite/tests/basic-multdef/multdef.mli b/testsuite/tests/basic-multdef/multdef.mli
new file mode 100644
index 00000000..8d67a548
--- /dev/null
+++ b/testsuite/tests/basic-multdef/multdef.mli
@@ -0,0 +1,3 @@
+val f : int -> int
+val f : int -> int
+val g : string -> int
diff --git a/testsuite/tests/basic-multdef/usemultdef.ml b/testsuite/tests/basic-multdef/usemultdef.ml
new file mode 100644
index 00000000..2bccabb6
--- /dev/null
+++ b/testsuite/tests/basic-multdef/usemultdef.ml
@@ -0,0 +1 @@
+let _ = print_int(Multdef.f 1); print_newline(); exit 0
diff --git a/testsuite/tests/basic-multdef/usemultdef.reference b/testsuite/tests/basic-multdef/usemultdef.reference
new file mode 100644
index 00000000..0cfbf088
--- /dev/null
+++ b/testsuite/tests/basic-multdef/usemultdef.reference
@@ -0,0 +1 @@
+2
diff --git a/testsuite/tests/basic-private/Makefile b/testsuite/tests/basic-private/Makefile
new file mode 100644
index 00000000..1deeb9ca
--- /dev/null
+++ b/testsuite/tests/basic-private/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+MODULES=length
+MAIN_MODULE=tlength
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-private/length.ml b/testsuite/tests/basic-private/length.ml
new file mode 100644
index 00000000..c36e6702
--- /dev/null
+++ b/testsuite/tests/basic-private/length.ml
@@ -0,0 +1,16 @@
+(*
+
+A testbed file for private type abbreviation definitions.
+
+We define a Length module to implement positive integers.
+
+*)
+
+type t = int;;
+
+let make x =
+  if x >= 0 then x else
+  failwith (Printf.sprintf "cannot build negative length : %i" x)
+;;
+
+external from : t -> int = "%identity";;
diff --git a/testsuite/tests/basic-private/length.mli b/testsuite/tests/basic-private/length.mli
new file mode 100644
index 00000000..67d055db
--- /dev/null
+++ b/testsuite/tests/basic-private/length.mli
@@ -0,0 +1,13 @@
+(*
+
+A testbed file for private type abbreviation definitions.
+
+We define a Length module to implement positive integers.
+
+*)
+
+type t = private int;;
+
+val make : int -> t;;
+
+external from : t -> int = "%identity";;
diff --git a/testsuite/tests/basic-private/tlength.ml b/testsuite/tests/basic-private/tlength.ml
new file mode 100644
index 00000000..73f0bf95
--- /dev/null
+++ b/testsuite/tests/basic-private/tlength.ml
@@ -0,0 +1,23 @@
+(*
+
+A testbed file for private type abbreviation definitions.
+
+We test the Length module that implements positive integers.
+
+*)
+
+(* We can build a null length. *)
+let l = Length.make 0;;
+
+
+(* We cannot build a negative length. *)
+try ignore (Length.make (-1)); assert false with
+| Failure _ -> ()
+;;
+
+
+(* We can build a positive length. *)
+let l3 = Length.make 3 in
+
+(* and use the associated injection and projection functions. *)
+Length.make (Length.from l3 + Length.from l3);;
diff --git a/testsuite/tests/basic-private/tlength.reference b/testsuite/tests/basic-private/tlength.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
new file mode 100644
index 00000000..446664a9
--- /dev/null
+++ b/testsuite/tests/basic/Makefile
@@ -0,0 +1,33 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+all: pr6322.ml check
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=pr6322.ml *.safe-string
+
+pr6322.ml: $(SAFE_STRING).safe-string
+ifeq ($(SAFE_STRING),false)
+	@cat pr6322.ml.in > $@
+else
+	@echo "Printf.printf \"PR#6322=Ok\\n%!\"" > $@
+endif
+
+%.safe-string:
+	@rm -f pr6322.ml
+	@touch $@
diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml
new file mode 100644
index 00000000..1ec4e4eb
--- /dev/null
+++ b/testsuite/tests/basic/arrays.ml
@@ -0,0 +1,137 @@
+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";
+  if not (testcopy (bigarray 42)) then
+    print_string "Test2: failed on big 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.make 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 test4 () =
+  let a = bigarray 0 in
+  let b = Array.sub a 50 10 in
+  if b <> [| 50;51;52;53;54;55;56;57;58;59 |] then
+    print_string "Test4: failed\n"
+
+let test5 () =
+  if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then
+    print_string "Test5: failed on int arrays\n";
+  if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |]
+  then
+    print_string "Test5: failed on float arrays\n"
+
+let test6 () =
+  let a = [| 0;1;2;3;4;5;6;7;8;9 |] in
+  let b = Array.concat [a;a;a;a;a;a;a;a;a;a] in
+  if not (Array.length b = 100 && b.(6) = 6 && b.(42) = 2 && b.(99) = 9) then
+    print_string "Test6: failed\n"
+
+let test7 () =
+  let a = Array.make 10 "a" in
+  let b = [| "b1"; "b2"; "b3" |] in
+  Array.blit b 0 a 5 3;
+  if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b2"; "b3"; "a"; "a"|]
+  || b <> [|"b1"; "b2"; "b3"|]
+  then print_string "Test7: failed(1)\n";
+  Array.blit a 5 a 6 4;
+  if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b1"; "b2"; "b3"; "a"|]
+  then print_string "Test7: failed(2)\n"
+
+let test8 () =
+  (try
+    ignore (Array.sub [||] 0 1); print_string "Test 8.1: failed\n"
+  with Invalid_argument _ -> ());
+  (try
+    ignore (Array.sub [|3;4|] 1 (-1)); print_string "Test 8.2: failed\n"
+  with Invalid_argument _ -> ());
+  (try
+    ignore (Array.sub [|3;4|] max_int 1); print_string "Test 8.3: failed\n"
+  with Invalid_argument _ -> ());
+  (try
+    ignore (Array.sub [|3;4|] (-1) 1); print_string "Test 8.4: failed\n"
+  with Invalid_argument _ -> ())
+
+let _ =
+  test1();
+  test2();
+  test3();
+  test4();
+  test5();
+  test6();
+  test7();
+  test8();
+  exit 0
diff --git a/testsuite/tests/basic/arrays.reference b/testsuite/tests/basic/arrays.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/bigints.ml b/testsuite/tests/basic/bigints.ml
new file mode 100644
index 00000000..23e571c3
--- /dev/null
+++ b/testsuite/tests/basic/bigints.ml
@@ -0,0 +1,25 @@
+let _ =
+  match Sys.word_size with
+  | 32 ->
+     print_int (1 * 1000000000); print_newline();
+     print_string "10000000000"; print_newline();
+     print_string "100000000000"; print_newline();
+     print_string "1000000000000"; print_newline();
+     print_string "10000000000000"; print_newline();
+     print_string "100000000000000"; print_newline();
+     print_string "1000000000000000"; print_newline();
+     print_string "10000000000000000"; print_newline();
+     print_string "100000000000000000"; print_newline();
+     print_string "1000000000000000000"; print_newline();
+  | 64 ->
+     print_int (1 * 1000000000); print_newline();
+     print_int (10 * 1000000000); print_newline();
+     print_int (100 * 1000000000); print_newline();
+     print_int (1000 * 1000000000); print_newline();
+     print_int (10000 * 1000000000); print_newline();
+     print_int (100000 * 1000000000); print_newline();
+     print_int (1000000 * 1000000000); print_newline();
+     print_int (10000000 * 1000000000); print_newline();
+     print_int (100000000 * 1000000000); print_newline();
+     print_int (1000000000 * 1000000000); print_newline()
+  | _ -> assert false
diff --git a/testsuite/tests/basic/bigints.reference b/testsuite/tests/basic/bigints.reference
new file mode 100644
index 00000000..512fd476
--- /dev/null
+++ b/testsuite/tests/basic/bigints.reference
@@ -0,0 +1,10 @@
+1000000000
+10000000000
+100000000000
+1000000000000
+10000000000000
+100000000000000
+1000000000000000
+10000000000000000
+100000000000000000
+1000000000000000000
diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml
new file mode 100644
index 00000000..016916f4
--- /dev/null
+++ b/testsuite/tests/basic/boxedints.ml
@@ -0,0 +1,581 @@
+(* 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
+  val skip_float_tests: bool
+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, "1073741824"; 6, "2147483647"; 7, "-2147483648"];
+    List.iter (fun (n, s) -> test n (format "0x%X" (of_string s)) s)
+      [8, "0x0"; 9, "0x123"; 10, "0xABCDEF"; 11, "0x12345678";
+       12, "0x7FFFFFFF"; 13, "0x80000000"; 14, "0xFFFFFFFF"];
+    test 15 (to_string max_int) "2147483647";
+    test 16 (to_string min_int) "-2147483648";
+    test 17 (to_string zero) "0";
+    test 18 (to_string one) "1";
+    test 19 (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, 127531236, 365;
+       7, 16384, 256;
+       8, -127531236, 365;
+       9, 127531236, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+    test 12 (div min_int (of_int (-1))) min_int;
+
+    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, 127531236, 365;
+       7, 16384, 256;
+       8, -127531236, 365;
+       9, 127531236, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+    test 12 (rem min_int (of_int (-1))) (of_int 0);
+
+    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"];
+
+    if not (skip_float_tests) then begin
+      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)
+    end;
+
+    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)
+      [8, "0x0"; 9, "0x123"; 10, "0xABCDEF"; 11, "0x1234567812345678";
+       12, "0x7FFFFFFFFFFFFFFF"; 13, "0x8000000000000000";
+       14, "0xFFFFFFFFFFFFFFFF"];
+    test 15 (to_string max_int) "9223372036854775807";
+    test 16 (to_string min_int) "-9223372036854775808";
+    test 17 (to_string zero) "0";
+    test 18 (to_string one) "1";
+    test 19 (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, 127531236, 365;
+       7, 16384, 256;
+       8, -127531236, 365;
+       9, 127531236, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+    test 12 (div min_int (of_int (-1))) min_int;
+
+    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, 127531236, 365;
+       7, 16384, 256;
+       8, -127531236, 365;
+       9, 127531236, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+    test 12 (rem min_int (of_int (-1))) (of_int 0);
+
+    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
+                               let skip_float_tests = false end) in
+  print_newline(); testing_function "-------- Int64 --------";
+  let module B = Test64(struct type t = int64
+                               module Ops = Int64
+                               let testcomp = testcomp_int64
+                               let skip_float_tests = false 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
+                      let skip_float_tests = true end)
+      in ()
+  | 64 ->
+      let module C =
+        Test64(struct type t = nativeint
+                      module Ops = Nativeint
+                      let testcomp = testcomp_nativeint
+                      let skip_float_tests = true 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");
+  if Sys.word_size = 64 then
+  test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0"))
+         (Int32.of_string "0x9ABCDEF0")
+  else
+  test 3 0 0; (* placeholder to have the same output on 32-bit and 64-bit *)
+  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"))
+         (if Sys.word_size = 64
+          then Nativeint.of_string "0x123456789ABCDEF0"
+          else Nativeint.of_string "0x9ABCDEF0")
+
+(********* End of test *********)
+
+let _ =
+  print_newline();
+  if !error_occurred then begin
+    prerr_endline "************* TEST FAILED ****************"; exit 2
+  end else
+    exit 0
diff --git a/testsuite/tests/basic/boxedints.reference b/testsuite/tests/basic/boxedints.reference
new file mode 100644
index 00000000..009390fa
--- /dev/null
+++ b/testsuite/tests/basic/boxedints.reference
@@ -0,0 +1,118 @@
+
+-------- Int32 --------
+
+of_int, to_int
+ 1... 2... 3... 4... 5...
+of_string
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+to_string, format
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19...
+neg
+ 1... 2... 3... 4... 5... 6...
+add
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+sub
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+mul
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+div
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+mod
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+and
+ 1... 2... 3... 4... 5...
+or
+ 1... 2... 3... 4... 5...
+xor
+ 1... 2... 3... 4... 5...
+shift_left
+ 1... 2... 3... 4... 5... 6... 7... 8...
+shift_right
+ 1... 2... 3... 4... 5... 6... 7...
+shift_right_logical
+ 1... 2... 3... 4... 5... 6... 7...
+of_float
+ 1... 2... 3... 4... 5... 6... 7...
+to_float
+ 1... 2... 3... 4... 5...
+Comparisons
+ 1... 2... 3... 4... 5... 6... 7...
+
+-------- Int64 --------
+
+of_int, to_int
+ 1... 2... 3... 4... 5...
+of_string
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+to_string, format
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19...
+neg
+ 1... 2... 3... 4... 5... 6...
+add
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+sub
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+mul
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+div
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+mod
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+and
+ 1... 2... 3... 4... 5...
+or
+ 1... 2... 3... 4... 5...
+xor
+ 1... 2... 3... 4... 5...
+shift_left
+ 1... 2... 3... 4... 5... 6... 7... 8...
+shift_right
+ 1... 2... 3... 4... 5... 6... 7...
+shift_right_logical
+ 1... 2... 3... 4... 5... 6... 7...
+Comparisons
+ 1... 2... 3... 4... 5... 6... 7...
+
+-------- Nativeint --------
+
+of_int, to_int
+ 1... 2... 3... 4... 5...
+of_string
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+to_string, format
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19...
+neg
+ 1... 2... 3... 4... 5... 6...
+add
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+sub
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+mul
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+div
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+mod
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+and
+ 1... 2... 3... 4... 5...
+or
+ 1... 2... 3... 4... 5...
+xor
+ 1... 2... 3... 4... 5...
+shift_left
+ 1... 2... 3... 4... 5... 6... 7... 8...
+shift_right
+ 1... 2... 3... 4... 5... 6... 7...
+shift_right_logical
+ 1... 2... 3... 4... 5... 6... 7...
+Comparisons
+ 1... 2... 3... 4... 5... 6... 7...
+
+--------- Conversions -----------
+
+nativeint of/to int32
+ 1... 2... 3...
+int64 of/to int32
+ 1... 2... 3...
+int64 of/to nativeint
+ 1... 2... 3...
diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml
new file mode 100644
index 00000000..89d98883
--- /dev/null
+++ b/testsuite/tests/basic/constprop.ml
@@ -0,0 +1,104 @@
+(* Test constant propagation through inlining *)
+
+(* constprop.ml is generated from constprop.mlp using
+      cpp constprop.mlp > constprop.ml
+*)
+let do_test msg res1 res2 =
+  Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED")
+(* Hide a constant from the optimizer, preventing constant propagation *)
+let hide x = List.nth [x] 0
+let _ =
+  begin
+    let x = true and y = false in
+    let xh = hide x and yh = hide y in
+    do_test "booleans" ((x && y, x || y, not x)) ((xh && yh, xh || yh, not xh))
+  end;
+  begin
+    let x = 89809344 and y = 457455773 and s = 7 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "integers"
+      ((-x, x + y, x - y, x * y, x / y, x mod y, x land y,
+        x lor y, x lxor y, x lsl s, x lsr s, x asr s, x = y,
+        x <> y, x < y, x <= y, x > y, x >= y, succ x, pred y))
+      ((-xh, xh + yh, xh - yh, xh * yh, xh / yh, xh mod yh, xh land yh,
+        xh lor yh, xh lxor yh, xh lsl sh, xh lsr sh, xh asr sh, xh = yh,
+        xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh, succ xh, pred yh))
+  end;
+  begin
+    let x = 3.141592654 and y = 0.341638588598232096 in
+    let xh = hide x and yh = hide y in
+    do_test "floats"
+      ((int_of_float x, x +. y, x -. y, x *. y, x /. y, x = y,
+        x <> y, x < y, x <= y, x > y, x >= y))
+      ((int_of_float xh, xh +. yh, xh -. yh, xh *. yh, xh /. yh, xh = yh,
+        xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 781944104l and y = 308219921l and s = 3 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "32-bit integers"
+      (Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y,
+              logand x y, logor x y, logxor x y, shift_left x s,
+              shift_right x s, shift_right_logical x s, x = y, x <> y,
+              x < y, x <= y, x > y, x >= y))
+      (Int32.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh,
+              logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh,
+              shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh,
+              xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 1828697041n and y = -521695949n and s = 8 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "native integers"
+      (Nativeint.(neg x, add x y, sub x y, mul x y, div x y,
+                  rem x y, logand x y, logor x y, logxor x y,
+                  shift_left x s, shift_right x s,
+                  shift_right_logical x s, x = y, x <> y, x < y,
+                  x <= y, x > y, x >= y))
+      (Nativeint.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh,
+                  rem xh yh, logand xh yh, logor xh yh, logxor xh yh,
+                  shift_left xh sh, shift_right xh sh,
+                  shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh,
+                  xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "64-bit integers"
+      (Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y,
+              logand x y, logor x y, logxor x y, shift_left x s,
+              shift_right x s, shift_right_logical x s, x = y, x <> y,
+              x < y, x <= y, x > y, x >= y))
+      (Int64.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh,
+              logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh,
+              shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh,
+              xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 1000807289 in
+    let xh = hide x in
+    do_test "integer conversions"
+      ((float_of_int x, Int32.of_int x, Nativeint.of_int x, Int64.of_int x))
+      ((float_of_int xh, Int32.of_int xh, Nativeint.of_int xh, Int64.of_int xh))
+  end;
+  begin
+    let x = 10486393l in
+    let xh = hide x in
+    do_test "32-bit integer conversions"
+      ((Int32.to_int x, Nativeint.of_int32 x, Int64.of_int32 x))
+      ((Int32.to_int xh, Nativeint.of_int32 xh, Int64.of_int32 xh))
+  end;
+  begin
+    let x = -131134014n in
+    let xh = hide x in
+    do_test "native integer conversions"
+      ((Nativeint.to_int x, Nativeint.to_int32 x, Int64.of_nativeint x))
+      ((Nativeint.to_int xh, Nativeint.to_int32 xh, Int64.of_nativeint xh))
+  end;
+  begin
+    let x = 531871273453404175L in
+    let xh = hide x in
+    do_test "64-bit integer conversions"
+      ((Int64.to_int x, Int64.to_int32 x, Int64.to_nativeint x))
+      ((Int64.to_int xh, Int64.to_int32 xh, Int64.to_nativeint xh))
+  end
diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp
new file mode 100644
index 00000000..f08bc50f
--- /dev/null
+++ b/testsuite/tests/basic/constprop.mlp
@@ -0,0 +1,117 @@
+(* Test constant propagation through inlining *)
+
+(* constprop.ml is generated from constprop.mlp using
+      cpp constprop.mlp > constprop.ml
+*)
+
+#define tbool(x,y) \
+  (x && y, x || y, not x)
+
+#define tint(x,y,s)                                                         \
+  (-x, x + y, x - y, x * y, x / y, x mod y,                                 \
+   x land y, x lor y, x lxor y,                                             \
+   x lsl s, x lsr s, x asr s,                                               \
+   x = y, x <> y, x < y, x <= y, x > y, x >= y,                             \
+   succ x, pred y)
+
+#define tfloat(x,y)                                                         \
+  (int_of_float x,                                                          \
+   x +. y, x -. y, x *. y, x /. y,                                          \
+   x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tconvint(i)                                                         \
+  (float_of_int i,                                                          \
+   Int32.of_int i,                                                          \
+   Nativeint.of_int i,                                                      \
+   Int64.of_int i)
+
+#define tconvint32(i)                                                       \
+  (Int32.to_int i,                                                          \
+   Nativeint.of_int32 i,                                                    \
+   Int64.of_int32 i)
+
+#define tconvnativeint(i)                                                   \
+  (Nativeint.to_int i,                                                      \
+   Nativeint.to_int32 i,                                                    \
+   Int64.of_nativeint i)
+
+#define tconvint64(i)                                                       \
+  (Int64.to_int i,                                                          \
+   Int64.to_int32 i,                                                        \
+   Int64.to_nativeint i)                                                    \
+
+#define tint32(x,y,s)                                                       \
+  Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y,                \
+         logand x y, logor x y, logxor x y,                                 \
+         shift_left x s, shift_right x s, shift_right_logical x s,          \
+         x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tnativeint(x,y,s)                                                   \
+  Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y,            \
+         logand x y, logor x y, logxor x y,                                 \
+         shift_left x s, shift_right x s, shift_right_logical x s,          \
+         x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tint64(x,y,s)                                                       \
+  Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y,                \
+         logand x y, logor x y, logxor x y,                                 \
+         shift_left x s, shift_right x s, shift_right_logical x s,          \
+         x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+let do_test msg res1 res2 =
+  Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED")
+
+(* Hide a constant from the optimizer, preventing constant propagation *)
+let hide x = List.nth [x] 0
+
+let _ =
+  begin
+    let x = true and y = false in
+    let xh = hide x and yh = hide y in
+    do_test "booleans" (tbool(x, y)) (tbool(xh,yh))
+  end;
+  begin
+    let x = 89809344 and y = 457455773 and s = 7 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh))
+  end;
+  begin
+    let x = 3.141592654 and y = 0.341638588598232096 in
+    let xh = hide x and yh = hide y in
+    do_test "floats" (tfloat(x, y)) (tfloat(xh, yh))
+  end;
+  begin
+    let x = 781944104l and y = 308219921l and s = 3 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh))
+  end;
+  begin
+    let x = 1828697041n and y = -521695949n and s = 8 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh))
+  end;
+  begin
+    let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh))
+  end;
+  begin
+    let x = 1000807289 in
+    let xh = hide x in
+    do_test "integer conversions" (tconvint(x)) (tconvint(xh))
+  end;
+  begin
+    let x = 10486393l in
+    let xh = hide x in
+    do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh))
+  end;
+  begin
+    let x = -131134014n in
+    let xh = hide x in
+    do_test "native integer conversions" (tconvnativeint(x))(tconvnativeint(xh))
+  end;
+  begin
+    let x = 531871273453404175L in
+    let xh = hide x in
+    do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh))
+  end
diff --git a/testsuite/tests/basic/constprop.reference b/testsuite/tests/basic/constprop.reference
new file mode 100644
index 00000000..59590530
--- /dev/null
+++ b/testsuite/tests/basic/constprop.reference
@@ -0,0 +1,10 @@
+booleans: passed
+integers: passed
+floats: passed
+32-bit integers: passed
+native integers: passed
+64-bit integers: passed
+integer conversions: passed
+32-bit integer conversions: passed
+native integer conversions: passed
+64-bit integer conversions: passed
diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml
new file mode 100644
index 00000000..c007edae
--- /dev/null
+++ b/testsuite/tests/basic/divint.ml
@@ -0,0 +1,145 @@
+open Printf
+
+(* Test integer division and modulus, esp. ocamlopt's optimization
+   when the divisor is a constant. *)
+
+let error = ref false
+
+module WithInt = struct
+
+let d = ref 0
+let divref n = n / !d
+let modref n = n mod !d
+
+let test_one (df: int -> int) (mf: int -> int) x =
+  if not (df x = divref x && mf x = modref x) then begin
+    printf "mismatch for %d\n" x;
+    error := true
+  end
+
+let do_test divisor (df: int -> int) (mf: int -> int) =
+  d := divisor;
+  List.iter (test_one df mf)
+    [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10;
+     100; 1000; 10000; 100000; 1000000; max_int - 1; max_int;
+     -1; -2; -3; -4; -5; -6; -7; -8; -9; -10;
+     -100; -1000; -10000; -100000; -1000000; min_int + 1; min_int];
+  let seed = ref 0 in
+  for i = 1 to 1000 do
+    seed := !seed * 69069 + 25173;
+    test_one df mf !seed
+  done
+
+end
+
+module WithNat = struct
+
+let d = ref 0n
+let divref n = Nativeint.div n !d
+let modref n = Nativeint.rem n !d
+
+let test_one (df: nativeint -> nativeint) (mf: nativeint -> nativeint) x =
+  if not (df x = divref x && mf x = modref x) then begin
+    printf "mismatch for %nd\n" x;
+    error := true
+  end
+
+let do_test divisor (df: nativeint -> nativeint) (mf: nativeint -> nativeint) =
+  d := Nativeint.of_int divisor;
+  List.iter (test_one df mf)
+    [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n;
+     100n; 1000n; 10000n; 100000n; 1000000n;
+     Nativeint.(pred max_int); Nativeint.max_int;
+     -1n; -2n; -3n; -4n; -5n; -6n; -7n; -8n; -9n; -10n;
+     -100n; -1000n; -10000n; -100000n; -1000000n;
+     Nativeint.(succ min_int); Nativeint.min_int];
+  let seed = ref 0n in
+  for i = 1 to 1000 do
+    seed := Nativeint.(add (mul !seed 69069n) 25173n);
+    test_one df mf !seed
+  done
+
+end
+
+let _ =
+  printf "1 int\n"; WithInt.do_test 1 (fun x -> x / 1)(fun x -> x mod 1);
+  printf "2 int\n"; WithInt.do_test 2 (fun x -> x / 2)(fun x -> x mod 2);
+  printf "3 int\n"; WithInt.do_test 3 (fun x -> x / 3)(fun x -> x mod 3);
+  printf "4 int\n"; WithInt.do_test 4 (fun x -> x / 4)(fun x -> x mod 4);
+  printf "5 int\n"; WithInt.do_test 5 (fun x -> x / 5)(fun x -> x mod 5);
+  printf "6 int\n"; WithInt.do_test 6 (fun x -> x / 6)(fun x -> x mod 6);
+  printf "7 int\n"; WithInt.do_test 7 (fun x -> x / 7)(fun x -> x mod 7);
+  printf "9 int\n"; WithInt.do_test 9 (fun x -> x / 9)(fun x -> x mod 9);
+  printf "10 int\n"; WithInt.do_test 10 (fun x -> x / 10)(fun x -> x mod 10);
+  printf "11 int\n"; WithInt.do_test 11 (fun x -> x / 11)(fun x -> x mod 11);
+  printf "12 int\n"; WithInt.do_test 12 (fun x -> x / 12)(fun x -> x mod 12);
+  printf "25 int\n"; WithInt.do_test 25 (fun x -> x / 25)(fun x -> x mod 25);
+  printf "55 int\n"; WithInt.do_test 55 (fun x -> x / 55)(fun x -> x mod 55);
+  printf "125 int\n";
+  WithInt.do_test 125 (fun x -> x / 125)(fun x -> x mod 125);
+  printf "625 int\n";
+  WithInt.do_test 625 (fun x -> x / 625)(fun x -> x mod 625);
+  printf "-1 int\n";
+  WithInt.do_test (-1) (fun x -> x / (-1))(fun x -> x mod (-1));
+  printf "-2 int\n";
+  WithInt.do_test (-2) (fun x -> x / (-2))(fun x -> x mod (-2));
+  printf "-3 int\n";
+  WithInt.do_test (-3) (fun x -> x / (-3))(fun x -> x mod (-3));
+
+  printf "1 nat\n";
+  WithNat.do_test 1 (fun x -> Nativeint.div x 1n)(fun x -> Nativeint.rem x 1n);
+  printf "2 nat\n";
+  WithNat.do_test 2 (fun x -> Nativeint.div x 2n)(fun x -> Nativeint.rem x 2n);
+  printf "3 nat\n";
+  WithNat.do_test 3 (fun x -> Nativeint.div x 3n)(fun x -> Nativeint.rem x 3n);
+  printf "4 nat\n";
+  WithNat.do_test 4 (fun x -> Nativeint.div x 4n)(fun x -> Nativeint.rem x 4n);
+  printf "5 nat\n";
+  WithNat.do_test 5 (fun x -> Nativeint.div x 5n)(fun x -> Nativeint.rem x 5n);
+  printf "6 nat\n";
+  WithNat.do_test 6 (fun x -> Nativeint.div x 6n)(fun x -> Nativeint.rem x 6n);
+  printf "7 nat\n";
+  WithNat.do_test 7 (fun x -> Nativeint.div x 7n)(fun x -> Nativeint.rem x 7n);
+  printf "9 nat\n";
+  WithNat.do_test 9 (fun x -> Nativeint.div x 9n)(fun x -> Nativeint.rem x 9n);
+  printf "10 nat\n";
+  WithNat.do_test 10 (fun x -> Nativeint.div x 10n)
+                     (fun x -> Nativeint.rem x 10n);
+  printf "11 nat\n";
+  WithNat.do_test 11 (fun x -> Nativeint.div x 11n)
+                     (fun x -> Nativeint.rem x 11n);
+  printf "12 nat\n";
+  WithNat.do_test 12 (fun x -> Nativeint.div x 12n)
+                     (fun x -> Nativeint.rem x 12n);
+  printf "25 nat\n";
+  WithNat.do_test 25 (fun x -> Nativeint.div x 25n)
+                     (fun x -> Nativeint.rem x 25n);
+  printf "55 nat\n";
+  WithNat.do_test 55 (fun x -> Nativeint.div x 55n)
+                     (fun x -> Nativeint.rem x 55n);
+  printf "125 nat\n";
+  WithNat.do_test 125 (fun x -> Nativeint.div x 125n)
+                      (fun x -> Nativeint.rem x 125n);
+  printf "625 nat\n";
+  WithNat.do_test 625 (fun x -> Nativeint.div x 625n)
+                      (fun x -> Nativeint.rem x 625n);
+  printf "-1 nat\n";
+  WithNat.do_test (-1) (fun x -> Nativeint.div x (-1n))
+                       (fun x -> Nativeint.rem x (-1n));
+  printf "-2 nat\n";
+  WithNat.do_test (-2) (fun x -> Nativeint.div x (-2n))
+                       (fun x -> Nativeint.rem x (-2n));
+  printf "-3 nat\n";
+  WithNat.do_test (-3) (fun x -> Nativeint.div x (-3n))
+                       (fun x -> Nativeint.rem x (-3n));
+
+  if !error then printf "TEST FAILED.\n" else printf "Test passed.\n"
+
+(* PR#6879 *)
+let f n = assert (1 mod n = 0)
+let () = f 1
+
+
+type t = {x: int; y:int}
+let f x = {x; y = x/0}.x
+let () = try ignore (f 1); assert false with Division_by_zero -> ()
diff --git a/testsuite/tests/basic/divint.reference b/testsuite/tests/basic/divint.reference
new file mode 100644
index 00000000..e9a6387f
--- /dev/null
+++ b/testsuite/tests/basic/divint.reference
@@ -0,0 +1,37 @@
+1 int
+2 int
+3 int
+4 int
+5 int
+6 int
+7 int
+9 int
+10 int
+11 int
+12 int
+25 int
+55 int
+125 int
+625 int
+-1 int
+-2 int
+-3 int
+1 nat
+2 nat
+3 nat
+4 nat
+5 nat
+6 nat
+7 nat
+9 nat
+10 nat
+11 nat
+12 nat
+25 nat
+55 nat
+125 nat
+625 nat
+-1 nat
+-2 nat
+-3 nat
+Test passed.
diff --git a/testsuite/tests/basic/equality.ml b/testsuite/tests/basic/equality.ml
new file mode 100644
index 00000000..ebf5cf43
--- /dev/null
+++ b/testsuite/tests/basic/equality.ml
@@ -0,0 +1,104 @@
+let test n check res =
+  print_string "Test "; print_int n;
+  if check res then print_string " passed.\n" else print_string " FAILED.\n";
+  flush stderr
+
+let eq0 = function 0 -> true | _ -> false
+let eqm1 = function -1 -> true | _ -> false
+let eq1 = function 1 -> true | _ -> false
+let eqtrue (b:bool) = b
+let eqftffff =
+  function (false,true,false,false,false,false) -> true | _ -> false
+
+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 eq0 (compare 0 0);
+  test 2 eqm1 (compare 0 1);
+  test 3 eq1 (compare 1 0);
+  test 4 eq0 (compare max_int max_int);
+  test 5 eqm1 (compare min_int max_int);
+  test 6 eq1 (compare max_int min_int);
+  test 7 eq0 (compare "foo" "foo");
+  test 8 eqm1 (compare "foo" "zorglub");
+  test 9 eqm1 (compare "abcdef" "foo");
+  test 10 eqm1 (compare "abcdefghij" "abcdefghijkl");
+  test 11 eq1 (compare "abcdefghij" "abcdefghi");
+  test 12 eq0 (compare (0,1) (0,1));
+  test 13 eqm1 (compare (0,1) (0,2));
+  test 14 eqm1 (compare (0,1) (1,0));
+  test 15 eq1 (compare (0,1) (0,0));
+  test 16 eq1 (compare (1,0) (0,1));
+  test 17 eq0 (compare 0.0 0.0);
+  test 18 eqm1 (compare 0.0 1.0);
+  test 19 eqm1 (compare (-1.0) 0.0);
+  test 20 eq0 (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 2.0 |]);
+  test 21 eqm1 (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 3.0 |]);
+  test 22 eq1 (compare [| 0.0; 5.0; 2.0 |] [| 0.0; 1.0; 2.0 |]);
+  test 23 eq0 (compare [1;2;3;4] [1;2;3;4]);
+  test 24 eqm1 (compare [1;2;3;4] [1;2;5;6]);
+  test 25 eqm1 (compare [1;2;3;4] [1;2;3;4;5]);
+  test 26 eq1 (compare [1;2;3;4] [1;2;3]);
+  test 27 eq1 (compare [1;2;3;4] [1;2;0;4]);
+  test 28 eq0 (compare (mklist 1000) (mklist 1000));
+  test 29 eq0 (compare (mkleftlist 1000) (mkleftlist 1000));
+  test 30 eq0 (compare (mktree 12) (mktree 12));
+  test 31 eqtrue (x = f []);
+  test 32 eqtrue (stdout <> stderr);
+  test 33 eqm1 (compare nan 0.0);
+  test 34 eqm1 (compare nan neg_infinity);
+  test 35 eq0 (compare nan nan);
+  test 36 eqm1 (compare (0.0, nan) (0.0, 0.0));
+  test 37 eqm1 (compare (0.0, nan) (0.0, neg_infinity));
+  test 38 eq0 (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 eqftffff (cmpgen nan nan);
+  test 40 eqftffff (cmpgen nan 0.0);
+  test 41 eqftffff (cmpfloat nan nan);
+  test 42 eqftffff (cmpfloat nan 0.0);
+  test 43 eqtrue ([||] = [||]);
+  (* Convoluted forms to test both the "positive" and "negative" cases
+     of float tests *)
+  let cmpfloatpos (x:float) (y:float) =
+    ((let r = ref false in (if x = y then r := true); !r),
+     (let r = ref false in (if x <> y then r := true); !r),
+     (let r = ref false in (if x < y then r := true); !r),
+     (let r = ref false in (if x <= y then r := true); !r),
+     (let r = ref false in (if x > y then r := true); !r),
+     (let r = ref false in (if x >= y then r := true); !r))
+  and cmpfloatneg (x:float) (y:float) =
+    ((let r = ref true in (if not (x = y) then r := false); !r),
+     (let r = ref true in (if not (x <> y) then r := false); !r),
+     (let r = ref true in (if not (x < y) then r := false); !r),
+     (let r = ref true in (if not (x <= y) then r := false); !r),
+     (let r = ref true in (if not (x > y) then r := false); !r),
+     (let r = ref true in (if not (x >= y) then r := false); !r)) in
+  let testcmpfloat x y =
+    cmpfloatpos x y = cmpgen x y &&
+    cmpfloatneg x y = cmpgen x y in
+  test 50 eqtrue (testcmpfloat nan nan);
+  test 51 eqtrue (testcmpfloat nan 0.0);
+  test 52 eqtrue (testcmpfloat 0.0 nan);
+  test 53 eqtrue (testcmpfloat 0.0 0.0);
+  test 54 eqtrue (testcmpfloat 1.0 0.0);
+  test 55 eqtrue (testcmpfloat 0.0 1.0)
diff --git a/testsuite/tests/basic/equality.reference b/testsuite/tests/basic/equality.reference
new file mode 100644
index 00000000..6070a6b0
--- /dev/null
+++ b/testsuite/tests/basic/equality.reference
@@ -0,0 +1,49 @@
+Test 1 passed.
+Test 2 passed.
+Test 3 passed.
+Test 4 passed.
+Test 5 passed.
+Test 6 passed.
+Test 7 passed.
+Test 8 passed.
+Test 9 passed.
+Test 10 passed.
+Test 11 passed.
+Test 12 passed.
+Test 13 passed.
+Test 14 passed.
+Test 15 passed.
+Test 16 passed.
+Test 17 passed.
+Test 18 passed.
+Test 19 passed.
+Test 20 passed.
+Test 21 passed.
+Test 22 passed.
+Test 23 passed.
+Test 24 passed.
+Test 25 passed.
+Test 26 passed.
+Test 27 passed.
+Test 28 passed.
+Test 29 passed.
+Test 30 passed.
+Test 31 passed.
+Test 32 passed.
+Test 33 passed.
+Test 34 passed.
+Test 35 passed.
+Test 36 passed.
+Test 37 passed.
+Test 38 passed.
+Test 39 passed.
+Test 40 passed.
+Test 41 passed.
+Test 42 passed.
+Test 43 passed.
+Test 50 passed.
+Test 51 passed.
+Test 52 passed.
+Test 53 passed.
+Test 54 passed.
+Test 55 passed.
diff --git a/testsuite/tests/basic/eval_order_1.ml b/testsuite/tests/basic/eval_order_1.ml
new file mode 100644
index 00000000..7c20be3f
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_1.ml
@@ -0,0 +1,4 @@
+let f x y = Printf.printf "%d %d\n" x y
+
+let i = ref 0
+let () = f (incr i; !i) !i
diff --git a/testsuite/tests/basic/eval_order_1.reference b/testsuite/tests/basic/eval_order_1.reference
new file mode 100644
index 00000000..80c0cc79
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_1.reference
@@ -0,0 +1 @@
+1 0
diff --git a/testsuite/tests/basic/eval_order_2.ml b/testsuite/tests/basic/eval_order_2.ml
new file mode 100644
index 00000000..378398b3
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_2.ml
@@ -0,0 +1,24 @@
+(* PR#6136 *)
+
+exception Ok
+
+let first () =
+  let f g x = ignore (failwith "called f"); g in
+  let g x = x in
+  f g 2 (raise Ok)
+
+let second () =
+  let f g x = ignore (failwith "called f"); g in
+  let g x = x in
+  let h f = f g 2 (raise Ok) in
+  ignore (h f)
+
+let () =
+  try
+    ignore (first ());
+    assert false
+  with Ok ->
+    try
+      ignore (second ());
+      assert false
+    with Ok -> ()
diff --git a/testsuite/tests/basic/eval_order_2.reference b/testsuite/tests/basic/eval_order_2.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/eval_order_3.ml b/testsuite/tests/basic/eval_order_3.ml
new file mode 100644
index 00000000..07c5367e
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_3.ml
@@ -0,0 +1,22 @@
+let i = ref 0
+
+let f x y =
+  Printf.printf "%d %d\n" x y;
+  0
+[@@inline never]
+
+let foo _ = ()
+
+let foobar baz =
+  let incr_i _ =
+    incr i;
+    !i
+  in
+  let b = !i in
+  let z = foo 42 in
+  let a = (incr_i [@inlined never]) z in
+  let x = f a b in
+  x + 1
+
+let () =
+  ignore ((foobar 0) : int)
diff --git a/testsuite/tests/basic/eval_order_3.reference b/testsuite/tests/basic/eval_order_3.reference
new file mode 100644
index 00000000..80c0cc79
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_3.reference
@@ -0,0 +1 @@
+1 0
diff --git a/testsuite/tests/basic/eval_order_4.ml b/testsuite/tests/basic/eval_order_4.ml
new file mode 100644
index 00000000..8e29f455
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_4.ml
@@ -0,0 +1,17 @@
+(* PR#7531 *)
+
+let f =
+  (let _i = print_endline "first"
+   in fun q -> fun i -> "") (print_endline "x")
+
+let _ =
+  let k = 
+    (let _i = print_int 1 
+     in fun q -> fun i -> "") () 
+  in k (print_int 0)
+
+let () =
+  print_endline "foo";
+  ignore ((f ()) : string);
+  ignore ((f ()) : string);
+  print_endline "bar"
diff --git a/testsuite/tests/basic/eval_order_4.reference b/testsuite/tests/basic/eval_order_4.reference
new file mode 100644
index 00000000..426ddfda
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_4.reference
@@ -0,0 +1,4 @@
+x
+first
+10foo
+bar
diff --git a/testsuite/tests/basic/float.ml b/testsuite/tests/basic/float.ml
new file mode 100644
index 00000000..9ebabbc4
--- /dev/null
+++ b/testsuite/tests/basic/float.ml
@@ -0,0 +1 @@
+Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
diff --git a/testsuite/tests/basic/float.reference b/testsuite/tests/basic/float.reference
new file mode 100644
index 00000000..3e7bab44
--- /dev/null
+++ b/testsuite/tests/basic/float.reference
@@ -0,0 +1 @@
+1./.0. = inf
diff --git a/testsuite/tests/basic/float_physical_equality.ml b/testsuite/tests/basic/float_physical_equality.ml
new file mode 100644
index 00000000..1fba3578
--- /dev/null
+++ b/testsuite/tests/basic/float_physical_equality.ml
@@ -0,0 +1,10 @@
+let a = -0.
+let b = +0.
+
+let _ =
+  assert(not (a == b))
+
+let f () =
+  let a = -0. in
+  let b = +0. in
+  assert(not (a == b))
diff --git a/testsuite/tests/basic/float_physical_equality.reference b/testsuite/tests/basic/float_physical_equality.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/includestruct.ml b/testsuite/tests/basic/includestruct.ml
new file mode 100644
index 00000000..a9c4e91b
--- /dev/null
+++ b/testsuite/tests/basic/includestruct.ml
@@ -0,0 +1,107 @@
+(* 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()
+
+
+
+include (struct
+  let a = 10
+  module X = struct let x = 1 let z = 42 let y = 2 end
+  exception XXX
+end : sig
+  module X : sig val y: int val x: int end
+  exception XXX
+  val a: int
+end)
+
+let () =
+  Printf.printf "%i / %i / %i \n%!" X.x X.y a;
+  Printf.printf "%s\n%!" (Printexc.to_string XXX)
diff --git a/testsuite/tests/basic/includestruct.reference b/testsuite/tests/basic/includestruct.reference
new file mode 100644
index 00000000..70af2e3d
--- /dev/null
+++ b/testsuite/tests/basic/includestruct.reference
@@ -0,0 +1,17 @@
+1, 2
+2, 3
+124, 457
+0
+2
+2
+1
+3
+F is called
+A
+42
+A
+42
+foo1
+foo1
+1 / 2 / 10 
+XXX
diff --git a/testsuite/tests/basic/localexn.ml b/testsuite/tests/basic/localexn.ml
new file mode 100755
index 00000000..b0f8e85f
--- /dev/null
+++ b/testsuite/tests/basic/localexn.ml
@@ -0,0 +1,9 @@
+let f (type t) () =
+  let exception E of t in
+  (fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+
+let inj1, proj1 = f ()
+let inj2, proj2 = f ()
+
+let () = proj1 (inj1 42)
+let () = proj1 (inj2 42)
diff --git a/testsuite/tests/basic/localexn.reference b/testsuite/tests/basic/localexn.reference
new file mode 100644
index 00000000..cd89967b
--- /dev/null
+++ b/testsuite/tests/basic/localexn.reference
@@ -0,0 +1,2 @@
+OK
+KO
diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
new file mode 100644
index 00000000..2ed02dec
--- /dev/null
+++ b/testsuite/tests/basic/maps.ml
@@ -0,0 +1,31 @@
+module IntMap = Map.Make(struct type t = int let compare x y = x-y end)
+
+let m1 = IntMap.add 0 "A" (IntMap.add 4 "Y" (IntMap.singleton 3 "X1"))
+let m2 = IntMap.add 0 "B" (IntMap.add 4 "Y" (IntMap.singleton 5 "X2"))
+
+let show m = IntMap.iter (fun k v -> Printf.printf "%d %s\n" k v) m
+
+let () =
+  print_endline "Union+concat";
+  let f1 _ l r =
+    match l, r with
+    | Some x, None | None, Some x -> Some x
+    | Some x, Some y when x = y -> None
+    | Some x, Some y -> Some (x ^ y)
+    | _ -> assert false
+  in
+  show (IntMap.merge f1 m1 m2);
+
+  print_endline "Inter";
+  let f2 _ l r =
+    match l, r with
+    | Some x, Some y when x = y -> Some x
+    | _ -> None
+  in
+  show (IntMap.merge f2 m1 m2);
+
+  print_endline "Union+concat (with Map.union)";
+  let f3 _ l r = if l = r then None else Some (l ^ r) in
+  show (IntMap.union f3 m1 m2);
+
+  ()
diff --git a/testsuite/tests/basic/maps.reference b/testsuite/tests/basic/maps.reference
new file mode 100644
index 00000000..74161504
--- /dev/null
+++ b/testsuite/tests/basic/maps.reference
@@ -0,0 +1,10 @@
+Union+concat
+0 AB
+3 X1
+5 X2
+Inter
+4 Y
+Union+concat (with Map.union)
+0 AB
+3 X1
+5 X2
diff --git a/testsuite/tests/basic/min_int.ml b/testsuite/tests/basic/min_int.ml
new file mode 100644
index 00000000..fe0dd7c8
--- /dev/null
+++ b/testsuite/tests/basic/min_int.ml
@@ -0,0 +1,10 @@
+(* This will test the parsing of the smallest integer on 32-bit architectures.
+   It doesn't do much on 64-bit but at least it doesn't crash.
+ *)
+
+let min_int = -1073741824
+let () = match min_int with
+| -1073741824 as i ->
+  assert (string_of_int i = "-1073741824");
+  print_endline "OK"
+| _ -> assert false
diff --git a/testsuite/tests/basic/min_int.reference b/testsuite/tests/basic/min_int.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/basic/min_int.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/basic/opt_variants.ml b/testsuite/tests/basic/opt_variants.ml
new file mode 100755
index 00000000..16966be2
--- /dev/null
+++ b/testsuite/tests/basic/opt_variants.ml
@@ -0,0 +1,114 @@
+let () =
+  assert(Sys.getenv_opt "FOOBAR_UNLIKELY_TO_EXIST_42" = None);
+
+  assert(int_of_string_opt "foo" = None);
+  assert(int_of_string_opt "42" = Some 42);
+  assert(int_of_string_opt (String.make 100 '9') = None);
+
+  assert(Nativeint.of_string_opt "foo" = None);
+  assert(Nativeint.of_string_opt "42" = Some 42n);
+  assert(Nativeint.of_string_opt (String.make 100 '9') = None);
+
+  assert(Int32.of_string_opt "foo" = None);
+  assert(Int32.of_string_opt "42" = Some 42l);
+  assert(Int32.of_string_opt (String.make 100 '9') = None);
+
+  assert(Int64.of_string_opt "foo" = None);
+  assert(Int64.of_string_opt "42" = Some 42L);
+  assert(Int64.of_string_opt (String.make 100 '9') = None);
+
+  assert(bool_of_string_opt "" = None);
+  assert(bool_of_string_opt "true" = Some true);
+  assert(bool_of_string_opt "false" = Some false);
+
+  assert(float_of_string_opt "foo" = None);
+  assert(float_of_string_opt "42." = Some 42.);
+  assert(float_of_string_opt (String.make 1000 '9') = Some infinity);
+
+  assert(List.nth_opt [] 0 = None);
+  assert(List.nth_opt [42] 0 = Some 42);
+  assert(List.nth_opt [42] 1 = None);
+
+  assert(List.find_opt (fun _ -> true) [] = None);
+  assert(List.find_opt (fun x -> x > 10) [4; 42] = Some 42);
+
+  assert(List.assoc_opt 42 [] = None);
+  assert(List.assoc_opt 42 [41, false; 42, true] = Some true);
+
+  assert(List.assq_opt 42 [] = None);
+  assert(List.assq_opt 42 [41, false; 42, true] = Some true);
+
+  let h = Hashtbl.create 5 in
+  assert(Hashtbl.find_opt h 42 = None);
+  Hashtbl.add h 42 ();
+  assert(Hashtbl.find_opt h 42 = Some ());
+
+
+  let module IntSet = Set.Make(struct
+      type t = int
+      let compare = compare
+    end)
+  in
+  let set = IntSet.of_list [42; 43] in
+  assert(IntSet.min_elt_opt IntSet.empty = None);
+  assert(IntSet.min_elt_opt set = Some 42);
+
+  assert(IntSet.max_elt_opt IntSet.empty = None);
+  assert(IntSet.max_elt_opt set = Some 43);
+
+  assert(IntSet.choose_opt IntSet.empty = None);
+  assert(IntSet.choose_opt set <> None);
+
+  assert(IntSet.find_opt 42 IntSet.empty = None);
+  assert(IntSet.find_opt 42 set = Some 42);
+  assert(IntSet.find_opt 0 set = None);
+
+
+  let module IntMap = Map.Make(struct
+      type t = int
+      let compare = compare
+    end)
+  in
+  let map = IntMap.add 42 "42" (IntMap.add 43 "43" IntMap.empty) in
+  assert(IntMap.min_binding_opt IntMap.empty = None);
+  assert(IntMap.min_binding_opt map = Some (42, "42"));
+
+  assert(IntMap.max_binding_opt IntMap.empty = None);
+  assert(IntMap.max_binding_opt map = Some (43, "43"));
+
+  assert(IntMap.choose_opt IntMap.empty = None);
+  assert(IntMap.choose_opt map <> None);
+
+  assert(IntMap.find_opt 42 IntMap.empty = None);
+  assert(IntMap.find_opt 42 map = Some "42");
+  assert(IntMap.find_opt 0 map = None);
+
+
+  let s = "Hello world !" in
+  assert(String.index_opt s 'x'  = None);
+  assert(String.index_opt s ' '  = Some 5);
+
+  assert(String.rindex_opt s 'x'  = None);
+  assert(String.rindex_opt s ' '  = Some 11);
+
+  assert(String.index_from_opt s 0 'x'  = None);
+  assert(String.index_from_opt s 6 ' '  = Some 11);
+
+  assert(String.rindex_from_opt s 0 'x'  = None);
+  assert(String.rindex_from_opt s 6 ' '  = Some 5);
+
+
+  let module W = Weak.Make(struct
+      type t = int ref
+      let equal = (=)
+      let hash = Hashtbl.hash
+    end)
+  in
+  let w = W.create 10 in
+  let x = Random.int 42 in
+  let r = ref x in
+  assert (W.find_opt w r = None);
+  W.add w r;
+  assert (W.find_opt w r = Some r);
+
+  ()
diff --git a/testsuite/tests/basic/opt_variants.reference b/testsuite/tests/basic/opt_variants.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml
new file mode 100644
index 00000000..43026be2
--- /dev/null
+++ b/testsuite/tests/basic/patmatch.ml
@@ -0,0 +1,1635 @@
+(* 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
+  | _ -> assert false
+
+(* The test *)
+
+open Printf
+
+external bytes_create: int -> bytes = "caml_create_bytes"
+external unsafe_chr: int -> char = "%identity"
+external bytes_unsafe_set : bytes -> int -> char -> unit
+                           = "%bytes_unsafe_set"
+
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
+
+(* The following function is roughly equivalent to Char.escaped,
+   except that it is locale-independent. *)
+let escaped = function
+  | '\'' -> "\\'"
+  | '\\' -> "\\\\"
+  | '\n' -> "\\n"
+  | '\t' -> "\\t"
+  | '\r' -> "\\r"
+  | '\b' -> "\\b"
+  | c ->
+    if ((k c) <> "othr") && ((Char.code c) <= 191) then begin
+      let s = bytes_create 1 in
+      bytes_unsafe_set s 0 c;
+      unsafe_to_string s
+    end else begin
+      let n = Char.code c in
+      let s = bytes_create 4 in
+      bytes_unsafe_set s 0 '\\';
+      bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+      bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+      bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+      unsafe_to_string s
+    end
+
+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 "\tk(%s) = %s" (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|])
+
+(* PR #5992 *)
+(* Was segfaulting *)
+
+let f = function
+ | lazy (), _, {contents=None} -> 0
+ | _, lazy (), {contents=Some x} -> 1
+
+let s = ref None
+let set_true = lazy (s := Some 1)
+let set_false = lazy (s := None)
+
+let () =
+  let _r = try f (set_true, set_false, s) with Match_failure _ -> 2 in
+  printf "PR#5992=Ok\n"
+
+(* PR #5788, was giving wrong result 3 *)
+exception Foo
+exception Bar = Foo
+
+let test e b =
+  match e, b with
+  | Foo, true -> 1
+  | Bar, false -> 2
+  | _, _ -> 3
+
+let () =
+  let r = test Bar false in
+  if r = 2 then printf "PR#5788=Ok\n"
+
+let test e b =
+  match e, b with
+  | Bar, false -> 0
+  | (Foo|Bar), true -> 1
+  | Foo, false -> 2
+  | _, _ -> 3
+
+
+let () =
+  let r = test Foo false in
+  if r = 0 then printf "PR#5788=Ok\n"
+
+(* PR#6646 Avoid explosion of default cases when there are many constructors *)
+
+(* This took forever to compile *)
+
+type token =
+  | Abs
+  | Acload
+  | After
+  | And
+  | Annotate
+  | Apply
+  | Arc
+  | Array
+  | Arraymacro
+  | Arrayrelatedinfo
+  | Arraysite
+  | Assign
+  | Atleast
+  | Atmost
+  | Author
+  | Basearray
+  | Becomes
+  | Between
+  | Block
+  | Boolean
+  | Booleandisplay
+  | Booleanmap
+  | Booleanvalue
+  | Borderpattern
+  | Borderwidth
+  | Boundingbox
+  | Ceiling
+  | Cell
+  | Cellref
+  | Celltype
+  | Change
+  | Circle
+  | Color
+  | Comment
+  | Commentgraphics
+  | Compound
+  | Concat
+  | Connectlocation
+  | Constant
+  | Constraint
+  | Contents
+  | Cornertype
+  | Criticality
+  | Currentmap
+  | Curve
+  | Cycle
+  | Dataorigin
+  | Dcfaninload
+  | Dcfanoutload
+  | Dcmaxfanin
+  | Dcmaxfanout
+  | Delay
+  | Delta
+  | Derivation
+  | Design
+  | Designator
+  | Difference
+  | Direction
+  | Display
+  | Divide
+  | Dominates
+  | Dot
+  | Duration
+  | E
+  | Edif
+  | Ediflevel
+  | Edifversion
+  | Else
+  | Enclosuredistance
+  | Endtype
+  | Entry
+  | Equal
+  | Escape
+  | Event
+  | Exactly
+  | External
+  | Fabricate
+  | False
+  | Figure
+  | Figurearea
+  | Figuregroup
+  | Figuregroupobject
+  | Figuregroupoverride
+  | Figuregroupref
+  | Figureperimeter
+  | Figurewidth
+  | Fillpattern
+  | Fix
+  | Floor
+  | Follow
+  | Forbiddenevent
+  | Form
+  | Globalportref
+  | Greaterthan
+  | Gridmap
+  | If
+  | Ignore
+  | Includefiguregroup
+  | Increasing
+  | Initial
+  | Instance
+  | Instancebackannotate
+  | Instancegroup
+  | Instancemap
+  | Instancenamedef
+  | Instanceref
+  | Integer
+  | Integerdisplay
+  | Interface
+  | Interfiguregroupspacing
+  | Intersection
+  | Intrafiguregroupspacing
+  | Inverse
+  | Isolated
+  | Iterate
+  | Joined
+  | Justify
+  | Keyworddisplay
+  | Keywordlevel
+  | Keywordmap
+  | Lessthan
+  | Library
+  | Libraryref
+  | Listofnets
+  | Listofports
+  | Loaddelay
+  | Logicassign
+  | Logicinput
+  | Logiclist
+  | Logicmapinput
+  | Logicmapoutput
+  | Logiconeof
+  | Logicoutput
+  | Logicport
+  | Logicref
+  | Logicvalue
+  | Logicwaveform
+  | Maintain
+  | Match
+  | Max
+  | Member
+  | Min
+  | Minomax
+  | Minomaxdisplay
+  | Mnm
+  | Mod
+  | Multiplevalueset
+  | Mustjoin
+  | Name
+  | Negate
+  | Net
+  | Netbackannotate
+  | Netbundle
+  | Netdelay
+  | Netgroup
+  | Netmap
+  | Netref
+  | Nochange
+  | Nonpermutable
+  | Not
+  | Notallowed
+  | Notchspacing
+  | Number
+  | Numberdefinition
+  | Numberdisplay
+  | Offpageconnector
+  | Offsetevent
+  | Openshape
+  | Or
+  | Orientation
+  | Origin
+  | Overhangdistance
+  | Overlapdistance
+  | Oversize
+  | Owner
+  | Page
+  | Pagesize
+  | Parameter
+  | Parameterassign
+  | Parameterdisplay
+  | Path
+  | Pathdelay
+  | Pathwidth
+  | Permutable
+  | Physicaldesignrule
+  | Plug
+  | Point
+  | Pointdisplay
+  | Pointlist
+  | Pointsubtract
+  | Pointsum
+  | Polygon
+  | Port
+  | Portbackannotate
+  | Portbundle
+  | Portdelay
+  | Portgroup
+  | Portimplementation
+  | Portinstance
+  | Portlist
+  | Portlistalias
+  | Portmap
+  | Portref
+  | Product
+  | Program
+  | Property
+  | Propertydisplay
+  | Protectionframe
+  | Pt
+  | Rangevector
+  | Rectangle
+  | Rectanglesize
+  | Rename
+  | Resolves
+  | Scale
+  | Scalex
+  | Scaley
+  | Section
+  | Shape
+  | Simulate
+  | Simulationinfo
+  | Singlevalueset
+  | Site
+  | Socket
+  | Socketset
+  | Statement
+  | Status
+  | Steady
+  | Strictlyincreasing
+  | String
+  | Stringdisplay
+  | Strong
+  | Subtract
+  | Sum
+  | Symbol
+  | Symmetry
+  | Table
+  | Tabledefault
+  | Technology
+  | Textheight
+  | Then
+  | Timeinterval
+  | Timestamp
+  | Timing
+  | Transform
+  | Transition
+  | Trigger
+  | True
+  | Typedvalue
+  | Unconstrained
+  | Undefined
+  | Union
+  | Unit
+  | Unused
+  | Userdata
+  | Valuenameref
+  | Variable
+  | Version
+  | View
+  | Viewlist
+  | Viewmap
+  | Viewref
+  | Viewtype
+  | Visible
+  | Voltagemap
+  | Wavevalue
+  | Weak
+  | Weakjoined
+  | When
+  | While
+  | Written
+  | Xcoord
+  | Xor
+  | Ycoord
+  | ILLEGAL of (char)
+  | ID of (string)
+  | TLIST of (token list)
+  | TLIST2 of (token list*token list)
+  | ITEM of (token*token)
+  | ITEM2 of (token*token*token)
+  | STRING of (string)
+  | INT of (int)
+  | ENDOFFILE
+  | EOL
+  | LPAREN
+  | RPAREN
+  | EMPTY
+
+let test_match tok = match tok with
+  | ITEM2(Array, ITEM (Rename, TLIST [ID id; STRING str]), INT idx) ->
+      1
+  | ITEM2(Cellref, TLIST [ID id], TLIST lst) ->
+      2
+  | ITEM2(Cell, TLIST [ID cellid], TLIST lst) ->
+      3
+  | ITEM2(Contents, TLIST lst1, TLIST lst2) ->
+      4
+  | ITEM2(Design, TLIST [ID id], TLIST lst) ->
+      5
+  | ITEM2(Edif, TLIST [ID id], TLIST lst) ->
+      6
+  | ITEM2(Instance,
+          TLIST [ID instid],
+          TLIST[ITEM2(Viewref, TLIST [ID netlist],
+                      TLIST[ITEM(Cellref, TLIST [ID cellid])])]) ->
+      7
+
+
+  | ITEM2(Instance,
+          TLIST [ID instid],
+          TLIST[ITEM2(Viewref, TLIST [ID netlist],
+                      TLIST[ITEM2(Cellref, TLIST [ID cellid],
+                                  TLIST [ITEM (Libraryref,
+                                               TLIST [ID libid])])])]) ->
+      8
+(* *)
+  | ITEM2(Instance, TLIST [ID instid],
+                    TLIST [ITEM2(viewref,
+                                 TLIST [ID netlist],
+                                 TLIST [ITEM2(cellref,
+                                              TLIST [ID cellid],
+                                              TLIST [ITEM(libraryref,
+                                                          TLIST [ID libid])])]);
+                    ITEM2(property, TLIST [ID xstlib],
+                                    TLIST [ITEM2(bool1,
+                                                 TLIST [],
+                                                 TLIST [ITEM(True, TLIST [])]);
+                                    ITEM(owner, TLIST [str])])]) ->  9
+(* *)
+  | ITEM2(Interface, TLIST [], TLIST lst) -> 100
+  | ITEM2(Joined, TLIST [], TLIST lst) -> 10
+  | ITEM2(Keywordmap, TLIST lst1, TLIST lst2) -> 11
+  | ITEM2(Library, TLIST [], TLIST lst) -> 12
+  | ITEM2(Library, TLIST [ID libid], TLIST lst) -> 13
+  | ITEM2(Net, TLIST [], TLIST [ITEM (Rename, TLIST [ID oldid; STRING newid]);
+        ITEM2(Joined, TLIST [],
+          TLIST portlst)]) -> 14
+  | ITEM2(Net, TLIST [ID netid], TLIST [ITEM2(Joined, TLIST [],
+          TLIST portlst)]) -> 15
+  | ITEM2(Net, _, _) -> 16
+  | ITEM2(Port, TLIST [], TLIST lst) -> 17
+  | ITEM2(Port, TLIST [ID id], TLIST lst) -> 18
+  | ITEM2(Portref, TLIST [ID id], TLIST [ITEM (Instanceref, TLIST [ID ref])]) ->
+      19
+  | ITEM2(Portref, TLIST [], TLIST [ITEM (Member, TLIST [ID mref; INT idx])]) ->
+      20
+  | ITEM2(Portref, TLIST [], TLIST[ITEM (Member, TLIST [ID mref; INT idx]);
+                                   ITEM (Instanceref, TLIST [ID instref])]) ->
+      21
+  | ITEM2(Program, TLIST [STRING progid], TLIST lst) ->21
+  | ITEM2(Property, TLIST [ID part], TLIST lst) -> 22
+  | ITEM2(Status, TLIST lst1, TLIST lst2) -> 23
+  | ITEM2(Technology, TLIST lst1, TLIST lst2) -> 24
+  | ITEM2(View, TLIST [ID netlist], TLIST lst) -> 25
+  | ITEM2(Viewref, TLIST [ID "netlist"], TLIST lst) -> 26
+  | ITEM2(Written, TLIST lst1, TLIST lst2) ->  27
+  | ITEM2(External, TLIST lst1, TLIST lst2) -> 28
+  | ITEM(Integer, TLIST [INT n]) -> 29
+  | ITEM (Author, TLIST [STRING author]) -> 30
+  | ITEM (Cellref, TLIST [ID id]) -> 31
+  | ITEM (Celltype, TLIST [ID "GENERIC"]) -> 32
+  | ITEM (Direction, TLIST [ID dir]) -> 32 (* print_endline dir *)
+  | ITEM (Ediflevel, TLIST [INT 0]) -> 32
+  | ITEM (Edifversion, TLIST [INT 2; INT 0; INT 0]) -> 32
+  | ITEM (Instanceref, TLIST [ID id]) -> 32
+  | ITEM (Keywordlevel, TLIST [INT 0]) -> 32
+  | ITEM (Libraryref, TLIST [ID "work"]) -> 32
+  | ITEM (Libraryref, TLIST [ID "xilinx"]) -> 32
+  | ITEM (Member, TLIST [ID id; INT n]) -> 32
+  | ITEM (Numberdefinition, TLIST []) -> 32
+  | ITEM (Owner, TLIST [STRING "\"Xilinx\""]) -> 32
+  | ITEM (Portref, TLIST [ID id]) -> 32
+  | ITEM (Rename, TLIST [ID id; STRING str]) -> 33
+  | ITEM (String, TLIST [STRING str]) -> 32
+  | ITEM (String, TLIST lst) -> 34
+  | ITEM (Timestamp, TLIST [INT yr; INT mon; INT day; INT hour; INT min;
+                            INT sec]) ->
+      32
+  | ITEM (Version, TLIST [STRING str]) -> 32
+  | ITEM (Viewtype, TLIST [ID "NETLIST"]) -> 32
+  | ITEM (Designator, TLIST lst) -> 34
+  | Abs -> failwith " Abs "
+  | Acload -> failwith " Acload "
+  | After -> failwith " After "
+  | And -> failwith " And "
+  | Annotate -> failwith " Annotate "
+  | Apply -> failwith " Apply "
+  | Arc -> failwith " Arc "
+  | Array -> failwith " Array "
+  | Arraymacro -> failwith " Arraymacro "
+  | Arrayrelatedinfo -> failwith " Arrayrelatedinfo "
+  | Arraysite -> failwith " Arraysite "
+  | Assign -> failwith " Assign "
+  | Atleast -> failwith " Atleast "
+  | Atmost -> failwith " Atmost "
+  | Author -> failwith " Author "
+  | Basearray -> failwith " Basearray "
+  | Becomes -> failwith " Becomes "
+  | Between -> failwith " Between "
+  | Block -> failwith " Block "
+  | Boolean -> failwith " Boolean "
+  | Booleandisplay -> failwith " Booleandisplay "
+  | Booleanmap -> failwith " Booleanmap "
+  | Booleanvalue -> failwith " Booleanvalue "
+  | Borderpattern -> failwith " Borderpattern "
+  | Borderwidth -> failwith " Borderwidth "
+  | Boundingbox -> failwith " Boundingbox "
+  | Ceiling -> failwith " Ceiling "
+  | Cell -> failwith " Cell "
+  | Cellref -> failwith " Cellref "
+  | Celltype -> failwith " Celltype "
+  | Change -> failwith " Change "
+  | Circle -> failwith " Circle "
+  | Color -> failwith " Color "
+  | Comment -> failwith " Comment "
+  | Commentgraphics -> failwith " Commentgraphics "
+  | Compound -> failwith " Compound "
+  | Concat -> failwith " Concat "
+  | Connectlocation -> failwith " Connectlocation "
+  | Constant -> failwith " Constant "
+  | Constraint -> failwith " Constraint "
+  | Contents -> failwith " Contents "
+  | Cornertype -> failwith " Cornertype "
+  | Criticality -> failwith " Criticality "
+  | Currentmap -> failwith " Currentmap "
+  | Curve -> failwith " Curve "
+  | Cycle -> failwith " Cycle "
+  | Dataorigin -> failwith " Dataorigin "
+  | Dcfaninload -> failwith " Dcfaninload "
+  | Dcfanoutload -> failwith " Dcfanoutload "
+  | Dcmaxfanin -> failwith " Dcmaxfanin "
+  | Dcmaxfanout -> failwith " Dcmaxfanout "
+  | Delay -> failwith " Delay "
+  | Delta -> failwith " Delta "
+  | Derivation -> failwith " Derivation "
+  | Design -> failwith " Design "
+  | Designator -> failwith " Designator "
+  | Difference -> failwith " Difference "
+  | Direction -> failwith " Direction "
+  | Display -> failwith " Display "
+  | Divide -> failwith " Divide "
+  | Dominates -> failwith " Dominates "
+  | Dot -> failwith " Dot "
+  | Duration -> failwith " Duration "
+  | E -> failwith " E "
+  | Edif -> failwith " Edif "
+  | Ediflevel -> failwith " Ediflevel "
+  | Edifversion -> failwith " Edifversion "
+  | Else -> failwith " Else "
+  | Enclosuredistance -> failwith " Enclosuredistance "
+  | Endtype -> failwith " Endtype "
+  | Entry -> failwith " Entry "
+  | Equal -> failwith " Equal "
+  | Escape -> failwith " Escape "
+  | Event -> failwith " Event "
+  | Exactly -> failwith " Exactly "
+  | External -> failwith " External "
+  | Fabricate -> failwith " Fabricate "
+  | False -> failwith " False "
+  | Figure -> failwith " Figure "
+  | Figurearea -> failwith " Figurearea "
+  | Figuregroup -> failwith " Figuregroup "
+  | Figuregroupobject -> failwith " Figuregroupobject "
+  | Figuregroupoverride -> failwith " Figuregroupoverride "
+  | Figuregroupref -> failwith " Figuregroupref "
+  | Figureperimeter -> failwith " Figureperimeter "
+  | Figurewidth -> failwith " Figurewidth "
+  | Fillpattern -> failwith " Fillpattern "
+  | Fix -> failwith " Fix "
+  | Floor -> failwith " Floor "
+  | Follow -> failwith " Follow "
+  | Forbiddenevent -> failwith " Forbiddenevent "
+  | Form -> failwith " Form "
+  | Globalportref -> failwith " Globalportref "
+  | Greaterthan -> failwith " Greaterthan "
+  | Gridmap -> failwith " Gridmap "
+  | If -> failwith " If "
+  | Ignore -> failwith " Ignore "
+  | Includefiguregroup -> failwith " Includefiguregroup "
+  | Increasing -> failwith " Increasing "
+  | Initial -> failwith " Initial "
+  | Instance -> failwith " Instance "
+  | Instancebackannotate -> failwith " Instancebackannotate "
+  | Instancegroup -> failwith " Instancegroup "
+  | Instancemap -> failwith " Instancemap "
+  | Instancenamedef -> failwith " Instancenamedef "
+  | Instanceref -> failwith " Instanceref "
+  | Integer -> failwith " Integer "
+  | Integerdisplay -> failwith " Integerdisplay "
+  | Interface -> failwith " Interface "
+  | Interfiguregroupspacing -> failwith " Interfiguregroupspacing "
+  | Intersection -> failwith " Intersection "
+  | Intrafiguregroupspacing -> failwith " Intrafiguregroupspacing "
+  | Inverse -> failwith " Inverse "
+  | Isolated -> failwith " Isolated "
+  | Iterate -> failwith " Iterate "
+  | Joined -> failwith " Joined "
+  | Justify -> failwith " Justify "
+  | Keyworddisplay -> failwith " Keyworddisplay "
+  | Keywordlevel -> failwith " Keywordlevel "
+  | Keywordmap -> failwith " Keywordmap "
+  | Lessthan -> failwith " Lessthan "
+  | Library -> failwith " Library "
+  | Libraryref -> failwith " Libraryref "
+  | Listofnets -> failwith " Listofnets "
+  | Listofports -> failwith " Listofports "
+  | Loaddelay -> failwith " Loaddelay "
+  | Logicassign -> failwith " Logicassign "
+  | Logicinput -> failwith " Logicinput "
+  | Logiclist -> failwith " Logiclist "
+  | Logicmapinput -> failwith " Logicmapinput "
+  | Logicmapoutput -> failwith " Logicmapoutput "
+  | Logiconeof -> failwith " Logiconeof "
+  | Logicoutput -> failwith " Logicoutput "
+  | Logicport -> failwith " Logicport "
+  | Logicref -> failwith " Logicref "
+  | Logicvalue -> failwith " Logicvalue "
+  | Logicwaveform -> failwith " Logicwaveform "
+  | Maintain -> failwith " Maintain "
+  | Match -> failwith " Match "
+  | Max -> failwith " Max "
+  | Member -> failwith " Member "
+  | Min -> failwith " Min "
+  | Minomax -> failwith " Minomax "
+  | Minomaxdisplay -> failwith " Minomaxdisplay "
+  | Mnm -> failwith " Mnm "
+  | Mod -> failwith " Mod "
+  | Multiplevalueset -> failwith " Multiplevalueset "
+  | Mustjoin -> failwith " Mustjoin "
+  | Name -> failwith " Name "
+  | Negate -> failwith " Negate "
+  | Net -> failwith " Net "
+  | Netbackannotate -> failwith " Netbackannotate "
+  | Netbundle -> failwith " Netbundle "
+  | Netdelay -> failwith " Netdelay "
+  | Netgroup -> failwith " Netgroup "
+  | Netmap -> failwith " Netmap "
+  | Netref -> failwith " Netref "
+  | Nochange -> failwith " Nochange "
+  | Nonpermutable -> failwith " Nonpermutable "
+  | Not -> failwith " Not "
+  | Notallowed -> failwith " Notallowed "
+  | Notchspacing -> failwith " Notchspacing "
+  | Number -> failwith " Number "
+  | Numberdefinition -> failwith " Numberdefinition "
+  | Numberdisplay -> failwith " Numberdisplay "
+  | Offpageconnector -> failwith " Offpageconnector "
+  | Offsetevent -> failwith " Offsetevent "
+  | Openshape -> failwith " Openshape "
+  | Or -> failwith " Or "
+  | Orientation -> failwith " Orientation "
+  | Origin -> failwith " Origin "
+  | Overhangdistance -> failwith " Overhangdistance "
+  | Overlapdistance -> failwith " Overlapdistance "
+  | Oversize -> failwith " Oversize "
+  | Owner -> failwith " Owner "
+  | Page -> failwith " Page "
+  | Pagesize -> failwith " Pagesize "
+  | Parameter -> failwith " Parameter "
+  | Parameterassign -> failwith " Parameterassign "
+  | Parameterdisplay -> failwith " Parameterdisplay "
+  | Path -> failwith " Path "
+  | Pathdelay -> failwith " Pathdelay "
+  | Pathwidth -> failwith " Pathwidth "
+  | Permutable -> failwith " Permutable "
+  | Physicaldesignrule -> failwith " Physicaldesignrule "
+  | Plug -> failwith " Plug "
+  | Point -> failwith " Point "
+  | Pointdisplay -> failwith " Pointdisplay "
+  | Pointlist -> failwith " Pointlist "
+  | Pointsubtract -> failwith " Pointsubtract "
+  | Pointsum -> failwith " Pointsum "
+  | Polygon -> failwith " Polygon "
+  | Port -> failwith " Port "
+  | Portbackannotate -> failwith " Portbackannotate "
+  | Portbundle -> failwith " Portbundle "
+  | Portdelay -> failwith " Portdelay "
+  | Portgroup -> failwith " Portgroup "
+  | Portimplementation -> failwith " Portimplementation "
+  | Portinstance -> failwith " Portinstance "
+  | Portlist -> failwith " Portlist "
+  | Portlistalias -> failwith " Portlistalias "
+  | Portmap -> failwith " Portmap "
+  | Portref -> failwith " Portref "
+  | Product -> failwith " Product "
+  | Program -> failwith " Program "
+  | Property -> failwith " Property "
+  | Propertydisplay -> failwith " Propertydisplay "
+  | Protectionframe -> failwith " Protectionframe "
+  | Pt -> failwith " Pt "
+  | Rangevector -> failwith " Rangevector "
+  | Rectangle -> failwith " Rectangle "
+  | Rectanglesize -> failwith " Rectanglesize "
+  | Rename -> failwith " Rename "
+  | Resolves -> failwith " Resolves "
+  | Scale -> failwith " Scale "
+  | Scalex -> failwith " Scalex "
+  | Scaley -> failwith " Scaley "
+  | Section -> failwith " Section "
+  | Shape -> failwith " Shape "
+  | Simulate -> failwith " Simulate "
+  | Simulationinfo -> failwith " Simulationinfo "
+  | Singlevalueset -> failwith " Singlevalueset "
+  | Site -> failwith " Site "
+  | Socket -> failwith " Socket "
+  | Socketset -> failwith " Socketset "
+  | Statement -> failwith " Statement "
+  | Status -> failwith " Status "
+  | Steady -> failwith " Steady "
+  | Strictlyincreasing -> failwith " Strictlyincreasing "
+  | String -> failwith " String "
+  | Stringdisplay -> failwith " Stringdisplay "
+  | Strong -> failwith " Strong "
+  | Subtract -> failwith " Subtract "
+  | Sum -> failwith " Sum "
+  | Symbol -> failwith " Symbol "
+  | Symmetry -> failwith " Symmetry "
+  | Table -> failwith " Table "
+  | Tabledefault -> failwith " Tabledefault "
+  | Technology -> failwith " Technology "
+  | Textheight -> failwith " Textheight "
+  | Then -> failwith " Then "
+  | Timeinterval -> failwith " Timeinterval "
+  | Timestamp -> failwith " Timestamp "
+  | Timing -> failwith " Timing "
+  | Transform -> failwith " Transform "
+  | Transition -> failwith " Transition "
+  | Trigger -> failwith " Trigger "
+  | True -> failwith " True "
+  | Typedvalue -> failwith " Typedvalue "
+  | Unconstrained -> failwith " Unconstrained "
+  | Undefined -> failwith " Undefined "
+  | Union -> failwith " Union "
+  | Unit -> failwith " Unit "
+  | Unused -> failwith " Unused "
+  | Userdata -> failwith " Userdata "
+  | Valuenameref -> failwith " Valuenameref "
+  | Variable -> failwith " Variable "
+  | Version -> failwith " Version "
+  | View -> failwith " View "
+  | Viewlist -> failwith " Viewlist "
+  | Viewmap -> failwith " Viewmap "
+  | Viewref -> failwith " Viewref "
+  | Viewtype -> failwith " Viewtype "
+  | Visible -> failwith " Visible "
+  | Voltagemap -> failwith " Voltagemap "
+  | Wavevalue -> failwith " Wavevalue "
+  | Weak -> failwith " Weak "
+  | Weakjoined -> failwith " Weakjoined "
+  | When -> failwith " When "
+  | While -> failwith " While "
+  | Written -> failwith " Written "
+  | Xcoord -> failwith " Xcoord "
+  | Xor -> failwith " Xor "
+  | Ycoord -> failwith " Ycoord "
+  | ILLEGAL _ -> failwith " ILLEGAL _ "
+  | ID _ -> failwith " ID _ "
+  | TLIST _ -> failwith " TLIST _ "
+  | TLIST2 _ -> failwith " TLIST2 _ "
+  | STRING _ -> failwith " STRING _ "
+  | INT _ -> failwith " INT _ "
+  | ENDOFFILE -> failwith " ENDOFFILE "
+  | EOL -> failwith " EOL "
+  | LPAREN -> failwith " LPAREN "
+  | RPAREN -> failwith " RPAREN "
+  | EMPTY -> failwith " EMPTY "
+
+  | ITEM2(Abs, _, _) -> failwith " ITEM2(Abs, _, _) "
+  | ITEM2(Acload, _, _) -> failwith " ITEM2(Acload, _, _) "
+  | ITEM2(After, _, _) -> failwith " ITEM2(After, _, _) "
+  | ITEM2(And, _, _) -> failwith " ITEM2(And, _, _) "
+  | ITEM2(Annotate, _, _) -> failwith " ITEM2(Annotate, _, _) "
+  | ITEM2(Apply, _, _) -> failwith " ITEM2(Apply, _, _) "
+  | ITEM2(Arc, _, _) -> failwith " ITEM2(Arc, _, _) "
+  | ITEM2(Array, _, _) -> failwith " ITEM2(Array, _, _) "
+  | ITEM2(Arraymacro, _, _) -> failwith " ITEM2(Arraymacro, _, _) "
+  | ITEM2(Arrayrelatedinfo, _, _) -> failwith " ITEM2(Arrayrelatedinfo, _, _) "
+  | ITEM2(Arraysite, _, _) -> failwith " ITEM2(Arraysite, _, _) "
+  | ITEM2(Assign, _, _) -> failwith " ITEM2(Assign, _, _) "
+  | ITEM2(Atleast, _, _) -> failwith " ITEM2(Atleast, _, _) "
+  | ITEM2(Atmost, _, _) -> failwith " ITEM2(Atmost, _, _) "
+  | ITEM2(Author, _, _) -> failwith " ITEM2(Author, _, _) "
+  | ITEM2(Basearray, _, _) -> failwith " ITEM2(Basearray, _, _) "
+  | ITEM2(Becomes, _, _) -> failwith " ITEM2(Becomes, _, _) "
+  | ITEM2(Between, _, _) -> failwith " ITEM2(Between, _, _) "
+  | ITEM2(Block, _, _) -> failwith " ITEM2(Block, _, _) "
+  | ITEM2(Boolean, _, _) -> failwith " ITEM2(Boolean, _, _) "
+  | ITEM2(Booleandisplay, _, _) -> failwith " ITEM2(Booleandisplay, _, _) "
+  | ITEM2(Booleanmap, _, _) -> failwith " ITEM2(Booleanmap, _, _) "
+  | ITEM2(Booleanvalue, _, _) -> failwith " ITEM2(Booleanvalue, _, _) "
+  | ITEM2(Borderpattern, _, _) -> failwith " ITEM2(Borderpattern, _, _) "
+  | ITEM2(Borderwidth, _, _) -> failwith " ITEM2(Borderwidth, _, _) "
+  | ITEM2(Boundingbox, _, _) -> failwith " ITEM2(Boundingbox, _, _) "
+  | ITEM2(Ceiling, _, _) -> failwith " ITEM2(Ceiling, _, _) "
+  | ITEM2(Cell, _, _) -> failwith " ITEM2(Cell, _, _) "
+  | ITEM2(Cellref, _, _) -> failwith " ITEM2(Cellref, _, _) "
+  | ITEM2(Celltype, _, _) -> failwith " ITEM2(Celltype, _, _) "
+  | ITEM2(Change, _, _) -> failwith " ITEM2(Change, _, _) "
+  | ITEM2(Circle, _, _) -> failwith " ITEM2(Circle, _, _) "
+  | ITEM2(Color, _, _) -> failwith " ITEM2(Color, _, _) "
+  | ITEM2(Comment, _, _) -> failwith " ITEM2(Comment, _, _) "
+  | ITEM2(Commentgraphics, _, _) -> failwith " ITEM2(Commentgraphics, _, _) "
+  | ITEM2(Compound, _, _) -> failwith " ITEM2(Compound, _, _) "
+  | ITEM2(Concat, _, _) -> failwith " ITEM2(Concat, _, _) "
+  | ITEM2(Connectlocation, _, _) -> failwith " ITEM2(Connectlocation, _, _) "
+  | ITEM2(Constant, _, _) -> failwith " ITEM2(Constant, _, _) "
+  | ITEM2(Constraint, _, _) -> failwith " ITEM2(Constraint, _, _) "
+  | ITEM2(Contents, _, _) -> failwith " ITEM2(Contents, _, _) "
+  | ITEM2(Cornertype, _, _) -> failwith " ITEM2(Cornertype, _, _) "
+  | ITEM2(Criticality, _, _) -> failwith " ITEM2(Criticality, _, _) "
+  | ITEM2(Currentmap, _, _) -> failwith " ITEM2(Currentmap, _, _) "
+  | ITEM2(Curve, _, _) -> failwith " ITEM2(Curve, _, _) "
+  | ITEM2(Cycle, _, _) -> failwith " ITEM2(Cycle, _, _) "
+  | ITEM2(Dataorigin, _, _) -> failwith " ITEM2(Dataorigin, _, _) "
+  | ITEM2(Dcfaninload, _, _) -> failwith " ITEM2(Dcfaninload, _, _) "
+  | ITEM2(Dcfanoutload, _, _) -> failwith " ITEM2(Dcfanoutload, _, _) "
+  | ITEM2(Dcmaxfanin, _, _) -> failwith " ITEM2(Dcmaxfanin, _, _) "
+  | ITEM2(Dcmaxfanout, _, _) -> failwith " ITEM2(Dcmaxfanout, _, _) "
+  | ITEM2(Delay, _, _) -> failwith " ITEM2(Delay, _, _) "
+  | ITEM2(Delta, _, _) -> failwith " ITEM2(Delta, _, _) "
+  | ITEM2(Derivation, _, _) -> failwith " ITEM2(Derivation, _, _) "
+  | ITEM2(Design, _, _) -> failwith " ITEM2(Design, _, _) "
+  | ITEM2(Designator, _, _) -> failwith " ITEM2(Designator, _, _) "
+  | ITEM2(Difference, _, _) -> failwith " ITEM2(Difference, _, _) "
+  | ITEM2(Direction, _, _) -> failwith " ITEM2(Direction, _, _) "
+  | ITEM2(Display, _, _) -> failwith " ITEM2(Display, _, _) "
+  | ITEM2(Divide, _, _) -> failwith " ITEM2(Divide, _, _) "
+  | ITEM2(Dominates, _, _) -> failwith " ITEM2(Dominates, _, _) "
+  | ITEM2(Dot, _, _) -> failwith " ITEM2(Dot, _, _) "
+  | ITEM2(Duration, _, _) -> failwith " ITEM2(Duration, _, _) "
+  | ITEM2(E, _, _) -> failwith " ITEM2(E, _, _) "
+  | ITEM2(Edif, _, _) -> failwith " ITEM2(Edif, _, _) "
+  | ITEM2(Ediflevel, _, _) -> failwith " ITEM2(Ediflevel, _, _) "
+  | ITEM2(Edifversion, _, _) -> failwith " ITEM2(Edifversion, _, _) "
+  | ITEM2(Else, _, _) -> failwith " ITEM2(Else, _, _) "
+  | ITEM2(Enclosuredistance, _, _) ->
+      failwith " ITEM2(Enclosuredistance, _, _) "
+  | ITEM2(Endtype, _, _) -> failwith " ITEM2(Endtype, _, _) "
+  | ITEM2(Entry, _, _) -> failwith " ITEM2(Entry, _, _) "
+  | ITEM2(Equal, _, _) -> failwith " ITEM2(Equal, _, _) "
+  | ITEM2(Escape, _, _) -> failwith " ITEM2(Escape, _, _) "
+  | ITEM2(Event, _, _) -> failwith " ITEM2(Event, _, _) "
+  | ITEM2(Exactly, _, _) -> failwith " ITEM2(Exactly, _, _) "
+  | ITEM2(External, _, _) -> failwith " ITEM2(External, _, _) "
+  | ITEM2(Fabricate, _, _) -> failwith " ITEM2(Fabricate, _, _) "
+  | ITEM2(False, _, _) -> failwith " ITEM2(False, _, _) "
+  | ITEM2(Figure, _, _) -> failwith " ITEM2(Figure, _, _) "
+  | ITEM2(Figurearea, _, _) -> failwith " ITEM2(Figurearea, _, _) "
+  | ITEM2(Figuregroup, _, _) -> failwith " ITEM2(Figuregroup, _, _) "
+  | ITEM2(Figuregroupobject, _, _) ->
+      failwith " ITEM2(Figuregroupobject, _, _) "
+  | ITEM2(Figuregroupoverride, _, _) ->
+      failwith " ITEM2(Figuregroupoverride, _, _) "
+  | ITEM2(Figuregroupref, _, _) -> failwith " ITEM2(Figuregroupref, _, _) "
+  | ITEM2(Figureperimeter, _, _) -> failwith " ITEM2(Figureperimeter, _, _) "
+  | ITEM2(Figurewidth, _, _) -> failwith " ITEM2(Figurewidth, _, _) "
+  | ITEM2(Fillpattern, _, _) -> failwith " ITEM2(Fillpattern, _, _) "
+  | ITEM2(Fix, _, _) -> failwith " ITEM2(Fix, _, _) "
+  | ITEM2(Floor, _, _) -> failwith " ITEM2(Floor, _, _) "
+  | ITEM2(Follow, _, _) -> failwith " ITEM2(Follow, _, _) "
+  | ITEM2(Forbiddenevent, _, _) -> failwith " ITEM2(Forbiddenevent, _, _) "
+  | ITEM2(Form, _, _) -> failwith " ITEM2(Form, _, _) "
+  | ITEM2(Globalportref, _, _) -> failwith " ITEM2(Globalportref, _, _) "
+  | ITEM2(Greaterthan, _, _) -> failwith " ITEM2(Greaterthan, _, _) "
+  | ITEM2(Gridmap, _, _) -> failwith " ITEM2(Gridmap, _, _) "
+  | ITEM2(If, _, _) -> failwith " ITEM2(If, _, _) "
+  | ITEM2(Ignore, _, _) -> failwith " ITEM2(Ignore, _, _) "
+  | ITEM2(Includefiguregroup, _, _) ->
+      failwith " ITEM2(Includefiguregroup, _, _) "
+  | ITEM2(Increasing, _, _) -> failwith " ITEM2(Increasing, _, _) "
+  | ITEM2(Initial, _, _) -> failwith " ITEM2(Initial, _, _) "
+  | ITEM2(Instance, arg1, arg2) -> failwith (" ITEM2(Instance, ) ")
+  | ITEM2(Instancebackannotate, _, _) ->
+      failwith " ITEM2(Instancebackannotate, _, _) "
+  | ITEM2(Instancegroup, _, _) -> failwith " ITEM2(Instancegroup, _, _) "
+  | ITEM2(Instancemap, _, _) -> failwith " ITEM2(Instancemap, _, _) "
+  | ITEM2(Instancenamedef, _, _) -> failwith " ITEM2(Instancenamedef, _, _) "
+  | ITEM2(Instanceref, _, _) -> failwith " ITEM2(Instanceref, _, _) "
+  | ITEM2(Integer, _, _) -> failwith " ITEM2(Integer, _, _) "
+  | ITEM2(Integerdisplay, _, _) -> failwith " ITEM2(Integerdisplay, _, _) "
+  | ITEM2(Interface, _, _) -> failwith " ITEM2(Interface, _, _) "
+  | ITEM2(Interfiguregroupspacing, _, _) ->
+      failwith " ITEM2(Interfiguregroupspacing, _, _) "
+  | ITEM2(Intersection, _, _) -> failwith " ITEM2(Intersection, _, _) "
+  | ITEM2(Intrafiguregroupspacing, _, _) ->
+      failwith " ITEM2(Intrafiguregroupspacing, _, _) "
+  | ITEM2(Inverse, _, _) -> failwith " ITEM2(Inverse, _, _) "
+  | ITEM2(Isolated, _, _) -> failwith " ITEM2(Isolated, _, _) "
+  | ITEM2(Iterate, _, _) -> failwith " ITEM2(Iterate, _, _) "
+  | ITEM2(Joined, _, _) -> failwith " ITEM2(Joined, _, _) "
+  | ITEM2(Justify, _, _) -> failwith " ITEM2(Justify, _, _) "
+  | ITEM2(Keyworddisplay, _, _) -> failwith " ITEM2(Keyworddisplay, _, _) "
+  | ITEM2(Keywordlevel, _, _) -> failwith " ITEM2(Keywordlevel, _, _) "
+  | ITEM2(Keywordmap, _, _) -> failwith " ITEM2(Keywordmap, _, _) "
+  | ITEM2(Lessthan, _, _) -> failwith " ITEM2(Lessthan, _, _) "
+  | ITEM2(Library, _, _) -> failwith " ITEM2(Library, _, _) "
+  | ITEM2(Libraryref, _, _) -> failwith " ITEM2(Libraryref, _, _) "
+  | ITEM2(Listofnets, _, _) -> failwith " ITEM2(Listofnets, _, _) "
+  | ITEM2(Listofports, _, _) -> failwith " ITEM2(Listofports, _, _) "
+  | ITEM2(Loaddelay, _, _) -> failwith " ITEM2(Loaddelay, _, _) "
+  | ITEM2(Logicassign, _, _) -> failwith " ITEM2(Logicassign, _, _) "
+  | ITEM2(Logicinput, _, _) -> failwith " ITEM2(Logicinput, _, _) "
+  | ITEM2(Logiclist, _, _) -> failwith " ITEM2(Logiclist, _, _) "
+  | ITEM2(Logicmapinput, _, _) -> failwith " ITEM2(Logicmapinput, _, _) "
+  | ITEM2(Logicmapoutput, _, _) -> failwith " ITEM2(Logicmapoutput, _, _) "
+  | ITEM2(Logiconeof, _, _) -> failwith " ITEM2(Logiconeof, _, _) "
+  | ITEM2(Logicoutput, _, _) -> failwith " ITEM2(Logicoutput, _, _) "
+  | ITEM2(Logicport, _, _) -> failwith " ITEM2(Logicport, _, _) "
+  | ITEM2(Logicref, _, _) -> failwith " ITEM2(Logicref, _, _) "
+  | ITEM2(Logicvalue, _, _) -> failwith " ITEM2(Logicvalue, _, _) "
+  | ITEM2(Logicwaveform, _, _) -> failwith " ITEM2(Logicwaveform, _, _) "
+  | ITEM2(Maintain, _, _) -> failwith " ITEM2(Maintain, _, _) "
+  | ITEM2(Match, _, _) -> failwith " ITEM2(Match, _, _) "
+  | ITEM2(Max, _, _) -> failwith " ITEM2(Max, _, _) "
+  | ITEM2(Member, _, _) -> failwith " ITEM2(Member, _, _) "
+  | ITEM2(Min, _, _) -> failwith " ITEM2(Min, _, _) "
+  | ITEM2(Minomax, _, _) -> failwith " ITEM2(Minomax, _, _) "
+  | ITEM2(Minomaxdisplay, _, _) -> failwith " ITEM2(Minomaxdisplay, _, _) "
+  | ITEM2(Mnm, _, _) -> failwith " ITEM2(Mnm, _, _) "
+  | ITEM2(Mod, _, _) -> failwith " ITEM2(Mod, _, _) "
+  | ITEM2(Multiplevalueset, _, _) -> failwith " ITEM2(Multiplevalueset, _, _) "
+  | ITEM2(Mustjoin, _, _) -> failwith " ITEM2(Mustjoin, _, _) "
+  | ITEM2(Name, _, _) -> failwith " ITEM2(Name, _, _) "
+  | ITEM2(Negate, _, _) -> failwith " ITEM2(Negate, _, _) "
+(*
+  | ITEM2(Net, _, _) -> failwith " ITEM2(Net, _, _) "
+*)
+  | ITEM2(Netbackannotate, _, _) -> failwith " ITEM2(Netbackannotate, _, _) "
+  | ITEM2(Netbundle, _, _) -> failwith " ITEM2(Netbundle, _, _) "
+  | ITEM2(Netdelay, _, _) -> failwith " ITEM2(Netdelay, _, _) "
+  | ITEM2(Netgroup, _, _) -> failwith " ITEM2(Netgroup, _, _) "
+  | ITEM2(Netmap, _, _) -> failwith " ITEM2(Netmap, _, _) "
+  | ITEM2(Netref, _, _) -> failwith " ITEM2(Netref, _, _) "
+  | ITEM2(Nochange, _, _) -> failwith " ITEM2(Nochange, _, _) "
+  | ITEM2(Nonpermutable, _, _) -> failwith " ITEM2(Nonpermutable, _, _) "
+  | ITEM2(Not, _, _) -> failwith " ITEM2(Not, _, _) "
+  | ITEM2(Notallowed, _, _) -> failwith " ITEM2(Notallowed, _, _) "
+  | ITEM2(Notchspacing, _, _) -> failwith " ITEM2(Notchspacing, _, _) "
+  | ITEM2(Number, _, _) -> failwith " ITEM2(Number, _, _) "
+  | ITEM2(Numberdefinition, _, _) -> failwith " ITEM2(Numberdefinition, _, _) "
+  | ITEM2(Numberdisplay, _, _) -> failwith " ITEM2(Numberdisplay, _, _) "
+  | ITEM2(Offpageconnector, _, _) -> failwith " ITEM2(Offpageconnector, _, _) "
+  | ITEM2(Offsetevent, _, _) -> failwith " ITEM2(Offsetevent, _, _) "
+  | ITEM2(Openshape, _, _) -> failwith " ITEM2(Openshape, _, _) "
+  | ITEM2(Or, _, _) -> failwith " ITEM2(Or, _, _) "
+  | ITEM2(Orientation, _, _) -> failwith " ITEM2(Orientation, _, _) "
+  | ITEM2(Origin, _, _) -> failwith " ITEM2(Origin, _, _) "
+  | ITEM2(Overhangdistance, _, _) -> failwith " ITEM2(Overhangdistance, _, _) "
+  | ITEM2(Overlapdistance, _, _) -> failwith " ITEM2(Overlapdistance, _, _) "
+  | ITEM2(Oversize, _, _) -> failwith " ITEM2(Oversize, _, _) "
+  | ITEM2(Owner, _, _) -> failwith " ITEM2(Owner, _, _) "
+  | ITEM2(Page, _, _) -> failwith " ITEM2(Page, _, _) "
+  | ITEM2(Pagesize, _, _) -> failwith " ITEM2(Pagesize, _, _) "
+  | ITEM2(Parameter, _, _) -> failwith " ITEM2(Parameter, _, _) "
+  | ITEM2(Parameterassign, _, _) -> failwith " ITEM2(Parameterassign, _, _) "
+  | ITEM2(Parameterdisplay, _, _) -> failwith " ITEM2(Parameterdisplay, _, _) "
+  | ITEM2(Path, _, _) -> failwith " ITEM2(Path, _, _) "
+  | ITEM2(Pathdelay, _, _) -> failwith " ITEM2(Pathdelay, _, _) "
+  | ITEM2(Pathwidth, _, _) -> failwith " ITEM2(Pathwidth, _, _) "
+  | ITEM2(Permutable, _, _) -> failwith " ITEM2(Permutable, _, _) "
+  | ITEM2(Physicaldesignrule, _, _) ->
+      failwith " ITEM2(Physicaldesignrule, _, _) "
+  | ITEM2(Plug, _, _) -> failwith " ITEM2(Plug, _, _) "
+  | ITEM2(Point, _, _) -> failwith " ITEM2(Point, _, _) "
+  | ITEM2(Pointdisplay, _, _) -> failwith " ITEM2(Pointdisplay, _, _) "
+  | ITEM2(Pointlist, _, _) -> failwith " ITEM2(Pointlist, _, _) "
+  | ITEM2(Pointsubtract, _, _) -> failwith " ITEM2(Pointsubtract, _, _) "
+  | ITEM2(Pointsum, _, _) -> failwith " ITEM2(Pointsum, _, _) "
+  | ITEM2(Polygon, _, _) -> failwith " ITEM2(Polygon, _, _) "
+  | ITEM2(Port, _, _) -> failwith " ITEM2(Port, _, _) "
+  | ITEM2(Portbackannotate, _, _) -> failwith " ITEM2(Portbackannotate, _, _) "
+  | ITEM2(Portbundle, _, _) -> failwith " ITEM2(Portbundle, _, _) "
+  | ITEM2(Portdelay, _, _) -> failwith " ITEM2(Portdelay, _, _) "
+  | ITEM2(Portgroup, _, _) -> failwith " ITEM2(Portgroup, _, _) "
+  | ITEM2(Portimplementation, _, _) ->
+      failwith " ITEM2(Portimplementation, _, _) "
+  | ITEM2(Portinstance, _, _) -> failwith " ITEM2(Portinstance, _, _) "
+  | ITEM2(Portlist, _, _) -> failwith " ITEM2(Portlist, _, _) "
+  | ITEM2(Portlistalias, _, _) -> failwith " ITEM2(Portlistalias, _, _) "
+  | ITEM2(Portmap, _, _) -> failwith " ITEM2(Portmap, _, _) "
+  | ITEM2(Portref, _, _) -> failwith " ITEM2(Portref, _, _) "
+  | ITEM2(Product, _, _) -> failwith " ITEM2(Product, _, _) "
+  | ITEM2(Program, _, _) -> failwith " ITEM2(Program, _, _) "
+  | ITEM2(Property, _, _) -> failwith " ITEM2(Property, _, _) "
+  | ITEM2(Propertydisplay, _, _) -> failwith " ITEM2(Propertydisplay, _, _) "
+  | ITEM2(Protectionframe, _, _) -> failwith " ITEM2(Protectionframe, _, _) "
+  | ITEM2(Pt, _, _) -> failwith " ITEM2(Pt, _, _) "
+  | ITEM2(Rangevector, _, _) -> failwith " ITEM2(Rangevector, _, _) "
+  | ITEM2(Rectangle, _, _) -> failwith " ITEM2(Rectangle, _, _) "
+  | ITEM2(Rectanglesize, _, _) -> failwith " ITEM2(Rectanglesize, _, _) "
+  | ITEM2(Rename, _, _) -> failwith " ITEM2(Rename, _, _) "
+  | ITEM2(Resolves, _, _) -> failwith " ITEM2(Resolves, _, _) "
+  | ITEM2(Scale, _, _) -> failwith " ITEM2(Scale, _, _) "
+  | ITEM2(Scalex, _, _) -> failwith " ITEM2(Scalex, _, _) "
+  | ITEM2(Scaley, _, _) -> failwith " ITEM2(Scaley, _, _) "
+  | ITEM2(Section, _, _) -> failwith " ITEM2(Section, _, _) "
+  | ITEM2(Shape, _, _) -> failwith " ITEM2(Shape, _, _) "
+  | ITEM2(Simulate, _, _) -> failwith " ITEM2(Simulate, _, _) "
+  | ITEM2(Simulationinfo, _, _) -> failwith " ITEM2(Simulationinfo, _, _) "
+  | ITEM2(Singlevalueset, _, _) -> failwith " ITEM2(Singlevalueset, _, _) "
+  | ITEM2(Site, _, _) -> failwith " ITEM2(Site, _, _) "
+  | ITEM2(Socket, _, _) -> failwith " ITEM2(Socket, _, _) "
+  | ITEM2(Socketset, _, _) -> failwith " ITEM2(Socketset, _, _) "
+  | ITEM2(Statement, _, _) -> failwith " ITEM2(Statement, _, _) "
+  | ITEM2(Status, _, _) -> failwith " ITEM2(Status, _, _) "
+  | ITEM2(Steady, _, _) -> failwith " ITEM2(Steady, _, _) "
+  | ITEM2(Strictlyincreasing, _, _) ->
+      failwith " ITEM2(Strictlyincreasing, _, _) "
+  | ITEM2(String, _, _) -> failwith " ITEM2(String, _, _) "
+  | ITEM2(Stringdisplay, _, _) -> failwith " ITEM2(Stringdisplay, _, _) "
+  | ITEM2(Strong, _, _) -> failwith " ITEM2(Strong, _, _) "
+  | ITEM2(Subtract, _, _) -> failwith " ITEM2(Subtract, _, _) "
+  | ITEM2(Sum, _, _) -> failwith " ITEM2(Sum, _, _) "
+  | ITEM2(Symbol, _, _) -> failwith " ITEM2(Symbol, _, _) "
+  | ITEM2(Symmetry, _, _) -> failwith " ITEM2(Symmetry, _, _) "
+  | ITEM2(Table, _, _) -> failwith " ITEM2(Table, _, _) "
+  | ITEM2(Tabledefault, _, _) -> failwith " ITEM2(Tabledefault, _, _) "
+  | ITEM2(Technology, _, _) -> failwith " ITEM2(Technology, _, _) "
+  | ITEM2(Textheight, _, _) -> failwith " ITEM2(Textheight, _, _) "
+  | ITEM2(Then, _, _) -> failwith " ITEM2(Then, _, _) "
+  | ITEM2(Timeinterval, _, _) -> failwith " ITEM2(Timeinterval, _, _) "
+  | ITEM2(Timestamp, _, _) -> failwith " ITEM2(Timestamp, _, _) "
+  | ITEM2(Timing, _, _) -> failwith " ITEM2(Timing, _, _) "
+  | ITEM2(Transform, _, _) -> failwith " ITEM2(Transform, _, _) "
+  | ITEM2(Transition, _, _) -> failwith " ITEM2(Transition, _, _) "
+  | ITEM2(Trigger, _, _) -> failwith " ITEM2(Trigger, _, _) "
+  | ITEM2(True, _, _) -> failwith " ITEM2(True, _, _) "
+  | ITEM2(Typedvalue, _, _) -> failwith " ITEM2(Typedvalue, _, _) "
+  | ITEM2(Unconstrained, _, _) -> failwith " ITEM2(Unconstrained, _, _) "
+  | ITEM2(Undefined, _, _) -> failwith " ITEM2(Undefined, _, _) "
+  | ITEM2(Union, _, _) -> failwith " ITEM2(Union, _, _) "
+  | ITEM2(Unit, _, _) -> failwith " ITEM2(Unit, _, _) "
+  | ITEM2(Unused, _, _) -> failwith " ITEM2(Unused, _, _) "
+  | ITEM2(Userdata, _, _) -> failwith " ITEM2(Userdata, _, _) "
+  | ITEM2(Valuenameref, _, _) -> failwith " ITEM2(Valuenameref, _, _) "
+  | ITEM2(Variable, _, _) -> failwith " ITEM2(Variable, _, _) "
+  | ITEM2(Version, _, _) -> failwith " ITEM2(Version, _, _) "
+  | ITEM2(View, _, _) -> failwith " ITEM2(View, _, _) "
+  | ITEM2(Viewlist, _, _) -> failwith " ITEM2(Viewlist, _, _) "
+  | ITEM2(Viewmap, _, _) -> failwith " ITEM2(Viewmap, _, _) "
+  | ITEM2(Viewref, _, _) -> failwith " ITEM2(Viewref, _, _) "
+  | ITEM2(Viewtype, _, _) -> failwith " ITEM2(Viewtype, _, _) "
+  | ITEM2(Visible, _, _) -> failwith " ITEM2(Visible, _, _) "
+  | ITEM2(Voltagemap, _, _) -> failwith " ITEM2(Voltagemap, _, _) "
+  | ITEM2(Wavevalue, _, _) -> failwith " ITEM2(Wavevalue, _, _) "
+  | ITEM2(Weak, _, _) -> failwith " ITEM2(Weak, _, _) "
+  | ITEM2(Weakjoined, _, _) -> failwith " ITEM2(Weakjoined, _, _) "
+  | ITEM2(When, _, _) -> failwith " ITEM2(When, _, _) "
+  | ITEM2(While, _, _) -> failwith " ITEM2(While, _, _) "
+  | ITEM2(Written, _, _) -> failwith " ITEM2(Written, _, _) "
+  | ITEM2(Xcoord, _, _) -> failwith " ITEM2(Xcoord, _, _) "
+  | ITEM2(Xor, _, _) -> failwith " ITEM2(Xor, _, _) "
+  | ITEM2(Ycoord, _, _) -> failwith " ITEM2(Ycoord, _, _) "
+  | ITEM2(ILLEGAL _, _, _) -> failwith " ITEM2(ILLEGAL _, _, _) "
+  | ITEM2(ID _, _, _) -> failwith " ITEM2(ID _, _, _) "
+  | ITEM2(TLIST _, _, _) -> failwith " ITEM2(TLIST _, _, _) "
+  | ITEM2(TLIST2 _, _, _) -> failwith " ITEM2(TLIST2 _, _, _) "
+  | ITEM2(STRING _, _, _) -> failwith " ITEM2(STRING _, _, _) "
+  | ITEM2(INT _, _, _) -> failwith " ITEM2(INT _, _, _) "
+  | ITEM2(ENDOFFILE, _, _) -> failwith " ITEM2(ENDOFFILE, _, _) "
+  | ITEM2(EOL, _, _) -> failwith " ITEM2(EOL, _, _) "
+  | ITEM2(LPAREN, _, _) -> failwith " ITEM2(LPAREN, _, _) "
+  | ITEM2(RPAREN, _, _) -> failwith " ITEM2(RPAREN, _, _) "
+  | ITEM2(EMPTY, _, _) -> failwith " ITEM2(EMPTY, _, _) "
+
+  | ITEM(Abs, _) -> failwith " ITEM(Abs, _) "
+  | ITEM(Acload, _) -> failwith " ITEM(Acload, _) "
+  | ITEM(After, _) -> failwith " ITEM(After, _) "
+  | ITEM(And, _) -> failwith " ITEM(And, _) "
+  | ITEM(Annotate, _) -> failwith " ITEM(Annotate, _) "
+  | ITEM(Apply, _) -> failwith " ITEM(Apply, _) "
+  | ITEM(Arc, _) -> failwith " ITEM(Arc, _) "
+  | ITEM(Array, _) -> failwith " ITEM(Array, _) "
+  | ITEM(Arraymacro, _) -> failwith " ITEM(Arraymacro, _) "
+  | ITEM(Arrayrelatedinfo, _) -> failwith " ITEM(Arrayrelatedinfo, _) "
+  | ITEM(Arraysite, _) -> failwith " ITEM(Arraysite, _) "
+  | ITEM(Assign, _) -> failwith " ITEM(Assign, _) "
+  | ITEM(Atleast, _) -> failwith " ITEM(Atleast, _) "
+  | ITEM(Atmost, _) -> failwith " ITEM(Atmost, _) "
+  | ITEM(Author, _) -> failwith " ITEM(Author, _) "
+  | ITEM(Basearray, _) -> failwith " ITEM(Basearray, _) "
+  | ITEM(Becomes, _) -> failwith " ITEM(Becomes, _) "
+  | ITEM(Between, _) -> failwith " ITEM(Between, _) "
+  | ITEM(Block, _) -> failwith " ITEM(Block, _) "
+  | ITEM(Boolean, _) -> failwith " ITEM(Boolean, _) "
+  | ITEM(Booleandisplay, _) -> failwith " ITEM(Booleandisplay, _) "
+  | ITEM(Booleanmap, _) -> failwith " ITEM(Booleanmap, _) "
+  | ITEM(Booleanvalue, _) -> failwith " ITEM(Booleanvalue, _) "
+  | ITEM(Borderpattern, _) -> failwith " ITEM(Borderpattern, _) "
+  | ITEM(Borderwidth, _) -> failwith " ITEM(Borderwidth, _) "
+  | ITEM(Boundingbox, _) -> failwith " ITEM(Boundingbox, _) "
+  | ITEM(Ceiling, _) -> failwith " ITEM(Ceiling, _) "
+  | ITEM(Cell, _) -> failwith " ITEM(Cell, _) "
+  | ITEM(Cellref, _) -> failwith " ITEM(Cellref, _) "
+  | ITEM(Celltype, _) -> failwith " ITEM(Celltype, _) "
+  | ITEM(Change, _) -> failwith " ITEM(Change, _) "
+  | ITEM(Circle, _) -> failwith " ITEM(Circle, _) "
+  | ITEM(Color, _) -> failwith " ITEM(Color, _) "
+  | ITEM(Comment, _) -> 32
+  | ITEM(Commentgraphics, _) -> failwith " ITEM(Commentgraphics, _) "
+  | ITEM(Compound, _) -> failwith " ITEM(Compound, _) "
+  | ITEM(Concat, _) -> failwith " ITEM(Concat, _) "
+  | ITEM(Connectlocation, _) -> failwith " ITEM(Connectlocation, _) "
+  | ITEM(Constant, _) -> failwith " ITEM(Constant, _) "
+  | ITEM(Constraint, _) -> failwith " ITEM(Constraint, _) "
+  | ITEM(Contents, _) -> failwith " ITEM(Contents, _) "
+  | ITEM(Cornertype, _) -> failwith " ITEM(Cornertype, _) "
+  | ITEM(Criticality, _) -> failwith " ITEM(Criticality, _) "
+  | ITEM(Currentmap, _) -> failwith " ITEM(Currentmap, _) "
+  | ITEM(Curve, _) -> failwith " ITEM(Curve, _) "
+  | ITEM(Cycle, _) -> failwith " ITEM(Cycle, _) "
+  | ITEM(Dataorigin, _) -> failwith " ITEM(Dataorigin, _) "
+  | ITEM(Dcfaninload, _) -> failwith " ITEM(Dcfaninload, _) "
+  | ITEM(Dcfanoutload, _) -> failwith " ITEM(Dcfanoutload, _) "
+  | ITEM(Dcmaxfanin, _) -> failwith " ITEM(Dcmaxfanin, _) "
+  | ITEM(Dcmaxfanout, _) -> failwith " ITEM(Dcmaxfanout, _) "
+  | ITEM(Delay, _) -> failwith " ITEM(Delay, _) "
+  | ITEM(Delta, _) -> failwith " ITEM(Delta, _) "
+  | ITEM(Derivation, _) -> failwith " ITEM(Derivation, _) "
+  | ITEM(Design, _) -> failwith " ITEM(Design, _) "
+  | ITEM(Designator, _) -> failwith " ITEM(Designator, _) "
+  | ITEM(Difference, _) -> failwith " ITEM(Difference, _) "
+  | ITEM(Direction, _) -> failwith " ITEM(Direction, _) "
+  | ITEM(Display, _) -> failwith " ITEM(Display, _) "
+  | ITEM(Divide, _) -> failwith " ITEM(Divide, _) "
+  | ITEM(Dominates, _) -> failwith " ITEM(Dominates, _) "
+  | ITEM(Dot, _) -> failwith " ITEM(Dot, _) "
+  | ITEM(Duration, _) -> failwith " ITEM(Duration, _) "
+  | ITEM(E, _) -> failwith " ITEM(E, _) "
+  | ITEM(Edif, _) -> failwith " ITEM(Edif, _) "
+  | ITEM(Ediflevel, _) -> failwith " ITEM(Ediflevel, _) "
+  | ITEM(Edifversion, _) -> failwith " ITEM(Edifversion, _) "
+  | ITEM(Else, _) -> failwith " ITEM(Else, _) "
+  | ITEM(Enclosuredistance, _) -> failwith " ITEM(Enclosuredistance, _) "
+  | ITEM(Endtype, _) -> failwith " ITEM(Endtype, _) "
+  | ITEM(Entry, _) -> failwith " ITEM(Entry, _) "
+  | ITEM(Equal, _) -> failwith " ITEM(Equal, _) "
+  | ITEM(Escape, _) -> failwith " ITEM(Escape, _) "
+  | ITEM(Event, _) -> failwith " ITEM(Event, _) "
+  | ITEM(Exactly, _) -> failwith " ITEM(Exactly, _) "
+  | ITEM(External, _) -> failwith " ITEM(External, _) "
+  | ITEM(Fabricate, _) -> failwith " ITEM(Fabricate, _) "
+  | ITEM(False, _) -> failwith " ITEM(False, _) "
+  | ITEM(Figure, _) -> failwith " ITEM(Figure, _) "
+  | ITEM(Figurearea, _) -> failwith " ITEM(Figurearea, _) "
+  | ITEM(Figuregroup, _) -> failwith " ITEM(Figuregroup, _) "
+  | ITEM(Figuregroupobject, _) -> failwith " ITEM(Figuregroupobject, _) "
+  | ITEM(Figuregroupoverride, _) -> failwith " ITEM(Figuregroupoverride, _) "
+  | ITEM(Figuregroupref, _) -> failwith " ITEM(Figuregroupref, _) "
+  | ITEM(Figureperimeter, _) -> failwith " ITEM(Figureperimeter, _) "
+  | ITEM(Figurewidth, _) -> failwith " ITEM(Figurewidth, _) "
+  | ITEM(Fillpattern, _) -> failwith " ITEM(Fillpattern, _) "
+  | ITEM(Fix, _) -> failwith " ITEM(Fix, _) "
+  | ITEM(Floor, _) -> failwith " ITEM(Floor, _) "
+  | ITEM(Follow, _) -> failwith " ITEM(Follow, _) "
+  | ITEM(Forbiddenevent, _) -> failwith " ITEM(Forbiddenevent, _) "
+  | ITEM(Form, _) -> failwith " ITEM(Form, _) "
+  | ITEM(Globalportref, _) -> failwith " ITEM(Globalportref, _) "
+  | ITEM(Greaterthan, _) -> failwith " ITEM(Greaterthan, _) "
+  | ITEM(Gridmap, _) -> failwith " ITEM(Gridmap, _) "
+  | ITEM(If, _) -> failwith " ITEM(If, _) "
+  | ITEM(Ignore, _) -> failwith " ITEM(Ignore, _) "
+  | ITEM(Includefiguregroup, _) -> failwith " ITEM(Includefiguregroup, _) "
+  | ITEM(Increasing, _) -> failwith " ITEM(Increasing, _) "
+  | ITEM(Initial, _) -> failwith " ITEM(Initial, _) "
+  | ITEM(Instance, _) -> failwith " ITEM(Instance, _) "
+  | ITEM(Instancebackannotate, _) -> failwith " ITEM(Instancebackannotate, _) "
+  | ITEM(Instancegroup, _) -> failwith " ITEM(Instancegroup, _) "
+  | ITEM(Instancemap, _) -> failwith " ITEM(Instancemap, _) "
+  | ITEM(Instancenamedef, _) -> failwith " ITEM(Instancenamedef, _) "
+  | ITEM(Instanceref, _) -> failwith " ITEM(Instanceref, _) "
+  | ITEM(Integer, _) -> failwith " ITEM(Integer, _) "
+  | ITEM(Integerdisplay, _) -> failwith " ITEM(Integerdisplay, _) "
+  | ITEM(Interface, _) -> failwith " ITEM(Interface, _) "
+  | ITEM(Interfiguregroupspacing, _) ->
+      failwith " ITEM(Interfiguregroupspacing, _) "
+  | ITEM(Intersection, _) -> failwith " ITEM(Intersection, _) "
+  | ITEM(Intrafiguregroupspacing, _) ->
+      failwith " ITEM(Intrafiguregroupspacing, _) "
+  | ITEM(Inverse, _) -> failwith " ITEM(Inverse, _) "
+  | ITEM(Isolated, _) -> failwith " ITEM(Isolated, _) "
+  | ITEM(Iterate, _) -> failwith " ITEM(Iterate, _) "
+  | ITEM(Joined, _) -> failwith " ITEM(Joined, _) "
+  | ITEM(Justify, _) -> failwith " ITEM(Justify, _) "
+  | ITEM(Keyworddisplay, _) -> failwith " ITEM(Keyworddisplay, _) "
+  | ITEM(Keywordlevel, _) -> failwith " ITEM(Keywordlevel, _) "
+  | ITEM(Keywordmap, _) -> failwith " ITEM(Keywordmap, _) "
+  | ITEM(Lessthan, _) -> failwith " ITEM(Lessthan, _) "
+  | ITEM(Library, _) -> failwith " ITEM(Library, _) "
+  | ITEM(Libraryref, _) -> failwith " ITEM(Libraryref, _) "
+  | ITEM(Listofnets, _) -> failwith " ITEM(Listofnets, _) "
+  | ITEM(Listofports, _) -> failwith " ITEM(Listofports, _) "
+  | ITEM(Loaddelay, _) -> failwith " ITEM(Loaddelay, _) "
+  | ITEM(Logicassign, _) -> failwith " ITEM(Logicassign, _) "
+  | ITEM(Logicinput, _) -> failwith " ITEM(Logicinput, _) "
+  | ITEM(Logiclist, _) -> failwith " ITEM(Logiclist, _) "
+  | ITEM(Logicmapinput, _) -> failwith " ITEM(Logicmapinput, _) "
+  | ITEM(Logicmapoutput, _) -> failwith " ITEM(Logicmapoutput, _) "
+  | ITEM(Logiconeof, _) -> failwith " ITEM(Logiconeof, _) "
+  | ITEM(Logicoutput, _) -> failwith " ITEM(Logicoutput, _) "
+  | ITEM(Logicport, _) -> failwith " ITEM(Logicport, _) "
+  | ITEM(Logicref, _) -> failwith " ITEM(Logicref, _) "
+  | ITEM(Logicvalue, _) -> failwith " ITEM(Logicvalue, _) "
+  | ITEM(Logicwaveform, _) -> failwith " ITEM(Logicwaveform, _) "
+  | ITEM(Maintain, _) -> failwith " ITEM(Maintain, _) "
+  | ITEM(Match, _) -> failwith " ITEM(Match, _) "
+  | ITEM(Max, _) -> failwith " ITEM(Max, _) "
+  | ITEM(Member, _) -> failwith " ITEM(Member, _) "
+  | ITEM(Min, _) -> failwith " ITEM(Min, _) "
+  | ITEM(Minomax, _) -> failwith " ITEM(Minomax, _) "
+  | ITEM(Minomaxdisplay, _) -> failwith " ITEM(Minomaxdisplay, _) "
+  | ITEM(Mnm, _) -> failwith " ITEM(Mnm, _) "
+  | ITEM(Mod, _) -> failwith " ITEM(Mod, _) "
+  | ITEM(Multiplevalueset, _) -> failwith " ITEM(Multiplevalueset, _) "
+  | ITEM(Mustjoin, _) -> failwith " ITEM(Mustjoin, _) "
+  | ITEM(Name, _) -> failwith " ITEM(Name, _) "
+  | ITEM(Negate, _) -> failwith " ITEM(Negate, _) "
+  | ITEM(Net, _) -> failwith " ITEM(Net, _) "
+  | ITEM(Netbackannotate, _) -> failwith " ITEM(Netbackannotate, _) "
+  | ITEM(Netbundle, _) -> failwith " ITEM(Netbundle, _) "
+  | ITEM(Netdelay, _) -> failwith " ITEM(Netdelay, _) "
+  | ITEM(Netgroup, _) -> failwith " ITEM(Netgroup, _) "
+  | ITEM(Netmap, _) -> failwith " ITEM(Netmap, _) "
+  | ITEM(Netref, _) -> failwith " ITEM(Netref, _) "
+  | ITEM(Nochange, _) -> failwith " ITEM(Nochange, _) "
+  | ITEM(Nonpermutable, _) -> failwith " ITEM(Nonpermutable, _) "
+  | ITEM(Not, _) -> failwith " ITEM(Not, _) "
+  | ITEM(Notallowed, _) -> failwith " ITEM(Notallowed, _) "
+  | ITEM(Notchspacing, _) -> failwith " ITEM(Notchspacing, _) "
+  | ITEM(Number, _) -> failwith " ITEM(Number, _) "
+  | ITEM(Numberdefinition, _) -> failwith " ITEM(Numberdefinition, _) "
+  | ITEM(Numberdisplay, _) -> failwith " ITEM(Numberdisplay, _) "
+  | ITEM(Offpageconnector, _) -> failwith " ITEM(Offpageconnector, _) "
+  | ITEM(Offsetevent, _) -> failwith " ITEM(Offsetevent, _) "
+  | ITEM(Openshape, _) -> failwith " ITEM(Openshape, _) "
+  | ITEM(Or, _) -> failwith " ITEM(Or, _) "
+  | ITEM(Orientation, _) -> failwith " ITEM(Orientation, _) "
+  | ITEM(Origin, _) -> failwith " ITEM(Origin, _) "
+  | ITEM(Overhangdistance, _) -> failwith " ITEM(Overhangdistance, _) "
+  | ITEM(Overlapdistance, _) -> failwith " ITEM(Overlapdistance, _) "
+  | ITEM(Oversize, _) -> failwith " ITEM(Oversize, _) "
+  | ITEM(Owner, _) -> failwith " ITEM(Owner, _) "
+  | ITEM(Page, _) -> failwith " ITEM(Page, _) "
+  | ITEM(Pagesize, _) -> failwith " ITEM(Pagesize, _) "
+  | ITEM(Parameter, _) -> failwith " ITEM(Parameter, _) "
+  | ITEM(Parameterassign, _) -> failwith " ITEM(Parameterassign, _) "
+  | ITEM(Parameterdisplay, _) -> failwith " ITEM(Parameterdisplay, _) "
+  | ITEM(Path, _) -> failwith " ITEM(Path, _) "
+  | ITEM(Pathdelay, _) -> failwith " ITEM(Pathdelay, _) "
+  | ITEM(Pathwidth, _) -> failwith " ITEM(Pathwidth, _) "
+  | ITEM(Permutable, _) -> failwith " ITEM(Permutable, _) "
+  | ITEM(Physicaldesignrule, _) -> failwith " ITEM(Physicaldesignrule, _) "
+  | ITEM(Plug, _) -> failwith " ITEM(Plug, _) "
+  | ITEM(Point, _) -> failwith " ITEM(Point, _) "
+  | ITEM(Pointdisplay, _) -> failwith " ITEM(Pointdisplay, _) "
+  | ITEM(Pointlist, _) -> failwith " ITEM(Pointlist, _) "
+  | ITEM(Pointsubtract, _) -> failwith " ITEM(Pointsubtract, _) "
+  | ITEM(Pointsum, _) -> failwith " ITEM(Pointsum, _) "
+  | ITEM(Polygon, _) -> failwith " ITEM(Polygon, _) "
+  | ITEM(Port, _) -> failwith " ITEM(Port, _) "
+  | ITEM(Portbackannotate, _) -> failwith " ITEM(Portbackannotate, _) "
+  | ITEM(Portbundle, _) -> failwith " ITEM(Portbundle, _) "
+  | ITEM(Portdelay, _) -> failwith " ITEM(Portdelay, _) "
+  | ITEM(Portgroup, _) -> failwith " ITEM(Portgroup, _) "
+  | ITEM(Portimplementation, _) -> failwith " ITEM(Portimplementation, _) "
+  | ITEM(Portinstance, _) -> failwith " ITEM(Portinstance, _) "
+  | ITEM(Portlist, _) -> failwith " ITEM(Portlist, _) "
+  | ITEM(Portlistalias, _) -> failwith " ITEM(Portlistalias, _) "
+  | ITEM(Portmap, _) -> failwith " ITEM(Portmap, _) "
+  | ITEM(Portref, _) -> failwith " ITEM(Portref, _) "
+  | ITEM(Product, _) -> failwith " ITEM(Product, _) "
+  | ITEM(Program, _) -> failwith " ITEM(Program, _) "
+  | ITEM(Property, _) -> failwith " ITEM(Property, _) "
+  | ITEM(Propertydisplay, _) -> failwith " ITEM(Propertydisplay, _) "
+  | ITEM(Protectionframe, _) -> failwith " ITEM(Protectionframe, _) "
+  | ITEM(Pt, _) -> failwith " ITEM(Pt, _) "
+  | ITEM(Rangevector, _) -> failwith " ITEM(Rangevector, _) "
+  | ITEM(Rectangle, _) -> failwith " ITEM(Rectangle, _) "
+  | ITEM(Rectanglesize, _) -> failwith " ITEM(Rectanglesize, _) "
+  | ITEM(Rename, _) -> failwith " ITEM(Rename, _) "
+  | ITEM(Resolves, _) -> failwith " ITEM(Resolves, _) "
+  | ITEM(Scale, _) -> failwith " ITEM(Scale, _) "
+  | ITEM(Scalex, _) -> failwith " ITEM(Scalex, _) "
+  | ITEM(Scaley, _) -> failwith " ITEM(Scaley, _) "
+  | ITEM(Section, _) -> failwith " ITEM(Section, _) "
+  | ITEM(Shape, _) -> failwith " ITEM(Shape, _) "
+  | ITEM(Simulate, _) -> failwith " ITEM(Simulate, _) "
+  | ITEM(Simulationinfo, _) -> failwith " ITEM(Simulationinfo, _) "
+  | ITEM(Singlevalueset, _) -> failwith " ITEM(Singlevalueset, _) "
+  | ITEM(Site, _) -> failwith " ITEM(Site, _) "
+  | ITEM(Socket, _) -> failwith " ITEM(Socket, _) "
+  | ITEM(Socketset, _) -> failwith " ITEM(Socketset, _) "
+  | ITEM(Statement, _) -> failwith " ITEM(Statement, _) "
+  | ITEM(Status, _) -> failwith " ITEM(Status, _) "
+  | ITEM(Steady, _) -> failwith " ITEM(Steady, _) "
+  | ITEM(Strictlyincreasing, _) -> failwith " ITEM(Strictlyincreasing, _) "
+  | ITEM(String, _) -> failwith " ITEM(String, _) "
+  | ITEM(Stringdisplay, _) -> failwith " ITEM(Stringdisplay, _) "
+  | ITEM(Strong, _) -> failwith " ITEM(Strong, _) "
+  | ITEM(Subtract, _) -> failwith " ITEM(Subtract, _) "
+  | ITEM(Sum, _) -> failwith " ITEM(Sum, _) "
+  | ITEM(Symbol, _) -> failwith " ITEM(Symbol, _) "
+  | ITEM(Symmetry, _) -> failwith " ITEM(Symmetry, _) "
+  | ITEM(Table, _) -> failwith " ITEM(Table, _) "
+  | ITEM(Tabledefault, _) -> failwith " ITEM(Tabledefault, _) "
+  | ITEM(Technology, _) -> failwith " ITEM(Technology, _) "
+  | ITEM(Textheight, _) -> failwith " ITEM(Textheight, _) "
+  | ITEM(Then, _) -> failwith " ITEM(Then, _) "
+  | ITEM(Timeinterval, _) -> failwith " ITEM(Timeinterval, _) "
+  | ITEM(Timestamp, _) -> failwith " ITEM(Timestamp, _) "
+  | ITEM(Timing, _) -> failwith " ITEM(Timing, _) "
+  | ITEM(Transform, _) -> failwith " ITEM(Transform, _) "
+  | ITEM(Transition, _) -> failwith " ITEM(Transition, _) "
+  | ITEM(Trigger, _) -> failwith " ITEM(Trigger, _) "
+  | ITEM(True, _) -> failwith " ITEM(True, _) "
+  | ITEM(Typedvalue, _) -> failwith " ITEM(Typedvalue, _) "
+  | ITEM(Unconstrained, _) -> failwith " ITEM(Unconstrained, _) "
+  | ITEM(Undefined, _) -> failwith " ITEM(Undefined, _) "
+  | ITEM(Union, _) -> failwith " ITEM(Union, _) "
+  | ITEM(Unit, _) -> failwith " ITEM(Unit, _) "
+  | ITEM(Unused, _) -> failwith " ITEM(Unused, _) "
+  | ITEM(Userdata, _) -> failwith " ITEM(Userdata, _) "
+  | ITEM(Valuenameref, _) -> failwith " ITEM(Valuenameref, _) "
+  | ITEM(Variable, _) -> failwith " ITEM(Variable, _) "
+  | ITEM(Version, _) -> failwith " ITEM(Version, _) "
+  | ITEM(View, _) -> failwith " ITEM(View, _) "
+  | ITEM(Viewlist, _) -> failwith " ITEM(Viewlist, _) "
+  | ITEM(Viewmap, _) -> failwith " ITEM(Viewmap, _) "
+  | ITEM(Viewref, _) -> failwith " ITEM(Viewref, _) "
+  | ITEM(Viewtype, _) -> failwith " ITEM(Viewtype, _) "
+  | ITEM(Visible, _) -> failwith " ITEM(Visible, _) "
+  | ITEM(Voltagemap, _) -> failwith " ITEM(Voltagemap, _) "
+  | ITEM(Wavevalue, _) -> failwith " ITEM(Wavevalue, _) "
+  | ITEM(Weak, _) -> failwith " ITEM(Weak, _) "
+  | ITEM(Weakjoined, _) -> failwith " ITEM(Weakjoined, _) "
+  | ITEM(When, _) -> failwith " ITEM(When, _) "
+  | ITEM(While, _) -> failwith " ITEM(While, _) "
+  | ITEM(Written, _) -> failwith " ITEM(Written, _) "
+  | ITEM(Xcoord, _) -> failwith " ITEM(Xcoord, _) "
+  | ITEM(Xor, _) -> failwith " ITEM(Xor, _) "
+  | ITEM(Ycoord, _) -> failwith " ITEM(Ycoord, _) "
+  | ITEM(ILLEGAL _, _) -> failwith " ITEM(ILLEGAL _, _) "
+  | ITEM(ID _, _) -> failwith " ITEM(ID _, _) "
+  | ITEM(TLIST _, _) -> failwith " ITEM(TLIST _, _) "
+  | ITEM(TLIST2 _, _) -> failwith " ITEM(TLIST2 _, _) "
+  | ITEM(STRING _, _) -> failwith " ITEM(STRING _, _) "
+  | ITEM(INT _, _) -> failwith " ITEM(INT _, _) "
+  | ITEM(ENDOFFILE, _) -> failwith " ITEM(ENDOFFILE, _) "
+  | ITEM(EOL, _) -> failwith " ITEM(EOL, _) "
+  | ITEM(LPAREN, _) -> failwith " ITEM(LPAREN, _) "
+  | ITEM(RPAREN, _) -> failwith " ITEM(RPAREN, _) "
+  | ITEM(EMPTY, _) -> failwith " ITEM(EMPTY, _) "
+  | ITEM ((ITEM _|ITEM2 _), _) -> failwith " ITEM ((ITEM _|ITEM2 _), _) "
+  | ITEM2 ((ITEM _|ITEM2 _), _, _) ->
+      failwith " ITEM2 ((ITEM _|ITEM2 _), _, _) "
+
+let () =  printf "PR#6646=Ok\n%!"
+
+(* Simplified example, with application test *)
+
+type t =
+  | B of int
+  | C of int
+  | I of t list
+  | A00
+  | A01
+  | A02
+  | A03
+  | A04
+  | A05
+  | A06
+  | A07
+  | A08
+  | A09
+  | A10
+  | A11
+  | A12
+  | A13
+  | A14
+  | A15
+  | A16
+  | A17
+  | A18
+  | A19
+  | A20
+  | A21
+  | A22
+  | A23
+  | A24
+  | A25
+  | A26
+  | A27
+  | A28
+  | A29
+  | A30
+  | A31
+  | A32
+  | A33
+  | A34
+  | A35
+  | A36
+  | A37
+  | A38
+  | A39
+  | A40
+  | A41
+  | A42
+  | A43
+  | A44
+  | A45
+  | A46
+  | A47
+  | A48
+  | A49
+  | A50
+  | A51
+  | A52
+  | A53
+  | A54
+  | A55
+  | A56
+  | A57
+  | A58
+  | A59
+  | A60
+  | A61
+  | A62
+  | A63
+  | A64
+  | A65
+  | A66
+  | A67
+  | A68
+  | A69
+  | A70
+  | A71
+  | A72
+  | A73
+  | A74
+  | A75
+  | A76
+  | A77
+  | A78
+  | A79
+  | A80
+  | A81
+  | A82
+  | A83
+  | A84
+  | A85
+  | A86
+  | A87
+  | A88
+  | A89
+  | A90
+  | A91
+  | A92
+  | A93
+  | A94
+  | A95
+  | A96
+  | A97
+  | A98
+  | A99
+
+
+let test = function
+  | I [A00;I [I [A00;I [A00]]]] -> 1
+  | I [A00;I [I [A00;I [A01]]]] -> 2
+  | I [A00;I [I [A00;I [A02]]]] -> 3
+  | I [A00;I [I [A00;I [A03]]]] -> -3
+  | I [A00;I [I [A00;I [A04]]]] -> 4
+  | I [A00;I [I [A00;I [A05]]]] -> 5
+  | I [A00;I [I [A00;I [A06]]]] -> 6
+  | I [A00;I [I [A00;I [A07]]]] -> 7
+  | I [A00;I [I [A00;I [A08]]]] -> 8
+  | I [A00;I [I [A00;I [A09]]]] -> 9
+
+  | I [A00;I [I [_ ; I [A00]]]] -> 11
+  | I [A00;I [I [_ ; I [A01]]]] -> 12
+  | I [A00;I [I [_ ; I [A02]]]] -> 13
+  | _ -> -1
+
+
+let () =
+  assert (test (I [A00;I [I [A00;I [A00]]]]) = 1) ;
+  assert (test (I [A00;I [I [A20;I [A00]]]]) = 11) ;
+  assert (test (I [A00;I [I [A00;I [A01]]]]) = 2) ;
+  assert (test (I [A00;I [I [A20;I [A01]]]]) = 12) ;
+  assert (test (I [A00;I [I [A00;I [A02]]]]) = 3) ;
+  assert (test (I [A00;I [I [A20;I [A02]]]]) = 13) ;
+  assert (test (I [A00;I [I [A00;I [A03]]]]) = -3) ;
+  assert (test (I [A00;I [I [A20;I [A03]]]]) = -1) ;
+  printf "PR#6646=Ok\n%!"
+
+(* PR#6674, a compilation failure introduced by correcting PR#6646 *)
+
+type t6674 =
+  | A1
+  | A2
+  | A3
+  | A4
+  | A5
+  | A6
+  | A7
+  | A8
+  | A9
+  | A10
+  | A11
+  | A12
+  | A13
+  | A14
+  | A15
+  | A16
+  | A17
+  | A18
+  | A19
+  | A20
+  | A21
+  | A22
+  | A23
+  | A24
+  | A25
+  | A26
+  | A27
+  | A28
+  | A29
+  | A30
+  | A31
+  | A32
+  | X of string
+
+let f = function
+  | X _ -> true
+  | _ -> false
+
+let () =  printf "PR#6676=Ok\n%!"
+
+(* GPR#234, allow ``[]`` as a user defined constructor *)
+module GPR234HList = struct
+
+  type _ cell =
+    | Int : int -> int cell
+    | Pair : int * int -> (int * int) cell
+    | StrInt : string -> string cell
+    | List : int list -> int list cell
+
+  type hlist =
+    | [] : hlist
+    | ( :: ) : 'a cell * hlist -> hlist
+
+  type 'b foldf = {
+    f: 'a. 'a cell -> 'b -> 'b
+  }
+
+  let fold_hlist : 'b foldf -> 'b -> hlist -> 'b = fun f init l ->
+    let rec loop : hlist -> 'b -> 'b = fun l acc ->
+      match l with
+      | [] -> acc
+      | hd :: tl -> loop tl (f.f hd acc) in
+    loop l init
+
+  let to_int_fold : type a. a cell -> int -> int = fun cell acc ->
+    match cell with
+    | Int x -> x + acc
+    | Pair (x, y) -> x + y + acc
+    | StrInt str -> int_of_string str + acc
+    | List l -> acc + List.fold_left (+) 0 l
+
+  let sum l = fold_hlist {f=to_int_fold} 0 l
+
+  let l = List [1; 2; 3] (* still fine to use normal list here *)
+
+  let ll = [Int 3; Pair (4, 5); StrInt "30"; l]
+
+  let test () = Printf.printf "%d\n" (sum ll)
+
+end
+
+let () = GPR234HList.test ()
+
+let () = printf "GPR#234=Ok\n%!"
diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference
new file mode 100644
index 00000000..11cd189a
--- /dev/null
+++ b/testsuite/tests/basic/patmatch.reference
@@ -0,0 +1,76 @@
+f(-5) = 0
+f(-4) = 0
+f(-3) = 0
+f(-2) = 0
+f(-1) = 0
+f(0) = 0
+f(1) = 1
+f(2) = 2
+f(3) = 3
+f(4) = 4
+f(5) = 5
+f(6) = 6
+f(7) = 0
+f(8) = 0
+f(9) = 0
+f(10) = 0
+g(0) = 0
+g(300) = 0
+g(303) = 1
+g(305) = 0
+g(400) = 0
+g(401) = 2
+g(402) = 0
+g(999) = 0
+iszero(-2) = false
+iszero(-1) = false
+iszero(0) = true
+iszero(1) = false
+iszero(2) = false
+h(a) = a
+h(b) = ?
+h(c) = ?
+h(d) = ?
+h(e) = e
+h(f) = ?
+h(g) = ?
+h(h) = ?
+h(i) = i
+h(j) = ?
+h(k) = ?
+h(l) = ?
+h(m) = ?
+h(n) = ?
+h(o) = o
+h(p) = ?
+h(q) = ?
+h(r) = ?
+h(s) = ?
+h(t) = ?
+h(u) = u
+h(v) = ?
+h(w) = ?
+h(x) = ?
+h(y) = ?
+h(z) = ?
+h({) = ?
+h(|) = ?
+h(}) = ?
+h(~) = ?
+	k(\000) = othr	k(\001) = othr	k(\002) = othr	k(\003) = othr	k(\004) = othr	k(\005) = othr	k(\006) = othr	k(\007) = othr	k(\b) = othr	k(\t) = blk	k(\n) = blk	k(\011) = othr	k(\012) = othr	k(\r) = blk	k(\014) = othr	k(\015) = othr	k(\016) = othr	k(\017) = othr	k(\018) = othr	k(\019) = othr	k(\020) = othr	k(\021) = othr	k(\022) = othr	k(\023) = othr	k(\024) = othr	k(\025) = othr	k(\026) = othr	k(\027) = othr	k(\028) = othr	k(\029) = othr	k(\030) = othr	k(\031) = othr	k( ) = blk	k(!) = oper	k(\034) = othr	k(#) = oper	k($) = oper	k(%) = oper	k(&) = oper	k(\') = othr	k(\040) = othr	k(\041) = othr	k(*) = oper	k(+) = oper	k(\044) = othr	k(\045) = othr	k(\046) = othr	k(/) = oper	k(0) = dig	k(1) = dig	k(2) = dig	k(3) = dig	k(4) = dig	k(5) = dig	k(6) = dig	k(7) = dig	k(8) = dig	k(9) = dig	k(:) = oper	k(\059) = othr	k(<) = oper	k(=) = oper	k(>) = oper	k(?) = oper	k(@) = oper	k(A) = letr	k(B) = letr	k(C) = letr	k(D) = letr	k(E) = letr	k(F) = letr	k(G) = letr	k(H) = letr	k(I) = letr	k(J) = letr	k(K) = letr	k(L) = letr	k(M) = letr	k(N) = letr	k(O) = letr	k(P) = letr	k(Q) = letr	k(R) = letr	k(S) = letr	k(T) = letr	k(U) = letr	k(V) = letr	k(W) = letr	k(X) = letr	k(Y) = letr	k(Z) = letr	k(\091) = othr	k(\\) = oper	k(\093) = othr	k(^) = oper	k(\095) = othr	k(\096) = othr	k(a) = letr	k(b) = letr	k(c) = letr	k(d) = letr	k(e) = letr	k(f) = letr	k(g) = letr	k(h) = letr	k(i) = letr	k(j) = letr	k(k) = letr	k(l) = letr	k(m) = letr	k(n) = letr	k(o) = letr	k(p) = letr	k(q) = letr	k(r) = letr	k(s) = letr	k(t) = letr	k(u) = letr	k(v) = letr	k(w) = letr	k(x) = letr	k(y) = letr	k(z) = letr	k(\123) = othr	k(|) = oper	k(\125) = othr	k(~) = oper	k(\127) = othr	k(\128) = othr	k(\129) = othr	k(\130) = othr	k(\131) = othr	k(\132) = othr	k(\133) = othr	k(\134) = othr	k(\135) = othr	k(\136) = othr	k(\137) = othr	k(\138) = othr	k(\139) = othr	k(\140) = othr	k(\141) = othr	k(\142) = othr	k(\143) = othr	k(\144) = othr	k(\145) = othr	k(\146) = othr	k(\147) = othr	k(\148) = othr	k(\149) = othr	k(\150) = othr	k(\151) = othr	k(\152) = othr	k(\153) = othr	k(\154) = othr	k(\155) = othr	k(\156) = othr	k(\157) = othr	k(\158) = othr	k(\159) = othr	k(\160) = othr	k(\161) = othr	k(\162) = othr	k(\163) = othr	k(\164) = othr	k(\165) = othr	k(\166) = othr	k(\167) = othr	k(\168) = othr	k(\169) = othr	k(\170) = othr	k(\171) = othr	k(\172) = othr	k(\173) = othr	k(\174) = othr	k(\175) = othr	k(\176) = othr	k(\177) = othr	k(\178) = othr	k(\179) = othr	k(\180) = othr	k(\181) = othr	k(\182) = othr	k(\183) = othr	k(\184) = othr	k(\185) = othr	k(\186) = othr	k(\187) = othr	k(\188) = othr	k(\189) = othr	k(\190) = othr	k(\191) = othr	k(\192) = letr	k(\193) = letr	k(\194) = letr	k(\195) = letr	k(\196) = letr	k(\197) = letr	k(\198) = letr	k(\199) = letr	k(\200) = letr	k(\201) = letr	k(\202) = letr	k(\203) = letr	k(\204) = letr	k(\205) = letr	k(\206) = letr	k(\207) = letr	k(\208) = letr	k(\209) = letr	k(\210) = letr	k(\211) = letr	k(\212) = letr	k(\213) = letr	k(\214) = letr	k(\215) = letr	k(\216) = letr	k(\217) = letr	k(\218) = letr	k(\219) = letr	k(\220) = letr	k(\221) = letr	k(\222) = letr	k(\223) = letr	k(\224) = letr	k(\225) = letr	k(\226) = letr	k(\227) = letr	k(\228) = letr	k(\229) = letr	k(\230) = letr	k(\231) = letr	k(\232) = letr	k(\233) = letr	k(\234) = letr	k(\235) = letr	k(\236) = letr	k(\237) = letr	k(\238) = letr	k(\239) = letr	k(\240) = letr	k(\241) = letr	k(\242) = letr	k(\243) = letr	k(\244) = letr	k(\245) = letr	k(\246) = letr	k(\247) = letr	k(\248) = letr	k(\249) = letr	k(\250) = letr	k(\251) = letr	k(\252) = letr	k(\253) = letr	k(\254) = letr	k(\255) = letr
+p([|"hello"|]) = hello
+p([|1.0|]) = 1.000000
+q([|2|]) = 2
+r([|3.0|]) = 3.000000
+l([||]) = 0
+l([|1|]) = 2
+l([|2;3|]) = 5
+l([|4;5;6|]) = 15
+PR#5992=Ok
+PR#5788=Ok
+PR#5788=Ok
+PR#6646=Ok
+PR#6646=Ok
+PR#6676=Ok
+48
+GPR#234=Ok
diff --git a/testsuite/tests/basic/pr6322.ml.in b/testsuite/tests/basic/pr6322.ml.in
new file mode 100644
index 00000000..460f0a3c
--- /dev/null
+++ b/testsuite/tests/basic/pr6322.ml.in
@@ -0,0 +1,11 @@
+(* No string sharing PR#6322. This test is not applicable when OCaml is compiled with -safe-string. *)
+
+let test x = match x with
+  | true -> "a"
+  | false -> "a"
+
+let () =
+  let s1 = test true in
+  let s2 = test false in
+  s1.[0] <- 'p';
+  if s1 <> s2 then Printf.printf "PR#6322=Ok\n%!"
diff --git a/testsuite/tests/basic/pr6322.reference b/testsuite/tests/basic/pr6322.reference
new file mode 100644
index 00000000..e07c25c6
--- /dev/null
+++ b/testsuite/tests/basic/pr6322.reference
@@ -0,0 +1 @@
+PR#6322=Ok
diff --git a/testsuite/tests/basic/pr7533.ml b/testsuite/tests/basic/pr7533.ml
new file mode 100644
index 00000000..47bbeeea
--- /dev/null
+++ b/testsuite/tests/basic/pr7533.ml
@@ -0,0 +1,19 @@
+(* PR#7533 *)
+
+exception Foo
+
+let f x =
+  if x > 42 then 1
+  else raise Foo
+
+let () =
+  let f = Sys.opaque_identity f in
+  match (f 0) / (List.hd (Sys.opaque_identity [0])) with
+  | exception Foo -> ()
+  | _ -> assert false
+
+let () =
+  let f = Sys.opaque_identity f in
+  match (f 0) mod (List.hd (Sys.opaque_identity [0])) with
+  | exception Foo -> ()
+  | _ -> assert false
diff --git a/testsuite/tests/basic/pr7533.reference b/testsuite/tests/basic/pr7533.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/recvalues.ml b/testsuite/tests/basic/recvalues.ml
new file mode 100644
index 00000000..df32f5e7
--- /dev/null
+++ b/testsuite/tests/basic/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/testsuite/tests/basic/recvalues.reference b/testsuite/tests/basic/recvalues.reference
new file mode 100644
index 00000000..ac71fc1d
--- /dev/null
+++ b/testsuite/tests/basic/recvalues.reference
@@ -0,0 +1,5 @@
+Test 1: passed
+Test 2: passed
+Test 3: passed
+foo
+Test 4: passed
diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml
new file mode 100644
index 00000000..8ce6ad59
--- /dev/null
+++ b/testsuite/tests/basic/sets.ml
@@ -0,0 +1,25 @@
+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/testsuite/tests/basic/sets.reference b/testsuite/tests/basic/sets.reference
new file mode 100644
index 00000000..2d4ebc24
--- /dev/null
+++ b/testsuite/tests/basic/sets.reference
@@ -0,0 +1,25 @@
+-10  true  false
+-9  false  false
+-8  false  false
+-7  false  true
+-6  false  false
+-5  false  false
+-4  false  false
+-3  false  true
+-2  true  false
+-1  false  false
+0  true  false
+1  false  true
+2  true  false
+3  false  false
+4  true  false
+5  false  true
+6  true  false
+7  false  false
+8  false  false
+9  false  true
+10  false  false
+false
+true
+true
+false
diff --git a/testsuite/tests/basic/stringmatch.ml b/testsuite/tests/basic/stringmatch.ml
new file mode 100644
index 00000000..e1f4bdb4
--- /dev/null
+++ b/testsuite/tests/basic/stringmatch.ml
@@ -0,0 +1,738 @@
+(* Empty string oddities *)
+
+let rec tst01 s = match s with
+| "" -> 0
+| _ -> 1
+
+let () =
+  assert (tst01 "" = 0) ;
+  assert (tst01  "\000\000\000\003" = 1) ;
+  assert (tst01  "\000\000\000\000\000\000\000\007" = 1) ;
+  ()
+
+(* A few when clauses *)
+
+let tst02 s =
+  let len = String.length s in
+  match s with
+  | "" when len < 0 -> assert false
+  | "" -> 1
+  | _ when len = 0 -> assert false
+  | "A" -> 2
+  | _ -> 3
+
+let () =
+  assert (tst02 "" = 1) ;
+  assert (tst02 "A" = 2) ;
+  assert (tst02 "B" = 3) ;
+  assert (tst02 "\000\000\000\000\000\000\000\007" = 3) ;
+  assert (tst02 "\000\000\000\003" = 3) ;
+  ()
+
+(* Keword reckognition *)
+
+let s00 = "get_const"
+let t00 = "set_congt"
+let s01 = "get_var"
+let t01 = "gat_ver"
+let s02 = "get_env"
+let t02 = "get_env"
+let s03 = "get_meth"
+let t03 = "met_geth"
+let s04 = "set_var"
+let t04 = "sev_tar"
+let s05 = "app_const"
+let t05 = "ppa_const"
+let s06 = "app_var"
+let t06 = "app_var"
+let s07 = "app_env"
+let t07 = "epp_anv"
+let s08 = "app_meth"
+let t08 = "atp_meph"
+let s09 = "app_const_const"
+let t09 = "app_const_const"
+let s10 = "app_const_var"
+let t10 = "atp_consp_var"
+let s11 = "app_const_env"
+let t11 = "app_constne_v"
+let s12 = "app_const_meth"
+let t12 = "spp_conat_meth"
+let s13 = "app_var_const"
+let t13 = "app_va_rconst"
+let s14 = "app_env_const"
+let t14 = "app_env_const"
+let s15 = "app_meth_const"
+let t15 = "app_teth_consm"
+let s16 = "meth_app_const"
+let t16 = "math_epp_const"
+let s17 = "meth_app_var"
+let t17 = "meth_app_var"
+let s18 = "meth_app_env"
+let t18 = "eeth_app_mnv"
+let s19 = "meth_app_meth"
+let t19 = "meth_apt_meph"
+let s20 = "send_const"
+let t20 = "tend_conss"
+let s21 = "send_var"
+let t21 = "serd_van"
+let s22 = "send_env"
+let t22 = "sen_denv"
+let s23 = "send_meth"
+let t23 = "tend_mesh"
+
+let tst03 s = match s with
+| "get_const" -> 0
+| "get_var" -> 1
+| "get_env" -> 2
+| "get_meth" -> 3
+| "set_var" -> 4
+| "app_const" -> 5
+| "app_var" -> 6
+| "app_env" -> 7
+| "app_meth" -> 8
+| "app_const_const" -> 9
+| "app_const_var" -> 10
+| "app_const_env" -> 11
+| "app_const_meth" -> 12
+| "app_var_const" -> 13
+| "app_env_const" -> 14
+| "app_meth_const" -> 15
+| "meth_app_const" -> 16
+| "meth_app_var" -> 17
+| "meth_app_env" -> 18
+| "meth_app_meth" -> 19
+| "send_const" -> 20
+| "send_var" -> 21
+| "send_env" -> 22
+| "send_meth" -> 23
+| _ -> -1
+
+let () =
+  assert (tst03 s00 = 0) ;
+  assert (tst03 t00 = -1) ;
+  assert (tst03 s01 = 1) ;
+  assert (tst03 t01 = -1) ;
+  assert (tst03 s02 = 2) ;
+  assert (tst03 t02 = 2) ;
+  assert (tst03 s03 = 3) ;
+  assert (tst03 t03 = -1) ;
+  assert (tst03 s04 = 4) ;
+  assert (tst03 t04 = -1) ;
+  assert (tst03 s05 = 5) ;
+  assert (tst03 t05 = -1) ;
+  assert (tst03 s06 = 6) ;
+  assert (tst03 t06 = 6) ;
+  assert (tst03 s07 = 7) ;
+  assert (tst03 t07 = -1) ;
+  assert (tst03 s08 = 8) ;
+  assert (tst03 t08 = -1) ;
+  assert (tst03 s09 = 9) ;
+  assert (tst03 t09 = 9) ;
+  assert (tst03 s10 = 10) ;
+  assert (tst03 t10 = -1) ;
+  assert (tst03 s11 = 11) ;
+  assert (tst03 t11 = -1) ;
+  assert (tst03 s12 = 12) ;
+  assert (tst03 t12 = -1) ;
+  assert (tst03 s13 = 13) ;
+  assert (tst03 t13 = -1) ;
+  assert (tst03 s14 = 14) ;
+  assert (tst03 t14 = 14) ;
+  assert (tst03 s15 = 15) ;
+  assert (tst03 t15 = -1) ;
+  assert (tst03 s16 = 16) ;
+  assert (tst03 t16 = -1) ;
+  assert (tst03 s17 = 17) ;
+  assert (tst03 t17 = 17) ;
+  assert (tst03 s18 = 18) ;
+  assert (tst03 t18 = -1) ;
+  assert (tst03 s19 = 19) ;
+  assert (tst03 t19 = -1) ;
+  assert (tst03 s20 = 20) ;
+  assert (tst03 t20 = -1) ;
+  assert (tst03 s21 = 21) ;
+  assert (tst03 t21 = -1) ;
+  assert (tst03 s22 = 22) ;
+  assert (tst03 t22 = -1) ;
+  assert (tst03 s23 = 23) ;
+  assert (tst03 t23 = -1) ;
+  ()
+
+(* Activate the test first column first heuristics *)
+
+let s00 = "AAAAAAAA"
+let s01 = "AAAAAAAAAAAAAAAA"
+let s02 = "AAAAAAAAAAAAAAAAAAAAAAAA"
+let s03 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s04 = "BBBBBBBB"
+let s05 = "BBBBBBBBBBBBBBBB"
+let s06 = "BBBBBBBBBBBBBBBBBBBBBBBB"
+let s07 = "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB"
+let s08 = "CCCCCCCC"
+let s09 = "CCCCCCCCCCCCCCCC"
+let s10 = "CCCCCCCCCCCCCCCCCCCCCCCC"
+let s11 = "CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC"
+
+let tst04 s = match s with
+| "AAAAAAAA" -> 0
+| "AAAAAAAAAAAAAAAA" -> 1
+| "AAAAAAAAAAAAAAAAAAAAAAAA" -> 2
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 3
+| "BBBBBBBB" -> 4
+| "BBBBBBBBBBBBBBBB" -> 5
+| "BBBBBBBBBBBBBBBBBBBBBBBB" -> 6
+| "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB" -> 7
+| "CCCCCCCC" -> 8
+| "CCCCCCCCCCCCCCCC" -> 9
+| "CCCCCCCCCCCCCCCCCCCCCCCC" -> 10
+| "CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC" -> 11
+| _ -> -1
+
+let () =
+  assert (tst04 s00 = 0) ;
+  assert (tst04 s01 = 1) ;
+  assert (tst04 s02 = 2) ;
+  assert (tst04 s03 = 3) ;
+  assert (tst04 s04 = 4) ;
+  assert (tst04 s05 = 5) ;
+  assert (tst04 s06 = 6) ;
+  assert (tst04 s07 = 7) ;
+  assert (tst04 s08 = 8) ;
+  assert (tst04 s09 = 9) ;
+  assert (tst04 s10 = 10) ;
+  assert (tst04 s11 = 11) ;
+  assert (tst04 "" = -1) ;
+  assert (tst04 "DDD" = -1) ;
+  assert (tst04 "DDDDDDD" = -1) ;
+  assert (tst04 "AAADDDD" = -1) ;
+  assert (tst04 "AAAAAAADDDDDDDD" = -1) ;
+  assert (tst04 "AAAAAAADDDD" = -1) ;
+  assert (tst04 "AAAAAAAAAAAAAAADDDD" = -1) ;
+  ()
+
+(* Similar *)
+
+let s00 = "AAA"
+let s01 = "AAAA"
+let s02 = "AAAAA"
+let s03 = "AAAAAA"
+let s04 = "AAAAAAA"
+let s05 = "AAAAAAAAAAAA"
+let s06 = "AAAAAAAAAAAAAAAA"
+let s07 = "AAAAAAAAAAAAAAAAAAAA"
+let s08 = "BBB"
+let s09 = "BBBB"
+let s10 = "BBBBB"
+let s11 = "BBBBBB"
+let s12 = "BBBBBBB"
+
+let tst05 s = match s with
+| "AAA" -> 0
+| "AAAA" -> 1
+| "AAAAA" -> 2
+| "AAAAAA" -> 3
+| "AAAAAAA" -> 4
+| "AAAAAAAAAAAA" -> 5
+| "AAAAAAAAAAAAAAAA" -> 6
+| "AAAAAAAAAAAAAAAAAAAA" -> 7
+| "BBB" -> 8
+| "BBBB" -> 9
+| "BBBBB" -> 10
+| "BBBBBB" -> 11
+| "BBBBBBB" -> 12
+| _ -> -1
+
+let () =
+  assert (tst05 s00 = 0) ;
+  assert (tst05 s01 = 1) ;
+  assert (tst05 s02 = 2) ;
+  assert (tst05 s03 = 3) ;
+  assert (tst05 s04 = 4) ;
+  assert (tst05 s05 = 5) ;
+  assert (tst05 s06 = 6) ;
+  assert (tst05 s07 = 7) ;
+  assert (tst05 s08 = 8) ;
+  assert (tst05 s09 = 9) ;
+  assert (tst05 s10 = 10) ;
+  assert (tst05 s11 = 11) ;
+  assert (tst05 s12 = 12) ;
+  assert (tst05 "" = -1) ;
+  assert (tst05 "AAD" = -1) ;
+  assert (tst05 "AAAD" = -1) ;
+  assert (tst05 "AAAAAAD" = -1) ;
+  assert (tst05 "AAAAAAAD" = -1) ;
+  assert (tst05 "BBD" = -1) ;
+  assert (tst05 "BBBD" = -1) ;
+  assert (tst05 "BBBBBBD" = -1) ;
+  assert (tst05 "BBBBBBBD" = -1) ;
+  ()
+
+(* Big test *)
+
+let s00 = "and"
+let t00 = "nad"
+let s01 = "as"
+let t01 = "sa"
+let s02 = "assert"
+let t02 = "asesrt"
+let s03 = "begin"
+let t03 = "negib"
+let s04 = "class"
+let t04 = "lcass"
+let s05 = "constraint"
+let t05 = "constiarnt"
+let s06 = "do"
+let t06 = "od"
+let s07 = "done"
+let t07 = "eond"
+let s08 = "downto"
+let t08 = "dowtno"
+let s09 = "else"
+let t09 = "lese"
+let s10 = "end"
+let t10 = "edn"
+let s11 = "exception"
+let t11 = "exception"
+let s12 = "external"
+let t12 = "external"
+let s13 = "false"
+let t13 = "fslae"
+let s14 = "for"
+let t14 = "ofr"
+let s15 = "fun"
+let t15 = "fnu"
+let s16 = "function"
+let t16 = "function"
+let s17 = "functor"
+let t17 = "ounctfr"
+let s18 = "if"
+let t18 = "fi"
+let s19 = "in"
+let t19 = "in"
+let s20 = "include"
+let t20 = "inculde"
+let s21 = "inherit"
+let t21 = "iehnrit"
+let s22 = "initializer"
+let t22 = "enitializir"
+let s23 = "lazy"
+let t23 = "zaly"
+let s24 = "let"
+let t24 = "elt"
+let s25 = "match"
+let t25 = "match"
+let s26 = "method"
+let t26 = "methdo"
+let s27 = "module"
+let t27 = "modelu"
+let s28 = "mutable"
+let t28 = "butamle"
+let s29 = "new"
+let t29 = "wen"
+let s30 = "object"
+let t30 = "objcet"
+let s31 = "of"
+let t31 = "of"
+let s32 = "open"
+let t32 = "epon"
+let s33 = "or"
+let t33 = "ro"
+let s34 = "private"
+let t34 = "privaet"
+let s35 = "rec"
+let t35 = "rec"
+let s36 = "sig"
+let t36 = "gis"
+let s37 = "struct"
+let t37 = "scrutt"
+let s38 = "then"
+let t38 = "hten"
+let s39 = "to"
+let t39 = "to"
+let s40 = "true"
+let t40 = "teur"
+let s41 = "try"
+let t41 = "try"
+let s42 = "type"
+let t42 = "pyte"
+let s43 = "val"
+let t43 = "val"
+let s44 = "virtual"
+let t44 = "vritual"
+let s45 = "when"
+let t45 = "whne"
+let s46 = "while"
+let t46 = "wlihe"
+let s47 = "with"
+let t47 = "iwth"
+let s48 = "mod"
+let t48 = "mod"
+let s49 = "land"
+let t49 = "alnd"
+let s50 = "lor"
+let t50 = "rol"
+let s51 = "lxor"
+let t51 = "lxor"
+let s52 = "lsl"
+let t52 = "lsl"
+let s53 = "lsr"
+let t53 = "lsr"
+let s54 = "asr"
+let t54 = "sar"
+let s55 = "A"
+let t55 = "A"
+let s56 = "AA"
+let t56 = "AA"
+let s57 = "AAA"
+let t57 = "AAA"
+let s58 = "AAAA"
+let t58 = "AAAA"
+let s59 = "AAAAA"
+let t59 = "AAAAA"
+let s60 = "AAAAAA"
+let t60 = "AAAAAA"
+let s61 = "AAAAAAA"
+let t61 = "AAAAAAA"
+let s62 = "AAAAAAAA"
+let t62 = "AAAAAAAA"
+let s63 = "AAAAAAAAA"
+let t63 = "AAAAAAAAA"
+let s64 = "AAAAAAAAAA"
+let t64 = "AAAAAAAAAA"
+let s65 = "AAAAAAAAAAA"
+let t65 = "AAAAAAAAAAA"
+let s66 = "AAAAAAAAAAAA"
+let t66 = "AAAAAAAAAAAA"
+let s67 = "AAAAAAAAAAAAA"
+let t67 = "AAAAAAAAAAAAA"
+let s68 = "AAAAAAAAAAAAAA"
+let t68 = "AAAAAAAAAAAAAA"
+let s69 = "AAAAAAAAAAAAAAA"
+let t69 = "AAAAAAAAAAAAAAA"
+let s70 = "AAAAAAAAAAAAAAAA"
+let t70 = "AAAAAAAAAAAAAAAA"
+let s71 = "AAAAAAAAAAAAAAAAA"
+let t71 = "AAAAAAAAAAAAAAAAA"
+let s72 = "AAAAAAAAAAAAAAAAAA"
+let t72 = "AAAAAAAAAAAAAAAAAA"
+let s73 = "AAAAAAAAAAAAAAAAAAA"
+let t73 = "AAAAAAAAAAAAAAAAAAA"
+let s74 = "AAAAAAAAAAAAAAAAAAAA"
+let t74 = "AAAAAAAAAAAAAAAAAAAA"
+let s75 = "AAAAAAAAAAAAAAAAAAAAA"
+let t75 = "AAAAAAAAAAAAAAAAAAAAA"
+let s76 = "AAAAAAAAAAAAAAAAAAAAAA"
+let t76 = "AAAAAAAAAAAAAAAAAAAAAA"
+let s77 = "AAAAAAAAAAAAAAAAAAAAAAA"
+let t77 = "AAAAAAAAAAAAAAAAAAAAAAA"
+let s78 = "AAAAAAAAAAAAAAAAAAAAAAAA"
+let t78 = "AAAAAAAAAAAAAAAAAAAAAAAA"
+let s79 = "AAAAAAAAAAAAAAAAAAAAAAAAA"
+let t79 = "AAAAAAAAAAAAAAAAAAAAAAAAA"
+let s80 = "AAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t80 = "AAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s81 = "AAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t81 = "AAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s82 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t82 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s83 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t83 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s84 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t84 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s85 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t85 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s86 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t86 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s87 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t87 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s88 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let t88 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+let s89 = "BBBBBBBBBBBBBBB"
+let t89 = "BBBBBBBBBBBBBBB"
+let s90 = "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB"
+let t90 = "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB"
+let s91 = "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB"
+let t91 = "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB"
+
+let tst06 s = match s with
+| "and" -> 0
+| "as" -> 1
+| "assert" -> 2
+| "begin" -> 3
+| "class" -> 4
+| "constraint" -> 5
+| "do" -> 6
+| "done" -> 7
+| "downto" -> 8
+| "else" -> 9
+| "end" -> 10
+| "exception" -> 11
+| "external" -> 12
+| "false" -> 13
+| "for" -> 14
+| "fun" -> 15
+| "function" -> 16
+| "functor" -> 17
+| "if" -> 18
+| "in" -> 19
+| "include" -> 20
+| "inherit" -> 21
+| "initializer" -> 22
+| "lazy" -> 23
+| "let" -> 24
+| "match" -> 25
+| "method" -> 26
+| "module" -> 27
+| "mutable" -> 28
+| "new" -> 29
+| "object" -> 30
+| "of" -> 31
+| "open" -> 32
+| "or" -> 33
+| "private" -> 34
+| "rec" -> 35
+| "sig" -> 36
+| "struct" -> 37
+| "then" -> 38
+| "to" -> 39
+| "true" -> 40
+| "try" -> 41
+| "type" -> 42
+| "val" -> 43
+| "virtual" -> 44
+| "when" -> 45
+| "while" -> 46
+| "with" -> 47
+| "mod" -> 48
+| "land" -> 49
+| "lor" -> 50
+| "lxor" -> 51
+| "lsl" -> 52
+| "lsr" -> 53
+| "asr" -> 54
+| "A" -> 55
+| "AA" -> 56
+| "AAA" -> 57
+| "AAAA" -> 58
+| "AAAAA" -> 59
+| "AAAAAA" -> 60
+| "AAAAAAA" -> 61
+| "AAAAAAAA" -> 62
+| "AAAAAAAAA" -> 63
+| "AAAAAAAAAA" -> 64
+| "AAAAAAAAAAA" -> 65
+| "AAAAAAAAAAAA" -> 66
+| "AAAAAAAAAAAAA" -> 67
+| "AAAAAAAAAAAAAA" -> 68
+| "AAAAAAAAAAAAAAA" -> 69
+| "AAAAAAAAAAAAAAAA" -> 70
+| "AAAAAAAAAAAAAAAAA" -> 71
+| "AAAAAAAAAAAAAAAAAA" -> 72
+| "AAAAAAAAAAAAAAAAAAA" -> 73
+| "AAAAAAAAAAAAAAAAAAAA" -> 74
+| "AAAAAAAAAAAAAAAAAAAAA" -> 75
+| "AAAAAAAAAAAAAAAAAAAAAA" -> 76
+| "AAAAAAAAAAAAAAAAAAAAAAA" -> 77
+| "AAAAAAAAAAAAAAAAAAAAAAAA" -> 78
+| "AAAAAAAAAAAAAAAAAAAAAAAAA" -> 79
+| "AAAAAAAAAAAAAAAAAAAAAAAAAA" -> 80
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 81
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 82
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 83
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 84
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 85
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 86
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 87
+| "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" -> 88
+| "BBBBBBBBBBBBBBB" -> 89
+| "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB" -> 90
+| "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB" -> 91
+| _ -> -1
+
+let () =
+  assert (tst06 s00 = 0) ;
+  assert (tst06 t00 = -1) ;
+  assert (tst06 s01 = 1) ;
+  assert (tst06 t01 = -1) ;
+  assert (tst06 s02 = 2) ;
+  assert (tst06 t02 = -1) ;
+  assert (tst06 s03 = 3) ;
+  assert (tst06 t03 = -1) ;
+  assert (tst06 s04 = 4) ;
+  assert (tst06 t04 = -1) ;
+  assert (tst06 s05 = 5) ;
+  assert (tst06 t05 = -1) ;
+  assert (tst06 s06 = 6) ;
+  assert (tst06 t06 = -1) ;
+  assert (tst06 s07 = 7) ;
+  assert (tst06 t07 = -1) ;
+  assert (tst06 s08 = 8) ;
+  assert (tst06 t08 = -1) ;
+  assert (tst06 s09 = 9) ;
+  assert (tst06 t09 = -1) ;
+  assert (tst06 s10 = 10) ;
+  assert (tst06 t10 = -1) ;
+  assert (tst06 s11 = 11) ;
+  assert (tst06 t11 = 11) ;
+  assert (tst06 s12 = 12) ;
+  assert (tst06 t12 = 12) ;
+  assert (tst06 s13 = 13) ;
+  assert (tst06 t13 = -1) ;
+  assert (tst06 s14 = 14) ;
+  assert (tst06 t14 = -1) ;
+  assert (tst06 s15 = 15) ;
+  assert (tst06 t15 = -1) ;
+  assert (tst06 s16 = 16) ;
+  assert (tst06 t16 = 16) ;
+  assert (tst06 s17 = 17) ;
+  assert (tst06 t17 = -1) ;
+  assert (tst06 s18 = 18) ;
+  assert (tst06 t18 = -1) ;
+  assert (tst06 s19 = 19) ;
+  assert (tst06 t19 = 19) ;
+  assert (tst06 s20 = 20) ;
+  assert (tst06 t20 = -1) ;
+  assert (tst06 s21 = 21) ;
+  assert (tst06 t21 = -1) ;
+  assert (tst06 s22 = 22) ;
+  assert (tst06 t22 = -1) ;
+  assert (tst06 s23 = 23) ;
+  assert (tst06 t23 = -1) ;
+  assert (tst06 s24 = 24) ;
+  assert (tst06 t24 = -1) ;
+  assert (tst06 s25 = 25) ;
+  assert (tst06 t25 = 25) ;
+  assert (tst06 s26 = 26) ;
+  assert (tst06 t26 = -1) ;
+  assert (tst06 s27 = 27) ;
+  assert (tst06 t27 = -1) ;
+  assert (tst06 s28 = 28) ;
+  assert (tst06 t28 = -1) ;
+  assert (tst06 s29 = 29) ;
+  assert (tst06 t29 = -1) ;
+  assert (tst06 s30 = 30) ;
+  assert (tst06 t30 = -1) ;
+  assert (tst06 s31 = 31) ;
+  assert (tst06 t31 = 31) ;
+  assert (tst06 s32 = 32) ;
+  assert (tst06 t32 = -1) ;
+  assert (tst06 s33 = 33) ;
+  assert (tst06 t33 = -1) ;
+  assert (tst06 s34 = 34) ;
+  assert (tst06 t34 = -1) ;
+  assert (tst06 s35 = 35) ;
+  assert (tst06 t35 = 35) ;
+  assert (tst06 s36 = 36) ;
+  assert (tst06 t36 = -1) ;
+  assert (tst06 s37 = 37) ;
+  assert (tst06 t37 = -1) ;
+  assert (tst06 s38 = 38) ;
+  assert (tst06 t38 = -1) ;
+  assert (tst06 s39 = 39) ;
+  assert (tst06 t39 = 39) ;
+  assert (tst06 s40 = 40) ;
+  assert (tst06 t40 = -1) ;
+  assert (tst06 s41 = 41) ;
+  assert (tst06 t41 = 41) ;
+  assert (tst06 s42 = 42) ;
+  assert (tst06 t42 = -1) ;
+  assert (tst06 s43 = 43) ;
+  assert (tst06 t43 = 43) ;
+  assert (tst06 s44 = 44) ;
+  assert (tst06 t44 = -1) ;
+  assert (tst06 s45 = 45) ;
+  assert (tst06 t45 = -1) ;
+  assert (tst06 s46 = 46) ;
+  assert (tst06 t46 = -1) ;
+  assert (tst06 s47 = 47) ;
+  assert (tst06 t47 = -1) ;
+  assert (tst06 s48 = 48) ;
+  assert (tst06 t48 = 48) ;
+  assert (tst06 s49 = 49) ;
+  assert (tst06 t49 = -1) ;
+  assert (tst06 s50 = 50) ;
+  assert (tst06 t50 = -1) ;
+  assert (tst06 s51 = 51) ;
+  assert (tst06 t51 = 51) ;
+  assert (tst06 s52 = 52) ;
+  assert (tst06 t52 = 52) ;
+  assert (tst06 s53 = 53) ;
+  assert (tst06 t53 = 53) ;
+  assert (tst06 s54 = 54) ;
+  assert (tst06 t54 = -1) ;
+  assert (tst06 s55 = 55) ;
+  assert (tst06 t55 = 55) ;
+  assert (tst06 s56 = 56) ;
+  assert (tst06 t56 = 56) ;
+  assert (tst06 s57 = 57) ;
+  assert (tst06 t57 = 57) ;
+  assert (tst06 s58 = 58) ;
+  assert (tst06 t58 = 58) ;
+  assert (tst06 s59 = 59) ;
+  assert (tst06 t59 = 59) ;
+  assert (tst06 s60 = 60) ;
+  assert (tst06 t60 = 60) ;
+  assert (tst06 s61 = 61) ;
+  assert (tst06 t61 = 61) ;
+  assert (tst06 s62 = 62) ;
+  assert (tst06 t62 = 62) ;
+  assert (tst06 s63 = 63) ;
+  assert (tst06 t63 = 63) ;
+  assert (tst06 s64 = 64) ;
+  assert (tst06 t64 = 64) ;
+  assert (tst06 s65 = 65) ;
+  assert (tst06 t65 = 65) ;
+  assert (tst06 s66 = 66) ;
+  assert (tst06 t66 = 66) ;
+  assert (tst06 s67 = 67) ;
+  assert (tst06 t67 = 67) ;
+  assert (tst06 s68 = 68) ;
+  assert (tst06 t68 = 68) ;
+  assert (tst06 s69 = 69) ;
+  assert (tst06 t69 = 69) ;
+  assert (tst06 s70 = 70) ;
+  assert (tst06 t70 = 70) ;
+  assert (tst06 s71 = 71) ;
+  assert (tst06 t71 = 71) ;
+  assert (tst06 s72 = 72) ;
+  assert (tst06 t72 = 72) ;
+  assert (tst06 s73 = 73) ;
+  assert (tst06 t73 = 73) ;
+  assert (tst06 s74 = 74) ;
+  assert (tst06 t74 = 74) ;
+  assert (tst06 s75 = 75) ;
+  assert (tst06 t75 = 75) ;
+  assert (tst06 s76 = 76) ;
+  assert (tst06 t76 = 76) ;
+  assert (tst06 s77 = 77) ;
+  assert (tst06 t77 = 77) ;
+  assert (tst06 s78 = 78) ;
+  assert (tst06 t78 = 78) ;
+  assert (tst06 s79 = 79) ;
+  assert (tst06 t79 = 79) ;
+  assert (tst06 s80 = 80) ;
+  assert (tst06 t80 = 80) ;
+  assert (tst06 s81 = 81) ;
+  assert (tst06 t81 = 81) ;
+  assert (tst06 s82 = 82) ;
+  assert (tst06 t82 = 82) ;
+  assert (tst06 s83 = 83) ;
+  assert (tst06 t83 = 83) ;
+  assert (tst06 s84 = 84) ;
+  assert (tst06 t84 = 84) ;
+  assert (tst06 s85 = 85) ;
+  assert (tst06 t85 = 85) ;
+  assert (tst06 s86 = 86) ;
+  assert (tst06 t86 = 86) ;
+  assert (tst06 s87 = 87) ;
+  assert (tst06 t87 = 87) ;
+  assert (tst06 s88 = 88) ;
+  assert (tst06 t88 = 88) ;
+  assert (tst06 s89 = 89) ;
+  assert (tst06 t89 = 89) ;
+  assert (tst06 s90 = 90) ;
+  assert (tst06 t90 = 90) ;
+  assert (tst06 s91 = 91) ;
+  assert (tst06 t91 = 91) ;
+  assert (tst06 "" = -1) ;
+  ()
diff --git a/testsuite/tests/basic/stringmatch.reference b/testsuite/tests/basic/stringmatch.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/basic/switch_opts.ml b/testsuite/tests/basic/switch_opts.ml
new file mode 100644
index 00000000..67034de3
--- /dev/null
+++ b/testsuite/tests/basic/switch_opts.ml
@@ -0,0 +1,63 @@
+(* Test for optimisation of jump tables to arrays of constants *)
+
+let p = Printf.printf
+
+type test =
+  Test : 'b * 'a * ('b -> 'a) -> test
+
+type t = A | B | C
+
+(* These test functions need to have at least three cases.
+   Functions with fewer cases don't trigger the optimisation,
+   as they are compiled to if-then-else, not switch *)
+let testcases = [
+  Test (3, 3, function 1 -> 1 | 2 -> 2 | 3 -> 3 | _ -> 0);
+  Test (3, -3, function 1 -> 1 | 2 -> 2 | 3 -> -3 | _ -> 0);
+  Test (3, min_int, function 1 -> 1 | 2 -> 2 | 3 -> min_int | _ -> 0);
+  Test (3, max_int, function 1 -> 1 | 2 -> 2 | 3 -> max_int | _ -> 0);
+  Test (3, 3., function 1 -> 1. | 2 -> 2. | 3 -> 3. | _ -> 0.);
+  Test (3, Sys.opaque_identity "c" ^ Sys.opaque_identity "c",
+        function 1 -> "a" | 2 -> "b" | 3 -> "cc" | _ -> "");
+  Test (3, List.rev [3;2;1], function 1 -> [] | 2 -> [42] | 3 -> [1;2;3] | _ -> [415]);
+
+  Test (C, 3, function A -> 1 | B -> 2 | C -> 3);
+  Test (C, -3, function A -> 1 | B -> 2 | C -> -3);
+  Test (C, min_int, function A -> 1 | B -> 2 | C -> min_int);
+  Test (C, max_int, function A -> 1 | B -> 2 | C -> max_int);
+  Test (C, 3., function A -> 1. | B -> 2. | C -> 3.);
+  Test (C, "c", function A -> "a" | B -> "b" | C -> "c");
+  Test (C, List.rev [3;2;1], function A -> [] | B -> [42] | C -> [1;2;3]);
+
+  Test (42, 42, function
+  | 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | 7 -> 7 | 8 -> 8
+  | 9 -> 9 | 10 -> 10 | 11 -> 11 | 12 -> 12 | 13 -> 13 | 14 -> 14 | 15 -> 15
+  | 16 -> 16 | 17 -> 17 | 18 -> 18 | 19 -> 19 | 20 -> 20 | 21 -> 21 | 22 -> 22
+  | 23 -> 23 | 24 -> 24 | 25 -> 25 | 26 -> 26 | 27 -> 27 | 28 -> 28 | 29 -> 29
+  | 30 -> 30 | 31 -> 31 | 32 -> 32 | 33 -> 33 | 34 -> 34 | 35 -> 35 | 36 -> 36
+  | 37 -> 37 | 38 -> 38 | 39 -> 39 | 40 -> 40 | 41 -> 41 | 42 -> 42 | 43 -> 43
+  | 44 -> 44 | 45 -> 45 | 46 -> 46 | 47 -> 47 | 48 -> 48 | 49 -> 49 | 50 -> 50
+  | 51 -> 51 | 52 -> 52 | 53 -> 53 | 54 -> 54 | 55 -> 55 | 56 -> 56 | 57 -> 57
+  | 58 -> 58 | 59 -> 59 | 60 -> 60 | 61 -> 61 | 62 -> 62 | 63 -> 63 | 64 -> 64
+  | 65 -> 65 | 66 -> 66 | 67 -> 67 | 68 -> 68 | 69 -> 69 | 70 -> 70 | 71 -> 71
+  | 72 -> 72 | 73 -> 73 | 74 -> 74 | 75 -> 75 | 76 -> 76 | 77 -> 77 | 78 -> 78
+  | 79 -> 79 | 80 -> 80 | 81 -> 81 | 82 -> 82 | 83 -> 83 | 84 -> 84 | 85 -> 85
+  | 86 -> 86 | 87 -> 87 | 88 -> 88 | 89 -> 89 | 90 -> 90 | 91 -> 91 | 92 -> 92
+  | 93 -> 93 | 94 -> 94 | 95 -> 95 | 96 -> 96 | 97 -> 97 | 98 -> 98 | 99 -> 99
+  | _ -> 0);
+
+  Test (3, `Tertiary, function
+  | 1 -> `Primary
+  | 2 -> `Secondary
+  | 3 -> `Tertiary
+  | n -> invalid_arg "test")
+  ]
+
+let passes = ref 0
+let run_test (Test (a, b, f)) =
+  assert (f a = b);
+  incr passes
+
+let () =
+  List.iter run_test testcases;
+  Printf.printf "%d tests passed\n" !passes
+
diff --git a/testsuite/tests/basic/switch_opts.reference b/testsuite/tests/basic/switch_opts.reference
new file mode 100644
index 00000000..48a00459
--- /dev/null
+++ b/testsuite/tests/basic/switch_opts.reference
@@ -0,0 +1 @@
+16 tests passed
diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml
new file mode 100644
index 00000000..9e998139
--- /dev/null
+++ b/testsuite/tests/basic/tailcalls.ml
@@ -0,0 +1,41 @@
+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
+
+(* regression test for PR#6441: *)
+let rec tailcall16_value_closures a b c d e f g h i j k l m n o p =
+  if a < 0
+  then b
+  else tailcall16_value_closures
+         (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)
+and fs = [tailcall16_value_closures]
+
+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();
+  print_int (tailcall16_value_closures 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0);
+  print_newline()
diff --git a/testsuite/tests/basic/tailcalls.reference b/testsuite/tests/basic/tailcalls.reference
new file mode 100644
index 00000000..c7117bc9
--- /dev/null
+++ b/testsuite/tests/basic/tailcalls.reference
@@ -0,0 +1,6 @@
+10000001
+10000001
+10000001
+11
+11
+10000001
diff --git a/testsuite/tests/basic/zero_divided_by_n.ml b/testsuite/tests/basic/zero_divided_by_n.ml
new file mode 100644
index 00000000..1523d962
--- /dev/null
+++ b/testsuite/tests/basic/zero_divided_by_n.ml
@@ -0,0 +1,17 @@
+(* Mantis 7201 *)
+
+let f () = 0 [@@inline never]
+
+let () =
+  try
+    ignore ((0 / f ()) : int);
+    assert false
+  with Division_by_zero -> ()
+
+(* Not in Mantis 7201, but related: *)
+
+let () =
+  try
+    ignore ((0 mod f ()) : int);
+    assert false
+  with Division_by_zero -> ()
diff --git a/testsuite/tests/basic/zero_divided_by_n.reference b/testsuite/tests/basic/zero_divided_by_n.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile
new file mode 100644
index 00000000..d6615a1c
--- /dev/null
+++ b/testsuite/tests/callback/Makefile
@@ -0,0 +1,69 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+CC=$(NATIVECC) -I $(CTOPDIR)/byterun
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/unix
+LD_PATH=$(TOPDIR)/otherlibs/unix
+
+.PHONY: default
+default:
+	@case " $(OTHERLIBRARIES) " in \
+	  *' unix '*) $(SET_LD_PATH) $(MAKE) run-byte; \
+	              $(SET_LD_PATH) $(MAKE) run-opt;; \
+	  *) $(MAKE) skip;; \
+	esac
+
+.PHONY: common
+common:
+	@$(CC) -c callbackprim.c
+
+.PHONY: skip
+skip:
+	@for c in bytecode native; do \
+	  echo " ... testing '$$c': => skipped" ; \
+	done
+
+.PHONY: run-byte
+run-byte: common
+	@printf " ... testing 'bytecode':"
+	@$(OCAMLC) $(COMPFLAGS) -c tcallback.ml
+	@$(OCAMLC) $(COMPFLAGS) -o ./program$(EXE) -custom unix.cma \
+	           callbackprim.$(O) tcallback.cmo
+	@./program$(EXE) >bytecode.result
+	@$(DIFF) reference bytecode.result \
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: run-opt
+run-opt: common
+	@if $(BYTECODE_ONLY); then : ; else \
+	  printf " ... testing 'native':"; \
+	  $(OCAMLOPT) $(COMPFLAGS) -c tcallback.ml; \
+	  $(OCAMLOPT) $(COMPFLAGS) -o ./program$(EXE) unix.cmxa \
+	              callbackprim.$(O) tcallback.cmx; \
+	  ./program$(EXE) >native.result; \
+	  $(DIFF) reference native.result \
+	  && echo " => passed" || echo " => failed"; \
+	fi
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result ./program$(EXE)
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/callback/callbackprim.c b/testsuite/tests/callback/callbackprim.c
new file mode 100644
index 00000000..b1ab2465
--- /dev/null
+++ b/testsuite/tests/callback/callbackprim.c
@@ -0,0 +1,69 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1995 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/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/testsuite/tests/callback/reference b/testsuite/tests/callback/reference
new file mode 100644
index 00000000..b35993aa
--- /dev/null
+++ b/testsuite/tests/callback/reference
@@ -0,0 +1,8 @@
+7
+7
+7
+7
+7
+aaaaa
+aaaaa
+bbbbb
diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml
new file mode 100644
index 00000000..121d3c57
--- /dev/null
+++ b/testsuite/tests/callback/tcallback.ml
@@ -0,0 +1,71 @@
+(**************************************************************************)
+
+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 *)
+  ignore (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.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler);
+  print_string(callbacksig ()); print_newline()
diff --git a/testsuite/tests/docstrings/Makefile b/testsuite/tests/docstrings/Makefile
new file mode 100644
index 00000000..ec94f6c1
--- /dev/null
+++ b/testsuite/tests/docstrings/Makefile
@@ -0,0 +1,4 @@
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.dparsetree
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/docstrings/empty.ml b/testsuite/tests/docstrings/empty.ml
new file mode 100644
index 00000000..a4394f68
--- /dev/null
+++ b/testsuite/tests/docstrings/empty.ml
@@ -0,0 +1,8 @@
+type t = Label (**)
+(** attached to t *)
+
+(**)
+
+(** Empty docstring comments should not generate attributes *)
+
+type w (**)
diff --git a/testsuite/tests/docstrings/empty.ml.reference b/testsuite/tests/docstrings/empty.ml.reference
new file mode 100644
index 00000000..5a91a65a
--- /dev/null
+++ b/testsuite/tests/docstrings/empty.ml.reference
@@ -0,0 +1,52 @@
+[
+  structure_item (empty.ml[1,0+0]..[1,0+14])
+    Pstr_type Rec
+    [
+      type_declaration "t" (empty.ml[1,0+5]..[1,0+6]) (empty.ml[1,0+0]..[1,0+14])
+        attribute "ocaml.doc"
+          [
+            structure_item (empty.ml[2,20+0]..[2,20+20])
+              Pstr_eval
+              expression (empty.ml[2,20+0]..[2,20+20])
+                Pexp_constant PConst_string(" attached to t ",None)
+          ]
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_variant
+            [
+              (empty.ml[1,0+9]..[1,0+14])
+                "Label" (empty.ml[1,0+9]..[1,0+14])
+                []
+                None
+            ]
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+  structure_item (empty.ml[6,48+0]..[6,48+62])
+    Pstr_attribute "ocaml.text"
+    [
+      structure_item (empty.ml[6,48+0]..[6,48+62])
+        Pstr_eval
+        expression (empty.ml[6,48+0]..[6,48+62])
+          Pexp_constant PConst_string(" Empty docstring comments should not generate attributes ",None)
+    ]
+  structure_item (empty.ml[8,112+0]..[8,112+6])
+    Pstr_type Rec
+    [
+      type_declaration "w" (empty.ml[8,112+5]..[8,112+6]) (empty.ml[8,112+0]..[8,112+6])
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+]
+
diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile
new file mode 100644
index 00000000..679c5b9d
--- /dev/null
+++ b/testsuite/tests/embedded/Makefile
@@ -0,0 +1,44 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+.PHONY: default
+default:
+	@$(MAKE) compile
+	@$(MAKE) run
+
+.PHONY: compile
+compile:
+	@$(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun cmstub.c
+	@$(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun cmmain.c
+	@$(OCAMLC) -c cmcaml.ml
+	@$(OCAMLC) -custom -o program cmstub.$(O) cmcaml.cmo cmmain.$(O)
+
+.PHONY: run
+run:
+	@printf " ... testing 'cmmain':"
+	@./program >program.result
+	@$(DIFF) program.reference program.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result program
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml
new file mode 100644
index 00000000..ae21a1f2
--- /dev/null
+++ b/testsuite/tests/embedded/cmcaml.ml
@@ -0,0 +1,16 @@
+(* OCaml 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 ignore (Bytes.create 256) done;
+  r
+
+(* Registration *)
+
+let _ =
+  Callback.register "fib" fib;
+  Callback.register "format_result" format_result
diff --git a/testsuite/tests/embedded/cmmain.c b/testsuite/tests/embedded/cmmain.c
new file mode 100644
index 00000000..04ed0728
--- /dev/null
+++ b/testsuite/tests/embedded/cmmain.c
@@ -0,0 +1,35 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA 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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* Main program -- in C */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <caml/callback.h>
+
+extern int fib(int n);
+extern char * format_result(int n);
+
+int main(int argc, char ** argv)
+{
+  printf("Initializing OCaml 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/testsuite/tests/embedded/cmstub.c b/testsuite/tests/embedded/cmstub.c
new file mode 100644
index 00000000..a83ad61e
--- /dev/null
+++ b/testsuite/tests/embedded/cmstub.c
@@ -0,0 +1,30 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA 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.     */
+/*                                                                     */
+/***********************************************************************/
+
+#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(caml_callback(*fib_closure, Val_int(n)));
+}
+
+char * format_result(int n)
+{
+  value * format_result_closure = caml_named_value("format_result");
+  return strdup(String_val(caml_callback(*format_result_closure, Val_int(n))));
+}
diff --git a/testsuite/tests/embedded/program.reference b/testsuite/tests/embedded/program.reference
new file mode 100644
index 00000000..4f27810c
--- /dev/null
+++ b/testsuite/tests/embedded/program.reference
@@ -0,0 +1,4 @@
+Initializing OCaml code...
+Back in C code...
+Computing fib(20)...
+Result = 10946
diff --git a/testsuite/tests/exotic-syntax/Makefile b/testsuite/tests/exotic-syntax/Makefile
new file mode 100644
index 00000000..447b65c7
--- /dev/null
+++ b/testsuite/tests/exotic-syntax/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*        Damien Doligez, projet Gallium, INRIA Rocquencourt              *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MAIN_MODULE=exotic
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/exotic-syntax/exotic.ml b/testsuite/tests/exotic-syntax/exotic.ml
new file mode 100644
index 00000000..18280e68
--- /dev/null
+++ b/testsuite/tests/exotic-syntax/exotic.ml
@@ -0,0 +1,159 @@
+(* Exotic OCaml syntax constructs found in the manual that are not *)
+(* used in the source of the OCaml distribution (even in the tests). *)
+
+(* Spaces between the parts of the ?label: token in a typexpr.
+   (used in bin-prot) *)
+type t1 = ? label : int -> int -> int;;
+
+(* Lazy in a pattern. (used in advi) *)
+function lazy y -> y;;
+
+(* Spaces between the parts of the ?label: token in a class-type. *)
+class c1 =
+  (fun ?label:x y -> object end : ? label : int -> int -> object end)
+;;
+
+(* type-class annotation in class-expr *)
+class c2 = (object end : object end);;
+
+(* virtual object field *)
+class virtual c3 = object val virtual x : int end;;
+class virtual c4 = object val mutable virtual x : int end;;
+
+(* abstract module type in a signature *)
+module type T = sig
+  module type U
+end;;
+
+(* associativity rules for patterns *)
+function Some Some x -> x | _ -> 0;;
+function Some `Tag x -> x | _ -> 0;;
+function `Tag Some x -> x | _ -> 0;;
+function `Tag `Tag x -> x | _ -> 0;;
+
+(* negative int32, int64, nativeint constants in patterns *)
+function -1l -> () | _ -> ();;
+function -1L -> () | _ -> ();;
+function -1n -> () | _ -> ();;
+
+(* surprising places where you can use an operator as a variable name *)
+function (+) -> (+);;
+function _ as (+) -> (+);;
+for (+) = 0 to 1 do () done;;
+
+(* access a class-type through an extended-module-path *)
+module F (X : sig end) = struct
+  class type t = object end
+end;;
+module M1 = struct end;;
+class type u = F(M1).t;;
+
+(* conjunctive constraints on tags (used by the compiler to print some
+   inferred types) *)
+type 'a t2 = [< `A of int & int & int ] as 'a;;
+
+(* same for a parameterless tag (triggers a very strange error message) *)
+(*type ('a, 'b) t3 = [< `A of & 'b ] as 'a;;*)
+
+(* negative float constant in a pattern *)
+function -1.0 -> 1 | _ -> 2;;
+
+(* combining language extensions (sec. 7.13 and 7.17) *)
+class c5 = object method f = 1 end;;
+object
+  inherit c5
+  method! f : type t . int = 2
+end;;
+
+(* private polymorphic method with local type *)
+object method private f : type t . int = 1 end;;
+
+(* type annotations on record fields, both in patterns and expressions, and both
+   with and without punning *)
+let get_int { contents : int } = contents
+let get_int2 { contents : int = c } = c
+let set_int contents = { contents : int }
+let set_int2 c = { contents : int = c }
+;;
+
+(* applying a functor to the unpacking of a first-class module *)
+module M() = struct
+  module type String = module type of String
+  let string = (module String : String)
+  module M = Set.Make(val string)
+end ;;
+
+(* More exotic: not even found in the manual (up to version 4.00),
+   but used in some programs found in the wild.
+*)
+
+(* local functor *)
+let module M (M1 : sig end) = struct end in ();;
+
+(* let-binding with a type coercion *)
+let x :> int = 1;;
+let x : int :> int = 1;;
+
+(* "begin end" as an alias for "()" *)
+begin end;;
+
+(* putting "virtual" before "mutable" or "private" *)
+class type virtual ct = object
+  val mutable virtual x : int
+  val virtual mutable y : int
+  method private virtual f : int
+  method virtual private g : int
+end;;
+class virtual c = object
+  val mutable virtual x : int
+  val virtual mutable y : int
+  method private virtual f : int
+  method virtual private g : int
+end;;
+
+(* Double-semicolon at the beginning of a module body [ocp-indent] *)
+module M2 = struct ;; end;;
+
+
+(**********************
+
+(* Most exotic: not found in the manual (up to 4.00) and not used
+   deliberately by anyone, but still implemented by the compiler. *)
+
+(* whitespace inside val!, method!, inherit! [found in ocamlspot] *)
+object
+  val x = 1
+  val ! x = 2
+  method m = 1
+  method ! m = 2
+  inherit ! object val x = 3 end
+end;;
+
+(* Using () as a constructor name [found in gettext] *)
+type t = ();;
+let x : t = ();;
+
+(* Using :: as a constructor name *)
+type t = :: of int * int;;
+
+(* Prefix syntax for :: in expressions *)
+(::) (1, 1);;
+
+(* Prefix syntax for :: in patterns *)
+function (::) (_, _) -> 1;;
+
+(* Unary plus in expressions (ints and float) *)
++1;;
++1l;;
++1L;;
++1n;;
++1.0;;
+
+(* Unary plus in patterns (ints and floats) *)
+function +1 -> ();;
+function +1l -> ();;
+function +1L -> ();;
+function +1n -> ();;
+function +1.0 -> ();;
+
+**********************)
diff --git a/testsuite/tests/exotic-syntax/exotic.reference b/testsuite/tests/exotic-syntax/exotic.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/extension-constructor/Makefile b/testsuite/tests/extension-constructor/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/extension-constructor/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/extension-constructor/test.ml b/testsuite/tests/extension-constructor/test.ml
new file mode 100644
index 00000000..d73777a3
--- /dev/null
+++ b/testsuite/tests/extension-constructor/test.ml
@@ -0,0 +1,21 @@
+type t = ..
+
+module M = struct
+  type t += A
+  type t += B of int
+end
+
+type t += C
+type t += D of int * string
+
+let () =
+  assert (Obj.extension_constructor  M.A
+          == [%extension_constructor M.A]);
+  assert (Obj.extension_constructor (M.B 42)
+          == [%extension_constructor M.B]);
+  assert (Obj.extension_constructor  C
+          == [%extension_constructor C]);
+  assert (Obj.extension_constructor (D (42, ""))
+          == [%extension_constructor D])
+
+let () = print_endline "OK"
diff --git a/testsuite/tests/extension-constructor/test.reference b/testsuite/tests/extension-constructor/test.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/extension-constructor/test.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/flambda/Makefile b/testsuite/tests/flambda/Makefile
new file mode 100644
index 00000000..cbf581ad
--- /dev/null
+++ b/testsuite/tests/flambda/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+ADD_OPTFLAGS=-unbox-closures
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/flambda/gpr998.ml b/testsuite/tests/flambda/gpr998.ml
new file mode 100644
index 00000000..9f16185d
--- /dev/null
+++ b/testsuite/tests/flambda/gpr998.ml
@@ -0,0 +1,39 @@
+(* This test attempts to check that unused closures are not deleted
+   during conversion from flambda to clambda. The idea is that there is
+   a direct call to [foo] in [bar] even though the closure for [foo] is
+   not used. This requires [bar] to be have a specialised parameter that
+   would be [foo]'s closure were there any calls to [bar], and for [bar]
+   to not be deleted even though there are no calls to it. Creating such
+   a situation is difficult, and the fact that the following code does so
+   is very fragile. This means two things:
+
+     1. This code only tests the appropriate property on amd64
+        architectures. Since the code conversion from flambda to
+        clambda is architecture independent, this should be fine
+        as long as the test is run on such an architecture as part
+        of CI.
+
+    2. It is likely that future changes to flambda will silently cause
+       this test to stop testing the desired property. It would be worth
+       periodically examining the flambda output for the code to check
+       that this test is still worth using.
+*)
+
+let main x =
+  let[@inline never] inner () =
+    let[@inline never] foo y () () () () () () () = x + y in
+    let x1, x2, x3 = x + 1, x + 2, x + 3 in
+    let bar p y () () () =
+      if p then foo y () () () () () () ()
+      else x1 + x2 + x3
+    in
+    let[@inline never] baz0 y () () () () () () () =
+      let y1 = y + 1 in
+      let[@inline never] baz1 () () () () () =
+        bar false y1 () () ()
+      in
+      baz1 () () () () ()
+    in
+    baz0 1 () () () () () () ()
+  in
+  inner ()
diff --git a/testsuite/tests/flambda/gpr998.reference b/testsuite/tests/flambda/gpr998.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/float-unboxing/Makefile b/testsuite/tests/float-unboxing/Makefile
new file mode 100644
index 00000000..8f44b4fa
--- /dev/null
+++ b/testsuite/tests/float-unboxing/Makefile
@@ -0,0 +1,32 @@
+#(***********************************************************************)
+#(*                                                                     *)
+#(*                                OCaml                                *)
+#(*                                                                     *)
+#(*                   Mark Shinwell, Jane Street Europe                 *)
+#(*                                                                     *)
+#(*  Copyright 2014 Institut National de Recherche en Informatique et   *)
+#(*  en Automatique.  All rights reserved.  This file is distributed    *)
+#(*  under the terms of the Q Public License version 1.0.               *)
+#(*                                                                     *)
+#(***********************************************************************)
+
+BASEDIR=../..
+MODULES=float_inline
+MAIN_MODULE=float_subst_boxed_number
+ADD_OPTCOMPFLAGS=-inline 20
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=float_inline.ml *.flambda
+
+float_inline.ml: $(FLAMBDA).flambda
+ifeq ($(FLAMBDA),false)
+	@echo "let eliminate_intermediate_float_record () = ()" > $@
+else
+	@cat float_flambda.ml > $@
+endif
+
+%.flambda:
+	@rm -f float_inline.ml
+	@touch $@
diff --git a/testsuite/tests/float-unboxing/float_flambda.ml b/testsuite/tests/float-unboxing/float_flambda.ml
new file mode 100644
index 00000000..3c5dfded
--- /dev/null
+++ b/testsuite/tests/float-unboxing/float_flambda.ml
@@ -0,0 +1,9 @@
+let eliminate_intermediate_float_record () =
+  let r = ref 0. in
+  for n = 1 to 1000 do
+    let open Complex in
+    let c = { re = float n; im = 0. } in
+    r := !r +. (norm [@inlined]) ((add [@inlined]) c i);
+  done;
+  ignore (Sys.opaque_identity !r)
+
diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
new file mode 100644
index 00000000..672b3ff8
--- /dev/null
+++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
@@ -0,0 +1,174 @@
+module PR_6686 = struct
+  type t =
+   | A of float
+   | B of (int * int)
+
+  let rec foo = function
+   | A x -> x
+   | B (x, y) -> float x +. float y
+
+  let (_ : float) = foo (A 4.)
+end
+
+module PR_6770 = struct
+  type t =
+  | Constant of float
+  | Exponent of (float * float)
+
+  let to_string = function
+    | Exponent (_b, _e) ->
+      ignore _b;
+      ignore _e;
+      ""
+    | Constant _ -> ""
+
+  let _ = to_string (Constant 4.)
+end
+
+
+let check_noalloc name f =
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  let _x = f () in
+  let a2 = Gc.allocated_bytes () in
+  let alloc = (a2 -. 2. *. a1 +. a0) in
+
+  (* is there a better to test whether we run in native code? *)
+  match Filename.basename Sys.argv.(0) with
+  | "program.byte" | "program.byte.exe" -> ()
+  | "program.native" | "program.native.exe" ->
+      if alloc > 100. then
+        failwith (Printf.sprintf "%s; alloc = %.0f" name alloc)
+  | _ -> assert false
+
+module GPR_109 = struct
+
+  let f () =
+    let r = ref 0. in
+    for i = 1 to 1000 do
+      let x = float i in
+      let y = if i mod 2 = 0 then x else x +. 1. in
+      r := !r +. y
+    done;
+    !r
+
+  let () = check_noalloc "gpr 1O9" f
+end
+
+
+let unbox_classify_float () =
+  let x = ref 100. in
+  for i = 1 to 1000 do
+    assert (classify_float !x = FP_normal);
+    x := !x +. 1.
+  done;
+  ignore (Sys.opaque_identity !x)
+
+let unbox_compare_float () =
+  let module M = struct type sf = { mutable x: float; y: float; } end in
+  let x = { M.x=100. ; y=1. } in
+  for i = 1 to 1000 do
+    assert (compare x.M.x x.M.y >= 0);
+    x.M.x <- x.M.x +. 1.
+  done;
+  ignore (Sys.opaque_identity x.M.x)
+
+let unbox_float_refs () =
+  let r = ref nan in
+  for i = 1 to 1000 do r := !r +. float i done;
+  ignore (Sys.opaque_identity !r)
+
+let unbox_let_float () =
+  let r = ref 0. in
+  for i = 1 to 1000 do
+    let y =
+      if i mod 2 = 0 then nan else float i
+    in
+    r := !r +. (y *. 2.)
+  done;
+  ignore (Sys.opaque_identity !r)
+
+type block =
+  { mutable float : float;
+    mutable int32 : int32 }
+
+let make_some_block record =
+  { record with int32 = record.int32 }
+
+let unbox_record_1 record =
+  (* There is some let lifting problem to handle that case with one
+     round, this currently requires 2 rounds to be correctly
+     recognized as a mutable variable pattern *)
+  (* let block = (make_some_block [@inlined]) record in *)
+  let block = { record with int32 = record.int32 } in
+  for i = 1 to 1000 do
+    let y_float =
+      if i mod 2 = 0 then nan else Pervasives.float i
+    in
+    block.float <- block.float +. (y_float *. 2.);
+    let y_int32 =
+      if i mod 2 = 0 then Int32.max_int else Int32.of_int i
+    in
+    block.int32 <- Int32.(add block.int32 (mul y_int32 2l))
+  done;
+  ignore (Sys.opaque_identity block.float);
+  ignore (Sys.opaque_identity block.int32)
+  [@@inline never]
+  (* Prevent inlining to test that the type is effectively used *)
+
+let float_int32_record = { float = 3.14; int32 = 12l }
+
+let unbox_record () =
+  unbox_record_1 float_int32_record
+
+let r = ref 0.
+
+let unbox_only_if_useful () =
+  for i = 1 to 1000 do
+    let x =
+      if i mod 2 = 0 then 1.
+      else 0.
+    in
+    r := x; (* would force boxing if the let binding above were unboxed *)
+    r := x  (* use [x] twice to avoid elimination of the let-binding *)
+  done;
+  ignore (Sys.opaque_identity !r)
+
+let unbox_minor_words () =
+  for i = 1 to 1000 do
+    ignore (Gc.minor_words () = 0.)
+  done
+
+let ignore_useless_args () =
+  let f x _y = int_of_float (cos x) in
+  let rec g a n x =
+    if n = 0
+    then a
+    else g (a + (f [@inlined always]) x (x +. 1.)) (n - 1) x
+  in
+  ignore (g 0 10 5.)
+
+let () =
+  let flambda =
+    match Sys.getenv "FLAMBDA" with
+    | "true" -> true
+    | "false" -> false
+    | _ -> failwith "Cannot determine is flambda is enabled"
+    | exception Not_found -> failwith "Cannot determine is flambda is enabled"
+  in
+
+  check_noalloc "classify float" unbox_classify_float;
+  check_noalloc "compare float" unbox_compare_float;
+  check_noalloc "float refs" unbox_float_refs;
+  check_noalloc "unbox let float" unbox_let_float;
+  check_noalloc "unbox only if useful" unbox_only_if_useful;
+  check_noalloc "ignore useless args" ignore_useless_args;
+
+  if flambda then begin
+    check_noalloc "float and int32 record" unbox_record;
+    check_noalloc "eliminate intermediate immutable float record"
+      Float_inline.eliminate_intermediate_float_record;
+  end;
+
+  check_noalloc "Gc.minor_words" unbox_minor_words;
+  ()
diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.reference b/testsuite/tests/float-unboxing/float_subst_boxed_number.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/formats-transition/Makefile b/testsuite/tests/formats-transition/Makefile
new file mode 100644
index 00000000..9625a3fb
--- /dev/null
+++ b/testsuite/tests/formats-transition/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml
new file mode 100644
index 00000000..3127d773
--- /dev/null
+++ b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml
@@ -0,0 +1,22 @@
+(* %n, %l, %N and %L have a scanf-specific semantics, but are supposed
+   to be interpreted by Printf and Format as %u, despite this
+   interpretation being mildly deprecated *)
+
+let test format = (Printf.sprintf format (-3) : string)
+;;
+
+let () = Printf.printf "%%n: %B\n"
+  (test "%n" = test "%u")
+;;
+
+let () = Printf.printf "%%l: %B\n"
+  (test "%l" = test "%u")
+;;
+
+let () = Printf.printf "%%N: %B\n"
+  (test "%N" = test "%u")
+;;
+
+let () = Printf.printf "%%L: %B\n"
+  (test "%L" = test "%u")
+;;
diff --git a/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference
new file mode 100644
index 00000000..0afeaa2b
--- /dev/null
+++ b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference
@@ -0,0 +1,7 @@
+
+# * *       val test : (int -> string, unit, string) format -> string = <fun>
+#       %n: true
+#       %l: true
+#       %N: true
+#       %L: true
+# 
diff --git a/testsuite/tests/formats-transition/ignored_scan_counters.ml b/testsuite/tests/formats-transition/ignored_scan_counters.ml
new file mode 100644
index 00000000..2186a82d
--- /dev/null
+++ b/testsuite/tests/formats-transition/ignored_scan_counters.ml
@@ -0,0 +1,33 @@
+(* Benoit's patch did not support %_[nlNL]; test their behavior *)
+
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+(* not supported by Printf or Format: fails at runtime *)
+let () = Printf.printf "%_n"
+;;
+let () = Printf.printf "%_N"
+;;
+let () = Printf.printf "%_l"
+;;
+let () = Printf.printf "%_L"
+;;
+
+let () = Format.printf "%_n"
+;;
+let () = Format.printf "%_N"
+;;
+let () = Format.printf "%_l"
+;;
+let () = Format.printf "%_L"
+;;
+
+(* identity for Scanf *)
+let () = print_endline (Scanf.sscanf "" "%_n" "Hello World!")
+;;
+let () = print_endline (Scanf.sscanf "" "%_N" "Hello World!")
+;;
+let () = print_endline (Scanf.sscanf "" "%_l" "Hello World!")
+;;
+let () = print_endline (Scanf.sscanf "" "%_L" "Hello World!")
+;;
diff --git a/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference b/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference
new file mode 100644
index 00000000..55f8ee68
--- /dev/null
+++ b/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference
@@ -0,0 +1,15 @@
+
+#       - : unit = ()
+#       Exception: Invalid_argument "Printf: bad conversion %_".
+#   Exception: Invalid_argument "Printf: bad conversion %_".
+#   Exception: Invalid_argument "Printf: bad conversion %_".
+#   Exception: Invalid_argument "Printf: bad conversion %_".
+#     Exception: Invalid_argument "Printf: bad conversion %_".
+#   Exception: Invalid_argument "Printf: bad conversion %_".
+#   Exception: Invalid_argument "Printf: bad conversion %_".
+#   Exception: Invalid_argument "Printf: bad conversion %_".
+#       Hello World!
+#   Hello World!
+#   Hello World!
+#   Hello World!
+# 
diff --git a/testsuite/tests/formats-transition/legacy_incompatible_flags.ml b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml
new file mode 100644
index 00000000..53cf5c26
--- /dev/null
+++ b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml
@@ -0,0 +1,20 @@
+(* the legacy parser ignores flags on formatters on which they make no
+   sense *)
+
+let () = Printf.printf "%+s\n" "toto"
+;;
+let () = Printf.printf "%#s\n" "toto"
+;;
+let () = Printf.printf "% s\n" "toto"
+;;
+let () = Printf.printf "%03s\n" "toto"
+;;
+let () = Printf.printf "%03S\n" "toto"
+;;
+let () = Printf.printf "%.3s\n" "toto"
+;;
+
+(* it still fails on flags used with ignored formats (%_d, etc.),
+   but it's unclear how to test that in a backward-compatible way,
+   if we accept that the error message may have changed
+*)
diff --git a/testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference
new file mode 100644
index 00000000..814a5d33
--- /dev/null
+++ b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml.reference
@@ -0,0 +1,8 @@
+
+# *       toto
+#   toto
+#   toto
+#   toto
+#   "toto"
+#   toto
+#   * * *   
diff --git a/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml
new file mode 100644
index 00000000..16eca40c
--- /dev/null
+++ b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml
@@ -0,0 +1,18 @@
+(* test whether padding modifiers are accepted without any padding
+   size
+
+   the precision modifier is accepted without precision setting, but it
+   defaults to 0, which is not the same thing as not having precision:
+     %.0f 3.5 => 3
+     %.f 3.5 => 3
+     %f  3.5 => 3.5
+*)
+
+let () = Printf.printf "%0d\n" 3
+;;
+let () = Printf.printf "%-d\n" 3
+;;
+let () = Printf.printf "%.d\n" 3
+;;
+let () = Printf.printf "%.f\n" 3.
+;;
diff --git a/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference
new file mode 100644
index 00000000..81c05c0d
--- /dev/null
+++ b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference
@@ -0,0 +1,6 @@
+
+# * * * * * * * *       3
+#   3
+#   3
+#   3
+# 
diff --git a/testsuite/tests/formatting/Makefile b/testsuite/tests/formatting/Makefile
new file mode 100644
index 00000000..3e7e9a52
--- /dev/null
+++ b/testsuite/tests/formatting/Makefile
@@ -0,0 +1,5 @@
+BASEDIR=../..
+MAIN_MODULE=margins
+
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/formatting/margins.ml b/testsuite/tests/formatting/margins.ml
new file mode 100644
index 00000000..92c592f1
--- /dev/null
+++ b/testsuite/tests/formatting/margins.ml
@@ -0,0 +1,7 @@
+let () = Format.pp_set_margin Format.std_formatter 20;;
+
+1 + "foo";;
+
+let () = Format.pp_set_margin Format.std_formatter 80;;
+
+1 + "foo";;
diff --git a/testsuite/tests/formatting/margins.ml.reference b/testsuite/tests/formatting/margins.ml.reference
new file mode 100644
index 00000000..66d2fc24
--- /dev/null
+++ b/testsuite/tests/formatting/margins.ml.reference
@@ -0,0 +1,14 @@
+
+# #   Characters 5-10:
+  1 + "foo";;
+      ^^^^^
+Error: This expression has type
+         string
+       but an expression was expected of type
+         int
+#   #   Characters 5-10:
+  1 + "foo";;
+      ^^^^^
+Error: This expression has type string but an expression was expected of type
+         int
+# 
diff --git a/testsuite/tests/gc-roots/Makefile b/testsuite/tests/gc-roots/Makefile
new file mode 100644
index 00000000..c8e24cce
--- /dev/null
+++ b/testsuite/tests/gc-roots/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=globroots
+C_FILES=globrootsprim
+ADD_COMPFLAGS=-w a
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/gc-roots/globroots.ml b/testsuite/tests/gc-roots/globroots.ml
new file mode 100644
index 00000000..016277cf
--- /dev/null
+++ b/testsuite/tests/gc-roots/globroots.ml
@@ -0,0 +1,83 @@
+module type GLOBREF = sig
+  type t
+  val register: string -> t
+  val get: t -> string
+  val set: t -> string -> unit
+  val remove: t -> unit
+end
+
+module Classic : GLOBREF = struct
+  type t
+  external register: string -> t = "gb_classic_register"
+  external get: t -> string = "gb_get"
+  external set: t -> string -> unit = "gb_classic_set"
+  external remove: t -> unit = "gb_classic_remove"
+end
+
+module Generational : GLOBREF = struct
+  type t
+  external register: string -> t = "gb_generational_register"
+  external get: t -> string = "gb_get"
+  external set: t -> string -> unit = "gb_generational_set"
+  external remove: t -> unit = "gb_generational_remove"
+end
+
+module Test(G: GLOBREF) = struct
+
+  let size = 1024
+
+  let vals = Array.init size string_of_int
+
+  let a = Array.init size (fun i -> G.register (string_of_int i))
+
+  let check () =
+    for i = 0 to size - 1 do
+      if G.get a.(i) <> vals.(i) then begin
+        print_string "Error on "; print_int i; print_string ": ";
+        print_string (String.escaped (G.get a.(i))); print_newline()
+      end
+    done
+
+  let change () =
+    match Random.int 37 with
+    | 0 ->
+        Gc.full_major()
+    | 1|2|3|4 ->
+        Gc.minor()
+    | 5|6|7|8|9|10|11|12 ->             (* update with young value *)
+        let i = Random.int size in
+        G.set a.(i) (string_of_int i)
+    | 13|14|15|16|17|18|19|20 ->        (* update with old value *)
+        let i = Random.int size in
+        G.set a.(i) vals.(i)
+    | 21|22|23|24|25|26|27|28 ->        (* re-register young value *)
+        let i = Random.int size in
+        G.remove a.(i);
+        a.(i) <- G.register (string_of_int i)
+    | (*29|30|31|32|33|34|35|36*) _ ->  (* re-register old value *)
+        let i = Random.int size in
+        G.remove a.(i);
+        a.(i) <- G.register vals.(i)
+
+  let test n =
+    for i = 1 to n do
+      change();
+      print_string "."; flush stdout
+    done
+end
+
+module TestClassic = Test(Classic)
+module TestGenerational = Test(Generational)
+
+external young2old : unit -> unit = "gb_young2old"
+let _ = young2old (); Gc.full_major ()
+
+let _ =
+  let n =
+    if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) in
+  print_string "Non-generational API\n";
+  TestClassic.test n;
+  print_newline();
+  print_string "Generational API\n";
+  TestGenerational.test n;
+  print_newline()
diff --git a/testsuite/tests/gc-roots/globroots.reference b/testsuite/tests/gc-roots/globroots.reference
new file mode 100644
index 00000000..aae90b22
--- /dev/null
+++ b/testsuite/tests/gc-roots/globroots.reference
@@ -0,0 +1,4 @@
+Non-generational API
+................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................
+Generational API
+................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................
diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c
new file mode 100644
index 00000000..28ad2267
--- /dev/null
+++ b/testsuite/tests/gc-roots/globrootsprim.c
@@ -0,0 +1,83 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* For testing global root registration */
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/alloc.h"
+#include "caml/gc.h"
+
+struct block { value header; value v; };
+
+#define Block_val(v) ((struct block*) &((value*) v)[-1])
+#define Val_block(b) ((value) &((b)->v))
+
+value gb_get(value vblock)
+{
+  return Block_val(vblock)->v;
+}
+
+value gb_classic_register(value v)
+{
+  struct block * b = caml_stat_alloc(sizeof(struct block));
+  b->header = Make_header(1, 0, Caml_black);
+  b->v = v;
+  caml_register_global_root(&(b->v));
+  return Val_block(b);
+}
+
+value gb_classic_set(value vblock, value newval)
+{
+  Block_val(vblock)->v = newval;
+  return Val_unit;
+}
+
+value gb_classic_remove(value vblock)
+{
+  caml_remove_global_root(&(Block_val(vblock)->v));
+  return Val_unit;
+}
+
+value gb_generational_register(value v)
+{
+  struct block * b = caml_stat_alloc(sizeof(struct block));
+  b->header = Make_header(1, 0, Caml_black);
+  b->v = v;
+  caml_register_generational_global_root(&(b->v));
+  return Val_block(b);
+}
+
+value gb_generational_set(value vblock, value newval)
+{
+  caml_modify_generational_global_root(&(Block_val(vblock)->v), newval);
+  return Val_unit;
+}
+
+value gb_generational_remove(value vblock)
+{
+  caml_remove_generational_global_root(&(Block_val(vblock)->v));
+  return Val_unit;
+}
+
+value root;
+
+value gb_young2old(value _dummy) {
+  root = caml_alloc_small(1, 0);
+  caml_register_generational_global_root(&root);
+  caml_modify_generational_global_root(&root, caml_alloc_shr(10, String_tag));
+  Field(root, 0) = 0xFFFFFFFF;
+  caml_remove_generational_global_root(&root);
+  root += sizeof(value);
+  return Val_unit;
+}
diff --git a/testsuite/tests/int64-unboxing/Makefile b/testsuite/tests/int64-unboxing/Makefile
new file mode 100644
index 00000000..926edd17
--- /dev/null
+++ b/testsuite/tests/int64-unboxing/Makefile
@@ -0,0 +1,24 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2015 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=
+MAIN_MODULE=test
+C_FILES=stubs
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+NATIVECODE_ONLY=true
diff --git a/testsuite/tests/int64-unboxing/stubs.c b/testsuite/tests/int64-unboxing/stubs.c
new file mode 100644
index 00000000..25004759
--- /dev/null
+++ b/testsuite/tests/int64-unboxing/stubs.c
@@ -0,0 +1,25 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                  Jeremie Dimino, Jane Street Europe                    */
+/*                                                                        */
+/*   Copyright 2015 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+
+int64_t test_int64_add(int64_t x, int64_t y) { return (x + y); }
+int64_t test_int64_sub(int64_t x, int64_t y) { return (x - y); }
+int64_t test_int64_mul(int64_t x, int64_t y) { return (x * y); }
+
+value test_ignore_int64(int64_t x)
+{
+  return Val_unit;
+}
diff --git a/testsuite/tests/int64-unboxing/test.ml b/testsuite/tests/int64-unboxing/test.ml
new file mode 100644
index 00000000..4bffcc67
--- /dev/null
+++ b/testsuite/tests/int64-unboxing/test.ml
@@ -0,0 +1,25 @@
+external ( + ) : int64 -> int64 -> int64
+  = "" "test_int64_add" [@@noalloc] [@@unboxed]
+external ( - ) : int64 -> int64 -> int64
+  = "" "test_int64_sub" [@@noalloc] [@@unboxed]
+external ( * ) : int64 -> int64 -> int64
+  = "" "test_int64_mul" [@@noalloc] [@@unboxed]
+
+external ignore_int64 : (int64 [@unboxed]) -> unit
+  = "" "test_ignore_int64" [@@noalloc]
+
+let f () =
+  let r = ref 1L in
+  for i = 0 to 100000 do
+    let n = !r + !r in
+    r := n * n
+  done;
+  ignore_int64 !r
+
+let () =
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  let _x = f () in
+  let a2 = Gc.allocated_bytes () in
+  let alloc = (a2 -. 2. *. a1 +. a0) in
+  assert(alloc = 0.)
diff --git a/testsuite/tests/int64-unboxing/test.reference b/testsuite/tests/int64-unboxing/test.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lazy/Makefile b/testsuite/tests/lazy/Makefile
new file mode 100644
index 00000000..59613588
--- /dev/null
+++ b/testsuite/tests/lazy/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Mark Shinwell, Jane Street Europe                     *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group, LLC                                *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+ADD_OPTFLAGS=-O3
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lazy/lazy1.ml b/testsuite/tests/lazy/lazy1.ml
new file mode 100644
index 00000000..8ec74b6e
--- /dev/null
+++ b/testsuite/tests/lazy/lazy1.ml
@@ -0,0 +1,14 @@
+(* Mantis 7301, due to A. Frisch *)
+
+let foo () =
+  (fun xs0 () -> Lazy.force (List.hd xs0) ())
+    (List.map (fun g -> lazy g)
+       [Lazy.force (  lazy ( let _ = () in fun () -> ()  ) )]
+    )
+
+let () =
+  let gen = foo () in
+  gen ();
+  Gc.compact ();
+  print_char 'A'; flush stdout;
+  gen ()
diff --git a/testsuite/tests/lazy/lazy1.reference b/testsuite/tests/lazy/lazy1.reference
new file mode 100644
index 00000000..8c7e5a66
--- /dev/null
+++ b/testsuite/tests/lazy/lazy1.reference
@@ -0,0 +1 @@
+A
\ No newline at end of file
diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile
new file mode 100644
index 00000000..ef0afea5
--- /dev/null
+++ b/testsuite/tests/letrec/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml
new file mode 100644
index 00000000..4a893225
--- /dev/null
+++ b/testsuite/tests/letrec/backreferences.ml
@@ -0,0 +1,18 @@
+(* testing backreferences; some compilation scheme may handle
+   differently recursive references to a mutually-recursive RHS
+   depending on whether it is before or after in the bindings list *)
+type t = { x : t; y : t; z : t }
+
+let test =
+  let rec x = { x; y; z }
+      and y = { x; y; z }
+      and z = { x; y; z }
+  in
+  List.iter (fun (f, t_ref) ->
+    List.iter (fun t -> assert (f t == t_ref)) [x; y; z]
+  )
+    [
+      (fun t -> t.x), x;
+      (fun t -> t.y), y;
+      (fun t -> t.z), z;
+    ]
diff --git a/testsuite/tests/letrec/backreferences.reference b/testsuite/tests/letrec/backreferences.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
new file mode 100644
index 00000000..a7d03388
--- /dev/null
+++ b/testsuite/tests/letrec/class_1.ml
@@ -0,0 +1,5 @@
+(* class expression are compiled to recursive bindings *)
+class test =
+object
+  method x = 1
+end
diff --git a/testsuite/tests/letrec/class_1.reference b/testsuite/tests/letrec/class_1.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
new file mode 100644
index 00000000..71c7880d
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.ml
@@ -0,0 +1,8 @@
+(* class expressions may also contain local recursive bindings *)
+class test =
+  let rec f = print_endline "f"; fun x -> g x
+      and g = print_endline "g"; fun x -> f x in
+object
+  method f : 'a 'b. 'a -> 'b = f
+  method g : 'a 'b. 'a -> 'b = g
+end
diff --git a/testsuite/tests/letrec/class_2.reference b/testsuite/tests/letrec/class_2.reference
new file mode 100644
index 00000000..ab713757
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.reference
@@ -0,0 +1,2 @@
+f
+g
diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
new file mode 100644
index 00000000..6c94439e
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -0,0 +1,20 @@
+(* test evaluation order
+
+   'y' is translated into a constant, and is therefore considered
+   non-recursive. With the current letrec compilation method,
+   it should be evaluated before x and z.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (print_endline "effect"; Tree [y; z])
+  and y = (print_endline "effect"; Tree [])
+  and z = (print_endline "effect"; Tree [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false
diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference
new file mode 100644
index 00000000..bf36c925
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.reference
@@ -0,0 +1,3 @@
+effect
+effect
+effect
diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
new file mode 100644
index 00000000..f8a845bd
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -0,0 +1,19 @@
+(* A variant of evaluation_order_1.ml where the side-effects
+   are inside the blocks.
+   Effect are not named to allow different evaluation orders (flambda
+   and clambda differ on this point).
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (Tree [(print_endline "effect"; y); z])
+  and y = Tree (print_endline "effect"; [])
+  and z = Tree (print_endline "effect"; [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false
diff --git a/testsuite/tests/letrec/evaluation_order_2.reference b/testsuite/tests/letrec/evaluation_order_2.reference
new file mode 100644
index 00000000..bf36c925
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.reference
@@ -0,0 +1,3 @@
+effect
+effect
+effect
diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
new file mode 100644
index 00000000..8f76a8f8
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -0,0 +1,11 @@
+type t = { x : t; y : t }
+
+let p = print_endline
+
+let test =
+  let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) }
+      and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) }
+   in
+   assert (x.x == x); assert (x.y == y);
+   assert (y.x == x); assert (y.y == y);
+   ()
diff --git a/testsuite/tests/letrec/evaluation_order_3.reference b/testsuite/tests/letrec/evaluation_order_3.reference
new file mode 100644
index 00000000..5b8c549e
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.reference
@@ -0,0 +1,6 @@
+x
+x_y
+x_x
+y
+y_y
+y_x
diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
new file mode 100644
index 00000000..b2f878bb
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -0,0 +1,10 @@
+(* Effect are not named to allow different evaluation orders (flambda
+   and clambda differ on this point).
+ *)
+let test =
+  let rec x = print_endline "effect"; [| 1; 2; 3 |]
+      and y = print_endline "effect"; [| 1.; 2.; 3. |]
+  in
+  assert (x = [| 1; 2; 3 |]);
+  assert (y = [| 1.; 2.; 3. |]);
+  ()
diff --git a/testsuite/tests/letrec/float_block_1.reference b/testsuite/tests/letrec/float_block_1.reference
new file mode 100644
index 00000000..fa0efbd2
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.reference
@@ -0,0 +1,2 @@
+effect
+effect
diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
new file mode 100644
index 00000000..968cba4e
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -0,0 +1,7 @@
+(* a bug in cmmgen.ml provokes a segfault in certain natively compiled
+   letrec-bindings involving float arrays *)
+let test =
+  let rec x = [| y; y |] and y = 1. in
+  assert (x = [| 1.; 1. |]);
+  assert (y = 1.);
+  ()
diff --git a/testsuite/tests/letrec/float_block_2.reference b/testsuite/tests/letrec/float_block_2.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
new file mode 100644
index 00000000..5686e493
--- /dev/null
+++ b/testsuite/tests/letrec/lists.ml
@@ -0,0 +1,8 @@
+(* a test with lists, because cyclic lists are fun *)
+let test =
+  let rec li = 0::1::2::3::4::5::6::7::8::9::li in
+  match li with
+    | 0::1::2::3::4::5::6::7::8::9::
+        0::1::2::3::4::5::6::7::8::9::li' ->
+      assert (li == li')
+    | _ -> assert false
diff --git a/testsuite/tests/letrec/lists.reference b/testsuite/tests/letrec/lists.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
new file mode 100644
index 00000000..e79f79ec
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -0,0 +1,8 @@
+(* mixing values and closures may exercise interesting code paths *)
+type t = A of (int -> int)
+let test =
+  let rec x = A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with A g -> g 0
+  in assert (f 1 = 2)
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.reference b/testsuite/tests/letrec/mixing_value_closures_1.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
new file mode 100644
index 00000000..eb5fcb74
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -0,0 +1,8 @@
+(* a polymorphic variant of test3.ml; found a real bug once *)
+let test =
+  let rec x = `A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with `A g -> g 0
+  in
+  assert (f 1 = 2)
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.reference b/testsuite/tests/letrec/mixing_value_closures_2.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
new file mode 100644
index 00000000..a5b6c51f
--- /dev/null
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -0,0 +1,11 @@
+(* a simple test with mutually recursive functions *)
+let test =
+  let rec even = function
+    | 0 -> true
+    | n -> odd (n - 1)
+  and odd = function
+    | 0 -> false
+    | n -> even (n - 1)
+  in
+  List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0)))
+    [0;1;2;3;4;5;6]
diff --git a/testsuite/tests/letrec/mutual_functions.reference b/testsuite/tests/letrec/mutual_functions.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/record_with.ml b/testsuite/tests/letrec/record_with.ml
new file mode 100644
index 00000000..8d2d01c0
--- /dev/null
+++ b/testsuite/tests/letrec/record_with.ml
@@ -0,0 +1,24 @@
+(* A regression test for both PR#4141 and PR#5819: when a recursive
+   variable is defined by a { record with ... } expression.
+*)
+
+type t = {
+  self : t;
+  t0 : int;
+  t1 : int;
+  t2 : int;
+  t3 : int;
+  t4 : int;
+};;
+let rec t = {
+  self = t;
+  t0 = 42;
+  t1 = 42;
+  t2 = 42;
+  t3 = 42;
+  t4 = 42;
+};;
+
+let rec self = { t with self=self } in
+Printf.printf "%d\n" self.self.t0
+;;
diff --git a/testsuite/tests/letrec/record_with.reference b/testsuite/tests/letrec/record_with.reference
new file mode 100644
index 00000000..d81cc071
--- /dev/null
+++ b/testsuite/tests/letrec/record_with.reference
@@ -0,0 +1 @@
+42
diff --git a/testsuite/tests/lib-arg/Makefile b/testsuite/tests/lib-arg/Makefile
new file mode 100644
index 00000000..dd488d43
--- /dev/null
+++ b/testsuite/tests/lib-arg/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*        Damien Doligez, projet Gallium, INRIA Rocquencourt              *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-arg/testarg.ml b/testsuite/tests/lib-arg/testarg.ml
new file mode 100644
index 00000000..380f420c
--- /dev/null
+++ b/testsuite/tests/lib-arg/testarg.ml
@@ -0,0 +1,189 @@
+let current = ref 0;;
+
+let accum = ref [];;
+
+let record fmt (* args *) =
+  Printf.kprintf (fun s -> accum := s :: !accum) fmt
+;;
+
+let f_unit () = record "unit()";;
+let f_bool b = record "bool(%b)" b;;
+let r_set = ref false;;
+let r_clear = ref true;;
+let f_string s = record "string(%s)" s;;
+let r_string = ref "";;
+let f_int i = record "int(%d)" i;;
+let r_int = ref 0;;
+let f_float f = record "float(%g)" f;;
+let r_float = ref 0.0;;
+let f_symbol s = record "symbol(%s)" s;;
+let f_rest s = record "rest(%s)" s;;
+let f_anon s = record "anon(%s)" s;;
+
+let spec = Arg.[
+  "-u", Unit f_unit, "Unit (0)";
+  "-b", Bool f_bool, "Bool (1)";
+  "-s", Set r_set, "Set (0)";
+  "-c", Clear r_clear, "Clear (0)";
+  "-str", String f_string, "String (1)";
+  "-sstr", Set_string r_string, "Set_string (1)";
+  "-i", Int f_int, "Int (1)";
+  "-si", Set_int r_int, "Set_int (1)";
+  "-f", Float f_float, "Float (1)";
+  "-sf", Set_float r_float, "Set_float (1)";
+  "-t", Tuple [Bool f_bool; String f_string; Int f_int], "Tuple (3)";
+  "-sym", Symbol (["a"; "b"; "c"], f_symbol), "Symbol (1)";
+  "-rest", Rest f_rest, "Rest (*)";
+];;
+
+let args1 = [|
+  "prog";
+  "anon1";
+  "-u";
+  "-b"; "true";
+  "-s";
+  "anon2";
+  "-c";
+  "-str"; "foo";
+  "-sstr"; "bar";
+  "-i"; "19";
+  "-si"; "42";
+  "-f"; "3.14";
+  "-sf"; "2.72";
+  "anon3";
+  "-t"; "false"; "gee"; "1436";
+  "-sym"; "c";
+  "anon4";
+  "-rest"; "r1"; "r2";
+|];;
+
+let args2 = [|
+  "prog";
+  "anon1";
+  "-u";
+  "-b=true";
+  "-s";
+  "anon2";
+  "-c";
+  "-str=foo";
+  "-sstr=bar";
+  "-i=19";
+  "-si=42";
+  "-f=3.14";
+  "-sf=2.72";
+  "anon3";
+  "-t"; "false"; "gee"; "1436";
+  "-sym=c";
+  "anon4";
+  "-rest"; "r1"; "r2";
+|];;
+
+let error s = Printf.printf "error (%s)\n" s;;
+let check r v msg = if !r <> v then error msg;;
+
+let test spec argv =
+  current := 0;
+  r_set := false;
+  r_clear := true;
+  r_string := "";
+  r_int := 0;
+  r_float := 0.0;
+  accum := [];
+  Arg.parse_and_expand_argv_dynamic current argv (ref spec) f_anon "usage";
+  let result = List.rev !accum in
+  let reference = [
+      "anon(anon1)";
+      "unit()";
+      "bool(true)";
+      "anon(anon2)";
+      "string(foo)";
+      "int(19)";
+      "float(3.14)";
+      "anon(anon3)";
+      "bool(false)"; "string(gee)"; "int(1436)";
+      "symbol(c)";
+      "anon(anon4)";
+      "rest(r1)"; "rest(r2)";
+    ]
+  in
+  if result <> reference then begin
+    let f x y =
+      Printf.printf "%20s %c %-20s\n%!" x (if x = y then '=' else '#') y
+    in
+    List.iter2 f result reference;
+  end;
+  check r_set true "Set";
+  check r_clear false "Clear";
+  check r_string "bar" "Set_string";
+  check r_int 42 "Set_int";
+  check r_float 2.72 "Set_float";
+;;
+
+let test_arg args = test spec (ref args);;
+
+test_arg args1;;
+test_arg args2;;
+
+
+let safe_rm file =
+  try
+    Sys.remove file
+  with _ -> ()
+
+let test_rw argv =
+  safe_rm "test_rw";
+  safe_rm "test_rw0";
+  Arg.write_arg "test_rw" argv;
+  Arg.write_arg0 "test_rw0" argv;
+  let argv' = Arg.read_arg "test_rw" in
+  let argv0 = Arg.read_arg0 "test_rw0" in
+  let f x y =
+    if x <> y then
+      Printf.printf "%20s %c %-20s\n%!" x (if x = y then '=' else '#') y
+  in
+  Array.iter2 f argv argv';
+  Array.iter2 f argv argv0;
+  safe_rm "test_rw";
+  safe_rm "test_rw0";
+;;
+
+test_rw args1;;
+test_rw args2;;
+test_rw (Array.make 0 "");;
+test_rw [|"";""|];;
+
+let f_expand r msg arg s =
+  if s <> r then error msg;
+  arg;
+;;
+
+let expand1,args1,expected1 =
+  let l = Array.length args1  - 1 in
+  let args = Array.sub args1 1 l in
+  let args1 =  [|"prog";"-expand";"expand_arg1"|] in
+  Arg.["-expand", Expand (f_expand "expand_arg1" "Expand" args), "Expand (1)";],
+  args1,
+  Array.append  args1 args
+;;
+
+let expand2,args2,expected2 =
+  let l = Array.length args2  - 1 in
+  let args = Array.sub args2 1 l in
+  let args2 = [|"prog";"-expand";"expand_arg2"|] in
+  Arg.["-expand", Expand (f_expand "expand_arg2" "Expand" args), "Expand (1)";],
+  args2,
+  Array.append args2 args
+;;
+
+let test_expand spec argv reference =
+  let result = ref argv in
+  test spec result;
+  let f x y =
+    if x <> y then
+      Printf.printf "%20s %c %-20s\n%!" x (if x = y then '=' else '#') y
+  in
+  Array.iter2 f !result reference;
+;;
+
+test_expand (expand1@spec) args1 expected1;;
+test_expand (expand2@spec) args2 expected2;;
diff --git a/testsuite/tests/lib-arg/testarg.reference b/testsuite/tests/lib-arg/testarg.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-arg/testerror.ml b/testsuite/tests/lib-arg/testerror.ml
new file mode 100644
index 00000000..d4b433ee
--- /dev/null
+++ b/testsuite/tests/lib-arg/testerror.ml
@@ -0,0 +1,41 @@
+(** Test that the right message errors are emitted by Arg *)
+
+
+let usage= "Arg module testing"
+
+let test total i (spec,anon,argv) =
+  let argv = Array.of_list ("testerror" :: argv) in
+  try Arg.parse_argv ~current:(ref 0) argv spec anon usage with
+  | Arg.Bad s-> Printf.printf "(%d/%d) Bad:\n%s\n" (i+1) total s
+  | Arg.Help s -> Printf.printf "(%d/%d) Help:\n%s\n" (i+1) total s
+
+
+let tests = [
+(** missing argument error *)
+  ["-s",  Arg.String ignore, "missing arg"], ignore, ["-s"]
+
+(** No argument expected *)
+; ["-set",  Arg.Set (ref false), "no argument expected"], ignore, ["-set=true"]
+
+(** help message *)
+; [], ignore, ["-help" ]
+
+(** wrong argument type *)
+; ["-int", Arg.Int ignore, "wrong argument type" ], ignore, ["-int"; "not_an_int" ]
+
+(** unknown option *)
+; [], ignore, [ "-an-unknown-option" ]
+
+(** user-error in anon fun *)
+; [], (fun _ -> raise @@ Arg.Bad("User-raised error")), [ "argument" ]
+
+(** user-error in anon fun *)
+; ["-error",
+   Arg.Unit (fun () -> raise @@ Arg.Bad("User-raised error bis")),
+   "user raised error"]
+, ignore, [ "-error" ]
+]
+
+let () =
+  let n = List.length tests in
+  List.iteri (test n) tests
diff --git a/testsuite/tests/lib-arg/testerror.reference b/testsuite/tests/lib-arg/testerror.reference
new file mode 100644
index 00000000..3608e11c
--- /dev/null
+++ b/testsuite/tests/lib-arg/testerror.reference
@@ -0,0 +1,45 @@
+(1/7) Bad:
+testerror: option '-s' needs an argument.
+Arg module testing
+  -s missing arg
+  -help  Display this list of options
+  --help  Display this list of options
+
+(2/7) Bad:
+testerror: wrong argument 'true'; option '-set=true' expects no argument.
+Arg module testing
+  -set no argument expected
+  -help  Display this list of options
+  --help  Display this list of options
+
+(3/7) Help:
+Arg module testing
+  -help  Display this list of options
+  --help  Display this list of options
+
+(4/7) Bad:
+testerror: wrong argument 'not_an_int'; option '-int' expects an integer.
+Arg module testing
+  -int wrong argument type
+  -help  Display this list of options
+  --help  Display this list of options
+
+(5/7) Bad:
+testerror: unknown option '-an-unknown-option'.
+Arg module testing
+  -help  Display this list of options
+  --help  Display this list of options
+
+(6/7) Bad:
+testerror: User-raised error.
+Arg module testing
+  -help  Display this list of options
+  --help  Display this list of options
+
+(7/7) Bad:
+testerror: User-raised error bis.
+Arg module testing
+  -error user raised error
+  -help  Display this list of options
+  --help  Display this list of options
+
diff --git a/testsuite/tests/lib-bigarray-2/Makefile b/testsuite/tests/lib-bigarray-2/Makefile
new file mode 100644
index 00000000..f36a3f00
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-2/Makefile
@@ -0,0 +1,24 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix bigarray
+C_FILES=bigarrfstub
+F_FILES=bigarrf
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray \
+	      -I $(OTOPDIR)/otherlibs/$(UNIXLIB)
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-bigarray-2/bigarrf.f b/testsuite/tests/lib-bigarray-2/bigarrf.f
new file mode 100644
index 00000000..ff52de1d
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-2/bigarrf.f
@@ -0,0 +1,26 @@
+	subroutine filltab()
+
+	integer dimx, dimy
+	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/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
new file mode 100644
index 00000000..d33862ed
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
@@ -0,0 +1,66 @@
+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/testsuite/tests/lib-bigarray-2/bigarrfml.reference b/testsuite/tests/lib-bigarray-2/bigarrfml.reference
new file mode 100644
index 00000000..8368d5ab
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-2/bigarrfml.reference
@@ -0,0 +1,27 @@
+
+
+------ Foreign function interface --------
+
+Passing an array to C
+
+Accessing a C array
+ 1... 2... 3... 4...
+Passing an array to Fortran
+  0     0.0     1.0     2.0     3.0     4.0     5.0     6.0     7.0
+  1  1000.0  1001.0  1002.0  1003.0  1004.0  1005.0  1006.0  1007.0
+  2  2000.0  2001.0  2002.0  2003.0  2004.0  2005.0  2006.0  2007.0
+  3  3000.0  3001.0  3002.0  3003.0  3004.0  3005.0  3006.0  3007.0
+  4  4000.0  4001.0  4002.0  4003.0  4004.0  4005.0  4006.0  4007.0
+  5  5000.0  5001.0  5002.0  5003.0  5004.0  5005.0  5006.0  5007.0
+
+Accessing a Fortran array
+ 1... 2... 3... 4...
+   1  1001.01002.01003.01004.0
+
+   2  2001.02002.02003.02004.0
+
+   3  3001.03002.03003.03004.0
+
+   4  4001.04002.04003.04004.0
+
+   5  5001.05002.05003.05004.0
diff --git a/testsuite/tests/lib-bigarray-2/bigarrfstub.c b/testsuite/tests/lib-bigarray-2/bigarrfstub.c
new file mode 100644
index 00000000..efec26aa
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-2/bigarrfstub.c
@@ -0,0 +1,74 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <stdio.h>
+#include <caml/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/testsuite/tests/lib-bigarray-file/Makefile b/testsuite/tests/lib-bigarray-file/Makefile
new file mode 100644
index 00000000..09ee70fa
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-file/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+              -I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-bigarray-file/mapfile.ml b/testsuite/tests/lib-bigarray-file/mapfile.ml
new file mode 100644
index 00000000..c69ca459
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-file/mapfile.ml
@@ -0,0 +1,109 @@
+open Bigarray
+
+(* 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
+   Printf.eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
+   flush stderr;
+   error_occurred := true
+ end else begin
+   Printf.printf " %d..." test_number
+ end
+
+(* Tests *)
+
+let tests () =
+  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_of_genarray (Genarray.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_of_genarray
+        (Genarray.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_of_genarray (Genarray.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;
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    let c =
+      array2_of_genarray
+        (Genarray.map_file fd ~pos:800L float64 c_layout false [|-1; 100|])
+    in
+    Unix.close fd;
+    let ok = ref true in
+    for i = 1 to 99 do
+      for j = 0 to 99 do
+        if c.{i-1,j} <> float (100 * i + j) then ok := false
+      done
+    done;
+    test 3 !ok true;
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    let c =
+      array2_of_genarray
+        (Genarray.map_file fd ~pos:79200L float64 c_layout false [|-1; 100|])
+    in
+    Unix.close fd;
+    let ok = ref true in
+    for j = 0 to 99 do
+      if c.{0,j} <> float (100 * 99 + j) then ok := false
+    done;
+    test 4 !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;
+
+  ()
+  [@@inline never]
+
+
+(********* End of test *********)
+
+let _ =
+  tests ();
+  print_newline();
+  if !error_occurred then begin
+    prerr_endline "************* TEST FAILED ****************"; exit 2
+  end else
+    exit 0
diff --git a/testsuite/tests/lib-bigarray-file/mapfile.reference b/testsuite/tests/lib-bigarray-file/mapfile.reference
new file mode 100644
index 00000000..4b66315c
--- /dev/null
+++ b/testsuite/tests/lib-bigarray-file/mapfile.reference
@@ -0,0 +1,3 @@
+
+map_file
+ 1... 2... 3... 4...
diff --git a/testsuite/tests/lib-bigarray/Makefile b/testsuite/tests/lib-bigarray/Makefile
new file mode 100644
index 00000000..09ee70fa
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+              -I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml
new file mode 100644
index 00000000..d229ae09
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -0,0 +1,1045 @@
+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 *)
+
+(* flambda can cause some of these values not to be reclaimed by the Gc, which
+ * can undermine the use of Gc.full_major for the Windows ports. All the tests
+ * are wrapped in a non-inlineable function to prevent this behaviour.
+ *)
+let tests () =
+  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
+
+  (* Test indexing arrays.  This test has to be copy-pasted, otherwise
+     indexing may not use the optimizations in
+     Cmmgen.bigarray_indexing. *)
+  begin
+    let v = 123 in
+    let cb = Array1.create int8_signed c_layout 1000 in
+    let fb = Array1.create int8_signed fortran_layout 1000 in
+    Array1.fill cb v;
+    Array1.fill fb v;
+    let return = ref true in
+    for i = 1 to 99 do
+      let i = i * 10 in
+      return := !return
+        && Array1.unsafe_get cb (i - 10) = v
+        && Array1.unsafe_get cb (i     ) = v
+        && Array1.unsafe_get cb (i +  9) = v
+        && Array1.unsafe_get fb (i -  9) = v
+        && Array1.unsafe_get fb (i     ) = v
+        && Array1.unsafe_get fb (i + 10) = v
+    done;
+    test 13 true !return
+  end;
+  begin
+    let v = 123 in
+    let cb = Array1.create int16_unsigned c_layout 1000 in
+    let fb = Array1.create int16_unsigned fortran_layout 1000 in
+    Array1.fill cb v;
+    Array1.fill fb v;
+    let return = ref true in
+    for i = 1 to 99 do
+      let i = i * 10 in
+      return := !return
+        && Array1.unsafe_get cb (i - 10) = v
+        && Array1.unsafe_get cb (i     ) = v
+        && Array1.unsafe_get cb (i +  9) = v
+        && Array1.unsafe_get fb (i -  9) = v
+        && Array1.unsafe_get fb (i     ) = v
+        && Array1.unsafe_get fb (i + 10) = v
+    done;
+    test 14 true !return
+  end;
+  begin
+    let v = 123. in
+    let cb = Array1.create float32 c_layout 1000 in
+    let fb = Array1.create float32 fortran_layout 1000 in
+    Array1.fill cb v;
+    Array1.fill fb v;
+    let return = ref true in
+    for i = 1 to 99 do
+      let i = i * 10 in
+      return := !return
+        && Array1.unsafe_get cb (i - 10) = v
+        && Array1.unsafe_get cb (i     ) = v
+        && Array1.unsafe_get cb (i +  9) = v
+        && Array1.unsafe_get fb (i -  9) = v
+        && Array1.unsafe_get fb (i     ) = v
+        && Array1.unsafe_get fb (i + 10) = v
+    done;
+    test 15 true !return
+  end;
+
+  begin
+    let v = 123. in
+    let cb = Array1.create float64 c_layout 1000 in
+    let fb = Array1.create float64 fortran_layout 1000 in
+    Array1.fill cb v;
+    Array1.fill fb v;
+    let return = ref true in
+    for i = 1 to 99 do
+      let i = i * 10 in
+      return := !return
+        && Array1.unsafe_get cb (i - 10) = v
+        && Array1.unsafe_get cb (i     ) = v
+        && Array1.unsafe_get cb (i +  9) = v
+        && Array1.unsafe_get fb (i -  9) = v
+        && Array1.unsafe_get fb (i     ) = v
+        && Array1.unsafe_get fb (i + 10) = v
+    done;
+    test 16 true !return
+  end;
+
+  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 ignore a.{3}; false with Invalid_argument _ -> true);
+  test 5 true (try ignore 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 ignore b.{4}; false with Invalid_argument _ -> true);
+  test 9 true (try ignore 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 ignore c.{3}; false with Invalid_argument _ -> true);
+  test 14 true (try ignore 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 ignore d.{4}; false with Invalid_argument _ -> true);
+  test 19 true (try ignore d.{0}; false with Invalid_argument _ -> true);
+
+  testing_function "set/get (unsafe, specialized)";
+  let a = Array1.create int c_layout 3 in
+  for i = 0 to 2 do Array1.unsafe_set a i i done;
+  for i = 0 to 2 do test (i+1) (Array1.unsafe_get a i) i done;
+
+  let b = Array1.create float64 fortran_layout 3 in
+  for i = 1 to 3 do Array1.unsafe_set b i (float i) done;
+  for i = 1 to 3 do test (5 + i) (Array1.unsafe_get b i) (float i) done;
+
+  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 "size_in_bytes_one";
+  test 1 (Array1.size_in_bytes (from_list int [1;2;3;4;5]))
+    (5 * (kind_size_in_bytes int));
+  test 2 (Array1.size_in_bytes (from_list int [])) 0;
+  let int64list = (from_list int64 (List.map Int64.of_int [1;2;3;4;5])) in
+  test 3 (Array1.size_in_bytes int64list) (5 * (kind_size_in_bytes int64));
+  test 4 (Array1.size_in_bytes (from_list int64 (List.map Int64.of_int []))) 0;
+
+  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);
+  testing_function "slice";
+  let a = Array1.of_array int c_layout [| 5; 4; 3 |] in
+  test 1 (Array1.slice a 0) (Array0.of_value int c_layout 5);
+  test 2 (Array1.slice a 1) (Array0.of_value int c_layout 4);
+  test 3 (Array1.slice a 2) (Array0.of_value int c_layout 3);
+  let a = Array1.of_array int fortran_layout [| 5; 4; 3 |] in
+  test 6 (Array1.slice a 1) (Array0.of_value int fortran_layout 5);
+  test 7 (Array1.slice a 2) (Array0.of_value int fortran_layout 4);
+  test 8 (Array1.slice a 3) (Array0.of_value int fortran_layout 3);
+
+
+(* 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 ignore a.{3,0}; false with Invalid_argument _ -> true);
+  test 3 true (try ignore a.{-1,0}; false with Invalid_argument _ -> true);
+  test 4 true (try ignore a.{0,3}; false with Invalid_argument _ -> true);
+  test 5 true (try ignore 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 ignore b.{4,1}; false with Invalid_argument _ -> true);
+  test 8 true (try ignore b.{0,1}; false with Invalid_argument _ -> true);
+  test 9 true (try ignore b.{1,4}; false with Invalid_argument _ -> true);
+  test 10 true (try ignore b.{1,0}; false with Invalid_argument _ -> true);
+
+  testing_function "set/get (unsafe, specialized)";
+  let a = Array2.create int16_signed c_layout 3 3 in
+  for i = 0 to 2 do for j = 0 to 2 do Array2.unsafe_set 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 Array2.unsafe_get a i j <> i-j then ok := false done
+  done;
+  test 1 true !ok;
+
+  let b = Array2.create float32 fortran_layout 3 3 in
+  for i = 1 to 3 do
+    for j = 1 to 3 do Array2.unsafe_set 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 Array2.unsafe_get b i j <> float(i-j) then ok := false
+    done
+  done;
+  test 2 true !ok;
+
+  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 "size_in_bytes_two";
+  let a = Array2.create int c_layout 4 6 in
+  test 1 (Array2.size_in_bytes a) (24 * (kind_size_in_bytes int));
+
+  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 "set/get (unsafe, 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
+     Array3.unsafe_set 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 (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k
+     then ok := false
+  done done done;
+  test 1 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 "size_in_bytes_three";
+  let a = Array3.create int c_layout 4 5 6 in
+  test 1 (Array3.size_in_bytes a) (120 * (kind_size_in_bytes int));
+
+  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]);
+
+  testing_function "size_in_bytes_general";
+  let a = Genarray.create int c_layout [|2;2;2;2;2|] in
+  test 1 (Genarray.size_in_bytes a) (32 * (kind_size_in_bytes int));
+
+(* Zero-dimensional arrays *)
+  testing_function "------ Array0 --------";
+  testing_function "create/set/get";
+  let test_setget kind vals =
+    List.for_all (fun (v1, v2) ->
+      let ca = Array0.create kind c_layout in
+      let fa = Array0.create kind fortran_layout in
+      Array0.set ca v1;
+      Array0.set fa v1;
+      Array0.get ca = v2 && Array0.get fa = v2) 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}]);
+
+
+(* Kind size *)
+  testing_function "kind_size_in_bytes";
+  let arr1 = Array1.create Float32 c_layout 1 in
+  test 1 (kind_size_in_bytes Float32) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Float64 c_layout 1 in
+  test 2 (kind_size_in_bytes Float64) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int8_signed c_layout 1 in
+  test 3 (kind_size_in_bytes Int8_signed) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int8_unsigned c_layout 1 in
+  test 4 (kind_size_in_bytes Int8_unsigned) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int16_signed c_layout 1 in
+  test 5 (kind_size_in_bytes Int16_signed) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int16_unsigned c_layout 1 in
+  test 6 (kind_size_in_bytes Int16_unsigned) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int32 c_layout 1 in
+  test 7 (kind_size_in_bytes Int32) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int64 c_layout 1 in
+  test 8 (kind_size_in_bytes Int64) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Int c_layout 1 in
+  test 9 (kind_size_in_bytes Int) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Nativeint c_layout 1 in
+  test 10 (kind_size_in_bytes Nativeint) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Complex32 c_layout 1 in
+  test 11 (kind_size_in_bytes Complex32) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Complex64 c_layout 1 in
+  test 12 (kind_size_in_bytes Complex64) (Array1.size_in_bytes arr1);
+  let arr1 = Array1.create Char c_layout 1 in
+  test 13 (kind_size_in_bytes Char) (Array1.size_in_bytes arr1);
+
+(* 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]);
+  testing_function "reshape";
+  let a = make_array2 int c_layout 0 1 1 (fun i -> i + 3) in
+  let b = reshape_0 (genarray_of_array2 a) in
+  let c = reshape (genarray_of_array0 b) [|1|] in
+  test 8 (Array0.get b) 3;
+  test 9 (Genarray.get c [|0|]) 3;
+  test 10 (Genarray.get (Genarray.slice_left c [|0|]) [||]) 3;
+
+(* 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;
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    let c = Array2.map_file fd ~pos:800L float64 c_layout false (-1) 100 in
+    Unix.close fd;
+    let ok = ref true in
+    for i = 1 to 99 do
+      for j = 0 to 99 do
+        if c.{i-1,j} <> float (100 * i + j) then ok := false
+      done
+    done;
+    test 3 !ok true;
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    let c = Array2.map_file fd ~pos:79200L float64 c_layout false (-1) 100 in
+    Unix.close fd;
+    let ok = ref true in
+    for j = 0 to 99 do
+      if c.{0,j} <> float (100 * 99 + j) then ok := false
+    done;
+    test 4 !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;
+
+  ()
+  [@@inline never]
+
+(********* End of test *********)
+
+let _ =
+  tests ();
+  print_newline();
+  if !error_occurred then begin
+    prerr_endline "************* TEST FAILED ****************"; exit 2
+  end else
+    exit 0
diff --git a/testsuite/tests/lib-bigarray/bigarrays.reference b/testsuite/tests/lib-bigarray/bigarrays.reference
new file mode 100644
index 00000000..e96d0114
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/bigarrays.reference
@@ -0,0 +1,79 @@
+
+------ Array1 --------
+
+create/set/get
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16...
+set/get (specialized)
+ 1... 2... 3... 4... 5... 6... 7... 8... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19...
+set/get (unsafe, specialized)
+ 1... 2... 3... 6... 7... 8...
+comparisons
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... 29... 30... 31... 32... 44... 45... 46... 47... 48... 49...
+dim
+ 1... 2...
+size_in_bytes_one
+ 1... 2... 3... 4...
+kind & layout
+ 1... 2... 1... 2...
+sub
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+blit, fill
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+slice
+ 1... 2... 3... 6... 7... 8...
+
+------ Array2 --------
+
+create/set/get
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
+set/get (specialized)
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
+set/get (unsafe, specialized)
+ 1... 2...
+dim
+ 1... 2... 3... 4...
+size_in_bytes_two
+ 1...
+sub
+ 1... 2...
+slice
+ 1... 2... 3... 4... 5... 6... 7... 8...
+
+------ Array3 --------
+
+create/set/get
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
+set/get (specialized)
+ 1... 2...
+set/get (unsafe, specialized)
+ 1...
+dim
+ 1... 2... 3... 4... 5... 6...
+size_in_bytes_three
+ 1...
+slice1
+ 1... 2... 3... 4... 5... 6... 7...
+size_in_bytes_general
+ 1...
+------ Array0 --------
+
+create/set/get
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+kind_size_in_bytes
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+
+------ Reshaping --------
+
+reshape_1
+ 1... 2...
+reshape_2
+ 1... 2... 3... 4... 5... 6... 7...
+reshape
+ 8... 9... 10...
+
+------ I/O --------
+
+output_value/input_value
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
+map_file
+ 1... 2... 3... 4...
diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml
new file mode 100644
index 00000000..8a01389c
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/fftba.ml
@@ -0,0 +1,182 @@
+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()
+*)
+  if abs_float !zr <= 1e-9 && abs_float !zi <= 1e-9
+  then print_string "ok"
+  else print_string "ERROR";
+  print_newline()
+
+
+let _ =
+  let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done
diff --git a/testsuite/tests/lib-bigarray/fftba.reference b/testsuite/tests/lib-bigarray/fftba.reference
new file mode 100644
index 00000000..71017f70
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/fftba.reference
@@ -0,0 +1,13 @@
+16... ok
+32... ok
+64... ok
+128... ok
+256... ok
+512... ok
+1024... ok
+2048... ok
+4096... ok
+8192... ok
+16384... ok
+32768... ok
+65536... ok
diff --git a/testsuite/tests/lib-bigarray/pr5115.ml b/testsuite/tests/lib-bigarray/pr5115.ml
new file mode 100644
index 00000000..e75215cf
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/pr5115.ml
@@ -0,0 +1,12 @@
+(* PR#5115 - multiple evaluation of bigarray expr *)
+
+open Bigarray
+
+let f y0 =
+  Printf.printf "***EXEC***\n%!";
+  y0
+
+let _ =
+  let y = Array1.of_array float64 fortran_layout [| 1. |] in
+  (f y).{1};
+  (f y).{1} <- 3.14
diff --git a/testsuite/tests/lib-bigarray/pr5115.reference b/testsuite/tests/lib-bigarray/pr5115.reference
new file mode 100644
index 00000000..63f719ac
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/pr5115.reference
@@ -0,0 +1,2 @@
+***EXEC***
+***EXEC***
diff --git a/testsuite/tests/lib-bigarray/weak_bigarray.ml b/testsuite/tests/lib-bigarray/weak_bigarray.ml
new file mode 100644
index 00000000..62f9b99f
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/weak_bigarray.ml
@@ -0,0 +1,28 @@
+
+
+(** check that custom block are not copied by Weak.get_copy *)
+
+open Bigarray
+open Bigarray.Array1
+
+let () =
+  let a = ref (create float64 c_layout 10) in
+  Gc.compact ();
+  set !a 0 42.;
+
+  let w = Weak.create 1 in
+  Weak.set w 0 (Some !a);
+
+  let b =
+    match Weak.get_copy w 0 with
+    | None -> assert false
+    | Some b -> b
+  in
+  Printf.printf "a.(0) = %f\n" (get !a 0);
+  Printf.printf "b.(0) = %f\n" (get b 0);
+  a := create float64 c_layout 10;
+  Gc.compact ();
+
+  let c = create float64 c_layout 10 in
+  set c 0 33.;
+  Printf.printf "b.(0) = %f\n" (get b 0);
diff --git a/testsuite/tests/lib-bigarray/weak_bigarray.reference b/testsuite/tests/lib-bigarray/weak_bigarray.reference
new file mode 100644
index 00000000..38901efc
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/weak_bigarray.reference
@@ -0,0 +1,3 @@
+a.(0) = 42.000000
+b.(0) = 42.000000
+b.(0) = 42.000000
diff --git a/testsuite/tests/lib-buffer/Makefile b/testsuite/tests/lib-buffer/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-buffer/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-buffer/test.ml b/testsuite/tests/lib-buffer/test.ml
new file mode 100644
index 00000000..0fd32a6c
--- /dev/null
+++ b/testsuite/tests/lib-buffer/test.ml
@@ -0,0 +1,86 @@
+open Printf
+;;
+
+(* Set up*)
+let n = 10
+;;
+
+let buf = Buffer.create n
+;;
+
+let () =
+  for i = 1 to 10 do
+    Buffer.add_char buf 'a'
+  done
+;;
+
+assert (Buffer.length buf = n)
+;;
+
+(* Helpers *)
+
+let output result str =
+  print_string ("Buffer " ^ str ^ " " ^ result ^ "\n")
+;;
+
+let passed = output "passed"
+;;
+
+let failed = output "failed"
+;;
+
+(* Tests *)
+let () = print_string "Standard Library: Module Buffer\n"
+;;
+
+let truncate_neg : unit = 
+  let msg =  "truncate: negative" in
+  try 
+    Buffer.truncate buf (-1);
+    failed msg
+  with
+    Invalid_argument "Buffer.truncate" ->
+      passed msg
+;;
+
+let truncate_large : unit =
+  let msg = "truncate: large" in
+  try
+    Buffer.truncate buf (n+1);
+    failed msg
+  with
+    Invalid_argument "Buffer.truncate" ->
+      passed msg
+;;
+
+let truncate_correct : unit =
+  let n' = n - 1 
+  and msg =  "truncate: in-range" in
+  try
+    Buffer.truncate buf n';
+    if Buffer.length buf = n' then
+      passed msg
+    else
+      failed msg
+  with
+    Invalid_argument "Buffer.truncate" ->
+      failed msg
+;;
+
+let reset_non_zero : unit =
+  let msg = "reset: non-zero" in
+  Buffer.reset buf;
+  if Buffer.length buf = 0 then
+    passed msg
+  else
+    failed msg
+;;
+
+let reset_zero : unit =
+  let msg = "reset: zero" in
+  Buffer.reset buf;
+  if Buffer.length buf = 0 then
+    passed msg
+  else
+    failed msg
+;;
diff --git a/testsuite/tests/lib-buffer/test.reference b/testsuite/tests/lib-buffer/test.reference
new file mode 100644
index 00000000..3e63c335
--- /dev/null
+++ b/testsuite/tests/lib-buffer/test.reference
@@ -0,0 +1,6 @@
+Standard Library: Module Buffer
+Buffer truncate: negative passed
+Buffer truncate: large passed
+Buffer truncate: in-range passed
+Buffer reset: non-zero passed
+Buffer reset: zero passed
diff --git a/testsuite/tests/lib-bytes/Makefile b/testsuite/tests/lib-bytes/Makefile
new file mode 100644
index 00000000..77b26912
--- /dev/null
+++ b/testsuite/tests/lib-bytes/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=testing
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-bytes/test_bytes.ml b/testsuite/tests/lib-bytes/test_bytes.ml
new file mode 100644
index 00000000..49725a5b
--- /dev/null
+++ b/testsuite/tests/lib-bytes/test_bytes.ml
@@ -0,0 +1,122 @@
+let test_raises_invalid_argument f x =
+  ignore
+    (Testing.test_raises_exc_p (function Invalid_argument _ -> true | _ -> false)
+         f x)
+
+let check b offset s =
+  let rec loop i =
+    i = String.length s ||
+    Bytes.get b (i + offset) = String.get s i && loop (i+1)
+  in
+  loop 0
+
+let () =
+  let abcde = Bytes.of_string "abcde" in
+  let open Bytes in
+  begin
+    (*
+           abcde
+    ?????     
+    *)
+    Testing.test
+      (length (extend abcde 7 (-7)) = 5); 
+
+    (*
+    abcde
+           ?????
+    *)
+    Testing.test
+      (length (extend abcde (-7) 7) = 5);
+
+    (*
+      abcde
+      abcde
+    *)
+    Testing.test
+      (let r = extend abcde 0 0 in
+       length r = 5 && check r 0 "abcde"
+       && r != abcde);
+
+    (*
+      abcde
+    ??abc
+    *)
+    Testing.test
+      (let r = extend abcde 2 (-2) in
+       length r = 5 && check r 2 "abc");
+
+    (*
+      abcde
+       bcd
+    *)
+    Testing.test
+      (let r = extend abcde (-1) (-1) in
+       length r = 3 && check r 0 "bcd");
+
+    (*
+      abcde
+         de??
+    *)
+    Testing.test
+      (let r = extend abcde (-3) 2 in
+       length r = 4 && check r 0 "de");
+
+    (*
+      abcde
+      abc
+    *)
+    Testing.test
+      (let r = extend abcde 0 (-2) in
+       length r = 3 && check r 0 "abc");
+
+    (*
+      abcde
+        cde
+    *)
+    Testing.test
+      (let r = extend abcde (-2) 0 in
+       length r = 3 && check r 0 "cde");
+
+    (*
+      abcde
+      abcde??
+    *)
+    Testing.test
+      (let r = extend abcde 0 2 in
+       length r = 7
+       && check r 0 "abcde");
+
+    (*
+        abcde
+      ??abcde
+    *)
+    Testing.test
+      (let r = extend abcde 2 0 in
+       length r = 7
+       && check r 2 "abcde");
+
+    (*
+       abcde
+      ?abcde?
+    *)
+    Testing.test
+      (let r = extend abcde 1 1 in
+       length r = 7
+       && check r 1 "abcde");
+
+    (* length + left + right < 0 *)
+    test_raises_invalid_argument
+      (fun () -> extend abcde (-3) (-3)) ();
+
+    (* length + left > max_int *)
+    test_raises_invalid_argument
+      (fun () -> extend abcde max_int 0) ();
+
+    (* length + right > max_int *)
+    test_raises_invalid_argument
+      (fun () -> extend abcde 0 max_int) ();
+
+    (* length + left + right > max_int *)
+    test_raises_invalid_argument
+      (fun () -> extend abcde max_int max_int) ();
+  end
diff --git a/testsuite/tests/lib-bytes/test_bytes.reference b/testsuite/tests/lib-bytes/test_bytes.reference
new file mode 100644
index 00000000..d2a3171e
--- /dev/null
+++ b/testsuite/tests/lib-bytes/test_bytes.reference
@@ -0,0 +1,2 @@
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+All tests succeeded.
diff --git a/testsuite/tests/lib-digest/Makefile b/testsuite/tests/lib-digest/Makefile
new file mode 100644
index 00000000..8d045d4e
--- /dev/null
+++ b/testsuite/tests/lib-digest/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=md5
+ADD_COMPFLAGS=-w a
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml
new file mode 100644
index 00000000..1b61d152
--- /dev/null
+++ b/testsuite/tests/lib-digest/md5.ml
@@ -0,0 +1,230 @@
+(* Test int32 arithmetic and optimizations using the MD5 algorithm *)
+
+open Printf
+
+type context =
+  { buf: bytes;
+    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 (Bytes.get s (j+3) |> Char.code)) 24)
+        (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+2) |> Char.code)) 16)
+          (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+1) |> Char.code)) 8)
+                       (Int32.of_int (Bytes.get s j |> Char.code))))
+  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 = Bytes.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 *)
+      Bytes.blit_string 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 Bytes.blit_string 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.init 64 (function 0 -> '\x80' | _ -> '\000') in
+  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 = Bytes.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;
+  Bytes.unsafe_to_string res
+
+let test hex 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 && Digest.to_hex exp = hex in
+  if not ok then
+    Printf.printf "Failure for %S : %S %S %S %S\n" s res exp
+                  (Digest.to_hex exp) hex;
+  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 "d41d8cd98f00b204e9800998ecf8427e" ""
+  && test "0cc175b9c0f1b6a831c399e269772661" "a"
+  && test "900150983cd24fb0d6963f7d28e17f72" "abc"
+  && test "8215ef0796a20bcaaae116d3876c664a"
+          "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+  && test "7707d6ae4e027c70eea2a935c2296f21" (String.make 1_000_000 'a')
+  && test "f96b697d7cb7938d525a2f31aaf161d0" "message digest"
+  && test "d174ab98d277d9f5a5611c2c9f419d9f"
+          "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+  && test "9e107d9d372bb6826bd81d3542a419d6"
+          "The quick brown fox jumps over the lazy dog"
+  && test "e4d909c290d0fb1ca068ffaddf22cbd0"
+          "The quick brown fox jumps over the lazy dog."
+  then printf "Test vectors passed.\n";
+  flush stdout;
+  (* Benchmark *)
+  if (Array.length Sys.argv) > 1 && (Sys.argv.(1) = "-benchmark") then begin
+    let s = String.make 50000 'a' in
+    let num_iter = 1000 in
+    time "OCaml 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))
+  end
diff --git a/testsuite/tests/lib-digest/md5.reference b/testsuite/tests/lib-digest/md5.reference
new file mode 100644
index 00000000..956ac654
--- /dev/null
+++ b/testsuite/tests/lib-digest/md5.reference
@@ -0,0 +1 @@
+Test vectors passed.
diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile
new file mode 100644
index 00000000..1e56b168
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/Makefile
@@ -0,0 +1,73 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/dynlink
+LD_PATH=.:$(TOPDIR)/otherlibs/dynlink
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) compile run; \
+	fi
+
+.PHONY: compile
+compile:
+	@$(OCAMLC) -c registry.ml
+	@for file in stub*.c; do \
+	  $(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun -c $$file; \
+	  $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' -e 's/\.c//'` \
+	                `basename $$file c`$(O); \
+	done
+	@for file in plug*.ml; do \
+	  $(OCAMLC) -c $$file; \
+	  $(OCAMLMKLIB) -o `basename $$file .ml` `basename $$file ml`cmo; \
+	done
+	@$(OCAMLC) -c main.ml
+	@rm -f main static custom custom.exe
+	@$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo
+	@$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma \
+	           -use-runtime $(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE)
+	@$(OCAMLC) -o custom$(EXE) -custom -linkall registry.cmo plug2.cma \
+	           plug1.cma -I .
+
+.PHONY: run
+run:
+	@printf " ... testing 'main'"
+	@$(OCAMLRUN) ./main plug1.cma plug2.cma >main.result
+	@$(DIFF) main.reference main.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+	@printf " ... testing 'static'"
+	@$(OCAMLRUN) ./static >static.result
+	@$(DIFF) static.reference static.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+	@printf " ... testing 'custom'"
+	@./custom$(EXE) >custom.result
+	@$(DIFF) custom.reference custom.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f main static custom custom.exe *.result marshal.data dllplug*.dll
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-bytecode/custom.reference b/testsuite/tests/lib-dynlink-bytecode/custom.reference
new file mode 100644
index 00000000..c9d2b575
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/custom.reference
@@ -0,0 +1,5 @@
+This is stub2, calling stub1:
+This is stub1!
+Ok!
+This is stub1!
+ABCDEF
diff --git a/testsuite/tests/lib-dynlink-bytecode/main.ml b/testsuite/tests/lib-dynlink-bytecode/main.ml
new file mode 100644
index 00000000..725ee80c
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/main.ml
@@ -0,0 +1,37 @@
+let f x = print_string "This is Main.f\n"; x
+
+let () = Registry.register f
+
+let _ =
+  Dynlink.init ();
+  Dynlink.allow_unsafe_modules true;
+  for i = 1 to Array.length Sys.argv - 1 do
+    let name = Sys.argv.(i) in
+    Printf.printf "Loading %s\n" name; flush stdout;
+    try
+      if name.[0] = '-'
+      then Dynlink.loadfile_private
+        (String.sub name 1 (String.length name - 1))
+      else Dynlink.loadfile name
+    with
+      | Dynlink.Error err ->
+          Printf.printf "Dynlink error: %s\n"
+            (Dynlink.error_message err)
+      | exn ->
+          Printf.printf "Error: %s\n" (Printexc.to_string exn)
+  done;
+  flush stdout;
+  try
+    let oc = open_out_bin "marshal.data" in
+    Marshal.to_channel oc (Registry.get_functions()) [Marshal.Closures];
+    close_out oc;
+    let ic = open_in_bin "marshal.data" in
+    let l = (Marshal.from_channel ic : (int -> int) list) in
+    close_in ic;
+    List.iter
+      (fun f ->
+        let res = f 0 in
+        Printf.printf "Result is: %d\n" res)
+      l
+  with Failure s ->
+    Printf.printf "Failure: %s\n" s
diff --git a/testsuite/tests/lib-dynlink-bytecode/main.reference b/testsuite/tests/lib-dynlink-bytecode/main.reference
new file mode 100644
index 00000000..577292f9
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/main.reference
@@ -0,0 +1,13 @@
+Loading plug1.cma
+This is stub1!
+ABCDEF
+Loading plug2.cma
+This is stub2, calling stub1:
+This is stub1!
+Ok!
+This is Plug2.f
+Result is: 2
+This is Plug1.f
+Result is: 1
+This is Main.f
+Result is: 0
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug1.ml b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
new file mode 100644
index 00000000..d0490689
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
@@ -0,0 +1,7 @@
+external stub1: unit -> string = "stub1"
+
+let f x = print_string "This is Plug1.f\n"; x + 1
+
+let () = Registry.register f
+
+let () = print_endline (stub1 ())
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug2.ml b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
new file mode 100644
index 00000000..350374e5
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
@@ -0,0 +1,7 @@
+external stub2: unit -> unit = "stub2"
+
+let f x = print_string "This is Plug2.f\n"; x + 2
+
+let () = Registry.register f
+
+let () = stub2 ()
diff --git a/testsuite/tests/lib-dynlink-bytecode/registry.ml b/testsuite/tests/lib-dynlink-bytecode/registry.ml
new file mode 100644
index 00000000..e0f76423
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/registry.ml
@@ -0,0 +1,7 @@
+let functions = ref ([]: (int -> int) list)
+
+let register f =
+  functions := f :: !functions
+
+let get_functions () =
+  !functions
diff --git a/testsuite/tests/lib-dynlink-bytecode/static.reference b/testsuite/tests/lib-dynlink-bytecode/static.reference
new file mode 100644
index 00000000..4faa129c
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/static.reference
@@ -0,0 +1,5 @@
+This is stub1!
+ABCDEF
+This is stub2, calling stub1:
+This is stub1!
+Ok!
diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c
new file mode 100644
index 00000000..2c66b28e
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c
@@ -0,0 +1,27 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                         Alain Frisch, LexiFi                           */
+/*                                                                        */
+/*   Copyright 2007 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/alloc.h"
+#include <stdio.h>
+
+value stub1(void) {
+  CAMLparam0();
+  CAMLlocal1(x);
+  printf("This is stub1!\n"); fflush(stdout);
+  x = caml_copy_string("ABCDEF");
+  CAMLreturn(x);
+}
diff --git a/testsuite/tests/lib-dynlink-bytecode/stub2.c b/testsuite/tests/lib-dynlink-bytecode/stub2.c
new file mode 100644
index 00000000..f4cd3a7e
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/stub2.c
@@ -0,0 +1,28 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                         Alain Frisch, LexiFi                           */
+/*                                                                        */
+/*   Copyright 2007 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/alloc.h"
+#include <stdio.h>
+
+extern value stub1(void);
+
+value stub2(void) {
+  printf("This is stub2, calling stub1:\n"); fflush(stdout);
+  stub1();
+  printf("Ok!\n"); fflush(stdout);
+  return Val_unit;
+}
diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
new file mode 100644
index 00000000..ae98ca0b
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -0,0 +1,122 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+# Only run this test for TOOLCHAIN=msvc
+CSC_COMMAND=$(filter csc,$(subst msvc,csc,$(TOOLCHAIN)))
+CSC=$(CSC_COMMAND) $(CSC_FLAGS)
+
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray -I $(OTOPDIR)/otherlibs/dynlink \
+          -I $(OTOPDIR)/byterun
+LD_PATH=$(TOPDIR)/otherlibs/bigarray:$(TOPDIR)/otherlibs/dynlink
+
+default:
+	@$(SET_LD_PATH) $(MAKE) all
+
+.PHONY: all
+all: prepare bytecode bytecode-dll native native-dll
+
+.PHONY: prepare
+prepare:
+	@if $(SUPPORTS_SHARED_LIBRARIES); then \
+	   $(OCAMLC) -c plugin.ml && \
+	   if $(BYTECODE_ONLY) ; then : ; else \
+	     $(OCAMLOPT) -o plugin.cmxs -shared plugin.ml; \
+	   fi; \
+	 fi
+
+.PHONY: bytecode
+bytecode:
+	@printf " ... testing 'bytecode':"
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC_COMMAND) >/dev/null 2>&1; \
+	then \
+	  echo " => skipped"; \
+	else \
+	  rm -f main.exe main.dll; \
+	  $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
+	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
+	  ./main.exe > bytecode.result; \
+	  $(DIFF) bytecode.reference bytecode.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	fi
+
+.PHONY: bytecode-dll
+bytecode-dll:
+	@printf " ... testing 'bytecode-dll':"
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC_COMMAND) > /dev/null 2>&1; \
+	then \
+	  echo " => skipped"; \
+	else \
+	  rm -f main.exe main_obj.$(O) main.dll; \
+	  $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \
+	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
+	           $(CTOPDIR)/byterun/libcamlrun.$(A)  $(BYTECCLIBS); \
+	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
+	  ./main.exe >bytecode-dll.result; \
+	  $(DIFF) bytecode.reference bytecode-dll.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	fi
+
+.PHONY: native
+native:
+	@printf " ... testing 'native':"
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) \
+	    || ! which $(CSC_COMMAND) > /dev/null 2>&1; then \
+	  echo " => skipped"; \
+	else \
+	  rm -f main.exe main.dll; \
+	  $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
+	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
+	  ./main.exe > native.result; \
+	  $(DIFF) native.reference native.result > /dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	fi
+
+.PHONY: native-dll
+native-dll:
+	@printf " ... testing 'native-dll':"
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) \
+	    || ! which $(CSC_COMMAND) > /dev/null 2>&1; then \
+	  echo " => skipped"; \
+	else \
+	  rm -f main.exe main_obj.$(O) main.dll; \
+	  $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c \
+	              main.ml; \
+	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
+		         $(CTOPDIR)/asmrun/libasmrun.lib $(NATIVECCLIBS); \
+	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
+	  ./main.exe > native-dll.result; \
+	  $(DIFF) native.reference native-dll.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	fi
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.exe *.dll *.so *.obj *.o
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+ifneq ($(FLEXLINK_PREFIX),)
+MKDLL=$(WINTOPDIR)/boot/ocamlrun $(WINTOPDIR)/flexdll/flexlink.exe $(FLEXLINK_FLAGS)
+endif
+
+ifeq ($(HOST),msvc)
+CSC_FLAGS=/platform:x86
+else
+CSC_FLAGS=
+endif
diff --git a/testsuite/tests/lib-dynlink-csharp/bytecode.reference b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
new file mode 100644
index 00000000..8be606c4
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
@@ -0,0 +1,6 @@
+Now starting the OCaml engine.
+Main is running.
+Loading ../../../otherlibs/bigarray/bigarray.cma
+Loading plugin.cmo
+I'm the plugin.
+OK.
diff --git a/testsuite/tests/lib-dynlink-csharp/entry.c b/testsuite/tests/lib-dynlink-csharp/entry.c
new file mode 100755
index 00000000..6116b6d4
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/entry.c
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                         Alain Frisch, LexiFi                           */
+/*                                                                        */
+/*   Copyright 2007 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/mlvalues.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+
+#if !defined(OPENSTEP) && (defined(_WIN32) && !defined(__CYGWIN__))
+#  if defined(_MSC_VER) || defined(__MINGW32__)
+#    define _DLLAPI __declspec(dllexport)
+#  else
+#    define _DLLAPI extern
+#  endif
+#  if defined(__MINGW32__) || defined(UNDER_CE)
+#    define _CALLPROC
+#  else
+#    define _CALLPROC __stdcall
+#  endif
+#elif defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__) >= 303
+#  define _DLLAPI __attribute__((visibility("default")))
+#  define _CALLPROC
+#endif /* WIN32 && !CYGWIN */
+
+_DLLAPI void _CALLPROC start_caml_engine() {
+  char * argv[2];
+  argv[0] = "--";
+  argv[1] = NULL;
+  caml_startup(argv);
+}
diff --git a/testsuite/tests/lib-dynlink-csharp/main.cs b/testsuite/tests/lib-dynlink-csharp/main.cs
new file mode 100755
index 00000000..5cbb8e86
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/main.cs
@@ -0,0 +1,11 @@
+using System.Runtime.InteropServices;
+
+public class M {
+  [DllImport("main.dll")]
+  public static extern void start_caml_engine();
+
+  public static void Main() {
+    System.Console.WriteLine("Now starting the OCaml engine.");
+    start_caml_engine();
+  }
+}
diff --git a/testsuite/tests/lib-dynlink-csharp/main.ml b/testsuite/tests/lib-dynlink-csharp/main.ml
new file mode 100755
index 00000000..d30c150e
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/main.ml
@@ -0,0 +1,23 @@
+let load s =
+  Printf.printf "Loading %s\n%!" s;
+  try
+    Dynlink.loadfile s
+  with Dynlink.Error e ->
+    print_endline (Dynlink.error_message e)
+
+let () =
+  ignore (Hashtbl.hash 42.0);
+  print_endline "Main is running.";
+  Dynlink.init ();
+  Dynlink.allow_unsafe_modules true;
+  let s1,s2 =
+    if Dynlink.is_native then
+      "../../../otherlibs/bigarray/bigarray.cmxs",
+      "plugin.cmxs"
+    else
+      "../../../otherlibs/bigarray/bigarray.cma",
+      "plugin.cmo"
+  in
+  load s1;
+  load s2;
+  print_endline "OK."
diff --git a/testsuite/tests/lib-dynlink-csharp/native.reference b/testsuite/tests/lib-dynlink-csharp/native.reference
new file mode 100644
index 00000000..ff18be96
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/native.reference
@@ -0,0 +1,6 @@
+Now starting the OCaml engine.
+Main is running.
+Loading ../../../otherlibs/bigarray/bigarray.cmxs
+Loading plugin.cmxs
+I'm the plugin.
+OK.
diff --git a/testsuite/tests/lib-dynlink-csharp/plugin.ml b/testsuite/tests/lib-dynlink-csharp/plugin.ml
new file mode 100755
index 00000000..aacf9f21
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-csharp/plugin.ml
@@ -0,0 +1,4 @@
+let f x = x.{2}
+
+let () =
+  print_endline "I'm the plugin."
diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile
new file mode 100644
index 00000000..13e1a4a9
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/Makefile
@@ -0,0 +1,128 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=$(shell pwd)/../..
+
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+	  -I $(OTOPDIR)/otherlibs/systhreads \
+          -I $(OTOPDIR)/otherlibs/dynlink
+LD_PATH = $(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/systhreads\
+:$(TOPDIR)/otherlibs/dynlink
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) ; then \
+	  echo " ... testing 'main' => skipped"; \
+	else \
+	   $(SET_LD_PATH) $(MAKE) all; \
+	fi
+
+.PHONY: all
+all: compile run
+
+PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so \
+        mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so \
+        plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so \
+        plugin_thread.so plugin4_unix.so a.so b.so c.so
+
+ADD_COMPFLAGS=-thread
+
+.PHONY: compile
+compile: $(PLUGINS) main$(EXE) mylib.so
+
+.PHONY: run
+run:
+	@printf " ... testing 'main'"
+	@./main$(EXE) plugin.so plugin2.so plugin_thread.so > result
+	@$(DIFF) reference result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+main$(EXE): api.cmx main.cmx
+	@$(OCAMLOPT) -thread -o main$(EXE) -linkall unix.cmxa threads.cmxa \
+	             dynlink.cmxa api.cmx main.cmx
+
+main_ext$(EXE): api.cmx main.cmx factorial.$(O)
+	@$(OCAMLOPT) -o main_ext$(EXE) dynlink.cmxa api.cmx main.cmx \
+	             factorial.$(O)
+
+sub/plugin3.cmx: sub/api.cmi sub/api.cmx sub/plugin3.ml
+	@cd sub; \
+	mv api.cmx api.cmx.bak; \
+	$(OCAMLOPT) -c plugin3.ml; \
+	mv api.cmx.bak api.cmx
+
+plugin2.cmx: api.cmx plugin.cmi plugin.cmx
+	@mv plugin.cmx plugin.cmx.bak;
+	@$(OCAMLOPT) -c plugin2.ml
+	@mv plugin.cmx.bak plugin.cmx
+
+sub/api.so: sub/api.cmi sub/api.ml
+	@cd sub; $(OCAMLOPT) -c $(SUPPORTS_SHARED_LIBRARIES) api.ml
+
+sub/api.cmi: sub/api.mli
+	@cd sub; $(OCAMLOPT) -c -opaque api.mli
+
+sub/api.cmx: sub/api.cmi sub/api.ml
+	@cd sub; $(OCAMLOPT) -c api.ml
+
+plugin.cmi: plugin.mli
+	@$(OCAMLOPT) -c -opaque plugin.mli
+
+plugin.cmx: api.cmx plugin.cmi
+sub/plugin.cmx: api.cmx
+plugin4.cmx: api.cmx
+main.cmx: api.cmx
+plugin_ext.cmx: api.cmx plugin_ext.ml
+	@$(OCAMLOPT) -c plugin_ext.ml
+
+plugin_ext.so: factorial.$(O) plugin_ext.cmx
+	@$(OCAMLOPT) -shared -o plugin_ext.so factorial.$(O) \
+	             plugin_ext.cmx
+
+plugin4_unix.so: plugin4.cmx
+	@$(OCAMLOPT) -shared -o plugin4_unix.so unix.cmxa plugin4.cmx
+
+packed1_client.cmx: packed1.cmx
+
+pack_client.cmx: mypack.cmx
+
+packed1.cmx: api.cmx packed1.ml
+	@$(OCAMLOPT) -c $(COMPFLAGS) -for-pack Mypack packed1.ml
+
+mypack.cmx: packed1.cmx
+	@$(OCAMLOPT) $(COMPFLAGS) -S -pack -o mypack.cmx packed1.cmx
+
+mylib.cmxa: plugin.cmx plugin2.cmx
+	@$(OCAMLOPT) $(COMPFLAGS) -a -o mylib.cmxa plugin.cmx plugin2.cmx
+
+factorial.$(O): factorial.c
+	@$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" -ccopt -I \
+	             -ccopt $(CTOPDIR)/byterun \
+	             factorial.c
+
+.PHONY: promote
+promote:
+	@cp result reference
+
+.PRECIOUS: %.cmx
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f result *.so *.o *.cm* main main_ext *.exe *.s *.asm *.obj
+	@rm -f *.a *.lib
+	@rm -f sub/*.so sub/*.o sub/*.cm* sub/*.s sub/*.asm sub/*.obj
+	@rm -f marshal.data
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-native/a.ml b/testsuite/tests/lib-dynlink-native/a.ml
new file mode 100755
index 00000000..b7915822
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/a.ml
@@ -0,0 +1,5 @@
+let x = ref 0
+let u = Random.int 1000
+
+let () =
+  Printf.printf "A is running (%i)\n%!" u
diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml
new file mode 100644
index 00000000..cd735abe
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/api.ml
@@ -0,0 +1,20 @@
+let mods = ref []
+
+let reg_mod name =
+  if List.mem name !mods then
+    Printf.printf "Reloading module %s\n" name
+  else (
+    mods := name :: !mods;
+    Printf.printf "Registering module %s\n" name
+  )
+
+
+let cbs = ref []
+
+let add_cb f = cbs := f :: !cbs
+let runall () = List.iter (fun f -> f ()) !cbs
+
+(*
+let () =
+  at_exit runall
+*)
diff --git a/testsuite/tests/lib-dynlink-native/b.ml b/testsuite/tests/lib-dynlink-native/b.ml
new file mode 100755
index 00000000..afa1bef0
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/b.ml
@@ -0,0 +1,4 @@
+let () =
+  print_endline "B is running";
+  incr A.x;
+  Printf.printf "A.x = %i\n" !A.x
diff --git a/testsuite/tests/lib-dynlink-native/bug.ml b/testsuite/tests/lib-dynlink-native/bug.ml
new file mode 100644
index 00000000..31c0f025
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/bug.ml
@@ -0,0 +1,2 @@
+let () = try raise (Invalid_argument "X") with Invalid_argument s ->
+  raise (Invalid_argument (s ^ s))
diff --git a/testsuite/tests/lib-dynlink-native/c.ml b/testsuite/tests/lib-dynlink-native/c.ml
new file mode 100755
index 00000000..d4de70f4
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/c.ml
@@ -0,0 +1,4 @@
+let () =
+  print_endline "C is running";
+  incr A.x;
+  Printf.printf "A.x = %i\n" !A.x
diff --git a/testsuite/tests/lib-dynlink-native/factorial.c b/testsuite/tests/lib-dynlink-native/factorial.c
new file mode 100644
index 00000000..8efc4aa5
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/factorial.c
@@ -0,0 +1,33 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                         Alain Frisch, LexiFi                           */
+/*                                                                        */
+/*   Copyright 2007 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/alloc.h"
+#include <stdio.h>
+
+value factorial(value n){
+  CAMLparam1(n);
+  CAMLlocal1(s);
+
+  static char buf[256];
+  int x = 1;
+  int i;
+  int m = Int_val(n);
+  for (i = 1; i <= m; i++) x *= i;
+  sprintf(buf,"%i",x);
+  s = copy_string(buf);
+  CAMLreturn (s);
+}
diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml
new file mode 100644
index 00000000..8c738aeb
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/main.ml
@@ -0,0 +1,32 @@
+let () =
+  Api.add_cb (fun () -> print_endline "Callback from main")
+
+let ()  =
+  Dynlink.init ();
+  Dynlink.allow_unsafe_modules true;
+  for i = 1 to Array.length Sys.argv - 1 do
+    let name = Sys.argv.(i) in
+    Printf.printf "Loading %s\n" name; flush stdout;
+    try
+      if name.[0] = '-'
+      then Dynlink.loadfile_private
+        (String.sub name 1 (String.length name - 1))
+      else Dynlink.loadfile name
+    with
+      | Dynlink.Error err ->
+          Printf.printf "Dynlink error: %s\n"
+            (Dynlink.error_message err)
+      | exn ->
+          Printf.printf "Error: %s\n" (Printexc.to_string exn)
+  done;
+  flush stdout;
+  try
+    let oc = open_out_bin "marshal.data" in
+    Marshal.to_channel oc !Api.cbs [Marshal.Closures];
+    close_out oc;
+    let ic = open_in_bin "marshal.data" in
+    let l = (Marshal.from_channel ic : (unit -> unit) list) in
+    close_in ic;
+    List.iter (fun f -> f()) l
+  with Failure s ->
+    Printf.printf "Failure: %s\n" s
diff --git a/testsuite/tests/lib-dynlink-native/pack_client.ml b/testsuite/tests/lib-dynlink-native/pack_client.ml
new file mode 100644
index 00000000..90229885
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/pack_client.ml
@@ -0,0 +1,2 @@
+let () =
+  print_endline Mypack.Packed1.mykey
diff --git a/testsuite/tests/lib-dynlink-native/packed1.ml b/testsuite/tests/lib-dynlink-native/packed1.ml
new file mode 100644
index 00000000..2ee83633
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/packed1.ml
@@ -0,0 +1,5 @@
+let () =
+  Api.reg_mod "Packed1"
+
+let bla = Sys.argv.(0) ^ "XXX"
+let mykey = Sys.argv.(0)
diff --git a/testsuite/tests/lib-dynlink-native/packed1_client.ml b/testsuite/tests/lib-dynlink-native/packed1_client.ml
new file mode 100644
index 00000000..c62534fd
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/packed1_client.ml
@@ -0,0 +1,3 @@
+let () =
+  Api.reg_mod "Packed1_client";
+  print_endline Packed1.mykey
diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml
new file mode 100644
index 00000000..d9b0574f
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin.ml
@@ -0,0 +1,11 @@
+let rec f x = ignore ([x]); f x
+
+let rec fact n = if n = 0 then 1 else n * fact (n - 1)
+
+let facts = [ fact 1; fact 2; fact 3; fact (Random.int 4) ]
+
+let () =
+  Api.reg_mod "Plugin";
+  Api.add_cb (fun () -> print_endline "Callback from plugin");
+  print_endline "COUCOU";
+  ()
diff --git a/testsuite/tests/lib-dynlink-native/plugin.mli b/testsuite/tests/lib-dynlink-native/plugin.mli
new file mode 100644
index 00000000..3e659d97
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin.mli
@@ -0,0 +1 @@
+val facts: int list
diff --git a/testsuite/tests/lib-dynlink-native/plugin2.ml b/testsuite/tests/lib-dynlink-native/plugin2.ml
new file mode 100644
index 00000000..109c129d
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin2.ml
@@ -0,0 +1,8 @@
+(*external ex: int -> int = "caml_ex"*)
+
+let () =
+  Api.reg_mod "Plugin2";
+  Api.add_cb (fun () -> print_endline "Callback from plugin2");
+(*  let i = ex 3 in*)
+  List.iter (fun i -> Printf.printf "%i\n" i) Plugin.facts;
+  Printf.printf "XXX\n"
diff --git a/testsuite/tests/lib-dynlink-native/plugin4.ml b/testsuite/tests/lib-dynlink-native/plugin4.ml
new file mode 100644
index 00000000..a9f86e60
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin4.ml
@@ -0,0 +1,3 @@
+let () =
+  Printf.printf "time = %f\n" (Unix.time ());
+  Api.reg_mod "Plugin"
diff --git a/testsuite/tests/lib-dynlink-native/plugin_ext.ml b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
new file mode 100644
index 00000000..9906769f
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
@@ -0,0 +1,5 @@
+external fact: int -> string = "factorial"
+
+let () =
+  Api.reg_mod "plugin_ext";
+  Printf.printf "fact 10 = %s\n" (fact 10)
diff --git a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
new file mode 100644
index 00000000..8c58aa15
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
@@ -0,0 +1,6 @@
+let f x x x x x x x x x x x x x = ()
+
+let g x = f x x x x x x x x
+
+let () =
+  Api.reg_mod "HA"
diff --git a/testsuite/tests/lib-dynlink-native/plugin_ref.ml b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
new file mode 100644
index 00000000..60f12735
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
@@ -0,0 +1,10 @@
+let x = ref 0
+
+let () =
+  Api.reg_mod "Plugin_ref";
+
+  Api.add_cb
+    (fun () ->
+       Printf.printf "current value for ref = %i\n" !x;
+       incr x
+    )
diff --git a/testsuite/tests/lib-dynlink-native/plugin_simple.ml b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
new file mode 100644
index 00000000..dd7d0226
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
@@ -0,0 +1,3 @@
+let facts = [ (Random.int 4) ]
+
+let () = print_endline "COUCOU"; print_char '\n'
diff --git a/testsuite/tests/lib-dynlink-native/plugin_thread.ml b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
new file mode 100644
index 00000000..6e3d9d48
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
@@ -0,0 +1,15 @@
+let () =
+  Api.reg_mod "Plugin_thread";
+  let _t =
+    Thread.create
+      (fun () ->
+         for i = 1 to 5 do
+           print_endline "Thread"; flush stdout;
+           Thread.delay 1.;
+         done
+      ) ()
+  in
+  for i = 1 to 10 do
+    print_endline "Thread"; flush stdout;
+    Thread.delay 0.50;
+  done
diff --git a/testsuite/tests/lib-dynlink-native/reference b/testsuite/tests/lib-dynlink-native/reference
new file mode 100644
index 00000000..e9e4ee45
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/reference
@@ -0,0 +1,30 @@
+Loading plugin.so
+Registering module Plugin
+COUCOU
+Loading plugin2.so
+Registering module Plugin2
+1
+2
+6
+1
+XXX
+Loading plugin_thread.so
+Registering module Plugin_thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Thread
+Callback from plugin2
+Callback from plugin
+Callback from main
diff --git a/testsuite/tests/lib-dynlink-native/sub/api.ml b/testsuite/tests/lib-dynlink-native/sub/api.ml
new file mode 100644
index 00000000..4a60586f
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/sub/api.ml
@@ -0,0 +1,3 @@
+let f i =
+  Printf.printf "Sub/api: f called with %i\n" i;
+  i + 1
diff --git a/testsuite/tests/lib-dynlink-native/sub/api.mli b/testsuite/tests/lib-dynlink-native/sub/api.mli
new file mode 100644
index 00000000..da5e52f2
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/sub/api.mli
@@ -0,0 +1 @@
+val f : int -> int
diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin.ml b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
new file mode 100644
index 00000000..d7faf9c8
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
@@ -0,0 +1,6 @@
+let rec fact n = if n = 0 then 1 else n * fact (n - 1)
+
+let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ]
+
+let () =
+  Api.reg_mod "Plugin'"
diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
new file mode 100644
index 00000000..82c9e486
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
@@ -0,0 +1,2 @@
+let () =
+  ignore (Api.f 10)
diff --git a/testsuite/tests/lib-filename/Makefile b/testsuite/tests/lib-filename/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-filename/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-filename/extension.ml b/testsuite/tests/lib-filename/extension.ml
new file mode 100755
index 00000000..917c0146
--- /dev/null
+++ b/testsuite/tests/lib-filename/extension.ml
@@ -0,0 +1,14 @@
+let () =
+  let test f e =
+    assert(Filename.extension f = e);
+    assert(Filename.extension ("foo/" ^ f) = e);
+    assert(f = Filename.remove_extension f ^ Filename.extension f)
+  in
+  test "" "";
+  test "foo" "";
+  test "foo.txt" ".txt";
+  test "foo.txt.gz" ".gz";
+  test ".foo" "";
+  test "." "";
+  test ".." "";
+  test "foo..txt" ".txt"
diff --git a/testsuite/tests/lib-filename/extension.reference b/testsuite/tests/lib-filename/extension.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-format/Makefile b/testsuite/tests/lib-format/Makefile
new file mode 100644
index 00000000..375d2e4c
--- /dev/null
+++ b/testsuite/tests/lib-format/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=testing
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-format/pr6824.ml b/testsuite/tests/lib-format/pr6824.ml
new file mode 100644
index 00000000..aa5e7eed
--- /dev/null
+++ b/testsuite/tests/lib-format/pr6824.ml
@@ -0,0 +1,7 @@
+let f = Format.sprintf "[%i]";;
+print_endline (f 1);;
+print_endline (f 2);;
+
+let f = Format.asprintf "[%i]";;
+print_endline (f 1);;
+print_endline (f 2);;
diff --git a/testsuite/tests/lib-format/pr6824.reference b/testsuite/tests/lib-format/pr6824.reference
new file mode 100644
index 00000000..69035c76
--- /dev/null
+++ b/testsuite/tests/lib-format/pr6824.reference
@@ -0,0 +1,6 @@
+[1]
+[2]
+[1]
+[2]
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-format/tformat.ml b/testsuite/tests/lib-format/tformat.ml
new file mode 100644
index 00000000..ee39a6a7
--- /dev/null
+++ b/testsuite/tests/lib-format/tformat.ml
@@ -0,0 +1,529 @@
+(*
+
+A test file for the Format module.
+
+*)
+
+open Testing;;
+open Format;;
+
+let say s = Printf.printf s;;
+
+try
+
+  say "d/i positive\n%!";
+  test (sprintf "%d/%i" 42 43 = "42/43");
+  test (sprintf "%-4d/%-5i" 42 43 = "42  /43   ");
+  test (sprintf "%04d/%05i" 42 43 = "0042/00043");
+  test (sprintf "%+d/%+i" 42 43 = "+42/+43");
+  test (sprintf "% d/% i" 42 43 = " 42/ 43");
+  test (sprintf "%#d/%#i" 42 43 = "42/43");
+  test (sprintf "%4d/%5i" 42 43 = "  42/   43");
+  test (sprintf "%*d" (-4) 42 = "42  ");
+  test (sprintf "%*d/%*i" 4 42 5 43 = "  42/   43");
+  test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43  ");
+
+  say "\nd/i negative\n%!";
+  test (sprintf "%d/%i" (-42) (-43) = "-42/-43");
+  test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43  ");
+  test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043");
+  test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43");
+  test (sprintf "% d/% i" (-42) (-43) = "-42/-43");
+  test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");
+  test (sprintf "%4d/%5i" (-42) (-43) = " -42/  -43");
+  test (sprintf "%*d" (-4) (-42) = "-42 ");
+  test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/  -43");
+  test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43  ");
+
+  say "\nu positive\n%!";
+  test (sprintf "%u" 42 = "42");
+  test (sprintf "%-4u" 42 = "42  ");
+  test (sprintf "%04u" 42 = "0042");
+  test (sprintf "%+u" 42 = "42");
+  test (sprintf "% u" 42 = "42");
+  test (sprintf "%#u" 42 = "42");
+  test (sprintf "%4u" 42 = "  42");
+  test (sprintf "%*u" 4 42 = "  42");
+  test (sprintf "%*u" (-4) 42 = "42  ");
+
+  say "\nu negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%u" (-1) = "2147483647");
+  | 64 ->
+     test (sprintf "%u" (-1) = "9223372036854775807");
+  | _ -> test false
+  end;
+
+  say "\nx positive\n%!";
+  test (sprintf "%x" 42 = "2a");
+  test (sprintf "%-4x" 42 = "2a  ");
+  test (sprintf "%04x" 42 = "002a");
+  test (sprintf "%+x" 42 = "2a");
+  test (sprintf "% x" 42 = "2a");
+  test (sprintf "%#x" 42 = "0x2a");
+  test (sprintf "%4x" 42 = "  2a");
+  test (sprintf "%*x" 5 42 = "   2a");
+  test (sprintf "%*x" (-5) 42 = "2a   ");
+  test (sprintf "%#*x" 5 42 = " 0x2a");
+  test (sprintf "%#*x" (-5) 42 = "0x2a ");
+  test (sprintf "%#-*x" 5 42 = "0x2a ");
+  test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
+
+  say "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%x" (-42) = "7fffffd6");
+  | 64 ->
+     test (sprintf "%x" (-42) = "7fffffffffffffd6");
+  | _ -> test false
+  end;
+
+  say "\nX positive\n%!";
+  test (sprintf "%X" 42 = "2A");
+  test (sprintf "%-4X" 42 = "2A  ");
+  test (sprintf "%04X" 42 = "002A");
+  test (sprintf "%+X" 42 = "2A");
+  test (sprintf "% X" 42 = "2A");
+  test (sprintf "%#X" 42 = "0X2A");
+  test (sprintf "%4X" 42 = "  2A");
+  test (sprintf "%*X" 5 42 = "   2A");
+  test (sprintf "%-0+ #*X" 5 42 = "0X2A ");
+
+  say "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%X" (-42) = "7FFFFFD6");
+  | 64 ->
+     test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6");
+  | _ -> test false
+  end;
+
+  say "\no positive\n%!";
+  test (sprintf "%o" 42 = "52");
+  test (sprintf "%-4o" 42 = "52  ");
+  test (sprintf "%04o" 42 = "0052");
+  test (sprintf "%+o" 42 = "52");
+  test (sprintf "% o" 42 = "52");
+  test (sprintf "%#o" 42 = "052");
+  test (sprintf "%4o" 42 = "  52");
+  test (sprintf "%*o" 5 42 = "   52");
+  test (sprintf "%-0+ #*o" 5 42 = "052  ");
+
+  say "\no negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%o" (-42) = "17777777726");
+  | 64 ->
+     test (sprintf "%o" (-42) = "777777777777777777726");
+  | _ -> test false
+  end;
+
+  say "\ns\n%!";
+  test (sprintf "%s" "foo" = "foo");
+  test (sprintf "%-5s" "foo" = "foo  ");
+  test (sprintf "%05s" "foo" = "  foo");
+  test (sprintf "%+s" "foo" = "foo");
+  test (sprintf "% s" "foo" = "foo");
+  test (sprintf "%#s" "foo" = "foo");
+  test (sprintf "%5s" "foo" = "  foo");
+  test (sprintf "%1s" "foo" = "foo");
+  test (sprintf "%*s" 6 "foo" = "   foo");
+  test (sprintf "%*s" (-6) "foo" = "foo   ");
+  test (sprintf "%*s" 2 "foo" = "foo");
+  test (sprintf "%-0+ #5s" "foo" = "foo  ");
+  test (sprintf "%s@@" "foo" = "foo@");
+  test (sprintf "%s@@inria.fr" "foo" = "foo@inria.fr");
+  test (sprintf "%s@@%s" "foo" "inria.fr" = "foo@inria.fr");
+
+  say "\nS\n%!";
+  test (sprintf "%S" "fo\"o" = "\"fo\\\"o\"");
+  test (sprintf "%-7S" "foo" = "\"foo\"  ");
+(*  test (sprintf "%07S" "foo" = "  \"foo\""); *)
+  (* %S is incompatible with '0' *)
+  test (sprintf "%+S" "foo" = "\"foo\"");
+  test (sprintf "% S" "foo" = "\"foo\"");
+  test (sprintf "%#S" "foo" = "\"foo\"");
+  test (sprintf "%7S" "foo" = "  \"foo\"");
+  test (sprintf "%1S" "foo" = "\"foo\"");
+  test (sprintf "%*S" 8 "foo" = "   \"foo\"");
+  test (sprintf "%*S" (-8) "foo" = "\"foo\"   ");
+  test (sprintf "%*S" 2 "foo" = "\"foo\"");
+(*  test (sprintf "%-0+ #5S" "foo" = "\"foo\"  ");  padding not done *)
+  (* %S is incompatible with '0','+' and ' ' *)
+  test (sprintf "%S@@" "foo" = "\"foo\"@");
+  test (sprintf "%S@@inria.fr" "foo" = "\"foo\"@inria.fr");
+  test (sprintf "%S@@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\"");
+
+  say "\nc\n%!";
+  test (sprintf "%c" 'c' = "c");
+(*  test (sprintf "%-4c" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04c" 'c' = "   c");    padding not done *)
+  test (sprintf "%+c" 'c' = "c");
+  test (sprintf "% c" 'c' = "c");
+  test (sprintf "%#c" 'c' = "c");
+(*  test (sprintf "%4c" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*c" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4c" 'c' = "c   ");  padding not done *)
+
+  say "\nC\n%!";
+  test (sprintf "%C" 'c' = "'c'");
+  test (sprintf "%C" '\'' = "'\\''");
+(*  test (sprintf "%-4C" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04C" 'c' = "   c");    padding not done *)
+  test (sprintf "%+C" 'c' = "'c'");
+  test (sprintf "% C" 'c' = "'c'");
+  test (sprintf "%#C" 'c' = "'c'");
+(*  test (sprintf "%4C" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*C" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4C" 'c' = "c   ");  padding not done *)
+
+  say "\nf\n%!";
+  test (sprintf "%f" (-42.42) = "-42.420000");
+  test (sprintf "%-13f" (-42.42) = "-42.420000   ");
+  test (sprintf "%013f" (-42.42) = "-00042.420000");
+  test (sprintf "%+f" 42.42 = "+42.420000");
+  test (sprintf "% f" 42.42 = " 42.420000");
+  test (sprintf "%#f" 42.42 = "42.420000");
+  test (sprintf "%13f" 42.42 = "    42.420000");
+  test (sprintf "%*f" 12 42.42 = "   42.420000");
+  test (sprintf "%-0+ #12f" 42.42 = "+42.420000  ");
+  test (sprintf "%.3f" (-42.42) = "-42.420");
+  test (sprintf "%-13.3f" (-42.42) = "-42.420      ");
+  test (sprintf "%013.3f" (-42.42) = "-00000042.420");
+  test (sprintf "%+.3f" 42.42 = "+42.420");
+  test (sprintf "% .3f" 42.42 = " 42.420");
+  test (sprintf "%#.3f" 42.42 = "42.420");
+  test (sprintf "%13.3f" 42.42 = "       42.420");
+  test (sprintf "%*.*f" 12 3 42.42 = "      42.420");
+  test (sprintf "%-0+ #12.3f" 42.42 = "+42.420     ");
+
+  (* Under Windows (mingw and maybe also MSVC), the stdlib uses three
+     digits for the exponent instead of the two used by Linux and BSD.
+     Check that the two strings are equal, except that there may be an
+     extra zero, and if there is one, there may be a missing space or
+     zero. All in the first string relative to the second. *)
+  let ( =* ) s1 s2 =
+    let ss1 = s1 ^ "$" in
+    let ss2 = s2 ^ "$" in
+    let rec loop i1 i2 extra missing =
+      if i1 = String.length ss1 && i2 = String.length ss2 then begin
+        if extra then true else not missing
+      end else if i1 = String.length ss1 || i2 = String.length ss2 then
+        false
+      else begin
+        match ss1.[i1], ss2.[i2] with
+        | x, y when x = y -> loop (i1+1) (i2+1) extra missing
+        | '0', _ when not extra -> loop (i1+1) i2 true missing
+        | _, (' '|'0') when not missing -> loop i1 (i2+1) extra true
+        | _, _ -> false
+      end
+    in
+    loop 0 0 false false
+  in
+
+  say "\nF\n%!";
+  test (sprintf "%F" 42.42 = "42.42");
+  test (sprintf "%F" 42.42e42 =* "4.242e+43");
+  test (sprintf "%F" 42.00 = "42.");
+  test (sprintf "%F" 0.042 = "0.042");
+  test (sprintf "%4F" 3. = "  3.");
+  test (sprintf "%-4F" 3. = "3.  ");
+  test (sprintf "%04F" 3. = "003.");
+(* plus-padding unsupported
+  test (sprintf "%+4F" 3. = " +3.");
+*)
+(* no precision
+  test (sprintf "%.3F" 42.42 = "42.420");
+  test (sprintf "%12.3F" 42.42e42 = "   4.242e+43");
+  test (sprintf "%.3F" 42.00 = "42.000");
+  test (sprintf "%.3F" 0.0042 = "0.004");
+*)
+
+  say "\nh\n%!";
+  test (sprintf "%+h" (+0.) = "+0x0p+0");
+  test (sprintf "%+h" (-0.) = "-0x0p+0");
+  test (sprintf "%+h" (+1.) = "+0x1p+0");
+  test (sprintf "%+h" (-1.) = "-0x1p+0");
+  test (sprintf "%+h" (+1024.) = "+0x1p+10");
+  test (sprintf "%+h" (-1024.) = "-0x1p+10");
+  test (sprintf "%h" 0x123.456 = "0x1.23456p+8");
+  test (sprintf "%h" 0x123456789ABCDE. = "0x1.23456789abcdep+52");
+  test (sprintf "%h" epsilon_float = "0x1p-52");
+  test (sprintf "%h" nan = "nan");
+  test (sprintf "%h" infinity = "infinity");
+  test (sprintf "%h" neg_infinity = "-infinity");
+  test (sprintf "%h" (4. *. atan 1.) = "0x1.921fb54442d18p+1");
+
+  say "\nH\n%!";
+  test (sprintf "%+H" (+0.) = "+0X0P+0");
+  test (sprintf "%+H" (-0.) = "-0X0P+0");
+  test (sprintf "%+H" (+1.) = "+0X1P+0");
+  test (sprintf "%+H" (-1.) = "-0X1P+0");
+  test (sprintf "%+H" (+1024.) = "+0X1P+10");
+  test (sprintf "%+H" (-1024.) = "-0X1P+10");
+  test (sprintf "%H" 0X123.456 = "0X1.23456P+8");
+  test (sprintf "%H" 0X123456789ABCDE. = "0X1.23456789ABCDEP+52");
+  test (sprintf "%H" epsilon_float = "0X1P-52");
+  test (sprintf "%H" nan = "NAN");
+  test (sprintf "%H" infinity = "INFINITY");
+  test (sprintf "%H" neg_infinity = "-INFINITY");
+  test (sprintf "%H" (4. *. atan 1.) = "0X1.921FB54442D18P+1");
+
+  say "\ne\n%!";
+  test (sprintf "%e" (-42.42) =* "-4.242000e+01");
+  test (sprintf "%-15e" (-42.42) =* "-4.242000e+01  ");
+  test (sprintf "%015e" (-42.42) =* "-004.242000e+01");
+  test (sprintf "%+e" 42.42 =* "+4.242000e+01");
+  test (sprintf "% e" 42.42 =* " 4.242000e+01");
+  test (sprintf "%#e" 42.42 =* "4.242000e+01");
+  test (sprintf "%15e" 42.42 =* "   4.242000e+01");
+  test (sprintf "%*e" 14 42.42 =* "  4.242000e+01");
+  test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");
+  test (sprintf "%.3e" (-42.42) =* "-4.242e+01");
+  test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01     ");
+  test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01");
+  test (sprintf "%+.3e" 42.42 =* "+4.242e+01");
+  test (sprintf "% .3e" 42.42 =* " 4.242e+01");
+  test (sprintf "%#.3e" 42.42 =* "4.242e+01");
+  test (sprintf "%15.3e" 42.42 =* "      4.242e+01");
+  test (sprintf "%*.*e" 11 3 42.42 =* "  4.242e+01");
+  test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01    ");
+
+  say "\nE\n%!";
+  test (sprintf "%E" (-42.42) =* "-4.242000E+01");
+  test (sprintf "%-15E" (-42.42) =* "-4.242000E+01  ");
+  test (sprintf "%015E" (-42.42) =* "-004.242000E+01");
+  test (sprintf "%+E" 42.42 =* "+4.242000E+01");
+  test (sprintf "% E" 42.42 =* " 4.242000E+01");
+  test (sprintf "%#E" 42.42 =* "4.242000E+01");
+  test (sprintf "%15E" 42.42 =* "   4.242000E+01");
+  test (sprintf "%*E" 14 42.42 =* "  4.242000E+01");
+  test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");
+  test (sprintf "%.3E" (-42.42) =* "-4.242E+01");
+  test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01     ");
+  test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01");
+  test (sprintf "%+.3E" 42.42 =* "+4.242E+01");
+  test (sprintf "% .3E" 42.42 =* " 4.242E+01");
+  test (sprintf "%#.3E" 42.42 =* "4.242E+01");
+  test (sprintf "%15.3E" 42.42 =* "      4.242E+01");
+  test (sprintf "%*.*E" 11 3 42.42 =* "  4.242E+01");
+  test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01    ");
+
+(* %g gives strange results that correspond to neither %f nor %e
+  say "\ng\n%!";
+  test (sprintf "%g" (-42.42) = "-42.42000");
+  test (sprintf "%-15g" (-42.42) = "-42.42000      ");
+  test (sprintf "%015g" (-42.42) = "-00000042.42000");
+  test (sprintf "%+g" 42.42 = "+42.42000");
+  test (sprintf "% g" 42.42 = " 42.42000");
+  test (sprintf "%#g" 42.42 = "42.42000");
+  test (sprintf "%15g" 42.42 = "       42.42000");
+  test (sprintf "%*g" 14 42.42 = "      42.42000");
+  test (sprintf "%-0+ #14g" 42.42 = "+42.42000     ");
+  test (sprintf "%.3g" (-42.42) = "-42.420");
+*)
+
+(* Same for %G
+  say "\nG\n%!";
+*)
+
+  say "\nB\n%!";
+  test (sprintf "%B" true = "true");
+  test (sprintf "%B" false = "false");
+ (* test (sprintf "%8B" false = "   false"); *)
+  (* padding not done *)
+
+  say "\nld/li positive\n%!";
+  test (sprintf "%ld/%li" 42l 43l = "42/43");
+  test (sprintf "%-4ld/%-5li" 42l 43l = "42  /43   ");
+  test (sprintf "%04ld/%05li" 42l 43l = "0042/00043");
+  test (sprintf "%+ld/%+li" 42l 43l = "+42/+43");
+  test (sprintf "% ld/% li" 42l 43l = " 42/ 43");
+  test (sprintf "%#ld/%#li" 42l 43l = "42/43");
+  test (sprintf "%4ld/%5li" 42l 43l = "  42/   43");
+  test (sprintf "%*ld/%*li" 4 42l 5 43l = "  42/   43");
+  test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43  ");
+
+  say "\nld/li negative\n%!";
+  test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43  ");
+  test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043");
+  test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/  -43");
+  test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/  -43");
+  test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43  ");
+
+  say "\nlu positive\n%!";
+  test (sprintf "%lu" 42l = "42");
+  test (sprintf "%-4lu" 42l = "42  ");
+  test (sprintf "%04lu" 42l = "0042");
+  test (sprintf "%+lu" 42l = "42");
+  test (sprintf "% lu" 42l = "42");
+  test (sprintf "%#lu" 42l = "42");
+  test (sprintf "%4lu" 42l = "  42");
+  test (sprintf "%*lu" 4 42l = "  42");
+  test (sprintf "%-0+ #6ld" 42l = "+42   ");
+
+  say "\nlu negative\n%!";
+  test (sprintf "%lu" (-1l) = "4294967295");
+
+  say "\nlx positive\n%!";
+  test (sprintf "%lx" 42l = "2a");
+  test (sprintf "%-4lx" 42l = "2a  ");
+  test (sprintf "%04lx" 42l = "002a");
+  test (sprintf "%+lx" 42l = "2a");
+  test (sprintf "% lx" 42l = "2a");
+  test (sprintf "%#lx" 42l = "0x2a");
+  test (sprintf "%4lx" 42l = "  2a");
+  test (sprintf "%*lx" 5 42l = "   2a");
+  test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");
+
+  say "\nlx negative\n%!";
+  test (sprintf "%lx" (-42l) = "ffffffd6");
+
+  say "\nlX positive\n%!";
+  test (sprintf "%lX" 42l = "2A");
+  test (sprintf "%-4lX" 42l = "2A  ");
+  test (sprintf "%04lX" 42l = "002A");
+  test (sprintf "%+lX" 42l = "2A");
+  test (sprintf "% lX" 42l = "2A");
+  test (sprintf "%#lX" 42l = "0X2A");
+  test (sprintf "%4lX" 42l = "  2A");
+  test (sprintf "%*lX" 5 42l = "   2A");
+  test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");
+
+  say "\nlx negative\n%!";
+  test (sprintf "%lX" (-42l) = "FFFFFFD6");
+
+  say "\nlo positive\n%!";
+  test (sprintf "%lo" 42l = "52");
+  test (sprintf "%-4lo" 42l = "52  ");
+  test (sprintf "%04lo" 42l = "0052");
+  test (sprintf "%+lo" 42l = "52");
+  test (sprintf "% lo" 42l = "52");
+  test (sprintf "%#lo" 42l = "052");
+  test (sprintf "%4lo" 42l = "  52");
+  test (sprintf "%*lo" 5 42l = "   52");
+  test (sprintf "%-0+ #*lo" 5 42l = "052  ");
+
+  say "\nlo negative\n%!";
+  test (sprintf "%lo" (-42l) = "37777777726");
+
+  (* Nativeint not tested: looks like too much work, and anyway it should
+     work like Int32 or Int64. *)
+
+  say "\nLd/Li positive\n%!";
+  test (sprintf "%Ld/%Li" 42L 43L = "42/43");
+  test (sprintf "%-4Ld/%-5Li" 42L 43L = "42  /43   ");
+  test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043");
+  test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");
+  test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");
+  test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");
+  test (sprintf "%4Ld/%5Li" 42L 43L = "  42/   43");
+  test (sprintf "%*Ld/%*Li" 4 42L 5 43L = "  42/   43");
+  test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43  ");
+
+  say "\nLd/Li negative\n%!";
+  test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43  ");
+  test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043");
+  test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/  -43");
+  test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/  -43");
+  test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43  ");
+
+  say "\nLu positive\n%!";
+  test (sprintf "%Lu" 42L = "42");
+  test (sprintf "%-4Lu" 42L = "42  ");
+  test (sprintf "%04Lu" 42L = "0042");
+  test (sprintf "%+Lu" 42L = "42");
+  test (sprintf "% Lu" 42L = "42");
+  test (sprintf "%#Lu" 42L = "42");
+  test (sprintf "%4Lu" 42L = "  42");
+  test (sprintf "%*Lu" 4 42L = "  42");
+  test (sprintf "%-0+ #6Ld" 42L = "+42   ");
+
+  say "\nLu negative\n%!";
+  test (sprintf "%Lu" (-1L) = "18446744073709551615");
+
+  say "\nLx positive\n%!";
+  test (sprintf "%Lx" 42L = "2a");
+  test (sprintf "%-4Lx" 42L = "2a  ");
+  test (sprintf "%04Lx" 42L = "002a");
+  test (sprintf "%+Lx" 42L = "2a");
+  test (sprintf "% Lx" 42L = "2a");
+  test (sprintf "%#Lx" 42L = "0x2a");
+  test (sprintf "%4Lx" 42L = "  2a");
+  test (sprintf "%*Lx" 5 42L = "   2a");
+  test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");
+
+  say "\nLx negative\n%!";
+  test (sprintf "%Lx" (-42L) = "ffffffffffffffd6");
+
+  say "\nLX positive\n%!";
+  test (sprintf "%LX" 42L = "2A");
+  test (sprintf "%-4LX" 42L = "2A  ");
+  test (sprintf "%04LX" 42L = "002A");
+  test (sprintf "%+LX" 42L = "2A");
+  test (sprintf "% LX" 42L = "2A");
+  test (sprintf "%#LX" 42L = "0X2A");
+  test (sprintf "%4LX" 42L = "  2A");
+  test (sprintf "%*LX" 5 42L = "   2A");
+  test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");
+
+  say "\nLx negative\n%!";
+  test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6");
+
+  say "\nLo positive\n%!";
+  test (sprintf "%Lo" 42L = "52");
+  test (sprintf "%-4Lo" 42L = "52  ");
+  test (sprintf "%04Lo" 42L = "0052");
+  test (sprintf "%+Lo" 42L = "52");
+  test (sprintf "% Lo" 42L = "52");
+  test (sprintf "%#Lo" 42L = "052");
+  test (sprintf "%4Lo" 42L = "  52");
+  test (sprintf "%*Lo" 5 42L = "   52");
+  test (sprintf "%-0+ #*Lo" 5 42L = "052  ");
+
+  say "\nLo negative\n%!";
+  test (sprintf "%Lo" (-42L) = "1777777777777777777726");
+
+  say "\na\n%!";
+  let x = ref () in
+  let f () y = if y == x then "ok" else "wrong" in
+  test (sprintf "%a" f x = "ok");
+
+  say "\nt\n%!";
+  let f () = "ok" in
+  test (sprintf "%t" f = "ok");
+
+(* %{ fmt %} prints the signature of [fmt], i.e. a canonical representation
+   of the conversions present in [fmt].
+*)
+  say "\n{...%%}\n%!";
+  let f = format_of_string "%f/%s" in
+  test (sprintf "%{%f%s%}" f = "%f%s");
+
+  say "\n(...%%)\n%!";
+  let f = format_of_string "%d/foo/%s" in
+  test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar");
+
+  say "\n! %% @ , and constants\n%!";
+  test (sprintf "%!" = "");
+  test (sprintf "%%" = "%");
+  test (sprintf "%@" = "@");
+  test (sprintf "%," = "");
+  test (sprintf "@@" = "@");
+  test (sprintf "@@@@" = "@@");
+  test (sprintf "@@%%" = "@%");
+  say "\nend of tests\n%!";
+
+with e ->
+  say "unexpected exception: %s\n%!" (Printexc.to_string e);
+  test false;
+;;
diff --git a/testsuite/tests/lib-format/tformat.reference b/testsuite/tests/lib-format/tformat.reference
new file mode 100644
index 00000000..461fe9da
--- /dev/null
+++ b/testsuite/tests/lib-format/tformat.reference
@@ -0,0 +1,95 @@
+d/i positive
+ 0 1 2 3 4 5 6 7 8 9
+d/i negative
+ 10 11 12 13 14 15 16 17 18 19
+u positive
+ 20 21 22 23 24 25 26 27 28
+u negative
+ 29
+x positive
+ 30 31 32 33 34 35 36 37 38 39 40 41 42
+x negative
+ 43
+X positive
+ 44 45 46 47 48 49 50 51 52
+x negative
+ 53
+o positive
+ 54 55 56 57 58 59 60 61 62
+o negative
+ 63
+s
+ 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
+S
+ 79 80 81 82 83 84 85 86 87 88 89 90 91
+c
+ 92 93 94 95
+C
+ 96 97 98 99 100
+f
+ 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
+F
+ 119 120 121 122 123 124 125
+h
+ 126 127 128 129 130 131 132 133 134 135 136 137 138
+H
+ 139 140 141 142 143 144 145 146 147 148 149 150 151
+e
+ 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
+E
+ 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
+B
+ 188 189
+ld/li positive
+ 190 191 192 193 194 195 196 197 198
+ld/li negative
+ 199 200 201 202 203 204 205 206 207
+lu positive
+ 208 209 210 211 212 213 214 215 216
+lu negative
+ 217
+lx positive
+ 218 219 220 221 222 223 224 225 226
+lx negative
+ 227
+lX positive
+ 228 229 230 231 232 233 234 235 236
+lx negative
+ 237
+lo positive
+ 238 239 240 241 242 243 244 245 246
+lo negative
+ 247
+Ld/Li positive
+ 248 249 250 251 252 253 254 255 256
+Ld/Li negative
+ 257 258 259 260 261 262 263 264 265
+Lu positive
+ 266 267 268 269 270 271 272 273 274
+Lu negative
+ 275
+Lx positive
+ 276 277 278 279 280 281 282 283 284
+Lx negative
+ 285
+LX positive
+ 286 287 288 289 290 291 292 293 294
+Lx negative
+ 295
+Lo positive
+ 296 297 298 299 300 301 302 303 304
+Lo negative
+ 305
+a
+ 306
+t
+ 307
+{...%}
+ 308
+(...%)
+ 309
+! % @ , and constants
+ 310 311 312 313 314 315 316
+end of tests
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-hashtbl/Makefile b/testsuite/tests/lib-hashtbl/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml
new file mode 100644
index 00000000..4fbb9cfe
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/hfun.ml
@@ -0,0 +1,42 @@
+(* Testing the hash function Hashtbl.hash *)
+(* What is tested:
+     - reproducibility on various platforms, esp. 32/64 bit issues
+     - equal values hash equally, esp NaNs. *)
+
+open Printf
+
+let _ =
+  printf "-- Strings:\n";
+  printf "\"\"\t\t%08x\n" (Hashtbl.hash "");
+  printf "\"Hello world\"\t%08x\n" (Hashtbl.hash "Hello world");
+
+  printf "-- Integers:\n";
+  printf "0\t\t%08x\n" (Hashtbl.hash 0);
+  printf "-1\t\t%08x\n" (Hashtbl.hash (-1));
+  printf "42\t\t%08x\n" (Hashtbl.hash 42);
+  printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFF);
+  printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000));
+
+  printf "-- Floats:\n";
+  printf "+0.0\t\t%08x\n" (Hashtbl.hash 0.0);
+  printf "-0.0\t\t%08x\n" (Hashtbl.hash (-. 0.0));
+  printf "+infty\t\t%08x\n" (Hashtbl.hash infinity);
+  printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity);
+  printf "NaN\t\t%08x\n" (Hashtbl.hash nan);
+  printf "NaN#2\t\t%08x\n"
+         (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL));
+  printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0));
+
+  printf "-- Native integers:\n";
+  printf "0\t\t%08x\n" (Hashtbl.hash 0n);
+  printf "-1\t\t%08x\n" (Hashtbl.hash (-1n));
+  printf "42\t\t%08x\n" (Hashtbl.hash 42n);
+  printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFFn);
+  printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000n));
+
+  printf "-- Lists:\n";
+  printf "[0..10]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10]);
+  printf "[0..12]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10;11;12]);
+  printf "[10..0]\t\t%08x\n" (Hashtbl.hash [10;9;8;7;6;5;4;3;2;1;0]);
+
+  ()
diff --git a/testsuite/tests/lib-hashtbl/hfun.reference b/testsuite/tests/lib-hashtbl/hfun.reference
new file mode 100644
index 00000000..2e92cf43
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/hfun.reference
@@ -0,0 +1,27 @@
+-- Strings:
+""		00000000
+"Hello world"	364b8272
+-- Integers:
+0		07be548a
+-1		3653e015
+42		1792870b
+2^30-1		23c392d0
+-2^30		0c66fde3
+-- Floats:
++0.0		0f478b8c
+-0.0		0f478b8c
++infty		23ea56fb
+-infty		059f7872
+NaN		3228858d
+NaN#2		3228858d
+NaN#3		3228858d
+-- Native integers:
+0		3f19274a
+-1		3653e015
+42		3e33aef8
+2^30-1		3711bf46
+-2^30		2e71f39c
+-- Lists:
+[0..10]		0ade0fc9
+[0..12]		0ade0fc9
+[10..0]		0cd6259d
diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml
new file mode 100644
index 00000000..0a8001f7
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/htbl.ml
@@ -0,0 +1,251 @@
+(* Hashtable operations, using maps as a reference *)
+
+open Printf
+
+module Test(H: Hashtbl.S) (M: Map.S with type key = H.key) = struct
+
+  let incl_mh m h =
+    try
+      M.iter
+        (fun k d ->
+          let d' = H.find h k in if d <> d' then raise Exit)
+        m;
+      true
+    with Exit | Not_found -> false
+
+  let domain_hm h m =
+    try
+      H.iter
+        (fun k d -> if not (M.mem k m) then raise Exit)
+        h;
+      true
+    with Exit -> false
+
+  let incl_hm h m =
+    try
+      H.iter
+        (fun k d ->
+           let d' = M.find k m in if d <> d' then raise Exit)
+        h;
+      true
+    with Exit | Not_found -> false
+
+  let test data =
+    let n = Array.length data in
+    let h = H.create 51 and m = ref M.empty in
+    (* Insert all data with H.add *)
+    Array.iter
+      (fun (k, d) -> H.add h k d; m := M.add k d !m)
+      data;
+    printf "Insertion: %s\n"
+           (if incl_mh !m h && domain_hm h !m then "passed" else "FAILED");
+    (* Insert all data with H.replace *)
+    H.clear h; m := M.empty;
+    Array.iter
+      (fun (k, d) -> H.replace h k d; m := M.add k d !m)
+      data;
+    printf "Insertion: %s\n"
+           (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED");
+    (* Remove some of the data *)
+    for i = 0 to n/3 - 1 do
+      let (k, _) = data.(i) in H.remove h k; m := M.remove k !m
+    done;
+    printf "Removal: %s\n"
+           (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED")
+
+end
+
+module SS = struct
+  type t = string
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SI = struct
+  type t = int
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SSP = struct
+  type t = string*string
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SSL = struct
+  type t = string list
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SSA = struct
+  type t = string array
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+
+module MS = Map.Make(SS)
+module MI = Map.Make(SI)
+module MSP = Map.Make(SSP)
+module MSL = Map.Make(SSL)
+module MSA = Map.Make(SSA)
+
+
+(* Generic hash wrapped as a functorial hash *)
+
+module HofM (M: Map.S) : Hashtbl.S with type key = M.key =
+  struct
+    type key = M.key
+    type 'a t = (key, 'a) Hashtbl.t
+    let create s = Hashtbl.create s
+    let clear = Hashtbl.clear
+    let reset = Hashtbl.reset
+    let copy = Hashtbl.copy
+    let add = Hashtbl.add
+    let remove = Hashtbl.remove
+    let find = Hashtbl.find
+    let find_opt = Hashtbl.find_opt
+    let find_all = Hashtbl.find_all
+    let replace = Hashtbl.replace
+    let mem = Hashtbl.mem
+    let iter = Hashtbl.iter
+    let fold = Hashtbl.fold
+    let length = Hashtbl.length
+    let stats = Hashtbl.stats
+    let filter_map_inplace = Hashtbl.filter_map_inplace
+  end
+
+module HS1 = HofM(MS)
+module HI1 = HofM(MI)
+module HSP = HofM(MSP)
+module HSL = HofM(MSL)
+
+(* Specific functorial hashes *)
+
+module HS2 = Hashtbl.Make(SS)
+module HI2 = Hashtbl.Make(SI)
+
+(* Specific weak functorial hashes *)
+module WS = Ephemeron.K1.Make(SS)
+module WSP1 = Ephemeron.K1.Make(SSP)
+module WSP2 = Ephemeron.K2.Make(SS)(SS)
+module WSL = Ephemeron.K1.Make(SSL)
+module WSA = Ephemeron.Kn.Make(SS)
+
+(* Instantiating the test *)
+
+module TS1 = Test(HS1)(MS)
+module TS2 = Test(HS2)(MS)
+module TI1 = Test(HI1)(MI)
+module TI2 = Test(HI2)(MI)
+module TSP = Test(HSP)(MSP)
+module TSL = Test(HSL)(MSL)
+module TWS  = Test(WS)(MS)
+module TWSP1 = Test(WSP1)(MSP)
+module TWSP2 = Test(WSP2)(MSP)
+module TWSL = Test(WSL)(MSL)
+module TWSA = Test(WSA)(MSA)
+
+(* Data set: strings from a file, associated with their line number *)
+
+let file_data filename =
+  let ic = open_in filename in
+  let lineno = ref 0 in
+  let data = ref [] in
+  begin try
+    while true do
+      let l = input_line ic in
+      incr lineno;
+      data := (l, !lineno) :: !data
+    done
+  with End_of_file -> ()
+  end;
+  close_in ic;
+  Array.of_list !data
+
+(* Data set: fixed strings *)
+
+let string_data = [|
+  "Si", 0; "non", 1; "e", 2; "vero", 3; "e", 4; "ben", 5; "trovato", 6;
+  "An", 10; "apple", 11; "a", 12; "day", 13; "keeps", 14; "the", 15;
+  "doctor", 16; "away", 17;
+  "Pierre", 20; "qui", 21; "roule", 22; "n'amasse", 23; "pas", 24; "mousse", 25;
+  "Asinus", 30; "asinum", 31; "fricat", 32
+|]
+
+(* Data set: random integers *)
+
+let random_integers num range =
+  let data = Array.make num (0,0) in
+  for i = 0 to num - 1 do
+    data.(i) <- (Random.int range, i)
+  done;
+  data
+
+(* Data set: pairs *)
+
+let pair_data data =
+  Array.map (fun (k, d) -> ((k, k), d)) data
+
+(* Data set: lists *)
+
+let list_data data =
+  let d = Array.make (Array.length data / 10) ([], "0") in
+  let j = ref 0 in
+  let rec mklist n =
+    if n <= 0 || !j >= Array.length data then [] else begin
+      let hd = fst data.(!j) in
+      incr j;
+      let tl = mklist (n-1) in
+      hd :: tl
+    end in
+  for i = 0 to Array.length d - 1 do
+    d.(i) <- (mklist (Random.int 16), string_of_int i)
+  done;
+  d
+
+(* The test *)
+
+let _ =
+  printf "-- Random integers, large range\n%!";
+  TI1.test (random_integers 20_000 1_000_000);
+  printf "-- Random integers, narrow range\n%!";
+  TI2.test (random_integers 20_000 1_000);
+  let d =
+    try file_data "../../LICENSE" with Sys_error _ -> string_data in
+  printf "-- Strings, generic interface\n%!";
+  TS1.test d;
+  printf "-- Strings, functorial interface\n%!";
+  TS2.test d;
+  printf "-- Pairs of strings\n%!";
+  TSP.test (pair_data d);
+  printf "-- Lists of strings\n%!";
+  TSL.test (list_data d);
+  (* weak *)
+  let d =
+    try file_data "../../LICENSE" with Sys_error _ -> string_data in
+  printf "-- Weak K1 -- Strings, functorial interface\n%!";
+  TWS.test d;
+  printf "-- Weak K1 -- Pairs of strings\n%!";
+  TWSP1.test (pair_data d);
+  printf "-- Weak K2 -- Pairs of strings\n%!";
+  TWSP2.test (pair_data d);
+  printf "-- Weak K1 -- Lists of strings\n%!";
+  TWSL.test (list_data d);
+  printf "-- Weak Kn -- Arrays of strings\n%!";
+  TWSA.test (Array.map (fun (l,i) -> (Array.of_list l,i)) (list_data d))
+
+
+let () =
+  let h = Hashtbl.create 16 in
+  for i = 1 to 1000 do Hashtbl.add h i (i * 2) done;
+  Printf.printf "%i elements\n" (Hashtbl.length h);
+  Hashtbl.filter_map_inplace (fun k v ->
+      if k mod 100 = 0 then ((*Hashtbl.add h v v;*) Some (v / 100)) else None)
+    h;
+  let l = Hashtbl.fold (fun k v acc -> (k, v) :: acc) h [] in
+  let l = List.sort compare l in
+  List.iter (fun (k, v) -> Printf.printf "%i,%i\n" k v) l;
+  Printf.printf "%i elements\n" (Hashtbl.length h)
diff --git a/testsuite/tests/lib-hashtbl/htbl.reference b/testsuite/tests/lib-hashtbl/htbl.reference
new file mode 100644
index 00000000..653fbc56
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/htbl.reference
@@ -0,0 +1,56 @@
+-- Random integers, large range
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Random integers, narrow range
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Strings, generic interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Strings, functorial interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Lists of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K1 -- Strings, functorial interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K1 -- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K2 -- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K1 -- Lists of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak Kn -- Arrays of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+1000 elements
+100,2
+200,4
+300,6
+400,8
+500,10
+600,12
+700,14
+800,16
+900,18
+1000,20
+10 elements
diff --git a/testsuite/tests/lib-marshal/Makefile b/testsuite/tests/lib-marshal/Makefile
new file mode 100644
index 00000000..a79f6bdd
--- /dev/null
+++ b/testsuite/tests/lib-marshal/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=intext
+C_FILES=intextaux
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml
new file mode 100644
index 00000000..11633092
--- /dev/null
+++ b/testsuite/tests/lib-marshal/intext.ml
@@ -0,0 +1,614 @@
+(* Test for output_value / input_value *)
+
+let max_data_depth = 500000
+
+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 =
+  print_string "Test "; print_int n;
+  if b then print_string " passed.\n" else print_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 : int -> int) 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 marshal_to_buffer s start len v flags =
+  ignore (Marshal.to_buffer s start len v flags)
+;;
+
+let test_buffer () =
+  let s = Bytes.create 512 in
+  marshal_to_buffer s 0 512 1 [];
+  test 201 (Marshal.from_bytes s 0 = 1);
+  marshal_to_buffer s 0 512 (-1) [];
+  test 202 (Marshal.from_bytes s 0 = (-1));
+  marshal_to_buffer s 0 512 258 [];
+  test 203 (Marshal.from_bytes s 0 = 258);
+  marshal_to_buffer s 0 512 20000 [];
+  test 204 (Marshal.from_bytes s 0 = 20000);
+  marshal_to_buffer s 0 512 0x12345678 [];
+  test 205 (Marshal.from_bytes s 0 = 0x12345678);
+  marshal_to_buffer s 0 512 bigint [];
+  test 206 (Marshal.from_bytes s 0 = bigint);
+  marshal_to_buffer s 0 512 "foobargeebuz" [];
+  test 207 (Marshal.from_bytes s 0 = "foobargeebuz");
+  marshal_to_buffer s 0 512 longstring [];
+  test 208 (Marshal.from_bytes s 0 = longstring);
+  test 209
+    (try marshal_to_buffer s 0 512 verylongstring []; false
+     with Failure s when s = "Marshal.to_buffer: buffer overflow" -> true);
+  marshal_to_buffer s 0 512 3.141592654 [];
+  test 210 (Marshal.from_bytes s 0 = 3.141592654);
+  marshal_to_buffer s 0 512 () [];
+  test 211 (Marshal.from_bytes s 0 = ());
+  marshal_to_buffer s 0 512 A [];
+  test 212 (match Marshal.from_bytes s 0 with
+    A -> true
+  | _ -> false);
+  marshal_to_buffer s 0 512 (B 1) [];
+  test 213 (match Marshal.from_bytes s 0 with
+    (B 1) -> true
+  | _ -> false);
+  marshal_to_buffer s 0 512 (C 2.718) [];
+  test 214 (match Marshal.from_bytes s 0 with
+    (C f) -> f = 2.718
+  | _ -> false);
+  marshal_to_buffer s 0 512 (D "hello, world!") [];
+  test 215 (match Marshal.from_bytes s 0 with
+    (D "hello, world!") -> true
+  | _ -> false);
+  marshal_to_buffer s 0 512 (E 'l') [];
+  test 216 (match Marshal.from_bytes s 0 with
+    (E 'l') -> true
+  | _ -> false);
+  marshal_to_buffer s 0 512 (F(B 1)) [];
+  test 217 (match Marshal.from_bytes 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_bytes 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_bytes s 0 with
+    (H(1, A)) -> true
+  | _ -> false);
+  marshal_to_buffer s 0 512 (I(B 2, 1e-6)) [];
+  test 220 (match Marshal.from_bytes 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_bytes 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_bytes 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 s when s = "Marshal.to_buffer: buffer overflow" -> true)
+
+let test_size() =
+  let s = Marshal.to_bytes (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 = Bytes.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 = "caml_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 s when s = "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!" [];
+         ignore (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
+
+(* Test for really deep data structures *)
+let test_deep () =
+  (* Right-leaning *)
+  let rec loop acc i =
+    if i < max_data_depth
+    then loop (i :: acc) (i+1)
+    else acc in
+  let x = loop [] 0 in
+  let s = Marshal.to_string x [] in
+  test 425 (Marshal.from_string s 0 = x);
+  (* Left-leaning *)
+  let rec loop acc i =
+    if i < max_data_depth
+    then loop (G(acc, B i)) (i+1)
+    else acc in
+  let x = loop A 0 in
+  let s = Marshal.to_string x [] in
+  test 426 (Marshal.from_string s 0 = x)
+
+(* Test for objects *)
+class foo = object (self : 'self)
+  val data1 = "foo"
+  val data2 = "bar"
+  val data3 = 42L
+  method test1 = data1 ^ data2
+  method test2 = false
+  method test3 = self#test1
+  method test4 = data3
+end
+
+class bar = object (self : 'self)
+  inherit foo as super
+  val! data2 = "test5"
+  val data4 = "test3"
+  val data5 = "test4"
+  method test1 =
+    data1
+  ^ data2
+  ^ data4
+  ^ data5
+  ^ Int64.to_string self#test4
+end
+
+class foobar = object (self : 'self)
+  inherit foo as super
+  inherit! bar
+end
+
+(* Test for objects *)
+let test_objects () =
+  let x = new foo in
+  let s = Marshal.to_string x [Marshal.Closures] in
+  let x = Marshal.from_string s 0 in
+  test 500 (x#test1 = "foobar");
+  test 501 (x#test2 = false);
+  test 502 (x#test3 = "foobar");
+  test 503 (x#test4 = 42L);
+  let x = new bar in
+  let s = Marshal.to_string x [Marshal.Closures] in
+  let x = Marshal.from_string s 0 in
+  test 504 (x#test1 = "footest5test3test442");
+  test 505 (x#test2 = false);
+  test 506 (x#test3 = "footest5test3test442");
+  test 507 (x#test4 = 42L);
+  let x0 = new foobar in
+  let s = Marshal.to_string x0 [Marshal.Closures] in
+  let x = Marshal.from_string s 0 in
+  test 508 (x#test1 = "footest5test3test442");
+  test 509 (x#test2 = false);
+  test 510 (x#test3 = "footest5test3test442");
+  test 511 (x#test4 = 42L);
+  test 512 (Oo.id x = Oo.id x0 + 1)     (* PR#5610 *)
+
+(* Test for infix pointers *)
+let test_infix () =
+  let t = true and
+      f = false in
+  let rec odd n =
+    if n = 0
+    then f
+    else even (n-1)
+  and even n =
+    if n = 0
+    then t
+    else odd (n-1)
+  in
+  let s = Marshal.to_string (odd, even) [Marshal.Closures] in
+  let (odd', even': (int -> bool) * (int -> bool)) = Marshal.from_string s 0 in
+  test 600 (odd' 41 = true);
+  test 601 (odd' 41 = odd 41);
+  test 602 (odd' 142 = false);
+  test 603 (odd' 142 = odd 142);
+  test 604 (even' 41 = false);
+  test 605 (even' 41 = even 41);
+  test 606 (even' 142 = true);
+  test 607 (even' 142 = even 142)
+
+
+let test_mutual_rec_regression () =
+  (* this regression was reported by Cedric Pasteur in PR#5772 *)
+  let rec test_one q x = x > 3
+  and test_list q = List.for_all (test_one q) q in
+  let g () = () in
+  let f q = if test_list q then g () in
+
+  test 700 (try ignore (Marshal.to_string f [Marshal.Closures]); true
+            with _ -> false)
+
+let test_end_of_file_regression () =
+  (* See PR#7142 *)
+  let write oc n =
+    for k = 0 to n - 1 do
+      Marshal.to_channel oc k []
+    done
+  in
+  let read ic n =
+    let k = ref 0 in
+    try
+      while true do
+        if Marshal.from_channel ic != !k then
+          failwith "unexpected integer";
+        incr k
+      done
+    with
+      | End_of_file when !k != n -> failwith "missing integer"
+      | End_of_file -> ()
+  in
+  test 800 (
+    try
+      let n = 100 in
+      let oc = open_out_bin "intext.data" in
+      write oc n;
+      close_out oc;
+
+      let ic = open_in_bin "intext.data" in
+      try
+        read ic n;
+        close_in ic;
+        true
+      with _ ->
+        close_in ic;
+        false
+    with _ -> false
+  )
+
+
+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";
+    test_string();
+    test_buffer();
+    test_size();
+    test_block();
+    test_deep();
+    test_objects();
+    test_infix ();
+    test_mutual_rec_regression ();
+    test_end_of_file_regression ();
+    Sys.remove "intext.data";
+  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/testsuite/tests/lib-marshal/intext.reference b/testsuite/tests/lib-marshal/intext.reference
new file mode 100644
index 00000000..412cea0c
--- /dev/null
+++ b/testsuite/tests/lib-marshal/intext.reference
@@ -0,0 +1,174 @@
+Test 1 passed.
+Test 2 passed.
+Test 3 passed.
+Test 4 passed.
+Test 5 passed.
+Test 6 passed.
+Test 7 passed.
+Test 8 passed.
+Test 9 passed.
+Test 10 passed.
+Test 11 passed.
+Test 12 passed.
+Test 13 passed.
+Test 14 passed.
+Test 15 passed.
+Test 16 passed.
+Test 17 passed.
+Test 18 passed.
+Test 19 passed.
+Test 20 passed.
+Test 21 passed.
+Test 22 passed.
+Test 23 passed.
+Test 24 passed.
+Test 25 passed.
+Test 26 passed.
+Test 27 passed.
+Test 28 passed.
+Test 29 passed.
+Test 30 passed.
+Test 31 passed.
+Test 32 passed.
+Test 33 passed.
+Test 34 passed.
+Test 35 passed.
+Test 36 passed.
+Test 37 passed.
+Test 38 passed.
+Test 39 passed.
+Test 1 passed.
+Test 2 passed.
+Test 3 passed.
+Test 4 passed.
+Test 5 passed.
+Test 6 passed.
+Test 7 passed.
+Test 8 passed.
+Test 9 passed.
+Test 10 passed.
+Test 11 passed.
+Test 12 passed.
+Test 13 passed.
+Test 14 passed.
+Test 15 passed.
+Test 16 passed.
+Test 17 passed.
+Test 18 passed.
+Test 19 passed.
+Test 20 passed.
+Test 21 passed.
+Test 22 passed.
+Test 23 passed.
+Test 24 passed.
+Test 25 passed.
+Test 26 passed.
+Test 27 passed.
+Test 28 passed.
+Test 29 passed.
+Test 30 passed.
+Test 31 passed.
+Test 32 passed.
+Test 33 passed.
+Test 34 passed.
+Test 35 passed.
+Test 36 passed.
+Test 37 passed.
+Test 38 passed.
+Test 39 passed.
+Test 101 passed.
+Test 102 passed.
+Test 103 passed.
+Test 104 passed.
+Test 105 passed.
+Test 106 passed.
+Test 107 passed.
+Test 108 passed.
+Test 109 passed.
+Test 110 passed.
+Test 111 passed.
+Test 112 passed.
+Test 113 passed.
+Test 114 passed.
+Test 115 passed.
+Test 116 passed.
+Test 117 passed.
+Test 118 passed.
+Test 119 passed.
+Test 120 passed.
+Test 121 passed.
+Test 122 passed.
+Test 123 passed.
+Test 201 passed.
+Test 202 passed.
+Test 203 passed.
+Test 204 passed.
+Test 205 passed.
+Test 206 passed.
+Test 207 passed.
+Test 208 passed.
+Test 209 passed.
+Test 210 passed.
+Test 211 passed.
+Test 212 passed.
+Test 213 passed.
+Test 214 passed.
+Test 215 passed.
+Test 216 passed.
+Test 217 passed.
+Test 218 passed.
+Test 219 passed.
+Test 220 passed.
+Test 221 passed.
+Test 222 passed.
+Test 223 passed.
+Test 300 passed.
+Test 401 passed.
+Test 402 passed.
+Test 403 passed.
+Test 404 passed.
+Test 405 passed.
+Test 406 passed.
+Test 407 passed.
+Test 408 passed.
+Test 409 passed.
+Test 410 passed.
+Test 411 passed.
+Test 412 passed.
+Test 413 passed.
+Test 414 passed.
+Test 415 passed.
+Test 416 passed.
+Test 417 passed.
+Test 418 passed.
+Test 419 passed.
+Test 420 passed.
+Test 421 passed.
+Test 422 passed.
+Test 423 passed.
+Test 424 passed.
+Test 425 passed.
+Test 426 passed.
+Test 500 passed.
+Test 501 passed.
+Test 502 passed.
+Test 503 passed.
+Test 504 passed.
+Test 505 passed.
+Test 506 passed.
+Test 507 passed.
+Test 508 passed.
+Test 509 passed.
+Test 510 passed.
+Test 511 passed.
+Test 512 passed.
+Test 600 passed.
+Test 601 passed.
+Test 602 passed.
+Test 603 passed.
+Test 604 passed.
+Test 605 passed.
+Test 606 passed.
+Test 607 passed.
+Test 700 passed.
+Test 800 passed.
diff --git a/testsuite/tests/lib-marshal/intextaux.c b/testsuite/tests/lib-marshal/intextaux.c
new file mode 100644
index 00000000..183343d6
--- /dev/null
+++ b/testsuite/tests/lib-marshal/intextaux.c
@@ -0,0 +1,30 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*             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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/intext.h>
+
+#define CAML_INTERNALS
+
+value marshal_to_block(value vbuf, value vlen, value v, value vflags)
+{
+  return Val_long(caml_output_value_to_block(v, vflags,
+                                        (char *) vbuf, Long_val(vlen)));
+}
+
+value marshal_from_block(value vbuf, value vlen)
+{
+  return caml_input_value_from_block((char *) vbuf, Long_val(vlen));
+}
diff --git a/testsuite/tests/lib-num-2/Makefile b/testsuite/tests/lib-num-2/Makefile
new file mode 100644
index 00000000..78930aef
--- /dev/null
+++ b/testsuite/tests/lib-num-2/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=nums
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/num
+LD_PATH=$(TOPDIR)/otherlibs/num
+PROGRAM_ARGS=1000
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-num-2/pi_big_int.ml b/testsuite/tests/lib-num-2/pi_big_int.ml
new file mode 100644
index 00000000..22872ba4
--- /dev/null
+++ b/testsuite/tests/lib-num-2/pi_big_int.ml
@@ -0,0 +1,78 @@
+(* Pi digits computed with the sreaming algorithm given on pages 4, 6
+   & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
+   Gibbons, August 2004. *)
+
+open Printf;;
+open Big_int;;
+
+let ( !$ ) = Big_int.big_int_of_int
+and ( +$ ) = Big_int.add_big_int
+and ( *$ ) = Big_int.mult_big_int
+and ( =$ ) = Big_int.eq_big_int
+;;
+
+let zero = Big_int.zero_big_int
+and one = Big_int.unit_big_int
+and three = !$ 3
+and four = !$ 4
+and ten = !$ 10
+and neg_ten = !$(-10)
+;;
+
+(* Linear Fractional (aka M=F6bius) Transformations *)
+module LFT = struct
+
+  let floor_ev (q, r, s, t) x = div_big_int (q *$ x +$ r) (s *$ x +$ t);;
+
+  let unit = (one, zero, zero, one);;
+
+  let comp (q, r, s, t) (q', r', s', t') =
+    (q *$ q' +$ r *$ s', q *$ r' +$ r *$ t',
+     s *$ q' +$ t *$ s', s *$ r' +$ t *$ t')
+;;
+
+end
+;;
+
+let next z = LFT.floor_ev z three
+and safe z n = (n =$ LFT.floor_ev z four)
+and prod z n = LFT.comp (ten, neg_ten *$ n, zero, one) z
+and cons z k =
+  let den = 2 * k + 1 in
+  LFT.comp z (!$ k, !$(2 * den), zero, !$ den)
+;;
+
+let rec digit k z n row col =
+  if n > 0 then
+    let y = next z in
+    if safe z y then
+      if col = 10 then (
+        let row = row + 10 in
+        printf "\t:%i\n%s" row (string_of_big_int y);
+        digit k (prod z y) (n - 1) row 1
+      )
+      else (
+        print_string(string_of_big_int y);
+        digit k (prod z y) (n - 1) row (col + 1)
+      )
+    else digit (k + 1) (cons z k) n row col
+  else
+    printf "%*s\t:%i\n" (10 - col) "" (row + col)
+;;
+
+let digits n = digit 1 LFT.unit n 0 0
+;;
+
+let usage () =
+  prerr_endline "Usage: pi_big_int <number of digits to compute for pi>";
+  exit 2
+;;
+
+let main () =
+  let args = Sys.argv in
+  if Array.length args <> 2 then usage () else
+  digits (int_of_string Sys.argv.(1))
+;;
+
+main ()
+;;
diff --git a/testsuite/tests/lib-num-2/pi_big_int.reference b/testsuite/tests/lib-num-2/pi_big_int.reference
new file mode 100644
index 00000000..ad4dc996
--- /dev/null
+++ b/testsuite/tests/lib-num-2/pi_big_int.reference
@@ -0,0 +1,100 @@
+3141592653	:10
+5897932384	:20
+6264338327	:30
+9502884197	:40
+1693993751	:50
+0582097494	:60
+4592307816	:70
+4062862089	:80
+9862803482	:90
+5342117067	:100
+9821480865	:110
+1328230664	:120
+7093844609	:130
+5505822317	:140
+2535940812	:150
+8481117450	:160
+2841027019	:170
+3852110555	:180
+9644622948	:190
+9549303819	:200
+6442881097	:210
+5665933446	:220
+1284756482	:230
+3378678316	:240
+5271201909	:250
+1456485669	:260
+2346034861	:270
+0454326648	:280
+2133936072	:290
+6024914127	:300
+3724587006	:310
+6063155881	:320
+7488152092	:330
+0962829254	:340
+0917153643	:350
+6789259036	:360
+0011330530	:370
+5488204665	:380
+2138414695	:390
+1941511609	:400
+4330572703	:410
+6575959195	:420
+3092186117	:430
+3819326117	:440
+9310511854	:450
+8074462379	:460
+9627495673	:470
+5188575272	:480
+4891227938	:490
+1830119491	:500
+2983367336	:510
+2440656643	:520
+0860213949	:530
+4639522473	:540
+7190702179	:550
+8609437027	:560
+7053921717	:570
+6293176752	:580
+3846748184	:590
+6766940513	:600
+2000568127	:610
+1452635608	:620
+2778577134	:630
+2757789609	:640
+1736371787	:650
+2146844090	:660
+1224953430	:670
+1465495853	:680
+7105079227	:690
+9689258923	:700
+5420199561	:710
+1212902196	:720
+0864034418	:730
+1598136297	:740
+7477130996	:750
+0518707211	:760
+3499999983	:770
+7297804995	:780
+1059731732	:790
+8160963185	:800
+9502445945	:810
+5346908302	:820
+6425223082	:830
+5334468503	:840
+5261931188	:850
+1710100031	:860
+3783875288	:870
+6587533208	:880
+3814206171	:890
+7766914730	:900
+3598253490	:910
+4287554687	:920
+3115956286	:930
+3882353787	:940
+5937519577	:950
+8185778053	:960
+2171226806	:970
+6130019278	:980
+7661119590	:990
+9216420198	:1000
diff --git a/testsuite/tests/lib-num-2/pi_num.ml b/testsuite/tests/lib-num-2/pi_num.ml
new file mode 100644
index 00000000..e2580c10
--- /dev/null
+++ b/testsuite/tests/lib-num-2/pi_num.ml
@@ -0,0 +1,72 @@
+(* Pi digits computed with the sreaming algorithm given on pages 4, 6
+   & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
+   Gibbons, August 2004. *)
+
+open Printf;;
+open Num;;
+
+let zero = num_of_int 0
+and one = num_of_int 1
+and three = num_of_int 3
+and four = num_of_int 4
+and ten = num_of_int 10
+and neg_ten = num_of_int(-10)
+;;
+
+(* Linear Fractional Transformation *)
+module LFT = struct
+
+  let floor_ev (q, r, s, t) x = quo_num (q */ x +/ r) (s */ x +/ t);;
+
+  let unit = (one, zero, zero, one);;
+
+  let comp (q, r, s, t) (q', r', s', t') =
+    (q */ q' +/ r */ s', q */ r' +/ r */ t',
+     s */ q' +/ t */ s', s */ r' +/ t */ t')
+;;
+
+end
+;;
+
+let next z = LFT.floor_ev z three
+and safe z n = (n =/ LFT.floor_ev z four)
+and prod z n = LFT.comp (ten, neg_ten */ n, zero, one) z
+and cons z k =
+  let den = 2 * k + 1 in
+  LFT.comp z (num_of_int k, num_of_int(2 * den), zero, num_of_int den)
+;;
+
+let rec digit k z n row col =
+  if n > 0 then
+    let y = next z in
+    if safe z y then
+      if col = 10 then (
+    let row = row + 10 in
+    printf "\t:%i\n%s" row (string_of_num y);
+    digit k (prod z y) (n-1) row 1
+      )
+      else (
+    print_string(string_of_num y);
+    digit k (prod z y) (n-1) row (col + 1)
+      )
+    else digit (k + 1) (cons z k) n row col
+  else
+    printf "%*s\t:%i\n" (10 - col) "" (row + col)
+;;
+
+let digits n = digit 1 LFT.unit n 0 0
+;;
+
+let usage () =
+  prerr_endline "Usage: pi_num <number of digits to compute for pi>";
+  exit 2
+;;
+
+let main () =
+  let args = Sys.argv in
+  if Array.length args <> 2 then usage () else
+  digits (int_of_string Sys.argv.(1))
+;;
+
+main ()
+;;
diff --git a/testsuite/tests/lib-num-2/pi_num.reference b/testsuite/tests/lib-num-2/pi_num.reference
new file mode 100644
index 00000000..ad4dc996
--- /dev/null
+++ b/testsuite/tests/lib-num-2/pi_num.reference
@@ -0,0 +1,100 @@
+3141592653	:10
+5897932384	:20
+6264338327	:30
+9502884197	:40
+1693993751	:50
+0582097494	:60
+4592307816	:70
+4062862089	:80
+9862803482	:90
+5342117067	:100
+9821480865	:110
+1328230664	:120
+7093844609	:130
+5505822317	:140
+2535940812	:150
+8481117450	:160
+2841027019	:170
+3852110555	:180
+9644622948	:190
+9549303819	:200
+6442881097	:210
+5665933446	:220
+1284756482	:230
+3378678316	:240
+5271201909	:250
+1456485669	:260
+2346034861	:270
+0454326648	:280
+2133936072	:290
+6024914127	:300
+3724587006	:310
+6063155881	:320
+7488152092	:330
+0962829254	:340
+0917153643	:350
+6789259036	:360
+0011330530	:370
+5488204665	:380
+2138414695	:390
+1941511609	:400
+4330572703	:410
+6575959195	:420
+3092186117	:430
+3819326117	:440
+9310511854	:450
+8074462379	:460
+9627495673	:470
+5188575272	:480
+4891227938	:490
+1830119491	:500
+2983367336	:510
+2440656643	:520
+0860213949	:530
+4639522473	:540
+7190702179	:550
+8609437027	:560
+7053921717	:570
+6293176752	:580
+3846748184	:590
+6766940513	:600
+2000568127	:610
+1452635608	:620
+2778577134	:630
+2757789609	:640
+1736371787	:650
+2146844090	:660
+1224953430	:670
+1465495853	:680
+7105079227	:690
+9689258923	:700
+5420199561	:710
+1212902196	:720
+0864034418	:730
+1598136297	:740
+7477130996	:750
+0518707211	:760
+3499999983	:770
+7297804995	:780
+1059731732	:790
+8160963185	:800
+9502445945	:810
+5346908302	:820
+6425223082	:830
+5334468503	:840
+5261931188	:850
+1710100031	:860
+3783875288	:870
+6587533208	:880
+3814206171	:890
+7766914730	:900
+3598253490	:910
+4287554687	:920
+3115956286	:930
+3882353787	:940
+5937519577	:950
+8185778053	:960
+2171226806	:970
+6130019278	:980
+7661119590	:990
+9216420198	:1000
diff --git a/testsuite/tests/lib-num/Makefile b/testsuite/tests/lib-num/Makefile
new file mode 100644
index 00000000..14f0d2c1
--- /dev/null
+++ b/testsuite/tests/lib-num/Makefile
@@ -0,0 +1,24 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=test test_nats test_big_ints test_ratios test_nums test_io
+MAIN_MODULE=end_test
+LIBRARIES=nums
+ADD_COMPFLAGS=-w a -I $(OTOPDIR)/otherlibs/num
+LD_PATH=$(TOPDIR)/otherlibs/num
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-num/end_test.ml b/testsuite/tests/lib-num/end_test.ml
new file mode 100644
index 00000000..57e099ed
--- /dev/null
+++ b/testsuite/tests/lib-num/end_test.ml
@@ -0,0 +1 @@
+Test.end_tests ();;
diff --git a/testsuite/tests/lib-num/end_test.reference b/testsuite/tests/lib-num/end_test.reference
new file mode 100644
index 00000000..ab99ae01
--- /dev/null
+++ b/testsuite/tests/lib-num/end_test.reference
@@ -0,0 +1,170 @@
+
+num_digits_nat
+ -1... 0... 1...
+length_nat
+ 1...
+equal_nat
+ 1... 2... 3... 4...
+incr_nat
+ 1... 2... 3... 4...
+decr_nat
+ 1... 2... 3... 4...
+is_zero_nat
+ 1... 2... 3... 4...
+string_of_nat
+ 1... 2...
+string_of_nat && nat_of_string
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22...
+gcd_nat
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20...
+sqrt_nat
+ 1... 2... 3... 4... 5...
+compare_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
+pred_big_int
+ 1... 2... 3...
+succ_big_int
+ 1... 2... 3...
+add_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17...
+sub_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17...
+mult_int_big_int
+ 1... 2... 3... 4...
+mult_big_int
+ 1... 2... 3... 4... 5...
+quomod_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25...
+gcd_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28...
+int_of_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8...
+is_int_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
+sys_string_of_big_int
+ 1...
+big_int_of_string
+ 1... 2... 4... 5... 6... 7... 9... 10... 18... 19... 20... 21...
+power_base_int
+ 1... 2... 3...
+base_power_big_int
+ 1... 2... 3...
+power_int_positive_big_int
+ 1... 2... 3... 4... 5... 6... 7...
+power_big_int_positive_int
+ 1... 2... 3... 4... 5...
+power_big_int_positive_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+square_big_int
+ 1... 2... 3... 4...
+big_int_of_nativeint
+ 1... 2... 3...
+nativeint_of_big_int
+ 1... 2... 2...
+big_int_of_int32
+ 1... 2... 3...
+int32_of_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8...
+big_int_of_int64
+ 1... 2... 3... 4... 5... 6... 7... 8...
+int64_of_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8...
+and_big_int
+ 1... 2... 3... 4... 5... 6...
+or_big_int
+ 1... 2... 3... 4... 5... 6...
+xor_big_int
+ 1... 2... 3... 4... 5... 6...
+shift_left_big_int
+ 1... 2... 2... 3... 4... 5... 6...
+shift_right_big_int
+ 1... 2... 3... 4... 5... 6...
+shift_right_towards_zero_big_int
+ 1... 2...
+extract_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
+hashing of big integers
+ 1... 2... 3... 4... 5... 6...
+float_of_big_int
+ 1... 2... 3... 4... 5... 6... 7... 8...
+create_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8...
+create_normalized_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
+null_denominator
+ 1... 2...
+sign_ratio
+ 1... 2... 3...
+normalize_ratio
+ 1... 2... 3... 4...
+report_sign_ratio
+ 1... 2...
+is_integer_ratio
+ 1... 2...
+add_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 1... 2... 3... 4...
+sub_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8...
+mult_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8...
+div_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8...
+integer_ratio
+ 1... 2... 3... 4... 5...
+floor_ratio
+ 1... 2... 3... 4... 5...
+round_ratio
+ 1... 2... 3... 4... 5...
+ceiling_ratio
+ 1... 2... 3... 4... 5... 6...
+eq_ratio
+ 1... 2... 3... 4... 5...
+compare_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... 29... 30... 31... 32... 33... 34... 35... 36...
+eq_big_int_ratio
+ 1... 2... 3... 4... 5...
+compare_big_int_ratio
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+int_of_ratio
+ 1... 2... 3... 4... 5...
+ratio_of_int
+ 1... 2...
+nat_of_ratio
+ 1... 2... 3... 4...
+ratio_of_big_int
+ 1...
+big_int_of_ratio
+ 1... 2... 3...
+string_of_ratio
+ 1... 2... 3... 4...
+ratio_of_string
+ 1... 6... 7... 8...
+round_futur_last_digit
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24...
+approx_ratio_fix
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
+approx_ratio_exp
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+float_of_ratio
+ 1...
+add_num
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+sub_num
+ 1... 2... 3... 4... 5... 7... 8... 9... 10...
+mult_num
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+div_num
+ 1... 2... 3... 4... 5... 6... 7... 8... 9...
+is_integer_num
+ 1... 2... 3... 4...
+num_of_ratio
+ 1... 2... 3...
+num_of_string
+ 1... 7... 8... 11... 12... 13... 14... 15...
+output_value/input_value on nats
+ 1... 2... 3... 4... 5... 6... 7...
+output_value/input_value on big ints
+ 1... 2... 3... 4... 5...
+output_value/input_value on nums
+ 1... 2... 3... 4... 5... 6... 7... 8...
+************* TESTS COMPLETED SUCCESSFULLY ****************
diff --git a/testsuite/tests/lib-num/test.ml b/testsuite/tests/lib-num/test.ml
new file mode 100644
index 00000000..b45d05d1
--- /dev/null
+++ b/testsuite/tests/lib-num/test.ml
@@ -0,0 +1,103 @@
+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
+   print_endline "************* TESTS FAILED ****************"; exit 2
+ end else begin
+   print_endline "************* TESTS COMPLETED SUCCESSFULLY ****************";
+   exit 0
+ end;;
+
+let eq = (==);;
+let eq_int (i: int) (j: int) = (i = j);;
+let eq_string (i: string) (j: string) = (i = j);;
+let eq_bytes (i: bytes) (j: bytes) = (i = j);;
+let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);;
+let eq_int32 (i: int32) (j: int32) = (i = j);;
+let eq_int64 (i: int64) (j: int64) = (i = j);;
+let eq_float (x: float) (y: float) = Pervasives.compare x y = 0;;
+
+let sixtyfour = (1 lsl 31) <> 0;;
+
+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/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
new file mode 100644
index 00000000..61e4a9f2
--- /dev/null
+++ b/testsuite/tests/lib-num/test_big_ints.ml
@@ -0,0 +1,1030 @@
+open Test;;
+open Nat;;
+open Big_int;;
+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
+;;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int 10) (big_int_of_int 20) in
+ test 18 eq_big_int (quotient, big_int_of_int 0) &&
+ test 19 eq_big_int (modulo, big_int_of_int 10);;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int (-10)) (big_int_of_int 20) in
+ test 20 eq_big_int (quotient, big_int_of_int (-1)) &&
+ test 21 eq_big_int (modulo, big_int_of_int 10);;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int 10) (big_int_of_int (-20)) in
+ test 22 eq_big_int (quotient, big_int_of_int 0) &&
+ test 23 eq_big_int (modulo, big_int_of_int 10);;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int (-10)) (big_int_of_int (-20)) in
+ test 24 eq_big_int (quotient, big_int_of_int 1) &&
+ test 25 eq_big_int (modulo, big_int_of_int 10);;
+
+
+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);;
+test 2
+eq_int (int_of_big_int (big_int_of_int(-1)), -1);;
+test 3
+eq_int (int_of_big_int zero_big_int, 0);;
+test 4
+eq_int (int_of_big_int (big_int_of_int max_int), max_int);;
+test 5
+eq_int (int_of_big_int (big_int_of_int min_int), min_int);;
+failwith_test 6
+  (fun () -> int_of_big_int (succ_big_int (big_int_of_int max_int)))
+  () (Failure "int_of_big_int");;
+failwith_test 7
+  (fun () -> int_of_big_int (pred_big_int (big_int_of_int min_int)))
+  () (Failure "int_of_big_int");;
+failwith_test 8
+  (fun () -> int_of_big_int (mult_big_int (big_int_of_int min_int)
+                                          (big_int_of_int 2)))
+  () (Failure "int_of_big_int");;
+
+
+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 (^) "";; (* To hell with efficiency *)
+
+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")))*)
+;;
+
+test 18
+eq_big_int (big_int_of_string "0xAbC", big_int_of_int 0xABC);;
+
+test 19
+eq_big_int (big_int_of_string "-0o452", big_int_of_int (-0o452));;
+
+test 20
+eq_big_int (big_int_of_string "0B110101", big_int_of_int 53);;
+
+test 21
+eq_big_int (big_int_of_string "0b11_01_01", big_int_of_int 53);;
+
+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");;
+
+test 4
+eq_big_int
+ (power_int_positive_big_int 1 (big_int_of_string "1000000000000000000000"),
+  big_int_of_int 1);;
+
+test 5
+eq_big_int
+ (power_int_positive_big_int (-1) (big_int_of_string "1000000000000000000000"),
+  big_int_of_int 1);;
+
+test 6
+eq_big_int
+ (power_int_positive_big_int (-1) (big_int_of_string "1000000000000000000001"),
+  big_int_of_int (-1));;
+
+test 7
+eq_big_int
+ (power_int_positive_big_int 0 (big_int_of_string "1000000000000000000000"),
+  big_int_of_int 0);;
+
+testing_function "power_big_int_positive_int";;
+
+test 1
+eq_big_int (power_big_int_positive_int (big_int_of_int 2) 10,
+            big_int_of_int 1024);;
+test 2
+eq_big_int
+ (power_big_int_positive_int (big_int_of_int 100) 20,
+  big_int_of_string "10000000000000000000000000000000000000000");;
+
+test 3
+eq_big_int
+ (power_big_int_positive_int (big_int_of_string "3") 47,
+  big_int_of_string "26588814358957503287787");;
+
+test 4
+eq_big_int
+ (power_big_int_positive_int (big_int_of_string "200000000000000") 34,
+  big_int_of_string
+"17179869184000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000");;
+
+test 5
+eq_big_int
+ (power_big_int_positive_int (big_int_of_string "2197609328765") 243,
+  big_int_of_string
+"12415638672345366257764851943822299490113545698929764576040102857365\
+27920436565335427676982530274588056944387957287793378051852205028658\
+73008292720317554332284838709453634119919368441951233982592586680844\
+20765201140575612595182857026804842796931784944918059630667794516774\
+58498235838834599150657873894983300999081942159304585449505963892008\
+97855706440206825609657816209327492197604711437269361628626691080334\
+38432768885637928268354258860147333786379766583179851226375449161073\
+10396958979998161989562418169797611757651190037273397850239552735199\
+63719988832594486235837899145390948533078339399890545062510060406048\
+61331200657727576638170520036143007285549092686618686739320973444703\
+33342725604091818763255601206325426337211467746377586080108631634250\
+11232258578207762608797108802386708549785680783113606089879687396654\
+54004281165259352412815385041917713969718327109245777066079665194617\
+29230093411050053217775067781725651590160086483960457766025246936489\
+92234225900994076609973190516835778346886551506344097474301175288686\
+25662752919718480402972207084177612056491949911377568680526080633587\
+33230060757162252611388973328501680433819585006035301408574879645573\
+47126018243568976860515247053858204554293343161581801846081341003624\
+22906934772131205632200433218165757307182816260714026614324014553342\
+77303133877636489457498062819003614421295692889321460150481573909330\
+77301946991278225819671075907191359721824291923283322225480199446258\
+03302645587072103949599624444368321734975586414930425964782010567575\
+43333331963876294983400462908871215572514487548352925949663431718284\
+14589547315559936497408670231851521193150991888789948397029796279240\
+53117024758684807981605608837291399377902947471927467827290844733264\
+70881963357258978768427852958888430774360783419404195056122644913454\
+24537375432013012467418602205343636983874410969339344956536142566292\
+67710105053213729008973121773436382170956191942409859915563249876601\
+97309463059908818473774872128141896864070835259683384180928526600888\
+17480854811931632353621014638284918544379784608050029606475137979896\
+79160729736625134310450643341951675749112836007180865039256361941093\
+99844921135320096085772541537129637055451495234892640418746420370197\
+76655592198723057553855194566534999101921182723711243608938705766658\
+35660299983828999383637476407321955462859142012030390036241831962713\
+40429407146441598507165243069127531565881439971034178400174881243483\
+00001434950666035560134867554719667076133414445044258086968145695386\
+00575860256380332451841441394317283433596457253185221717167880159573\
+60478649571700878049257386910142909926740023800166057094445463624601\
+79490246367497489548435683835329410376623483996271147060314994344869\
+89606855219181727424853876740423210027967733989284801813769926906846\
+45570461348452758744643550541290031199432061998646306091218518879810\
+17848488755494879341886158379140088252013009193050706458824793551984\
+39285914868159111542391208521561221610797141925061986437418522494485\
+59871215531081904861310222368465288125816137210222223075106739997863\
+76953125");;
+
+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");;
+
+test 4
+eq_big_int
+ (power_big_int_positive_big_int
+     (big_int_of_string "200000000000000") (big_int_of_int 34),
+  big_int_of_string
+"17179869184000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000000000000000000000000000000000000000000000000000000000000\
+00000000000");;
+
+test 5
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_string "2197609328765")
+                                 (big_int_of_string "243"),
+  big_int_of_string
+"12415638672345366257764851943822299490113545698929764576040102857365\
+27920436565335427676982530274588056944387957287793378051852205028658\
+73008292720317554332284838709453634119919368441951233982592586680844\
+20765201140575612595182857026804842796931784944918059630667794516774\
+58498235838834599150657873894983300999081942159304585449505963892008\
+97855706440206825609657816209327492197604711437269361628626691080334\
+38432768885637928268354258860147333786379766583179851226375449161073\
+10396958979998161989562418169797611757651190037273397850239552735199\
+63719988832594486235837899145390948533078339399890545062510060406048\
+61331200657727576638170520036143007285549092686618686739320973444703\
+33342725604091818763255601206325426337211467746377586080108631634250\
+11232258578207762608797108802386708549785680783113606089879687396654\
+54004281165259352412815385041917713969718327109245777066079665194617\
+29230093411050053217775067781725651590160086483960457766025246936489\
+92234225900994076609973190516835778346886551506344097474301175288686\
+25662752919718480402972207084177612056491949911377568680526080633587\
+33230060757162252611388973328501680433819585006035301408574879645573\
+47126018243568976860515247053858204554293343161581801846081341003624\
+22906934772131205632200433218165757307182816260714026614324014553342\
+77303133877636489457498062819003614421295692889321460150481573909330\
+77301946991278225819671075907191359721824291923283322225480199446258\
+03302645587072103949599624444368321734975586414930425964782010567575\
+43333331963876294983400462908871215572514487548352925949663431718284\
+14589547315559936497408670231851521193150991888789948397029796279240\
+53117024758684807981605608837291399377902947471927467827290844733264\
+70881963357258978768427852958888430774360783419404195056122644913454\
+24537375432013012467418602205343636983874410969339344956536142566292\
+67710105053213729008973121773436382170956191942409859915563249876601\
+97309463059908818473774872128141896864070835259683384180928526600888\
+17480854811931632353621014638284918544379784608050029606475137979896\
+79160729736625134310450643341951675749112836007180865039256361941093\
+99844921135320096085772541537129637055451495234892640418746420370197\
+76655592198723057553855194566534999101921182723711243608938705766658\
+35660299983828999383637476407321955462859142012030390036241831962713\
+40429407146441598507165243069127531565881439971034178400174881243483\
+00001434950666035560134867554719667076133414445044258086968145695386\
+00575860256380332451841441394317283433596457253185221717167880159573\
+60478649571700878049257386910142909926740023800166057094445463624601\
+79490246367497489548435683835329410376623483996271147060314994344869\
+89606855219181727424853876740423210027967733989284801813769926906846\
+45570461348452758744643550541290031199432061998646306091218518879810\
+17848488755494879341886158379140088252013009193050706458824793551984\
+39285914868159111542391208521561221610797141925061986437418522494485\
+59871215531081904861310222368465288125816137210222223075106739997863\
+76953125");;
+
+test 6
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_int 1)
+                                 (big_int_of_string "1000000000000000000000"),
+  big_int_of_int 1);;
+
+test 7
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_int (-1))
+                                 (big_int_of_string "1000000000000000000000"),
+  big_int_of_int 1);;
+
+test 8
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_int (-1))
+                                 (big_int_of_string "1000000000000000000001"),
+  big_int_of_int (-1));;
+
+test 9
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_int 0)
+                                 (big_int_of_string "1000000000000000000000"),
+  big_int_of_int 0);;
+
+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");;
+
+
+testing_function "big_int_of_nativeint";;
+
+test 1 eq_big_int
+  (big_int_of_nativeint 0n, zero_big_int);;
+test 2 eq_big_int
+  (big_int_of_nativeint 1234n, big_int_of_string "1234");;
+test 3 eq_big_int
+  (big_int_of_nativeint (-1234n), big_int_of_string "-1234");;
+
+testing_function "nativeint_of_big_int";;
+
+test 1 eq_nativeint
+  (nativeint_of_big_int zero_big_int, 0n);;
+test 2 eq_nativeint
+  (nativeint_of_big_int (big_int_of_string "1234"), 1234n);;
+test 2 eq_nativeint
+  (nativeint_of_big_int (big_int_of_string "-1234"), -1234n);;
+
+testing_function "big_int_of_int32";;
+
+test 1 eq_big_int
+  (big_int_of_int32 0l, zero_big_int);;
+test 2 eq_big_int
+  (big_int_of_int32 2147483647l, big_int_of_string "2147483647");;
+test 3 eq_big_int
+  (big_int_of_int32 (-2147483648l), big_int_of_string "-2147483648");;
+
+testing_function "int32_of_big_int";;
+
+test 1 eq_int32
+  (int32_of_big_int zero_big_int, 0l);;
+test 2 eq_int32
+  (int32_of_big_int (big_int_of_string "2147483647"), 2147483647l);;
+test 3 eq_int32
+  (int32_of_big_int (big_int_of_string "-2147483648"), -2147483648l);;
+test 4 eq_int32
+  (int32_of_big_int (big_int_of_string "-2147"), -2147l);;
+let should_fail s =
+  try ignore (int32_of_big_int (big_int_of_string s)); 0
+  with Failure _ -> 1;;
+test 5 eq_int
+  (should_fail "2147483648", 1);;
+test 6 eq_int
+  (should_fail "-2147483649", 1);;
+test 7 eq_int
+  (should_fail "4294967296", 1);;
+test 8 eq_int
+  (should_fail "18446744073709551616", 1);;
+
+testing_function "big_int_of_int64";;
+
+test 1 eq_big_int
+  (big_int_of_int64 0L, zero_big_int);;
+test 2 eq_big_int
+  (big_int_of_int64 9223372036854775807L,
+   big_int_of_string "9223372036854775807");;
+test 3 eq_big_int
+  (big_int_of_int64 (-9223372036854775808L),
+   big_int_of_string "-9223372036854775808");;
+test 4 eq_big_int (*PR#4792*)
+  (big_int_of_int64 (Int64.of_int32 Int32.min_int),
+   big_int_of_string "-2147483648");;
+test 5 eq_big_int
+  (big_int_of_int64 1234L, big_int_of_string "1234");;
+test 6 eq_big_int
+  (big_int_of_int64 0x1234567890ABCDEFL,
+   big_int_of_string "1311768467294899695");;
+test 7 eq_big_int
+  (big_int_of_int64 (-1234L), big_int_of_string "-1234");;
+test 8 eq_big_int
+  (big_int_of_int64 (-0x1234567890ABCDEFL),
+   big_int_of_string "-1311768467294899695");;
+
+testing_function "int64_of_big_int";;
+
+test 1 eq_int64
+  (int64_of_big_int zero_big_int, 0L);;
+test 2 eq_int64
+  (int64_of_big_int (big_int_of_string "9223372036854775807"),
+   9223372036854775807L);;
+test 3 eq_int64
+  (int64_of_big_int (big_int_of_string "-9223372036854775808"),
+   -9223372036854775808L);;
+test 4 eq_int64
+  (int64_of_big_int (big_int_of_string "-9223372036854775"),
+   -9223372036854775L);;
+test 5 eq_int64 (* PR#4804 *)
+  (int64_of_big_int (big_int_of_string "2147483648"), 2147483648L);;
+let should_fail s =
+  try ignore (int64_of_big_int (big_int_of_string s)); 0
+  with Failure _ -> 1;;
+test 6 eq_int
+  (should_fail "9223372036854775808", 1);;
+test 7 eq_int
+  (should_fail "-9223372036854775809", 1);;
+test 8 eq_int
+  (should_fail "18446744073709551616", 1);;
+
+(* build a 128-bit big int from two int64 *)
+
+let big_int_128 hi lo =
+  add_big_int (mult_big_int (big_int_of_int64 hi)
+                            (big_int_of_string "18446744073709551616"))
+              (big_int_of_int64 lo);;
+let h1 = 0x7fd05b7ee46a29f8L
+and h2 = 0x64b28b8ee70b6e6dL
+and h3 = 0x58546e563f5b44f0L
+and h4 = 0x1db72f6377ff3ec6L
+and h5 = 0x4f9bb0a19c543cb1L;;
+
+testing_function "and_big_int";;
+
+test 1 eq_big_int
+  (and_big_int unit_big_int zero_big_int, zero_big_int);;
+test 2 eq_big_int
+  (and_big_int zero_big_int unit_big_int, zero_big_int);;
+test 3 eq_big_int
+  (and_big_int unit_big_int unit_big_int, unit_big_int);;
+test 4 eq_big_int
+  (and_big_int (big_int_128 h1 h2) (big_int_128 h3 h4),
+   big_int_128 (Int64.logand h1 h3) (Int64.logand h2 h4));;
+test 5 eq_big_int
+  (and_big_int (big_int_128 h1 h2) (big_int_of_int64 h5),
+   big_int_of_int64 (Int64.logand h2 h5));;
+test 6 eq_big_int
+  (and_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) ,
+   big_int_of_int64 (Int64.logand h5 h4));;
+
+testing_function "or_big_int";;
+
+test 1 eq_big_int
+  (or_big_int unit_big_int zero_big_int, unit_big_int);;
+test 2 eq_big_int
+  (or_big_int zero_big_int unit_big_int, unit_big_int);;
+test 3 eq_big_int
+  (or_big_int unit_big_int unit_big_int, unit_big_int);;
+test 4 eq_big_int
+  (or_big_int (big_int_128 h1 h2) (big_int_128 h3 h4),
+   big_int_128 (Int64.logor h1 h3) (Int64.logor h2 h4));;
+test 5 eq_big_int
+  (or_big_int (big_int_128 h1 h2) (big_int_of_int64 h5),
+   big_int_128 h1 (Int64.logor h2 h5));;
+test 6 eq_big_int
+  (or_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) ,
+   big_int_128 h3 (Int64.logor h5 h4));;
+
+testing_function "xor_big_int";;
+
+test 1 eq_big_int
+  (xor_big_int unit_big_int zero_big_int, unit_big_int);;
+test 2 eq_big_int
+  (xor_big_int zero_big_int unit_big_int, unit_big_int);;
+test 3 eq_big_int
+  (xor_big_int unit_big_int unit_big_int, zero_big_int);;
+test 4 eq_big_int
+  (xor_big_int (big_int_128 h1 h2) (big_int_128 h3 h4),
+   big_int_128 (Int64.logxor h1 h3) (Int64.logxor h2 h4));;
+test 5 eq_big_int
+  (xor_big_int (big_int_128 h1 h2) (big_int_of_int64 h5),
+   big_int_128 h1 (Int64.logxor h2 h5));;
+test 6 eq_big_int
+  (xor_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) ,
+   big_int_128 h3 (Int64.logxor h5 h4));;
+
+testing_function "shift_left_big_int";;
+
+test 1 eq_big_int
+  (shift_left_big_int unit_big_int 0,
+   unit_big_int);;
+test 2 eq_big_int
+  (shift_left_big_int unit_big_int 1,
+   big_int_of_int 2);;
+test 2 eq_big_int
+  (shift_left_big_int unit_big_int 31,
+   big_int_of_string "2147483648");;
+test 3 eq_big_int
+  (shift_left_big_int unit_big_int 64,
+   big_int_of_string "18446744073709551616");;
+test 4 eq_big_int
+  (shift_left_big_int unit_big_int 95,
+   big_int_of_string "39614081257132168796771975168");;
+test 5 eq_big_int
+  (shift_left_big_int (big_int_of_string "39614081257132168796771975168") 67,
+   big_int_of_string "5846006549323611672814739330865132078623730171904");;
+test 6 eq_big_int
+  (shift_left_big_int (big_int_of_string "-39614081257132168796771975168") 67,
+   big_int_of_string "-5846006549323611672814739330865132078623730171904");;
+
+testing_function "shift_right_big_int";;
+
+test 1 eq_big_int
+  (shift_right_big_int unit_big_int 0,
+   unit_big_int);;
+test 2 eq_big_int
+  (shift_right_big_int (big_int_of_int 12345678) 3,
+   big_int_of_int 1543209);;
+test 3 eq_big_int
+  (shift_right_big_int (big_int_of_string "5299989648942") 32,
+   big_int_of_int 1234);;
+test 4 eq_big_int
+  (shift_right_big_int (big_int_of_string
+                          "5846006549323611672814739330865132078623730171904")
+                       67,
+   big_int_of_string "39614081257132168796771975168");;
+test 5 eq_big_int
+  (shift_right_big_int (big_int_of_string "-5299989648942") 32,
+   big_int_of_int (-1235));;
+test 6 eq_big_int
+  (shift_right_big_int (big_int_of_string "-16570089876543209725755392") 27,
+   big_int_of_string "-123456790123456789");;
+
+testing_function "shift_right_towards_zero_big_int";;
+
+test 1 eq_big_int
+  (shift_right_towards_zero_big_int (big_int_of_string "-5299989648942") 32,
+   big_int_of_int (-1234));;
+test 2 eq_big_int
+  (shift_right_towards_zero_big_int (big_int_of_string
+                                       "-16570089876543209725755392")
+                                    27,
+   big_int_of_string "-123456790123456789");;
+
+testing_function "extract_big_int";;
+
+test 1 eq_big_int
+  (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 3 13,
+   big_int_of_int 6589);;
+test 2 eq_big_int
+  (extract_big_int (big_int_128 h1 h2) 67 12,
+   big_int_of_int 1343);;
+test 3 eq_big_int
+  (extract_big_int (big_int_of_string "-1844674407370955178") 37 9,
+   big_int_of_int 307);;
+test 4 eq_big_int
+  (extract_big_int unit_big_int 2048 254,
+   zero_big_int);;
+test 5 eq_big_int
+  (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 0 32,
+   big_int_of_int64 2309737967L);;
+test 6 eq_big_int
+  (extract_big_int (big_int_of_int (-1)) 0 16,
+   big_int_of_int 0xFFFF);;
+test 7 eq_big_int
+  (extract_big_int (big_int_of_int (-1)) 1027 12,
+   big_int_of_int 0xFFF);;
+test 8 eq_big_int
+  (extract_big_int (big_int_of_int (-1234567)) 0 16,
+   big_int_of_int 10617);;
+test 9 eq_big_int
+  (extract_big_int (minus_big_int (power_int_positive_int 2 64)) 64 20,
+   big_int_of_int 0xFFFFF);;
+test 10 eq_big_int
+  (extract_big_int (pred_big_int (minus_big_int (power_int_positive_int 2 64)))
+                   64 20,
+   big_int_of_int 0xFFFFE);;
+
+testing_function "hashing of big integers";;
+
+test 1 eq_int (Hashtbl.hash zero_big_int,
+               955772237);;
+test 2 eq_int (Hashtbl.hash unit_big_int,
+               992063522);;
+test 3 eq_int (Hashtbl.hash (minus_big_int unit_big_int),
+               161678167);;
+test 4 eq_int (Hashtbl.hash (big_int_of_string "123456789123456789"),
+               755417385);;
+test 5 eq_int (Hashtbl.hash (sub_big_int
+                               (big_int_of_string "123456789123456789")
+                               (big_int_of_string "123456789123456789")),
+               955772237);;
+test 6 eq_int (Hashtbl.hash (sub_big_int
+                               (big_int_of_string "123456789123456789")
+                               (big_int_of_string "123456789123456788")),
+              992063522);;
+
+testing_function "float_of_big_int";;
+
+test 1 eq_float (float_of_big_int zero_big_int, 0.0);;
+test 2 eq_float (float_of_big_int unit_big_int, 1.0);;
+test 3 eq_float (float_of_big_int (minus_big_int unit_big_int), -1.0);;
+test 4 eq_float (float_of_big_int (shift_left_big_int unit_big_int 1024),
+                 infinity);;
+test 5 eq_float (float_of_big_int (shift_left_big_int unit_big_int 1023),
+                 ldexp 1.0 1023);;
+(* Some random int64 values *)
+let ok = ref true in
+for i = 1 to 100 do
+  let n = Random.int64 Int64.max_int in
+  if not (eq_float (float_of_big_int (big_int_of_int64 n)) (Int64.to_float n))
+  then ok := false;
+  let n = Int64.neg n in
+  if not (eq_float (float_of_big_int (big_int_of_int64 n)) (Int64.to_float n))
+  then ok := false
+done;
+test 6 eq (!ok, true);;
+(* Some random int64 values scaled by some random power of 2 *)
+let ok = ref true in
+for i = 1 to 1000 do
+  let n = Random.int64 Int64.max_int in
+  let exp = Random.int 1200 in
+  if not (eq_float
+             (float_of_big_int
+                 (shift_left_big_int (big_int_of_int64 n) exp))
+             (ldexp (Int64.to_float n) exp))
+  then ok := false;
+  let n = Int64.neg n in
+  if not (eq_float
+             (float_of_big_int
+                 (shift_left_big_int (big_int_of_int64 n) exp))
+             (ldexp (Int64.to_float n) exp))
+  then ok := false
+done;
+test 7 eq (!ok, true);;
+(* Round to nearest even *)
+let ok = ref true in
+for i = 0 to 15 do
+  let n = Int64.(add 0xfffffffffffff0L (of_int i)) in
+  if not (eq_float
+             (float_of_big_int
+                 (shift_left_big_int (big_int_of_int64 n) 32))
+             (ldexp (Int64.to_float n) 32))
+  then ok := false
+done;
+test 8 eq (!ok, true);;
diff --git a/testsuite/tests/lib-num/test_io.ml b/testsuite/tests/lib-num/test_io.ml
new file mode 100644
index 00000000..1df11a5f
--- /dev/null
+++ b/testsuite/tests/lib-num/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/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml
new file mode 100644
index 00000000..74ce5ecd
--- /dev/null
+++ b/testsuite/tests/lib-num/test_nats.ml
@@ -0,0 +1,148 @@
+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.init i (function 0 -> '1' | _ -> '0') in
+  ignore (test i eq_string (string_of_nat (nat_of_string s), s))
+done;;
+
+let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 =
+  ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3)
+;;
+
+let s =
+  "33333333333333333333333333333333333333333333333333333333333333333333\
+   33333333333333333333333333333333333333333333333333333333333333333333"
+in
+test 21 equal_nat (
+nat_of_string s,
+(let nat = make_nat 15 in
+  set_digit_nat nat 0 3;
+  set_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
+  ignore (gcd_nat nat1 0 1 nat2 0 1);
+  ignore (test i eq (int_of_nat nat1, 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/testsuite/tests/lib-num/test_nums.ml b/testsuite/tests/lib-num/test_nums.ml
new file mode 100644
index 00000000..e6cd5c9c
--- /dev/null
+++ b/testsuite/tests/lib-num/test_nums.ml
@@ -0,0 +1,234 @@
+open Test;;
+open Nat;;
+open Big_int;;
+open Ratio;;
+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");;
+
+test 12
+eq_num (num_of_string "0xAbCdEf",
+        Big_int (big_int_of_int 0xabcdef));;
+
+test 13
+eq_num (num_of_string "0b1101/0O1765",
+        Ratio (ratio_of_string "0b1101/0o1765"));;
+
+test 14
+eq_num (num_of_string "-12_34_56",
+        Big_int (big_int_of_int (-123456)));;
+
+test 15
+eq_num (num_of_string "0B101010", Big_int (big_int_of_int 42));;
+
+(*******
+
+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/testsuite/tests/lib-num/test_ratios.ml b/testsuite/tests/lib-num/test_ratios.ml
new file mode 100644
index 00000000..a5d8fe5e
--- /dev/null
+++ b/testsuite/tests/lib-num/test_ratios.ml
@@ -0,0 +1,1195 @@
+open Test;;
+open Nat;;
+open Big_int;;
+open Ratio;;
+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
+ignore (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
+ignore (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 = Bytes.of_string "+123456" in
+test 1 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+            false) &&
+test 2 eq_bytes (s, Bytes.of_string "+123466")
+;;
+
+let s = Bytes.of_string "123456" in
+test 3 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 4 eq_bytes (s, Bytes.of_string "123466")
+;;
+
+let s = Bytes.of_string "-123456" in
+test 5 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+            false) &&
+test 6 eq_bytes (s, Bytes.of_string "-123466")
+;;
+
+let s = Bytes.of_string "+123496" in
+test 7 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+            false) &&
+test 8 eq_bytes (s, Bytes.of_string "+123506")
+;;
+
+let s = Bytes.of_string "123496" in
+test 9 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 10 eq_bytes (s, Bytes.of_string "123506")
+;;
+
+let s = Bytes.of_string "-123496" in
+test 11 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+            false) &&
+test 12 eq_bytes (s, Bytes.of_string "-123506")
+;;
+
+let s = Bytes.of_string "+996" in
+test 13 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+            true) &&
+test 14 eq_bytes (s, Bytes.of_string "+006")
+;;
+
+let s = Bytes.of_string "996" in
+test 15 eq (round_futur_last_digit s 0 (Bytes.length s), true) &&
+test 16 eq_bytes (s, Bytes.of_string "006")
+;;
+
+let s = Bytes.of_string "-996" in
+test 17 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+             true) &&
+test 18 eq_bytes (s, Bytes.of_string "-006")
+;;
+
+let s = Bytes.of_string "+6666666" in
+test 19 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+             false) &&
+test 20 eq_bytes (s, Bytes.of_string "+6666676")
+;;
+
+let s = Bytes.of_string "6666666" in
+test 21 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 22 eq_bytes (s, Bytes.of_string "6666676")
+;;
+
+let s = Bytes.of_string "-6666666" in
+test 23 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
+             false) &&
+test 24 eq_bytes (s, Bytes.of_string "-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")
+;;
+
+(* PR#4566 *)
+test 12
+eq_string (approx_ratio_fix 8
+                            (create_ratio (big_int_of_int 9603)
+                                          (big_int_of_string "100000000000")),
+
+          "+0.00000010")
+;;
+test 13
+eq_string (approx_ratio_fix 1
+                            (create_ratio (big_int_of_int 94)
+                                          (big_int_of_int 1000)),
+          "+0.1")
+;;
+test 14
+eq_string (approx_ratio_fix 1
+                            (create_ratio (big_int_of_int 49)
+                                          (big_int_of_int 1000)),
+          "+0.0")
+;;
+
+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")
+;;
+
+testing_function "float_of_ratio";;
+let ok = ref true in
+for i = 1 to 100 do
+  let p = Random.int64 0x20000000000000L
+  and pexp = Random.int 100
+  and q = Random.int64 0x20000000000000L
+  and qexp = Random.int 100 in
+  if not (eq_float
+             (float_of_ratio
+               (create_ratio
+                 (shift_left_big_int (big_int_of_int64 p) pexp)
+                 (shift_left_big_int (big_int_of_int64 q) qexp)))
+             (ldexp (Int64.to_float p) pexp /.
+              ldexp (Int64.to_float q) qexp))
+  then ok := false
+done;
+test 1 eq (!ok, true)
+;;
diff --git a/testsuite/tests/lib-obj/Makefile b/testsuite/tests/lib-obj/Makefile
new file mode 100755
index 00000000..bb9cfbad
--- /dev/null
+++ b/testsuite/tests/lib-obj/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=
+MAIN_MODULE=reachable_words
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-obj/reachable_words.ml b/testsuite/tests/lib-obj/reachable_words.ml
new file mode 100755
index 00000000..68aeca47
--- /dev/null
+++ b/testsuite/tests/lib-obj/reachable_words.ml
@@ -0,0 +1,37 @@
+let native =
+  match Filename.basename Sys.argv.(0) with
+  | "program.byte" | "program.byte.exe" -> false
+  | "program.native" | "program.native.exe" -> true
+  | s -> print_endline s; assert false
+
+
+let size x = Obj.reachable_words (Obj.repr x)
+
+let expect_size s x =
+  let i = size x in
+  if i <> s then
+    Printf.printf "size = %i; expected = %i\n%!" i s
+
+type t =
+  | A of int
+  | B of t * t
+
+let f () =
+  let x = Random.int 10 in
+  expect_size 0 42;
+  expect_size (if native then 0 else 3) (1, 2);
+  expect_size 2 [| x |];
+  expect_size 3 [| x; 0 |];
+
+  let a = A x in
+  expect_size 2 a;
+  expect_size 5 (B (a, a)); (* sharing *)
+  expect_size 7 (B (a, A (x + 1)));
+
+  let rec b = B (a, b) in (* cycle *)
+  expect_size 5 b;
+
+  print_endline "OK"
+
+let () =
+  f ()
diff --git a/testsuite/tests/lib-obj/reachable_words.reference b/testsuite/tests/lib-obj/reachable_words.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/lib-obj/reachable_words.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile
new file mode 100644
index 00000000..d464524f
--- /dev/null
+++ b/testsuite/tests/lib-printf/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MODULES=testing
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-printf/pr6534.ml b/testsuite/tests/lib-printf/pr6534.ml
new file mode 100644
index 00000000..a356d521
--- /dev/null
+++ b/testsuite/tests/lib-printf/pr6534.ml
@@ -0,0 +1,19 @@
+(* these are not valid under -strict-formats, but we test them here
+   for backward-compatibility *)
+open Printf
+
+let () =
+  printf "1 [%.5s]\n" "foo";
+  printf "2 [%.*s]\n" 5 "foo";
+  printf "3 [%.-5s]\n" "foo";
+  printf "4 [%-.5s]\n" "foo";
+  printf "5 [%-.*s]\n" 5 "foo";
+  printf "6 [%.*s]\n" (-5) "foo";
+
+  printf "1 [%.7S]\n" "foo";
+  printf "2 [%.*S]\n" 7 "foo";
+  printf "3 [%.-7S]\n" "foo";
+  printf "4 [%-.7S]\n" "foo";
+  printf "5 [%-.*S]\n" 7 "foo";
+  printf "6 [%.*S]\n" (-7) "foo";
+  ()
diff --git a/testsuite/tests/lib-printf/pr6534.reference b/testsuite/tests/lib-printf/pr6534.reference
new file mode 100644
index 00000000..c3e2a7ff
--- /dev/null
+++ b/testsuite/tests/lib-printf/pr6534.reference
@@ -0,0 +1,14 @@
+1 [  foo]
+2 [  foo]
+3 [foo  ]
+4 [foo  ]
+5 [foo  ]
+6 [foo  ]
+1 [  "foo"]
+2 [  "foo"]
+3 ["foo"  ]
+4 ["foo"  ]
+5 ["foo"  ]
+6 ["foo"  ]
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-printf/pr6938.ml b/testsuite/tests/lib-printf/pr6938.ml
new file mode 100644
index 00000000..b081b4ce
--- /dev/null
+++ b/testsuite/tests/lib-printf/pr6938.ml
@@ -0,0 +1,42 @@
+(* these are not valid under -strict-formats, but we test them here
+   for backward-compatibility *)
+
+Printf.printf "%047.27d\n" 1036201459;;
+Printf.printf "%047.27ld\n" 1036201459l;;
+Printf.printf "%047.27Ld\n" 1036201459L;;
+Printf.printf "%047.27nd\n" 1036201459n;;
+
+print_newline ();;
+
+Printf.printf "%047.27i\n" 1036201459;;
+Printf.printf "%047.27li\n" 1036201459l;;
+Printf.printf "%047.27Li\n" 1036201459L;;
+Printf.printf "%047.27ni\n" 1036201459n;;
+
+print_newline ();;
+
+Printf.printf "%047.27u\n" 1036201459;;
+Printf.printf "%047.27lu\n" 1036201459l;;
+Printf.printf "%047.27Lu\n" 1036201459L;;
+Printf.printf "%047.27nu\n" 1036201459n;;
+
+print_newline ();;
+
+Printf.printf "%047.27x\n" 1036201459;;
+Printf.printf "%047.27lx\n" 1036201459l;;
+Printf.printf "%047.27Lx\n" 1036201459L;;
+Printf.printf "%047.27nx\n" 1036201459n;;
+
+print_newline ();;
+
+Printf.printf "%047.27X\n" 1036201459;;
+Printf.printf "%047.27lX\n" 1036201459l;;
+Printf.printf "%047.27LX\n" 1036201459L;;
+Printf.printf "%047.27nX\n" 1036201459n;;
+
+print_newline ();;
+
+Printf.printf "%047.27o\n" 1036201459;;
+Printf.printf "%047.27lo\n" 1036201459l;;
+Printf.printf "%047.27Lo\n" 1036201459L;;
+Printf.printf "%047.27no\n" 1036201459n;;
diff --git a/testsuite/tests/lib-printf/pr6938.reference b/testsuite/tests/lib-printf/pr6938.reference
new file mode 100644
index 00000000..3e5e220d
--- /dev/null
+++ b/testsuite/tests/lib-printf/pr6938.reference
@@ -0,0 +1,31 @@
+                    000000000000000001036201459
+                    000000000000000001036201459
+                    000000000000000001036201459
+                    000000000000000001036201459
+
+                    000000000000000001036201459
+                    000000000000000001036201459
+                    000000000000000001036201459
+                    000000000000000001036201459
+
+                    000000000000000001036201459
+                    000000000000000001036201459
+                    000000000000000001036201459
+                    000000000000000001036201459
+
+                    00000000000000000003dc32df3
+                    00000000000000000003dc32df3
+                    00000000000000000003dc32df3
+                    00000000000000000003dc32df3
+
+                    00000000000000000003DC32DF3
+                    00000000000000000003DC32DF3
+                    00000000000000000003DC32DF3
+                    00000000000000000003DC32DF3
+
+                    000000000000000007560626763
+                    000000000000000007560626763
+                    000000000000000007560626763
+                    000000000000000007560626763
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
new file mode 100644
index 00000000..4ab57230
--- /dev/null
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -0,0 +1,609 @@
+(*
+
+A test file for the Printf module.
+
+*)
+
+open Testing;;
+open Printf;;
+
+try
+
+  printf "d/i positive\n%!";
+  test (sprintf "%d/%i" 42 43 = "42/43");
+  test (sprintf "%-4d/%-5i" 42 43 = "42  /43   ");
+  test (sprintf "%04d/%05i" 42 43 = "0042/00043");
+  test (sprintf "%+d/%+i" 42 43 = "+42/+43");
+  test (sprintf "% d/% i" 42 43 = " 42/ 43");
+  (*test (sprintf "%#d/%#i" 42 43 = "42/43");*)
+    (* >> '#' is incompatible with 'd' *)
+  test (sprintf "%4d/%5i" 42 43 = "  42/   43");
+  test (sprintf "%*d" (-4) 42 = "42  ");
+  test (sprintf "%*d/%*i" 4 42 5 43 = "  42/   43");
+  (*test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43  ");*)
+    (* >> '#' is incompatible with 'd' *)
+
+  printf "\nd/i negative\n%!";
+  test (sprintf "%d/%i" (-42) (-43) = "-42/-43");
+  test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43  ");
+  test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043");
+  test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43");
+  test (sprintf "% d/% i" (-42) (-43) = "-42/-43");
+  (*test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");*)
+    (* >> '#' is incompatible with 'd' *)
+  test (sprintf "%4d/%5i" (-42) (-43) = " -42/  -43");
+  test (sprintf "%*d" (-4) (-42) = "-42 ");
+  test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/  -43");
+  (*test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43  ");*)
+    (* >> '0' is incompatible with '-', '#' is incompatible with 'd' *)
+
+  printf "\nu positive\n%!";
+  test (sprintf "%u" 42 = "42");
+  test (sprintf "%-4u" 42 = "42  ");
+  test (sprintf "%04u" 42 = "0042");
+  (*test (sprintf "%+u" 42 = "42");*)
+    (* >> '+' is incompatible with 'u' *)
+  (*test (sprintf "% u" 42 = "42");*)
+    (* >> ' ' is incompatible with 'u' *)
+  (*test (sprintf "%#u" 42 = "42");*)
+    (* >> '#' is incompatible with 'u' *)
+  test (sprintf "%4u" 42 = "  42");
+  test (sprintf "%*u" 4 42 = "  42");
+  test (sprintf "%*u" (-4) 42 = "42  ");
+
+  printf "\nu negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%u" (-1) = "2147483647");
+  | 64 ->
+     test (sprintf "%u" (-1) = "9223372036854775807");
+  | _ -> test false
+  end;
+
+  printf "\nx positive\n%!";
+  test (sprintf "%x" 42 = "2a");
+  test (sprintf "%-4x" 42 = "2a  ");
+  test (sprintf "%04x" 42 = "002a");
+  (*test (sprintf "%+x" 42 = "2a");*)
+    (* >> '+' is incompatible with 'x' *)
+  (*test (sprintf "% x" 42 = "2a");*)
+    (* >> ' ' is incompatible with 'x' *)
+  test (sprintf "%#x" 42 = "0x2a");
+  test (sprintf "%4x" 42 = "  2a");
+  test (sprintf "%*x" 5 42 = "   2a");
+  test (sprintf "%*x" (-5) 42 = "2a   ");
+  test (sprintf "%#*x" 5 42 = " 0x2a");
+  test (sprintf "%#*x" (-5) 42 = "0x2a ");
+  test (sprintf "%#-*x" 5 42 = "0x2a ");
+  test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
+
+  printf "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%x" (-42) = "7fffffd6");
+  | 64 ->
+     test (sprintf "%x" (-42) = "7fffffffffffffd6");
+  | _ -> test false
+  end;
+
+  printf "\nX positive\n%!";
+  test (sprintf "%X" 42 = "2A");
+  test (sprintf "%-4X" 42 = "2A  ");
+  test (sprintf "%04X" 42 = "002A");
+  (*test (sprintf "%+X" 42 = "2A");*)
+    (* >> '+' is incompatible with 'X' *)
+  (*test (sprintf "% X" 42 = "2A");*)
+    (* >> ' ' is incompatible with 'X' *)
+  test (sprintf "%#X" 42 = "0X2A");
+  test (sprintf "%4X" 42 = "  2A");
+  test (sprintf "%*X" 5 42 = "   2A");
+  (*test (sprintf "%-0+ #*X" 5 42 = "0X2A ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%X" (-42) = "7FFFFFD6");
+  | 64 ->
+     test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6");
+  | _ -> test false
+  end;
+
+  printf "\no positive\n%!";
+  test (sprintf "%o" 42 = "52");
+  test (sprintf "%-4o" 42 = "52  ");
+  test (sprintf "%04o" 42 = "0052");
+  (*test (sprintf "%+o" 42 = "52");*)
+    (* >> '+' is incompatible with 'o' *)
+  (*test (sprintf "% o" 42 = "52");*)
+    (* >> '+' is incompatible with 'o' *)
+  test (sprintf "%#o" 42 = "052");
+  test (sprintf "%4o" 42 = "  52");
+  test (sprintf "%*o" 5 42 = "   52");
+  (*test (sprintf "%-0+ #*o" 5 42 = "052  ");*)
+    (* >> '-' is incompatible with 'o' *)
+
+  printf "\no negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%o" (-42) = "17777777726");
+  | 64 ->
+     test (sprintf "%o" (-42) = "777777777777777777726");
+  | _ -> test false
+  end;
+
+  printf "\ns\n%!";
+  test (sprintf "%s" "foo" = "foo");
+  test (sprintf "%-5s" "foo" = "foo  ");
+  (*test (sprintf "%05s" "foo" = "  foo");*)
+    (* >> '0' is incompatible with 's' *)
+  (*test (sprintf "%+s" "foo" = "foo");*)
+    (* >> '+' is incompatible with 's' *)
+  (*test (sprintf "% s" "foo" = "foo");*)
+    (* >> ' ' is incompatible with 's' *)
+  (*test (sprintf "%#s" "foo" = "foo");*)
+    (* >> '#' is incompatible with 's' *)
+  test (sprintf "%5s" "foo" = "  foo");
+  test (sprintf "%1s" "foo" = "foo");
+  test (sprintf "%*s" 6 "foo" = "   foo");
+  test (sprintf "%*s" (-6) "foo" = "foo   ");
+  test (sprintf "%*s" 2 "foo" = "foo");
+  (*test (sprintf "%-0+ #5s" "foo" = "foo  ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 's' *)
+  test (sprintf "%s@" "foo" = "foo@");
+  test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr");
+  test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr");
+
+  printf "\nS\n%!";
+  test (sprintf "%S" "fo\"o" = "\"fo\\\"o\"");
+(*  test (sprintf "%-5S" "foo" = "\"foo\"  ");   padding not done *)
+(*  test (sprintf "%05S" "foo" = "  \"foo\"");   padding not done *)
+  (*test (sprintf "%+S" "foo" = "\"foo\"");*)
+    (* >> '#' is incompatible with 'S' *)
+  (*test (sprintf "% S" "foo" = "\"foo\"");*)
+    (* >> '#' is incompatible with 'S' *)
+  (*test (sprintf "%#S" "foo" = "\"foo\"");*)
+    (* >> '#' is incompatible with 'S' *)
+(*  test (sprintf "%5S" "foo" = "  \"foo\"");    padding not done *)
+  test (sprintf "%1S" "foo" = "\"foo\"");
+  test (sprintf "%*S" 8 "foo" = "   \"foo\"");
+  test (sprintf "%*S" (-8) "foo" = "\"foo\"   ");
+  test (sprintf "%*S" 2 "foo" = "\"foo\"");
+(*  test (sprintf "%-0+ #5S" "foo" = "\"foo\"  ");  padding not done *)
+  test (sprintf "%S@" "foo" = "\"foo\"@");
+  test (sprintf "%S@inria.fr" "foo" = "\"foo\"@inria.fr");
+  test (sprintf "%S@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\"");
+
+  printf "\nc\n%!";
+  test (sprintf "%c" 'c' = "c");
+(*  test (sprintf "%-4c" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04c" 'c' = "   c");    padding not done *)
+  (*test (sprintf "%+c" 'c' = "c");*)
+    (* >> '#' is incompatible with 'c' *)
+  (*test (sprintf "% c" 'c' = "c");*)
+    (* >> '#' is incompatible with 'c' *)
+  (*test (sprintf "%#c" 'c' = "c");*)
+    (* >> '#' is incompatible with 'c' *)
+(*  test (sprintf "%4c" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*c" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4c" 'c' = "c   ");  padding not done *)
+
+  printf "\nC\n%!";
+  test (sprintf "%C" 'c' = "'c'");
+  test (sprintf "%C" '\'' = "'\\''");
+(*  test (sprintf "%-4C" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04C" 'c' = "   c");    padding not done *)
+  (*test (sprintf "%+C" 'c' = "'c'");*)
+    (* >> '+' is incompatible with 'C' *)
+  (*test (sprintf "% C" 'c' = "'c'");*)
+    (* >> ' ' is incompatible with 'C' *)
+  (*test (sprintf "%#C" 'c' = "'c'");*)
+    (* >> '#' is incompatible with 'C' *)
+(*  test (sprintf "%4C" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*C" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4C" 'c' = "c   ");  padding not done *)
+
+  printf "\nf\n%!";
+  test (sprintf "%f" (-42.42) = "-42.420000");
+  test (sprintf "%-13f" (-42.42) = "-42.420000   ");
+  test (sprintf "%013f" (-42.42) = "-00042.420000");
+  test (sprintf "%+f" 42.42 = "+42.420000");
+  test (sprintf "% f" 42.42 = " 42.420000");
+  (*test (sprintf "%#f" 42.42 = "42.420000");*)
+    (* >> '#' is incompatible with 'f' *)
+  test (sprintf "%13f" 42.42 = "    42.420000");
+  test (sprintf "%*f" 12 42.42 = "   42.420000");
+  (*test (sprintf "%-0+ #12f" 42.42 = "+42.420000  ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *)
+  test (sprintf "%.3f" (-42.42) = "-42.420");
+  test (sprintf "%.*f" (-3) 42.42 = "42.420");
+    (* dynamically-provided negative precisions are currently silently
+       turned into their absolute value; we could error on this
+       in the future (the behavior is unspecified), but the previous
+       buggy output "%.0-3f-" is not desirable. *)
+  test (sprintf "%-13.3f" (-42.42) = "-42.420      ");
+  test (sprintf "%013.3f" (-42.42) = "-00000042.420");
+  test (sprintf "%+.3f" 42.42 = "+42.420");
+  test (sprintf "% .3f" 42.42 = " 42.420");
+  (*test (sprintf "%#.3f" 42.42 = "42.420");*)
+    (* >> '#' is incompatible with 'f' *)
+  test (sprintf "%13.3f" 42.42 = "       42.420");
+  test (sprintf "%*.*f" 12 3 42.42 = "      42.420");
+  (*test (sprintf "%-0+ #12.3f" 42.42 = "+42.420     ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *)
+
+  (* Under Windows (mingw and maybe also MSVC), the stdlib uses three
+     digits for the exponent instead of the two used by Linux and BSD.
+     Check that the two strings are equal, except that there may be an
+     extra zero, and if there is one, there may be a missing space or
+     zero. All in the first string relative to the second. *)
+  let ( =* ) s1 s2 =
+    let ss1 = s1 ^ "$" in
+    let ss2 = s2 ^ "$" in
+    let rec loop i1 i2 extra missing =
+      if i1 = String.length ss1 && i2 = String.length ss2 then begin
+        if extra then true else not missing
+      end else if i1 = String.length ss1 || i2 = String.length ss2 then
+        false
+      else begin
+        match ss1.[i1], ss2.[i2] with
+        | x, y when x = y -> loop (i1+1) (i2+1) extra missing
+        | '0', _ when not extra -> loop (i1+1) i2 true missing
+        | _, (' '|'0') when not missing -> loop i1 (i2+1) extra true
+        | _, _ -> false
+      end
+    in
+    loop 0 0 false false
+  in
+
+  printf "\nF\n%!";
+  test (sprintf "%F" 42.42 = "42.42");
+  test (sprintf "%F" 42.42e42 =* "4.242e+43");
+  test (sprintf "%F" 42.00 = "42.");
+  test (sprintf "%F" 0.042 = "0.042");
+  test (sprintf "%4F" 3. = "  3.");
+  test (sprintf "%-4F" 3. = "3.  ");
+  test (sprintf "%04F" 3. = "003.");
+(* plus-padding unsupported
+  test (sprintf "%+4F" 3. = " +3.");
+*)
+(* no precision
+  test (sprintf "%.3F" 42.42 = "42.420");
+  test (sprintf "%12.3F" 42.42e42 = "   4.242e+43");
+  test (sprintf "%.3F" 42.00 = "42.000");
+  test (sprintf "%.3F" 0.0042 = "0.004");
+*)
+
+  printf "\nh\n%!";
+  test (sprintf "%+h" (+0.) = "+0x0p+0");
+  test (sprintf "%+h" (-0.) = "-0x0p+0");
+  test (sprintf "%+h" (+1.) = "+0x1p+0");
+  test (sprintf "%+h" (-1.) = "-0x1p+0");
+  test (sprintf "%+h" (+1024.) = "+0x1p+10");
+  test (sprintf "%+h" (-1024.) = "-0x1p+10");
+  test (sprintf "%h" 0x123.456 = "0x1.23456p+8");
+  test (sprintf "%h" 0x123456789ABCDE. = "0x1.23456789abcdep+52");
+  test (sprintf "%h" epsilon_float = "0x1p-52");
+  test (sprintf "%h" nan = "nan");
+  test (sprintf "%h" infinity = "infinity");
+  test (sprintf "%h" neg_infinity = "-infinity");
+  test (sprintf "%h" (4. *. atan 1.) = "0x1.921fb54442d18p+1");
+
+  printf "\nH\n%!";
+  test (sprintf "%+H" (+0.) = "+0X0P+0");
+  test (sprintf "%+H" (-0.) = "-0X0P+0");
+  test (sprintf "%+H" (+1.) = "+0X1P+0");
+  test (sprintf "%+H" (-1.) = "-0X1P+0");
+  test (sprintf "%+H" (+1024.) = "+0X1P+10");
+  test (sprintf "%+H" (-1024.) = "-0X1P+10");
+  test (sprintf "%H" 0X123.456 = "0X1.23456P+8");
+  test (sprintf "%H" 0X123456789ABCDE. = "0X1.23456789ABCDEP+52");
+  test (sprintf "%H" epsilon_float = "0X1P-52");
+  test (sprintf "%H" nan = "NAN");
+  test (sprintf "%H" infinity = "INFINITY");
+  test (sprintf "%H" neg_infinity = "-INFINITY");
+  test (sprintf "%H" (4. *. atan 1.) = "0X1.921FB54442D18P+1");
+
+  printf "\ne\n%!";
+  test (sprintf "%e" (-42.42) =* "-4.242000e+01");
+  test (sprintf "%-15e" (-42.42) =* "-4.242000e+01  ");
+  test (sprintf "%015e" (-42.42) =* "-004.242000e+01");
+  test (sprintf "%+e" 42.42 =* "+4.242000e+01");
+  test (sprintf "% e" 42.42 =* " 4.242000e+01");
+  (*test (sprintf "%#e" 42.42 =* "4.242000e+01");*)
+    (* >> '#' is incompatible with 'e' *)
+  test (sprintf "%15e" 42.42 =* "   4.242000e+01");
+  test (sprintf "%*e" 14 42.42 =* "  4.242000e+01");
+  (*test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'e' *)
+  test (sprintf "%.3e" (-42.42) =* "-4.242e+01");
+  test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01     ");
+  test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01");
+  test (sprintf "%+.3e" 42.42 =* "+4.242e+01");
+  test (sprintf "% .3e" 42.42 =* " 4.242e+01");
+  (*test (sprintf "%#.3e" 42.42 =* "4.242e+01");*)
+    (* >> '#' is incompatible with 'e' *)
+  test (sprintf "%15.3e" 42.42 =* "      4.242e+01");
+  test (sprintf "%*.*e" 11 3 42.42 =* "  4.242e+01");
+  (*test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01    ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'e' *)
+
+  printf "\nE\n%!";
+  test (sprintf "%E" (-42.42) =* "-4.242000E+01");
+  test (sprintf "%-15E" (-42.42) =* "-4.242000E+01  ");
+  test (sprintf "%015E" (-42.42) =* "-004.242000E+01");
+  test (sprintf "%+E" 42.42 =* "+4.242000E+01");
+  test (sprintf "% E" 42.42 =* " 4.242000E+01");
+  (*test (sprintf "%#E" 42.42 =* "4.242000E+01");*)
+    (* >> '#' is incompatible with 'E' *)
+  test (sprintf "%15E" 42.42 =* "   4.242000E+01");
+  test (sprintf "%*E" 14 42.42 =* "  4.242000E+01");
+  (*test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");*)
+    (* >> '#' is incompatible with 'E' *)
+  test (sprintf "%.3E" (-42.42) =* "-4.242E+01");
+  test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01     ");
+  test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01");
+  test (sprintf "%+.3E" 42.42 =* "+4.242E+01");
+  test (sprintf "% .3E" 42.42 =* " 4.242E+01");
+  (*test (sprintf "%#.3E" 42.42 =* "4.242E+01");*)
+    (* >> '#' is incompatible with 'E' *)
+  test (sprintf "%15.3E" 42.42 =* "      4.242E+01");
+  test (sprintf "%*.*E" 11 3 42.42 =* "  4.242E+01");
+  (*test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01    ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'E' *)
+
+(* %g gives strange results that correspond to neither %f nor %e
+  printf "\ng\n%!";
+  test (sprintf "%g" (-42.42) = "-42.42000");
+  test (sprintf "%-15g" (-42.42) = "-42.42000      ");
+  test (sprintf "%015g" (-42.42) = "-00000042.42000");
+  test (sprintf "%+g" 42.42 = "+42.42000");
+  test (sprintf "% g" 42.42 = " 42.42000");
+  test (sprintf "%#g" 42.42 = "42.42000");
+  test (sprintf "%15g" 42.42 = "       42.42000");
+  test (sprintf "%*g" 14 42.42 = "      42.42000");
+  test (sprintf "%-0+ #14g" 42.42 = "+42.42000     ");
+  test (sprintf "%.3g" (-42.42) = "-42.420");
+*)
+
+(* Same for %G
+  printf "\nG\n%!";
+*)
+
+  printf "\nB\n%!";
+  test (sprintf "%B" true = "true");
+  test (sprintf "%B" false = "false");
+
+  printf "\nld/li positive\n%!";
+  test (sprintf "%ld/%li" 42l 43l = "42/43");
+  test (sprintf "%-4ld/%-5li" 42l 43l = "42  /43   ");
+  test (sprintf "%04ld/%05li" 42l 43l = "0042/00043");
+  test (sprintf "%+ld/%+li" 42l 43l = "+42/+43");
+  test (sprintf "% ld/% li" 42l 43l = " 42/ 43");
+  (*test (sprintf "%#ld/%#li" 42l 43l = "42/43");*)
+    (* >> '#' is incompatible with 'ld' *)
+  test (sprintf "%4ld/%5li" 42l 43l = "  42/   43");
+  test (sprintf "%*ld/%*li" 4 42l 5 43l = "  42/   43");
+  (*test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43  ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *)
+
+  printf "\nld/li negative\n%!";
+  test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43  ");
+  test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043");
+  test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43");
+  (*test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");*)
+    (* >> '#' is incompatible with 'ld' *)
+  test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/  -43");
+  test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/  -43");
+  (*test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43  ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *)
+
+  printf "\nlu positive\n%!";
+  test (sprintf "%lu" 42l = "42");
+  test (sprintf "%-4lu" 42l = "42  ");
+  test (sprintf "%04lu" 42l = "0042");
+  (*test (sprintf "%+lu" 42l = "42");*)
+    (* >> '+' is incompatible with 'lu' *)
+  (*test (sprintf "% lu" 42l = "42");*)
+    (* >> ' ' is incompatible with 'lu' *)
+  (*test (sprintf "%#lu" 42l = "42");*)
+    (* >> '#' is incompatible with 'lu' *)
+  test (sprintf "%4lu" 42l = "  42");
+  test (sprintf "%*lu" 4 42l = "  42");
+  (*test (sprintf "%-0+ #6ld" 42l = "+42   ");*)
+    (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *)
+
+  printf "\nlu negative\n%!";
+  test (sprintf "%lu" (-1l) = "4294967295");
+
+  printf "\nlx positive\n%!";
+  test (sprintf "%lx" 42l = "2a");
+  test (sprintf "%-4lx" 42l = "2a  ");
+  test (sprintf "%04lx" 42l = "002a");
+  (*test (sprintf "%+lx" 42l = "2a");*)
+    (* >> '+' is incompatible with 'lx' *)
+  (*test (sprintf "% lx" 42l = "2a");*)
+    (* >> ' ' is incompatible with 'lx' *)
+  test (sprintf "%#lx" 42l = "0x2a");
+  test (sprintf "%4lx" 42l = "  2a");
+  test (sprintf "%*lx" 5 42l = "   2a");
+  (*test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nlx negative\n%!";
+  test (sprintf "%lx" (-42l) = "ffffffd6");
+
+  printf "\nlX positive\n%!";
+  test (sprintf "%lX" 42l = "2A");
+  test (sprintf "%-4lX" 42l = "2A  ");
+  test (sprintf "%04lX" 42l = "002A");
+  (*test (sprintf "%+lX" 42l = "2A");*)
+    (* >> '+' is incompatible with 'lX' *)
+  (*test (sprintf "% lX" 42l = "2A");*)
+    (* >> ' ' is incompatible with 'lX' *)
+  test (sprintf "%#lX" 42l = "0X2A");
+  test (sprintf "%4lX" 42l = "  2A");
+  test (sprintf "%*lX" 5 42l = "   2A");
+  (*test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nlx negative\n%!";
+  test (sprintf "%lX" (-42l) = "FFFFFFD6");
+
+  printf "\nlo positive\n%!";
+  test (sprintf "%lo" 42l = "52");
+  test (sprintf "%-4lo" 42l = "52  ");
+  test (sprintf "%04lo" 42l = "0052");
+  (*test (sprintf "%+lo" 42l = "52");*)
+    (* >> '+' is incompatible with 'lo' *)
+  (*test (sprintf "% lo" 42l = "52");*)
+    (* >> ' ' is incompatible with 'lo' *)
+  test (sprintf "%#lo" 42l = "052");
+  test (sprintf "%4lo" 42l = "  52");
+  test (sprintf "%*lo" 5 42l = "   52");
+  (*test (sprintf "%-0+ #*lo" 5 42l = "052  ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nlo negative\n%!";
+  test (sprintf "%lo" (-42l) = "37777777726");
+
+  (* Nativeint not tested: looks like too much work, and anyway it should
+     work like Int32 or Int64. *)
+
+  printf "\nLd/Li positive\n%!";
+  test (sprintf "%Ld/%Li" 42L 43L = "42/43");
+  test (sprintf "%-4Ld/%-5Li" 42L 43L = "42  /43   ");
+  test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043");
+  (*test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");*)
+    (* >> '+' is incompatible with 'Ld' *)
+  (*test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");*)
+    (* >> ' ' is incompatible with 'Ld' *)
+  (*test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");*)
+    (* >> '#' is incompatible with 'Ld' *)
+  test (sprintf "%4Ld/%5Li" 42L 43L = "  42/   43");
+  test (sprintf "%*Ld/%*Li" 4 42L 5 43L = "  42/   43");
+  (*test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43  ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nLd/Li negative\n%!";
+  test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43  ");
+  test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043");
+  (*test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");*)
+    (* >> '+' is incompatible with 'Ld' *)
+  (*test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");*)
+    (* >> ' ' is incompatible with 'Ld' *)
+  (*test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");*)
+    (* >> '#' is incompatible with 'Ld' *)
+  test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/  -43");
+  test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/  -43");
+  (*test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43  ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nLu positive\n%!";
+  test (sprintf "%Lu" 42L = "42");
+  test (sprintf "%-4Lu" 42L = "42  ");
+  test (sprintf "%04Lu" 42L = "0042");
+  (*test (sprintf "%+Lu" 42L = "42");*)
+    (* >> '+' is incompatible with 'Lu' *)
+  (*test (sprintf "% Lu" 42L = "42");*)
+    (* >> ' ' is incompatible with 'Lu' *)
+  (*test (sprintf "%#Lu" 42L = "42");*)
+    (* >> '#' is incompatible with 'Lu' *)
+  test (sprintf "%4Lu" 42L = "  42");
+  test (sprintf "%*Lu" 4 42L = "  42");
+  (*test (sprintf "%-0+ #6Ld" 42L = "+42   ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nLu negative\n%!";
+  test (sprintf "%Lu" (-1L) = "18446744073709551615");
+
+  printf "\nLx positive\n%!";
+  test (sprintf "%Lx" 42L = "2a");
+  test (sprintf "%-4Lx" 42L = "2a  ");
+  test (sprintf "%04Lx" 42L = "002a");
+  (*test (sprintf "%+Lx" 42L = "2a");*)
+    (* >> '+' is incompatible with 'Lx' *)
+  (*test (sprintf "% Lx" 42L = "2a");*)
+    (* >> ' ' is incompatible with 'Lx' *)
+  test (sprintf "%#Lx" 42L = "0x2a");
+  test (sprintf "%4Lx" 42L = "  2a");
+  test (sprintf "%*Lx" 5 42L = "   2a");
+  (*test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nLx negative\n%!";
+  test (sprintf "%Lx" (-42L) = "ffffffffffffffd6");
+
+  printf "\nLX positive\n%!";
+  test (sprintf "%LX" 42L = "2A");
+  test (sprintf "%-4LX" 42L = "2A  ");
+  test (sprintf "%04LX" 42L = "002A");
+  (*test (sprintf "%+LX" 42L = "2A");*)
+    (* >> '+' is incompatible with 'LX' *)
+  (*test (sprintf "% LX" 42L = "2A");*)
+    (* >> ' ' is incompatible with 'LX' *)
+  test (sprintf "%#LX" 42L = "0X2A");
+  test (sprintf "%4LX" 42L = "  2A");
+  test (sprintf "%*LX" 5 42L = "   2A");
+  (*test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nLx negative\n%!";
+  test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6");
+
+  printf "\nLo positive\n%!";
+  test (sprintf "%Lo" 42L = "52");
+  test (sprintf "%-4Lo" 42L = "52  ");
+  test (sprintf "%04Lo" 42L = "0052");
+  (*test (sprintf "%+Lo" 42L = "52");*)
+    (* >> '+' is incompatible with 'Lo' *)
+  (*test (sprintf "% Lo" 42L = "52");*)
+    (* >> ' ' is incompatible with 'Lo' *)
+  test (sprintf "%#Lo" 42L = "052");
+  test (sprintf "%4Lo" 42L = "  52");
+  test (sprintf "%*Lo" 5 42L = "   52");
+  (*test (sprintf "%-0+ #*Lo" 5 42L = "052  ");*)
+    (* >> '-' is incompatible with '0' *)
+
+  printf "\nLo negative\n%!";
+  test (sprintf "%Lo" (-42L) = "1777777777777777777726");
+
+  printf "\na\n%!";
+  let x = ref () in
+  let f () y = if y == x then "ok" else "wrong" in
+  test (sprintf "%a" f x = "ok");
+
+  printf "\nt\n%!";
+  let f () = "ok" in
+  test (sprintf "%t" f = "ok");
+
+  (* Work as expected. Prints the format string type digest.
+     If you want to print the contents of the format string,
+     do not use a meta format; simply convert the format string
+     to a string and print it using %s. *)
+
+  printf "\n{...%%}\n%!";
+  let f = format_of_string "%4g/%s" in
+  test (sprintf "%{%.4F%5S%}" f = "%f%s");
+
+  printf "\n(...%%)\n%!";
+  let f = format_of_string "%d/foo/%s" in
+  test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar");
+
+  printf "\n! %% @ , and constants\n%!";
+  test (sprintf "%!" = "");
+  test (sprintf "%%" = "%");
+  test (sprintf "%@" = "@");
+  test (sprintf "%," = "");
+  test (sprintf "@" = "@");
+  test (sprintf "@@" = "@@");
+  test (sprintf "@%%" = "@%");
+
+  printf "\nend of tests\n%!";
+with e ->
+  printf "unexpected exception: %s\n%!" (Printexc.to_string e);
+  test false;
+;;
diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference
new file mode 100644
index 00000000..de3dc1db
--- /dev/null
+++ b/testsuite/tests/lib-printf/tprintf.reference
@@ -0,0 +1,95 @@
+d/i positive
+ 0 1 2 3 4 5 6 7
+d/i negative
+ 8 9 10 11 12 13 14 15
+u positive
+ 16 17 18 19 20 21
+u negative
+ 22
+x positive
+ 23 24 25 26 27 28 29 30 31 32 33
+x negative
+ 34
+X positive
+ 35 36 37 38 39 40
+x negative
+ 41
+o positive
+ 42 43 44 45 46 47
+o negative
+ 48
+s
+ 49 50 51 52 53 54 55 56 57 58
+S
+ 59 60 61 62 63 64 65 66
+c
+ 67
+C
+ 68 69
+f
+ 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
+F
+ 85 86 87 88 89 90 91
+h
+ 92 93 94 95 96 97 98 99 100 101 102 103 104
+H
+ 105 106 107 108 109 110 111 112 113 114 115 116 117
+e
+ 118 119 120 121 122 123 124 125 126 127 128 129 130 131
+E
+ 132 133 134 135 136 137 138 139 140 141 142 143 144 145
+B
+ 146 147
+ld/li positive
+ 148 149 150 151 152 153 154
+ld/li negative
+ 155 156 157 158 159 160 161
+lu positive
+ 162 163 164 165 166
+lu negative
+ 167
+lx positive
+ 168 169 170 171 172 173
+lx negative
+ 174
+lX positive
+ 175 176 177 178 179 180
+lx negative
+ 181
+lo positive
+ 182 183 184 185 186 187
+lo negative
+ 188
+Ld/Li positive
+ 189 190 191 192 193
+Ld/Li negative
+ 194 195 196 197 198
+Lu positive
+ 199 200 201 202 203
+Lu negative
+ 204
+Lx positive
+ 205 206 207 208 209 210
+Lx negative
+ 211
+LX positive
+ 212 213 214 215 216 217
+Lx negative
+ 218
+Lo positive
+ 219 220 221 222 223 224
+Lo negative
+ 225
+a
+ 226
+t
+ 227
+{...%}
+ 228
+(...%)
+ 229
+! % @ , and constants
+ 230 231 232 233 234 235 236
+end of tests
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-queue/Makefile b/testsuite/tests/lib-queue/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-queue/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-queue/test.ml b/testsuite/tests/lib-queue/test.ml
new file mode 100644
index 00000000..5574abd8
--- /dev/null
+++ b/testsuite/tests/lib-queue/test.ml
@@ -0,0 +1,138 @@
+module Q = struct
+  include Queue
+
+  let to_list q = fold (fun l x -> x :: l) [] q |> List.rev
+end
+
+let does_raise f q =
+  try
+    ignore (f q : int);
+    false
+  with Q.Empty ->
+    true
+
+let () =
+  let q = Q.create () in
+  ();                    assert (Q.to_list q = [          ] && Q.length q = 0);
+  Q.add 1 q;             assert (Q.to_list q = [1         ] && Q.length q = 1);
+  Q.add 2 q;             assert (Q.to_list q = [1; 2      ] && Q.length q = 2);
+  Q.add 3 q;             assert (Q.to_list q = [1; 2; 3   ] && Q.length q = 3);
+  Q.add 4 q;             assert (Q.to_list q = [1; 2; 3; 4] && Q.length q = 4);
+  assert (Q.take q = 1); assert (Q.to_list q = [   2; 3; 4] && Q.length q = 3);
+  assert (Q.take q = 2); assert (Q.to_list q = [      3; 4] && Q.length q = 2);
+  assert (Q.take q = 3); assert (Q.to_list q = [         4] && Q.length q = 1);
+  assert (Q.take q = 4); assert (Q.to_list q = [          ] && Q.length q = 0);
+  assert (does_raise Q.take q);
+;;
+
+let () =
+  let q = Q.create () in
+  Q.add 1 q; assert (Q.take q = 1); assert (does_raise Q.take q);
+  Q.add 2 q; assert (Q.take q = 2); assert (does_raise Q.take q);
+  assert (Q.length q = 0);
+;;
+
+let () =
+  let q = Q.create () in
+  Q.add 1 q; assert (Q.peek q = 1);
+  Q.add 2 q; assert (Q.peek q = 1);
+  Q.add 3 q; assert (Q.peek q = 1);
+  assert (Q.peek q = 1); assert (Q.take q = 1);
+  assert (Q.peek q = 2); assert (Q.take q = 2);
+  assert (Q.peek q = 3); assert (Q.take q = 3);
+  assert (does_raise Q.peek q);
+  assert (does_raise Q.peek q);
+;;
+
+let () =
+  let q = Q.create () in
+  for i = 1 to 10 do Q.add i q done;
+  Q.clear q;
+  assert (Q.length q = 0);
+  assert (does_raise Q.take q);
+  assert (q = Q.create ());
+  Q.add 42 q;
+  assert (Q.take q = 42);
+;;
+
+let () =
+  let q1 = Q.create () in
+  for i = 1 to 10 do Q.add i q1 done;
+  let q2 = Q.copy q1 in
+  assert (Q.to_list q1 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]);
+  assert (Q.to_list q2 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]);
+  assert (Q.length q1 = 10);
+  assert (Q.length q2 = 10);
+  for i = 1 to 10 do
+    assert (Q.take q1 = i);
+  done;
+  for i = 1 to 10 do
+    assert (Q.take q2 = i);
+  done;
+;;
+
+let () =
+  let q = Q.create () in
+  assert (Q.is_empty q);
+  for i = 1 to 10 do
+    Q.add i q;
+    assert (Q.length q = i);
+    assert (not (Q.is_empty q));
+  done;
+  for i = 10 downto 1 do
+    assert (Q.length q = i);
+    assert (not (Q.is_empty q));
+    ignore (Q.take q : int);
+  done;
+  assert (Q.length q = 0);
+  assert (Q.is_empty q);
+;;
+
+let () =
+  let q = Q.create () in
+  for i = 1 to 10 do Q.add i q done;
+  let i = ref 1 in
+  Q.iter (fun j -> assert (!i = j); incr i) q;
+;;
+
+let () =
+  let q1 = Q.create () and q2 = Q.create () in
+  assert (Q.length q1 = 0); assert (Q.to_list q1 = []);
+  assert (Q.length q2 = 0); assert (Q.to_list q2 = []);
+  Q.transfer q1 q2;
+  assert (Q.length q1 = 0); assert (Q.to_list q1 = []);
+  assert (Q.length q2 = 0); assert (Q.to_list q2 = []);
+;;
+
+let () =
+  let q1 = Q.create () and q2 = Q.create () in
+  for i = 1 to 4 do Q.add i q1 done;
+  assert (Q.length q1 = 4); assert (Q.to_list q1 = [1; 2; 3; 4]);
+  assert (Q.length q2 = 0); assert (Q.to_list q2 = [          ]);
+  Q.transfer q1 q2;
+  assert (Q.length q1 = 0); assert (Q.to_list q1 = [          ]);
+  assert (Q.length q2 = 4); assert (Q.to_list q2 = [1; 2; 3; 4]);
+;;
+
+let () =
+  let q1 = Q.create () and q2 = Q.create () in
+  for i = 5 to 8 do Q.add i q2 done;
+  assert (Q.length q1 = 0); assert (Q.to_list q1 = [          ]);
+  assert (Q.length q2 = 4); assert (Q.to_list q2 = [5; 6; 7; 8]);
+  Q.transfer q1 q2;
+  assert (Q.length q1 = 0); assert (Q.to_list q1 = [          ]);
+  assert (Q.length q2 = 4); assert (Q.to_list q2 = [5; 6; 7; 8]);
+;;
+
+let () =
+  let q1 = Q.create () and q2 = Q.create () in
+  for i = 1 to 4 do Q.add i q1 done;
+  for i = 5 to 8 do Q.add i q2 done;
+  assert (Q.length q1 = 4); assert (Q.to_list q1 = [1; 2; 3; 4]);
+  assert (Q.length q2 = 4); assert (Q.to_list q2 = [5; 6; 7; 8]);
+  Q.transfer q1 q2;
+  assert (Q.length q1 = 0); assert (Q.to_list q1 = [                      ]);
+  assert (Q.length q2 = 8); assert (Q.to_list q2 = [5; 6; 7; 8; 1; 2; 3; 4]);
+;;
+
+let () = print_endline "OK"
diff --git a/testsuite/tests/lib-queue/test.reference b/testsuite/tests/lib-queue/test.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/lib-queue/test.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/lib-random/Makefile b/testsuite/tests/lib-random/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-random/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-random/rand.ml b/testsuite/tests/lib-random/rand.ml
new file mode 100644
index 00000000..a05761ea
--- /dev/null
+++ b/testsuite/tests/lib-random/rand.ml
@@ -0,0 +1,12 @@
+(* Test that two Random.self_init() in close succession will not result
+   in the same PRNG state.
+   Note that even when the code is correct this test is expected to fail
+   once in 10000 runs.
+*)
+
+let () =
+  Random.self_init ();
+  let x = Random.int 10000 in
+  Random.self_init ();
+  let y = Random.int 10000 in
+  if x = y then print_endline "FAILED" else print_endline "PASSED"
diff --git a/testsuite/tests/lib-random/rand.reference b/testsuite/tests/lib-random/rand.reference
new file mode 100644
index 00000000..53cdf1e9
--- /dev/null
+++ b/testsuite/tests/lib-random/rand.reference
@@ -0,0 +1 @@
+PASSED
diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile
new file mode 100644
index 00000000..baee1d59
--- /dev/null
+++ b/testsuite/tests/lib-scanf-2/Makefile
@@ -0,0 +1,63 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+MYRUNTIME=`if [ -z "$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi`
+
+.PHONY: default
+default:
+	@$(MAKE) compile
+	@$(SET_LD_PATH) $(MAKE) run
+
+.PHONY: compile
+compile: tscanf2_io.cmo
+	@rm -f master.byte master.native master.native.exe
+	@rm -f slave.byte slave.native slave.native.exe
+	@$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml
+	@$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml
+	@if $(BYTECODE_ONLY); then : ; else \
+	  $(MAKE) tscanf2_io.cmx; \
+	  $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native$(EXE) \
+	              tscanf2_master.ml; \
+	  $(OCAMLOPT) tscanf2_io.cmx -o slave.native$(EXE) tscanf2_slave.ml; \
+	fi
+
+run:
+	@printf " ... testing with ocamlc"
+	@$(MYRUNTIME) ./master.byte "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+	                                     `$(CYGPATH) ./slave.byte`" \
+	             >result.byte 2>&1
+	@$(DIFF) reference result.byte >/dev/null \
+	&& if $(BYTECODE_ONLY); then : ; else \
+	     printf " ocamlopt"; \
+	     ./master.native$(EXE) "`$(CYGPATH) ./slave.native`" \
+	                           >result.native 2>&1; \
+	     $(DIFF) reference result.native >/dev/null; \
+	   fi \
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote:
+	@cp result.byte reference
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f master.* slave.* result.*
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-scanf-2/reference b/testsuite/tests/lib-scanf-2/reference
new file mode 100644
index 00000000..4b8d53fc
--- /dev/null
+++ b/testsuite/tests/lib-scanf-2/reference
@@ -0,0 +1,2 @@
+ Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong!
+Test OK.
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_io.ml b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
new file mode 100644
index 00000000..03997897
--- /dev/null
+++ b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
@@ -0,0 +1,19 @@
+(* A very simple communication module using buffers. It should help detecting
+   advanced character reading by Scanf when using stdin. *)
+
+let send_flush send ob oc t =
+  send ob t;
+  Buffer.output_buffer oc ob;
+  Buffer.clear ob;
+  flush oc
+;;
+
+(* The correct sending format for the test should be "%S\n",
+   but to avoid problems when Scanf ask too early for the next character,
+   "%S\n\n" is fine. *)
+let send_string = send_flush (fun ob -> Printf.bprintf ob "%S\n");;
+
+(* The correct reading format for the test should be "%S\n",
+   but to avoid problems when Scanf ask too early for the next character,
+   " %S\n" is fine. *)
+let receive_string ib = Scanf.bscanf ib "%S\n" (fun s -> s);;
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_master.ml b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
new file mode 100644
index 00000000..2dd91bc0
--- /dev/null
+++ b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
@@ -0,0 +1,51 @@
+(* A very simple master:
+   - first launch a slave process,
+   - then repeat a random number of times:
+     + print the string " Ping" on stderr,
+     + send it to the slave,
+     + and wait for its answer "-pong",
+   - finally send the string "stop" to the slave
+     and wait for its answer "OK, bye!"
+     and die.
+
+   Use the communication module Tscanf2_io.
+
+   Usage: test_master <slave_name> *)
+
+open Tscanf2_io;;
+
+let slave = Sys.argv.(1);;
+let ic, oc = Unix.open_process slave;;
+let ib = Scanf.Scanning.from_channel ic;;
+let ob = Buffer.create 1024;;
+
+let send_string_ping ob = send_string ob oc " Ping";;
+let send_string_stop ob = send_string ob oc "stop";;
+
+let interact i =
+  Printf.eprintf " Ping"; flush stderr;
+  send_string_ping ob;
+  let s = receive_string ib in
+  if s <> "-pong" then failwith ("Master: unbound string " ^ s)
+;;
+
+begin
+(*
+  Random.self_init ();
+  let n = max (Random.int 8) 1 in
+*)
+  let n = 8 in
+  let rec loop i =
+    if i > 0 then (interact i; loop (i - 1)) in
+  loop n
+end
+;;
+
+begin
+  send_string_stop ob;
+  let ack = receive_string ib in
+  if ack = "OK, bye!"
+  then (print_endline "Test OK."; exit 0)
+  else (print_endline "Test Failed!"; exit 2)
+end
+;;
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
new file mode 100644
index 00000000..e06a81f8
--- /dev/null
+++ b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
@@ -0,0 +1,28 @@
+(* A very simple slave:
+   - read the string " Ping" on stdin,
+   - then print the string "-pong" on stderr,
+   - and send it back on stdout
+   - until reading the string "stop" on stdin,
+   - then print the string "!\n" on stderr,
+   - send back the string "OK, bye!" on stdout,
+   - and die.
+
+   Use the communication module Test_scanf2_io. *)
+
+open Tscanf2_io;;
+
+let ib = Scanf.Scanning.from_channel stdin;;
+let ob = Buffer.create 1024
+and oc = stdout;;
+
+let send_string_pong ob = send_string ob oc "-pong";;
+let send_string_okbye ob = send_string ob oc "OK, bye!";;
+
+while true do
+  let s = receive_string ib in
+  match s with
+  | " Ping" -> Printf.eprintf "-pong"; flush stderr; send_string_pong ob
+  | "stop" -> Printf.eprintf "!\n"; flush stderr; send_string_okbye ob; exit 0
+  | s -> failwith ("Slave: unbound string " ^ s)
+done
+;;
diff --git a/testsuite/tests/lib-scanf/Makefile b/testsuite/tests/lib-scanf/Makefile
new file mode 100644
index 00000000..194a7684
--- /dev/null
+++ b/testsuite/tests/lib-scanf/Makefile
@@ -0,0 +1,24 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=tscanf
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
+ADD_MODULES=testing
+TEST_TEMP_FILES=tscanf_data
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml
new file mode 100644
index 00000000..421c1b40
--- /dev/null
+++ b/testsuite/tests/lib-scanf/tscanf.ml
@@ -0,0 +1,1537 @@
+(*
+
+A testbed file for the module Scanf.
+
+*)
+
+open Testing;;
+
+open Scanf;;
+
+(* The ``continuation'' that returns the scanned value. *)
+let id x = x;;
+
+(* Testing space scanning. *)
+let test0 () =
+  (sscanf "" "" id) 1 +
+  (sscanf "" " " id) 2 +
+  (sscanf " " " " id) 3 +
+  (sscanf "\t" " " id) 4 +
+  (sscanf "\n" " " id) 5 +
+  (sscanf "\n\t 6" " %d" id)
+;;
+
+test (test0 () = 21)
+;;
+
+(* Testing integer scanning %i and %d. *)
+let test1 () =
+  sscanf "1" "%d" id +
+  sscanf " 2" " %d" id +
+  sscanf " -2" " %d" id +
+  sscanf " +2" " %d" id +
+  sscanf " 2a " " %da" id
+;;
+
+test (test1 () = 5)
+;;
+
+let test2 () =
+  sscanf "123" "%2i" id +
+  sscanf "245" "%d" id +
+  sscanf " 2a " " %1da" id
+;;
+
+test (test2 () = 259)
+;;
+
+let test3 () =
+  sscanf "0xff" "%3i" id +
+  sscanf "0XEF" "%3i" id +
+  sscanf "x=-245" " x = %d" id +
+  sscanf " 2a " " %1da" id
+;;
+
+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 ())
+;;
+
+let same_float x y =
+  let is_nan z = (z <> z) in
+  if is_nan x then is_nan y
+  else Int64.bits_of_float y = Int64.bits_of_float x
+;;
+
+(* 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)
+  &&
+(* F style *)
+  bscanf (Scanning.from_string "1.5 1.5e0 15e-1 0x1.8 0X1.8")
+    "%F %F %f %F %F"
+    (fun b1 b2 b3 b4 b5 -> b1 = b2 && b2 = b3 && b3 = b4 && b4 = b5)
+  &&
+(* h style *)
+  begin
+    let roundtrip x =
+      bscanf (Printf.ksprintf Scanning.from_string "%h" x) "%h" (same_float x)
+    in
+    roundtrip (+0.) &&
+    roundtrip (-0.) &&
+    roundtrip (+1.) &&
+    roundtrip (-1.) &&
+    roundtrip (+1024.) &&
+    roundtrip (-1024.) &&
+    roundtrip 0X123.456 &&
+    roundtrip 0X123456789ABCDE. &&
+    roundtrip epsilon_float &&
+    roundtrip (4. *. atan 1.) &&
+    (Sys.win32 ||
+     (* nan/infinity parsing fails on Windows? *)
+     (roundtrip nan &&
+      roundtrip infinity &&
+      roundtrip neg_infinity)) &&
+    true
+  end
+  &&
+
+  (* H style *)
+  begin
+    let roundtrip x =
+      bscanf (Printf.ksprintf Scanning.from_string "%H" x) "%H" (same_float x)
+    in
+    roundtrip (+0.) &&
+    roundtrip (-0.) &&
+    roundtrip (+1.) &&
+    roundtrip (-1.) &&
+    roundtrip (+1024.) &&
+    roundtrip (-1024.) &&
+    roundtrip 0X123.456 &&
+    roundtrip 0X123456789ABCDE. &&
+    roundtrip epsilon_float &&
+    roundtrip (4. *. atan 1.) &&
+    (Sys.win32 ||
+     (* nan/infinity parsing fails on Windows? *)
+     (roundtrip nan &&
+      roundtrip infinity &&
+      roundtrip neg_infinity)) &&
+    true
+  end
+;;
+
+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" id = 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 id
+;;
+
+let test_fmt fmt s = unit fmt s = s;;
+
+let test9_string = "\239\187\191";;
+
+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_S "\xef" &&
+  test_S "\\xef" &&
+  Scanf.sscanf "\"\\xef\"" "%S" (fun s -> s) =
+                  "\xef" &&
+  Scanf.sscanf "\"\\xef\\xbb\\xbf\"" "%S" (fun s -> s) =
+                  test9_string &&
+  Scanf.sscanf "\"\\xef\\xbb\\xbf\"" "%S" (fun s -> s) =
+                  "\239\187\191" &&
+  Scanf.sscanf "\"\xef\xbb\xbf\"" "%S" (fun s -> s) =
+                  test9_string &&
+  Scanf.sscanf "\"\\\\xef\\\\xbb\\\\xbf\"" "%S" (fun s -> s) =
+                  "\\xef\\xbb\\xbf" &&
+  Scanf.sscanf "\"\ \"" "%S" (fun s -> s) =
+                  "\ "
+;;
+
+test (test9 ())
+;;
+
+let test10 () =
+  let unit s =
+    let ib = Scanning.from_string s in
+  Scanf.bscanf ib "%S" id in
+
+  let res =
+    sscanf "Une chaine: \"celle-ci\" et \"celle-la\"!"
+           "%s %s %S %s %S %s"
+           (fun s1 s2 s3 s4 s5 s6 -> s1 ^ s2 ^ s3 ^ s4 ^ s5 ^ s6) in
+  res = "Unechaine:celle-cietcelle-la!" &&
+  (* Testing the result of reading a %S string. *)
+  unit "\"a\\\n  b\"" = "ab" &&
+  unit "\"\\\n  ab\"" = "ab" &&
+  unit "\"\n\\\n  ab\"" = "\nab" &&
+  unit "\"\n\\\n  a\nb\"" = "\na\nb" &&
+  unit "\"\n\\\n  \\\n  a\nb\"" = "\na\nb" &&
+  unit "\"\n\\\n  a\n\\\nb\\\n\"" = "\na\nb" &&
+  unit "\"a\\\n  \"" = "a" &&
+  true
+;;
+
+test (test10 ())
+;;
+
+(* %[] style *)
+let test11 () =
+  sscanf "Pierre\tWeis\t70" "%s %s %s"
+    (fun prenom nom poids ->
+     prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70)
+  &&
+  sscanf "Jean-Luc\tde Leage\t68" "%[^\t] %[^\t] %d"
+    (fun prenom nom poids ->
+     prenom = "Jean-Luc" && nom = "de Leage" && poids = 68)
+  &&
+  sscanf "Daniel\tde Rauglaudre\t66" "%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 = "poi" && y = "!") &&
+  sscanf " poi !" "%s@ %s@." (fun x y -> x = "" && y = "poi !")
+;;
+
+let test111 () = sscanf "" "%[^\n]@\n" (fun x -> x = "");;
+
+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 -> print_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 empty. *)
+        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 but 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.
+   This version does not fix the separator, nor the spacing before and after
+   the separator (it uses the functional argument [scan_elem] to parse the
+   separator, its spacing, and the item).
+ *)
+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 an OCaml 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 polymorphic item scanner, *)
+let scan_elem fmt ib f ek = kscanf ib ek fmt f;;
+
+(* Derivation of list scanners from the generic polymorphic item scanner
+   applications. *)
+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[;]");;
+
+(* In this version the [scan_elem] function should be a [kscanf] like
+   scanning function: we give it an error continuation.
+
+   The [scan_elem] argument, probably use some partial application of the
+   following generic [scan_elem]:
+
+   let scan_elem fmt ib f ek = kscanf ib ek fmt f;;
+
+   For instance, a suitable [scan_elem] for integers could be:
+
+   let scan_integer_elem = scan_elem " %i";;
+
+*)
+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.
+
+   We use format values to stand for ``functional'' specifications to scan
+   the elements of lists.
+
+   The list item separator and the separator spacing are builtin into the
+   [scan_elems] iterator and thus are conveniently omitted from the
+   definitional format for item scanning.
+*)
+let rec scan_elems ib scan_elem_fmt accu =
+  kscanf ib (fun ib exc -> accu)
+    scan_elem_fmt
+    (fun i ->
+     let accu = i :: accu in
+     bscanf ib
+       " %1[;] "
+       (function
+        | "" -> accu
+        | _ -> scan_elems ib scan_elem_fmt accu)
+    )
+;;
+
+let scan_list scan_elem_fmt ib =
+  bscanf ib "[ " ();
+  let accu = scan_elems ib scan_elem_fmt [] 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 ())
+;;
+
+(* Using kscanf only.
+
+   Same as the preceding functional, except that we no more use format values
+   to scan items: we use scanners that scan elements of the list on the
+   fly.
+*)
+(* This version cannot handle empty lists!
+let rec scan_elems ib scan_elem accu =
+  scan_elem ib
+    (fun elem ->
+     let accu = elem :: accu in
+     kscanf ib (fun ib exc -> accu)
+       " %1[;] "
+       (function
+        | "" -> accu
+        | _ -> scan_elems ib scan_elem accu))
+;;
+*)
+
+(* We use [kscanf] with a [%r] format ! *)
+let rec scan_elems scan_elem accu ib =
+  kscanf ib (fun ib exc -> accu)
+    "%r"
+    (function ib ->
+     scan_elem ib
+       (function elem ->
+        let accu = elem :: accu in
+        bscanf ib
+          " %1[;] "
+          (function
+           | "" -> accu
+           | _ -> scan_elems scan_elem accu ib)))
+    (function l -> l)
+;;
+
+let scan_list scan_elem ib =
+  bscanf ib "[ " ();
+  let accu = scan_elems scan_elem [] ib in
+  bscanf ib " ]" ();
+  List.rev accu
+;;
+
+(* We may also try a version with only one format:
+   We also changed the type of [scan_elem] to partially apply it to its
+   ``natural'' continuation.
+let rec scan_elems scan_elem accu ib =
+  (* We use [kscanf], so that:
+     if the element reader fails, we can return the list of elements read so
+     far. *)
+  kscanf ib (fun ib exc -> accu)
+    (* The format string for [kscanf]: we read an element using [scan_elem],
+       then find a semi-colon if any, in order to decide if we stop reading
+       or go on with other elements. *)
+    "%r %1[;] "
+    (* The reader: once an element has been read it returns the new accu. *)
+    (scan_elem (function elem -> elem :: accu))
+    (fun accu s ->
+     (* Cannot find a semi-colon: no more elements to read. *)
+     if s = "" then accu
+     (* We found a semi-colon: go on with the new accu. *)
+     else scan_elems scan_elem accu ib)
+;;
+
+let scan_list scan_elem ib =
+  bscanf ib "[ %r ]" (scan_elems scan_elem []) List.rev
+;;
+
+(* For instance:
+let scan_float f ib = Scanf.bscanf ib "%f" f;;
+# scan_list scan_float;;
+- : Scanf.Scanning.scanbuf -> float list = <fun>
+*)
+
+(* The element scanner builder. *)
+let make_scan_elem fmt f ib = Scanf.bscanf ib fmt f;;
+
+(* Promote an element reader format to an element list reader. *)
+let list_scanner fmt = scan_list (make_scan_elem fmt);;
+
+let scan_float = make_scan_elem "%f";;
+
+scan_list scan_float;;
+
+list_scanner "%f";;
+- : Scanf.Scanning.scanbuf -> float list = <fun>
+*)
+
+(* The prototype of a [scan_elem] function for the generic [scan_list]
+   functional.
+   This [scan_elem] scans a floating point number. *)
+let scan_float ib = Scanf.bscanf ib "%f";;
+let scan_float_list = scan_list scan_float;;
+
+(* In the following list scanners, we directly give the [scan_elem] function
+   as an immediate function value argument to the polymorphic
+   [scan_list]. *)
+let scan_int_list = scan_list (fun ib -> Scanf.bscanf ib "%i");;
+let scan_string_list = scan_list (fun ib -> Scanf.bscanf ib "%S");;
+let scan_bool_list = scan_list (fun ib -> Scanf.bscanf ib "%B");;
+let scan_char_list = scan_list (fun ib -> Scanf.bscanf ib "%C");;
+
+(* [scan_list] is truely polymorphic: scanning a list of lists of items
+   is a one liner!
+
+   Here we scan list of lists of floats. *)
+let scan_float_list_list =
+  scan_list
+    (fun ib k -> k (scan_list (fun ib -> Scanf.bscanf ib "%f") ib))
+;;
+
+let scan_float_list_list =
+  scan_list
+    (fun ib k -> k (scan_list scan_float ib))
+;;
+
+let scan_float_list_list =
+  scan_list
+    (fun ib k -> k (scan_float_list ib))
+;;
+
+(* The killer way to define [scan_float_list_list]. *)
+(* let scan_float_list_list = scan_list scan_float_list;; *)
+
+let test340 () =
+  scan_float_list_list
+   (Scanning.from_string "[[1.0] ; []; [2.0; 3; 5.0; 6.];]") =
+  [[1.]; []; [2.; 3.; 5.; 6.]]
+;;
+
+(* A general scan_list_list functional. *)
+let scan_list_list scan_elems ib =
+  scan_list
+    (fun ib k -> k (scan_elems ib)) ib
+;;
+
+let scan_float_list_list = scan_list_list scan_float_list;;
+
+(* Programming with continuations :) *)
+let scan_float_item ib k = k (scan_float ib (fun x -> x));;
+let scan_float_list ib k = k (scan_list scan_float_item ib);;
+let scan_float_list_list ib k = k (scan_list scan_float_list ib);;
+
+(* 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 (test340 () && test35 ())
+;;
+
+(* The prefered reader functionnals. *)
+
+(* To read a list as in OCaml (elements are ``blank + semicolon + blank''
+   separated, and the list is enclosed in brackets). *)
+let rec read_elems read_elem accu ib =
+  kscanf ib (fun ib exc -> accu)
+    "%r %1[;] "
+    (read_elem (function elem -> elem :: accu))
+    (fun accu s -> if s = "" then accu else read_elems read_elem accu ib)
+;;
+
+let read_list read_elem ib =
+  bscanf ib "[ %r ]" (read_elems read_elem []) List.rev
+;;
+
+(* The element reader builder. *)
+let make_read_elem fmt f ib = Scanf.bscanf ib fmt f;;
+
+(* Promote an element reader format to an element list reader. *)
+let scan_List fmt = read_list (make_read_elem fmt);;
+
+(* Example for list of floatting point numbers. *)
+(*
+scan_List "%f";;
+- : Scanf.Scanning.scanbuf -> float list = <fun>
+
+(* To read a list as a succession of elements separated by a blank. *)
+let rec read_elems read_elem accu ib =
+  kscanf ib (fun ib exc -> accu)
+    "%r "
+    (read_elem (function elem -> elem :: accu))
+    (fun accu -> read_elems read_elem accu ib)
+;;
+
+let read_list read_elem ib =
+   List.rev (read_elems read_elem [] ib)
+;;
+
+(* Promote an element reader format to an element list reader. *)
+let scan_list fmt = read_list (make_read_elem fmt);;
+
+scan_list "%f";;
+*)
+
+(* 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, "", 0)
+;;
+
+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 "a" "a%!" true &&
+  sscanf "a" "a%!%!" true &&
+  sscanf " a" " a%!" true &&
+  sscanf "a " "a %!" true &&
+  sscanf "" "%!" true &&
+  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]%[abc]%s%!" (fun s1 s2 s3 ->
+   s1 = "def" && s2 = "cbaa" && s3 = "ghi") &&
+ let ib = Scanning.from_string s in
+ bscanf ib "%s@\t" (fun s -> s = "defcbaaghi")
+;;
+
+test (test42 ())
+;;
+
+(* Testing end of file condition (bug found). *)
+let test43, test44 =
+ let s = "" in
+ let ib = Scanning.from_string s in
+ (fun () -> bscanf ib "%i%!" (fun i -> i)),
+ (fun () -> bscanf ib "%!%i" (fun i -> i))
+;;
+
+test_raises_this_exc End_of_file test43 () &&
+test_raises_this_exc End_of_file test44 ()
+;;
+
+(* Testing small range scanning (bug found once). *)
+let test45 () =
+ 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 (test45 ())
+;;
+
+(* Testing printing of meta formats. *)
+
+let test46, test47 =
+  (fun () ->
+     Printf.sprintf "%i %(%s%)."
+       1 "spells one, %s" "in english"),
+  (fun () ->
+     Printf.sprintf "%i %{%s%}, %s."
+       1 "spells one %s" "in english")
+;;
+
+test (test46 () = "1 spells one, in english.")
+;;
+test (test47 () = "1 %s, in english.")
+;;
+
+(* Testing scanning of meta formats. *)
+let test48 () =
+  (* Testing format_from_string. *)
+  let test_meta_read s fmt efmt = format_from_string s fmt = efmt in
+  (* Test if format %i is indeed read as %i. *)
+  let s, fmt = "%i", format_of_string "%i" in
+  test_meta_read s fmt fmt &&
+  (* Test if format %i is compatible with %d and indeed read as %i. *)
+  let s, fmt = "%i", format_of_string "%d" in
+  test_meta_read s fmt "%i" &&
+  (* Complex test of scanning a meta format specified in the scanner input
+     format string and extraction of its specification from a string. *)
+  sscanf "12 \"%i\"89 " "%i %{%d%}%s %!"
+    (fun i f s -> i = 12 && f = "%i" && s = "89") &&
+  (* Testing scanf format string replacement *)
+  let k s =
+    Scanf.sscanf s
+      "%(%f%)" (fun _fmt i -> i) in
+  k "\" : %1f\": 987654321" = 9.0  &&
+  k "\" : %2f\": 987654321" = 98.0 &&
+  k "\" : %3f\": 9.87654321" = 9.8 &&
+  k "\" : %4f\": 9.87654321" = 9.87 &&
+
+  let h s =
+    Scanf.sscanf s
+      "Read integers with %(%i%)" (fun _fmt i -> i) in
+  h "Read integers with \"%1d\"987654321" = 9  &&
+  h "Read integers with \"%2d\"987654321" = 98 &&
+  h "Read integers with \"%3u\"987654321" = 987 &&
+  h "Read integers with \"%4x\"987654321" = 39030 &&
+
+  let i s =
+    Scanf.sscanf s
+      "with %(%i %s%)" (fun _fmt amount currency -> amount, currency) in
+  i "with \" : %d %s\" :        21 euros" = (21, "euros")  &&
+  i "with \" : %d %s\" : 987654321 dollars" = (987654321, "dollars") &&
+  i "with \" : %u %s\" :     54321 pounds" = (54321, "pounds") &&
+  i "with \" : %x %s\" :       321 yens" = (801, "yens") &&
+
+  let j s =
+    Scanf.sscanf s
+      "with %(%i %_s %s%)" (fun _fmt amount currency -> amount, currency) in
+  j "with \" : %1d %_s %s\" : 987654321 euros" = (9, "euros")  &&
+  j "with \" : %2d %_s %s\" : 987654321 dollars" = (98, "dollars") &&
+  j "with \" : %3u %_s %s\" : 987654321 pounds" = (987, "pounds") &&
+  j "with \" : %4x %_s %s\" : 987654321 yens" = (39030, "yens")
+;;
+
+test (test48 ())
+;;
+
+(* Testing stoppers after ranges. *)
+let test49 () =
+  sscanf "as" "%[\\]" (fun s -> s = "") &&
+  sscanf "as" "%[\\]%s" (fun s t -> s = "" && t = "as") &&
+  sscanf "as" "%[\\]%s%!" (fun s t -> s = "" && t = "as") &&
+  sscanf "as" "%[a..z]" (fun s -> s = "a") &&
+  sscanf "as" "%[a-z]" (fun s -> s = "as") &&
+  sscanf "as" "%[a..z]%s" (fun s t -> s = "a" && t = "s") &&
+  sscanf "as" "%[a-z]%s" (fun s t -> s = "as" && t = "") &&
+  sscanf "-as" "%[-a-z]" (fun s -> s = "-as") &&
+  sscanf "-as" "%[-a-z]@s" (fun s -> s = "-a") &&
+  sscanf "-as" "-%[a]@s" (fun s -> s = "a") &&
+  sscanf "-asb" "-%[a]@sb%!" (fun s -> s = "a") &&
+  sscanf "-asb" "-%[a]@s%s" (fun s t -> s = "a" && t = "b")
+;;
+
+test (test49 ())
+;;
+
+(* Testing buffers defined via functions
+   + co-routines that read and write from the same buffers
+   + range chars and proper handling of \n
+   + the end of file condition. *)
+let next_char ob () =
+  let s = Buffer.contents ob in
+  let len = String.length s in
+  if len = 0 then raise End_of_file else
+  let c = s.[0] in
+  Buffer.clear ob;
+  Buffer.add_string ob (String.sub s 1 (len - 1));
+  c
+;;
+
+let send_string ob s =
+  Buffer.add_string ob s; Buffer.add_char ob '\n';;
+let send_int ob i = send_string ob (string_of_int i);;
+
+let rec reader =
+  let count = ref 0 in
+  (fun ib ob ->
+    if Scanf.Scanning.beginning_of_input ib then begin
+      count := 0; send_string ob "start"; writer ib ob end else
+    Scanf.bscanf ib "%[^\n]\n" (function
+    | "stop" -> send_string ob "stop"; writer ib ob
+    | s ->
+      let l = String.length s in
+      count := l + !count;
+      if !count >= 100 then begin
+        send_string ob "stop";
+        send_int ob !count
+        end else
+      send_int ob l;
+      writer ib ob))
+
+and writer ib ob =
+  Scanf.bscanf ib "%s\n" (function
+    | "start" -> send_string ob "Hello World!"; reader ib ob
+    | "stop" -> Scanf.bscanf ib "%i" (function i -> i)
+    | s -> send_int ob (int_of_string s); reader ib ob);;
+
+let go () =
+  let ob = Buffer.create 17 in
+  let ib = Scanf.Scanning.from_function (next_char ob) in
+  reader ib ob
+;;
+
+let test50 () = go () = 100;;
+
+test (test50 ())
+;;
+
+(* Simple tests may also fail!
+   Ensure this is not the case with the current version for module [Scanf]. *)
+let test51 () =
+ sscanf "Hello" "%s" id = "Hello" &&
+ sscanf "Hello\n" "%s\n" id = "Hello" &&
+ sscanf "Hello\n" "%s%s\n" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "") &&
+ sscanf "Hello\nWorld" "%s\n%s%!" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "World") &&
+ sscanf "Hello\nWorld!" "%s\n%s" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "World!") &&
+ sscanf "Hello\n" "%s@\n%s" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "") &&
+ sscanf "Hello \n" "%s@\n%s" (fun s1 s2 ->
+   s1 = "Hello " && s2 = "")
+;;
+
+test (test51 ())
+;;
+
+(* Tests that indeed the [%s@c] format works properly.
+   Also tests the difference between [\n] and [@\n] is correctly handled.
+   In particular, tests that if no [c] character can be found in the
+   input, then the token obtained for [%s@c] spreads to the end of
+   input. *)
+let test52 () =
+ sscanf "Hello\n" "%s@\n" id = "Hello" &&
+ sscanf "Hello" "%s@\n" id = "Hello" &&
+ sscanf "Hello" "%s%s@\n" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "") &&
+ sscanf "Hello\nWorld" "%s@\n%s%!" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "World") &&
+ sscanf "Hello\nWorld!" "%s@\n%s@\n" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "World!") &&
+ sscanf "Hello\n" "%s@\n%s" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "") &&
+ sscanf "Hello \n" "%s%s@\n" (fun s1 s2 ->
+   s1 = "Hello" && s2 = " ") &&
+sscanf "Hello \n" "%s%s%_1[ ]\n" (fun s1 s2 ->
+         s1 = "Hello" && s2 = "") &&
+ sscanf "Hello \n" "%s%_1[ ]%s\n" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "") &&
+ sscanf "Hello\nWorld" "%s\n%s%!" (fun s1 s2 ->
+      s1 = "Hello" && s2 = "World") &&
+ sscanf "Hello\nWorld!" "%s\n%s%!" (fun s1 s2 ->
+      s1 = "Hello" && s2 = "World!") &&
+ sscanf "Hello\nWorld!" "%s\n%s@!%!" (fun s1 s2 ->
+      s1 = "Hello" && s2 = "World") &&
+ (* PR#6791 *)
+ sscanf "Hello{foo}" "%s@{%s" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "foo}") &&
+ sscanf "Hello[foo]" "%s@[%s" (fun s1 s2 ->
+   s1 = "Hello" && s2 = "foo]")
+;;
+
+test (test52 ())
+;;
+
+(* Reading native, int32 and int64 numbers. *)
+let test53 () =
+ sscanf "123" "%nd" id = 123n &&
+ sscanf "124" "%nd" (fun i -> Nativeint.pred i = 123n) &&
+
+ sscanf "123" "%ld" id = 123l &&
+ sscanf "124" "%ld" (fun i -> Int32.succ i = 125l) &&
+
+ sscanf "123" "%Ld" id = 123L &&
+ sscanf "124" "%Ld" (fun i -> Int64.pred i = 123L)
+;;
+
+test (test53 ())
+;;
+
+(* Routines to create the file that tscanf uses as a testbed case. *)
+let create_tscanf_data ob lines =
+  let add_line (p, e) =
+    Buffer.add_string ob (Printf.sprintf "%S" p);
+    Buffer.add_string ob " -> ";
+    Buffer.add_string ob (Printf.sprintf "%S" e);
+    Buffer.add_string ob ";\n" in
+  List.iter add_line lines
+;;
+
+let write_tscanf_data_file fname lines =
+  let oc = open_out fname in
+  let ob = Buffer.create 42 in
+  create_tscanf_data ob lines;
+  Buffer.output_buffer oc ob;
+  close_out oc
+;;
+
+(* The tscanf testbed case file name. *)
+let tscanf_data_file = "tscanf_data";;
+(* The contents of the tscanf testbed case file. *)
+let tscanf_data_file_lines = [
+    "Objective", "Caml";
+]
+;;
+(* We write the tscanf testbed case file. *)
+write_tscanf_data_file tscanf_data_file tscanf_data_file_lines
+;;
+
+(* Then we verify that its contents is indeed correct:
+   the lines written into the [tscanf_data] file should be the same as the
+   lines read from it. *)
+
+(* Reading back tscanf_data_file_lines (hence, testing data file reading as
+   well). *)
+let get_lines fname =
+  let ib = Scanf.Scanning.from_file fname in
+  let l = ref [] in
+  try
+    while not (Scanf.Scanning.end_of_input ib) do
+      Scanf.bscanf ib " %S -> %S; " (fun x y ->
+        l := (x, y) :: !l)
+    done;
+    List.rev !l
+  with
+  | Scanf.Scan_failure s ->
+    failwith (Printf.sprintf "in file %s, %s" fname s)
+  | End_of_file ->
+    failwith (Printf.sprintf "in file %s, unexpected end of file" fname)
+;;
+
+(* Simply test that the list of lines read from the file is the list of lines
+   written to it!. *)
+let test54 () =
+  get_lines tscanf_data_file = tscanf_data_file_lines
+;;
+
+test (test54 ())
+;;
+
+(* Creating digests for files. *)
+let add_digest_ib ob ib =
+  let digest s = String.uppercase_ascii (Digest.to_hex (Digest.string s)) in
+  let scan_line ib f = Scanf.bscanf ib "%[^\n\r]\n" f in
+  let output_line_digest s =
+    Buffer.add_string ob s;
+    Buffer.add_char ob '#'; Buffer.add_string ob (digest s);
+    Buffer.add_char ob '\n' in
+  try while true do scan_line ib output_line_digest done; with
+  | End_of_file -> ()
+;;
+
+let digest_file fname =
+  let ib = Scanf.Scanning.from_file fname in
+  let ob = Buffer.create 42 in
+  add_digest_ib ob ib;
+  Buffer.contents ob
+;;
+
+let test55 () =
+  let ob = Buffer.create 42 in
+  let ib =
+    create_tscanf_data ob tscanf_data_file_lines;
+    let s = Buffer.contents ob in
+    Buffer.clear ob;
+    Scanning.from_string s in
+  let tscanf_data_file_lines_digest = add_digest_ib ob ib; Buffer.contents ob in
+  digest_file tscanf_data_file = tscanf_data_file_lines_digest
+;;
+
+test (test55 ())
+;;
+
+(* Testing the number of characters read. *)
+let test56 () =
+   let g s = Scanf.sscanf s "%d%n" (fun i n -> (i, n)) in
+   g "99" = (99, 2) &&
+   g "99 syntaxes all in a row" = (99, 2) &&
+   g "-20 degrees Celsius" = (-20, 3)
+;;
+
+test (test56 ())
+;;
+
+(* Testing the scanning of formats. *)
+let test57 () =
+  (* Testing format_from_string. *)
+  let test_format_scan s fmt efmt =
+    format_from_string s fmt = efmt in
+  (* Test if format %i is indeed read as %i. *)
+  let s, fmt = " %i ", format_of_string "%i" in
+  test_format_scan s fmt " %i " &&
+  (* Test if format %i is compatible with %d and indeed read as %i. *)
+  let s, fmt = "%i", format_of_string "%d" in
+  test_format_scan s fmt "%i" &&
+
+  let s, fmt =
+    "Read an int %i then a string %s.",
+    format_of_string "Spec%difi%scation" in
+  test_format_scan s fmt "Read an int %i then a string %s." &&
+
+  let s, fmt =
+    "Read an int %i then a string \"%s\".",
+    format_of_string "Spec%difi%Scation" in
+  test_format_scan s fmt "Read an int %i then a string \"%s\"." &&
+
+  let s, fmt =
+    "Read an int %i then a string \"%s\".",
+    format_of_string "Spec%difi%scation" in
+  test_format_scan s fmt "Read an int %i then a string \"%s\"." &&
+
+  (* Complex test of scanning a meta format specified in the scanner input
+     format string and extraction of its specification from a string. *)
+  sscanf "12 \"%i\"89 " "%i %{%d%}%s %!"
+    (fun i f s -> i = 12 && f = "%i" && s = "89")
+;;
+
+test (test57 ())
+;;
+
+let test58 () =
+     sscanf "string1%string2" "%s@%%s" id = "string1"
+  && sscanf "string1%string2" "%s@%%%s" (^) = "string1string2"
+  && sscanf "string1@string2" "%[a-z0-9]@%s" (^) = "string1string2"
+  && sscanf "string1@%string2" "%[a-z0-9]%@%%%s" (^) = "string1string2"
+;;
+
+test (test58 ())
+;;
+
+(* skip test number "59" which is commented below *)
+let () = test (true);;
+(*
+let test59 () =
+;;
+
+test (test59 ())
+;;
+*)
+
+(* To be continued ...
+(* 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
+;;
+
+let scan_field ib =
+  bscanf ib "%s = %[^;]" (fun finame ficont -> finame, ficont);;
+*)
+
+(* testing formats that do not consume their input *)
+let test60 () =
+  sscanf "abc" "%0c%0c%c%n" (fun c1 c2 c3 n ->
+    c1 = 'a' && c2 = 'a' && c3 = 'a' && n = 1)
+  &&
+  sscanf "abc" "%0s%s" (fun s1 s2 -> s1 = "" && s2 = "abc")
+  &&
+  sscanf "abc" "%1s%s" (fun s1 s2 -> s1 = "a" && s2 = "bc")
+;;
+
+test (test60 ());
diff --git a/testsuite/tests/lib-scanf/tscanf.reference b/testsuite/tests/lib-scanf/tscanf.reference
new file mode 100644
index 00000000..5b2859cb
--- /dev/null
+++ b/testsuite/tests/lib-scanf/tscanf.reference
@@ -0,0 +1,2 @@
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
+All tests succeeded.
diff --git a/testsuite/tests/lib-set/Makefile b/testsuite/tests/lib-set/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-set/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml
new file mode 100644
index 00000000..307c7f8d
--- /dev/null
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -0,0 +1,224 @@
+module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
+
+let img x m = try Some(M.find x m) with Not_found -> None
+
+let testvals = [0;1;2;3;4;5;6;7;8;9]
+
+let check msg cond =
+  if not (List.for_all cond testvals) then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let checkbool msg b =
+  if not b then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let uncurry (f: 'a -> 'b -> 'c) (x, y: 'a * 'b) : 'c = f x y
+
+let test x v s1 s2 =
+
+  checkbool "is_empty"
+    (M.is_empty s1 = List.for_all (fun i -> img i s1 = None) testvals);
+
+  check "mem"
+    (fun i -> M.mem i s1 = (img i s1 <> None));
+
+  check "add"
+    (let s = M.add x v s1 in
+     fun i -> img i s = (if i = x then Some v else img i s1));
+
+  check "singleton"
+    (let s = M.singleton x v in
+     fun i -> img i s = (if i = x then Some v else None));
+
+  check "remove"
+    (let s = M.remove x s1 in
+     fun i -> img i s = (if i = x then None else img i s1));
+
+  check "merge-union"
+    (let f _ o1 o2 =
+       match o1, o2 with
+       | Some v1, Some v2 -> Some (v1 +. v2)
+       | None, _ -> o2
+       | _, None -> o1 in
+     let s = M.merge f s1 s2 in
+     fun i -> img i s = f i (img i s1) (img i s2));
+
+  check "merge-inter"
+    (let f _ o1 o2 =
+       match o1, o2 with
+       | Some v1, Some v2 -> Some (v1 -. v2)
+       | _, _ -> None in
+     let s = M.merge f s1 s2 in
+     fun i -> img i s = f i (img i s1) (img i s2));
+
+  checkbool "bindings"
+    (let rec extract = function
+       | [] -> []
+       | hd :: tl ->
+           match img hd s1 with
+           | None -> extract tl
+           | Some v ->(hd,  v) :: extract tl in
+     M.bindings s1 = extract testvals);
+
+  checkbool "for_all"
+    (let p x y = x mod 2 = 0 in
+     M.for_all p s1 = List.for_all (uncurry p) (M.bindings s1));
+
+  checkbool "exists"
+    (let p x y = x mod 3 = 0 in
+     M.exists p s1 = List.exists (uncurry p) (M.bindings s1));
+
+  checkbool "filter"
+    (let p x y = x >= 3 && x <= 6 in
+     M.bindings(M.filter p s1) = List.filter (uncurry p) (M.bindings s1));
+
+  checkbool "partition"
+    (let p x y = x >= 3 && x <= 6 in
+     let (st,sf) = M.partition p s1
+     and (lt,lf) = List.partition (uncurry p) (M.bindings s1) in
+     M.bindings st = lt && M.bindings sf = lf);
+
+  checkbool "cardinal"
+    (M.cardinal s1 = List.length (M.bindings s1));
+
+  checkbool "min_binding"
+    (try
+       let (k,v) = M.min_binding s1 in
+       img k s1 = Some v && M.for_all (fun i _ -> k <= i) s1
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "max_binding"
+    (try
+       let (k,v) = M.max_binding s1 in
+       img k s1 = Some v && M.for_all (fun i _ -> k >= i) s1
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "choose"
+    (try
+       let (x,v) = M.choose s1 in img x s1 = Some v
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "find_first"
+    (let (l, p, r) = M.split x s1 in
+    if p = None && M.is_empty r then
+      try
+        let _ = M.find_first (fun k -> k >= x) s1 in
+        false
+      with Not_found ->
+        true
+    else
+      let (k, v) = M.find_first (fun k -> k >= x) s1 in
+      match p with
+        None -> (k, v) = M.min_binding r
+      | Some v1 -> (k, v) = (x, v1));
+
+  checkbool "find_first_opt"
+    (let (l, p, r) = M.split x s1 in
+    if p = None && M.is_empty r then
+      match M.find_first_opt (fun k -> k >= x) s1 with
+        None -> true
+      | _ -> false
+    else
+      let Some (k, v) = M.find_first_opt (fun k -> k >= x) s1 in
+      match p with
+        None -> (k, v) = M.min_binding r
+      | Some v1 -> (k, v) = (x, v1));
+
+  checkbool "find_last"
+    (let (l, p, r) = M.split x s1 in
+    if p = None && M.is_empty l then
+      try
+        let _ = M.find_last (fun k -> k <= x) s1 in
+        false
+      with Not_found ->
+        true
+    else
+      let (k, v) = M.find_last (fun k -> k <= x) s1 in
+      match p with
+        None -> (k, v) = M.max_binding l
+      | Some v1 -> (k, v) = (x, v1));
+
+  checkbool "find_last_opt"
+    (let (l, p, r) = M.split x s1 in
+    if p = None && M.is_empty l then
+      match M.find_last_opt (fun k -> k <= x) s1 with
+        None -> true
+      | _ -> false
+    else
+      let Some (k, v) = M.find_last_opt (fun k -> k <= x) s1 in
+      match p with
+        None -> (k, v) = M.max_binding l
+      | Some v1 -> (k, v) = (x, v1));
+
+  check "split"
+    (let (l, p, r) = M.split x s1 in
+     fun i ->
+       if i < x then img i l = img i s1
+       else if i > x then img i r = img i s1
+       else p = img i s1)
+
+let rkey() = Random.int 10
+
+let rdata() = Random.float 1.0
+
+let rmap() =
+  let s = ref M.empty in
+  for i = 1 to Random.int 10 do s := M.add (rkey()) (rdata()) !s done;
+  !s
+
+let _ =
+  Random.init 42;
+  for i = 1 to 10000 do test (rkey()) (rdata()) (rmap()) (rmap()) done
+
+let () =
+  (* check that removing a binding from a map that is not present in this map
+     (1) doesn't allocate and (2) return the original map *)
+  let m1 = ref M.empty in
+  for i = 1 to 10 do m1 := M.add i (float i) !m1 done;
+  let m2 = ref !m1 in
+
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  for i = 11 to 30 do m2 := M.remove i !m2 done;
+  let a2 = Gc.allocated_bytes () in
+
+  assert (!m2 == !m1);
+  assert(a2 -. a1 = a1 -. a0)
+
+let () =
+  (* check that filtering a map where all bindings are satisfied by
+     the given predicate returns the original map *)
+  let m1 = ref M.empty in
+  for i = 1 to 10 do m1 := M.add i (float i) !m1 done;
+  let m2 = M.filter (fun e _ -> e >= 0) !m1 in
+  assert (m2 == !m1)
+
+let () =
+  (* check that adding a binding "x -> y" to a map that already
+     contains it doesn't allocate and return the original map. *)
+  let m1 = ref M.empty in
+  let tmp = ref None in
+  for i = 1 to 10 do
+    tmp := Some (float i);
+    m1 := M.add i !tmp !m1
+  done;
+  let m2 = ref !m1 in
+
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+
+  (* 10 |-> !tmp is already present in !m2 *)
+  m2 := M.add 10 !tmp !m2;
+
+  let a2 = Gc.allocated_bytes () in
+
+  assert (!m2 == !m1);
+  assert(a2 -. a1 = a1 -. a0);
+
+  (* 4 |-> Some 84. is not present in !m2 *)
+  m2 := M.add 4 (Some 84.) !m2;
+
+  assert (not (!m2 == !m1));
diff --git a/testsuite/tests/lib-set/testmap.reference b/testsuite/tests/lib-set/testmap.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
new file mode 100644
index 00000000..35878ea0
--- /dev/null
+++ b/testsuite/tests/lib-set/testset.ml
@@ -0,0 +1,243 @@
+module S = Set.Make(struct type t = int let compare (x:t) y = compare x y end)
+
+let testvals = [0;1;2;3;4;5;6;7;8;9]
+
+let check msg cond =
+  if not (List.for_all cond testvals) then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let checkbool msg b =
+  if not b then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let normalize_cmp c =
+  if c = 0 then 0 else if c > 0 then 1 else -1
+
+let test x s1 s2 =
+
+  checkbool "is_empty"
+    (S.is_empty s1 = List.for_all (fun i -> not (S.mem i s1)) testvals);
+
+  check "add"
+    (let s = S.add x s1 in
+     fun i -> S.mem i s = (S.mem i s1 || i = x));
+
+  check "singleton"
+    (let s = S.singleton x in
+     fun i -> S.mem i s = (i = x));
+
+  check "remove"
+    (let s = S.remove x s1 in
+     fun i -> S.mem i s = (S.mem i s1 && i <> x));
+
+  check "union"
+    (let s = S.union s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 || S.mem i s2));
+
+  check "inter"
+    (let s = S.inter s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 && S.mem i s2));
+
+  check "diff"
+    (let s = S.diff s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 && not (S.mem i s2)));
+
+  checkbool "elements"
+    (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals);
+
+  checkbool "compare"
+    (normalize_cmp (S.compare s1 s2)
+     = normalize_cmp (compare (S.elements s1) (S.elements s2)));
+
+  checkbool "equal"
+    (S.equal s1 s2 = (S.elements s1 = S.elements s2));
+
+  check "subset"
+    (let b = S.subset s1 s2 in
+     fun i -> if b && S.mem i s1 then S.mem i s2 else true);
+
+  checkbool "subset2"
+    (let b = S.subset s1 s2 in
+     b || not (S.is_empty (S.diff s1 s2)));
+
+  checkbool "map"
+    (S.elements (S.map succ s1) = List.map succ (S.elements s1));
+
+  checkbool "map2"
+    (S.map (fun x -> x) s1 == s1);
+
+  checkbool "map3"
+    ((* check that the traversal is made in increasing element order *)
+     let last = ref min_int in
+     S.map (fun x -> assert (!last <= x); last := x; x) s1 == s1);
+
+  checkbool "for_all"
+    (let p x = x mod 2 = 0 in
+     S.for_all p s1 = List.for_all p (S.elements s1));
+
+  checkbool "exists"
+    (let p x = x mod 3 = 0 in
+     S.exists p s1 = List.exists p (S.elements s1));
+
+  checkbool "filter"
+    (let p x = x >= 3 && x <= 6 in
+     S.elements(S.filter p s1) = List.filter p (S.elements s1));
+
+  checkbool "partition"
+    (let p x = x >= 3 && x <= 6 in
+     let (st,sf) = S.partition p s1
+     and (lt,lf) = List.partition p (S.elements s1) in
+     S.elements st = lt && S.elements sf = lf);
+
+  checkbool "cardinal"
+    (S.cardinal s1 = List.length (S.elements s1));
+
+  checkbool "min_elt"
+    (try
+       let m = S.min_elt s1 in
+       S.mem m s1 && S.for_all (fun i -> m <= i) s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "max_elt"
+    (try
+       let m = S.max_elt s1 in
+       S.mem m s1 && S.for_all (fun i -> m >= i) s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "choose"
+    (try
+       let x = S.choose s1 in S.mem x s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "find_first"
+    (let (l, p, r) = S.split x s1 in
+    if not p && S.is_empty r then
+      try
+        let _ = S.find_first (fun k -> k >= x) s1 in
+        false
+      with Not_found ->
+        true
+    else
+      let e = S.find_first (fun k -> k >= x) s1 in
+      if p then
+        e = x
+      else
+        e = S.min_elt r);
+
+  checkbool "find_first_opt"
+    (let (l, p, r) = S.split x s1 in
+    if not p && S.is_empty r then
+      match S.find_first_opt (fun k -> k >= x) s1 with
+        None -> true
+      | _ -> false
+    else
+      let Some e = S.find_first_opt (fun k -> k >= x) s1 in
+      if p then
+        e = x
+      else
+        e = S.min_elt r);
+
+  checkbool "find_last"
+    (let (l, p, r) = S.split x s1 in
+    if not p && S.is_empty l then
+      try
+        let _ = S.find_last (fun k -> k <= x) s1 in
+        false
+      with Not_found ->
+        true
+    else
+      let e = S.find_last (fun k -> k <= x) s1 in
+      if p then
+        e = x
+      else
+        e = S.max_elt l);
+
+  checkbool "find_last_opt"
+    (let (l, p, r) = S.split x s1 in
+    if not p && S.is_empty l then
+      match S.find_last_opt (fun k -> k <= x) s1 with
+        None -> true
+      | _ -> false
+    else
+      let Some e = S.find_last_opt (fun k -> k <= x) s1 in
+      if p then
+        e = x
+      else
+        e = S.max_elt l);
+
+  check "split"
+    (let (l, p, r) = S.split x s1 in
+     fun i ->
+       if i < x then S.mem i l = S.mem i s1
+       else if i > x then S.mem i r = S.mem i s1
+       else p = S.mem i s1)
+
+let relt() = Random.int 10
+
+let rset() =
+  let s = ref S.empty in
+  for i = 1 to Random.int 10 do s := S.add (relt()) !s done;
+  !s
+
+let _ =
+  Random.init 42;
+  for i = 1 to 10000 do test (relt()) (rset()) (rset()) done
+
+let () =
+  (* #6645: check that adding an element to set that already contains
+     it doesn't allocate and return the original set. *)
+  let s1 = ref S.empty in
+  for i = 1 to 10 do s1 := S.add i !s1 done;
+  let s2 = ref !s1 in
+
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  for i = 1 to 10 do s2 := S.add i !s2 done;
+  let a2 = Gc.allocated_bytes () in
+
+  assert (!s2 == !s1);
+  assert(a2 -. a1 = a1 -. a0)
+
+let () =
+  (* check that removing an element from a set that is not present in this set
+     (1) doesn't allocate and (2) return the original set *)
+  let s1 = ref S.empty in
+  for i = 1 to 10 do s1 := S.add i !s1 done;
+  let s2 = ref !s1 in
+
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  for i = 11 to 30 do s2 := S.remove i !s2 done;
+  let a2 = Gc.allocated_bytes () in
+
+  assert (!s2 == !s1);
+  assert(a2 -. a1 = a1 -. a0)
+
+let () =
+  (* check that filtering a set where all elements are satisfied by
+     the given predicate return the original set *)
+  let s1 = ref S.empty in
+  for i = 1 to 10 do s1 := S.add i !s1 done;
+  let s2 = S.filter (fun e -> e >= 0) !s1 in
+  assert (s2 == !s1)
+
+let valid_structure s =
+  (* this test should return 'true' for all set,
+     but it can detect sets that are ill-structured,
+     for example incorrectly ordered, as the S.mem
+     function will make assumptions about the set ordering.
+
+     (This trick was used to exhibit the bug in PR#7403)
+  *)
+  List.for_all (fun n -> S.mem n s) (S.elements s)
+
+let () =
+  (* PR#7403: map buggily orders elements according to the input
+     set order, not the output set order. Mapping functions that
+     change the value ordering thus break the set structure. *)
+  let test = S.of_list [1; 3; 5] in
+  let f = function 3 -> 8 | n -> n in
+  assert (valid_structure (S.map f test))
diff --git a/testsuite/tests/lib-set/testset.reference b/testsuite/tests/lib-set/testset.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-stack/Makefile b/testsuite/tests/lib-stack/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-stack/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-stack/test.ml b/testsuite/tests/lib-stack/test.ml
new file mode 100644
index 00000000..e0105c50
--- /dev/null
+++ b/testsuite/tests/lib-stack/test.ml
@@ -0,0 +1,118 @@
+module S = struct
+  include Stack
+
+  let to_list s =    (* from bottom to top *)
+    let l = ref [] in
+    iter (fun x -> l := x :: !l) s;
+    !l
+end
+
+let does_raise f s =
+  try
+    ignore (f s : int);
+    false
+  with S.Empty ->
+    true
+
+let () =
+  let s = S.create () in
+  ();                   assert (S.to_list s = [          ] && S.length s = 0);
+  S.push 1 s;           assert (S.to_list s = [1         ] && S.length s = 1);
+  S.push 2 s;           assert (S.to_list s = [1; 2      ] && S.length s = 2);
+  S.push 3 s;           assert (S.to_list s = [1; 2; 3   ] && S.length s = 3);
+  S.push 4 s;           assert (S.to_list s = [1; 2; 3; 4] && S.length s = 4);
+  assert (S.pop s = 4); assert (S.to_list s = [1; 2; 3;  ] && S.length s = 3);
+  assert (S.pop s = 3); assert (S.to_list s = [1; 2;     ] && S.length s = 2);
+  assert (S.pop s = 2); assert (S.to_list s = [1;        ] && S.length s = 1);
+  assert (S.pop s = 1); assert (S.to_list s = [          ] && S.length s = 0);
+  assert (does_raise S.pop s);
+;;
+
+let () =
+  let s = S.create () in
+  S.push 1 s; assert (S.pop s = 1); assert (does_raise S.pop s);
+  S.push 2 s; assert (S.pop s = 2); assert (does_raise S.pop s);
+  assert (S.length s = 0);
+;;
+
+let () =
+  let s = S.create () in
+  S.push 1 s; assert (S.top s = 1);
+  S.push 2 s; assert (S.top s = 2);
+  S.push 3 s; assert (S.top s = 3);
+  assert (S.top s = 3); assert (S.pop s = 3);
+  assert (S.top s = 2); assert (S.pop s = 2);
+  assert (S.top s = 1); assert (S.pop s = 1);
+  assert (does_raise S.top s);
+  assert (does_raise S.top s);
+;;
+
+let () =
+  let s = S.create () in
+  for i = 1 to 10 do S.push i s done;
+  S.clear s;
+  assert (S.length s = 0);
+  assert (does_raise S.pop s);
+  assert (s = S.create ());
+  S.push 42 s;
+  assert (S.pop s = 42);
+;;
+
+let () =
+  let s1 = S.create () in
+  for i = 1 to 10 do S.push i s1 done;
+  let s2 = S.copy s1 in
+  assert (S.to_list s1 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]);
+  assert (S.to_list s2 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]);
+  assert (S.length s1 = 10);
+  assert (S.length s2 = 10);
+  for i = 10 downto 1 do
+    assert (S.pop s1 = i);
+  done;
+  for i = 10 downto 1 do
+    assert (S.pop s2 = i);
+  done;
+;;
+
+let () =
+  let s = S.create () in
+  assert (S.is_empty s);
+  for i = 1 to 10 do
+    S.push i s;
+    assert (S.length s = i);
+    assert (not (S.is_empty s));
+  done;
+  for i = 10 downto 1 do
+    assert (S.length s = i);
+    assert (not (S.is_empty s));
+    ignore (S.pop s : int);
+  done;
+  assert (S.length s = 0);
+  assert (S.is_empty s);
+;;
+
+let () =
+  let s = S.create () in
+  for i = 10 downto 1 do S.push i s done;
+  let i = ref 1 in
+  S.iter (fun j -> assert (!i = j); incr i) s;
+;;
+
+let () =
+  let s1 = S.create () in
+  assert (S.length s1 = 0); assert (S.to_list s1 = []);
+  let s2 = S.copy s1 in
+  assert (S.length s1 = 0); assert (S.to_list s1 = []);
+  assert (S.length s2 = 0); assert (S.to_list s2 = []);
+;;
+
+let () =
+  let s1 = S.create () and s2 = S.create () in
+  for i = 1 to 4 do S.push i s1 done;
+  assert (S.length s1 = 4); assert (S.to_list s1 = [1; 2; 3; 4]);
+  let s2 = S.copy s1 in
+  assert (S.length s1 = 4); assert (S.to_list s1 = [1; 2; 3; 4]);
+  assert (S.length s2 = 4); assert (S.to_list s2 = [1; 2; 3; 4]);
+;;
+
+let () = print_endline "OK"
diff --git a/testsuite/tests/lib-stack/test.reference b/testsuite/tests/lib-stack/test.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/lib-stack/test.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/lib-stdlabels/Makefile b/testsuite/tests/lib-stdlabels/Makefile
new file mode 100644
index 00000000..fe35955c
--- /dev/null
+++ b/testsuite/tests/lib-stdlabels/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+ADD_COMPFLAGS=-nolabels
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-stdlabels/test_stdlabels.ml b/testsuite/tests/lib-stdlabels/test_stdlabels.ml
new file mode 100644
index 00000000..5e9770d8
--- /dev/null
+++ b/testsuite/tests/lib-stdlabels/test_stdlabels.ml
@@ -0,0 +1,40 @@
+module A : module type of Array = ArrayLabels
+module B : module type of Bytes = BytesLabels
+module L : module type of List = ListLabels
+module S : module type of String = StringLabels
+
+module M : module type of Map = MoreLabels.Map
+module Se : module type of Set = MoreLabels.Set
+
+
+(* For  *)
+(* module H : module type of Hashtbl = MoreLabels.Hashtbl *)
+(* we will have following error: *)
+(* Error: Signature mismatch: *)
+(*        ... *)
+(*        Type declarations do not match: *)
+(*          type statistics = Hashtbl.statistics *)
+(*        is not included in *)
+(*          type statistics = { *)
+(*            num_bindings : int; *)
+(*            num_buckets : int; *)
+(*            max_bucket_length : int; *)
+(*            bucket_histogram : int array; *)
+(*          } *)
+(*        Their kinds differ. *)
+(* This is workaround:*)
+module Indirection = struct
+  type t = Hashtbl.statistics = {  num_bindings: int;
+                                   num_buckets: int;
+                                   max_bucket_length: int;
+                                   bucket_histogram: int array}
+end
+module type HS = sig
+  type statistics = Indirection.t
+  include module type of Hashtbl
+                         with type statistics := Indirection.t
+end
+module H : HS = MoreLabels.Hashtbl
+
+let ()  =
+  ()
diff --git a/testsuite/tests/lib-stdlabels/test_stdlabels.reference b/testsuite/tests/lib-stdlabels/test_stdlabels.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-str/Makefile b/testsuite/tests/lib-str/Makefile
new file mode 100644
index 00000000..b25e53f9
--- /dev/null
+++ b/testsuite/tests/lib-str/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=str
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str
+LD_PATH=$(TOPDIR)/otherlibs/str
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml
new file mode 100644
index 00000000..1e1b2705
--- /dev/null
+++ b/testsuite/tests/lib-str/t01.ml
@@ -0,0 +1,1078 @@
+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/ (case-insensitive)";
+  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 /[^a]/";
+  let r = Str.regexp "[^a]" in
+  let n = 0 in
+  test_search_forward r n "athing" [|"t"|];
+  test_search_forward r n "Athing" [|"A"|];
+
+  start_test "Search for /[^a]/ (case-insensitive)";
+  let r = Str.regexp_case_fold "[^a]" in
+  let n = 0 in
+  test_search_forward r n "athing" [|"t"|];
+  test_search_forward r n "Athing" [|"t"|];
+
+  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 /^\255/";
+  let r = Str.regexp "^\255" in
+  let n = 0 in
+  test_search_forward r n "\255"
+    [|"\255"|];
+
+  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 "a2cd"
+    [|"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 "bc_a"
+    [|"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" |];
+
+  (* PR#6989 *)
+  start_test "Many groups";
+  test_search_forward
+    (Str.regexp
+      "\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\
+       \\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\
+       \\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\\(\\)\
+       \\(\\)\\(x\\)\\(y\\)")
+    33 "xy"
+    [| "xy";
+       ""; ""; ""; ""; ""; ""; ""; ""; ""; "";
+       ""; ""; ""; ""; ""; ""; ""; ""; ""; "";
+       ""; ""; ""; ""; ""; ""; ""; ""; ""; "";
+       ""; "x"; "y" |];
+
+  (** 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";
+
+  (** Splitting *)
+  start_test "Splitting";
+  test (Str.split (Str.regexp "[ \t]+") "si non e vero")
+       ["si"; "non"; "e"; "vero"];
+  test (Str.split (Str.regexp "[ \t]+") " si non\te vero\t")
+       ["si"; "non"; "e"; "vero"];
+  test (Str.bounded_split (Str.regexp "[ \t]+") " si non e vero " 3)
+       ["si"; "non"; "e vero "];
+  test (Str.split (Str.regexp "[ \t]*") "si non e vero")
+       ["s"; "i"; "n"; "o"; "n"; "e"; "v"; "e"; "r"; "o"];
+  test (Str.split_delim (Str.regexp "[ \t]+") " si non e vero\t")
+       [""; "si"; "non"; "e"; "vero"; ""];
+  test (Str.full_split (Str.regexp "[ \t]+") " si non\te vero\t")
+       [Str.Delim " "; Str.Text "si";
+        Str.Delim " "; Str.Text "non";
+        Str.Delim "\t"; Str.Text "e";
+        Str.Delim " "; Str.Text "vero"; Str.Delim "\t"];
+
+  (** 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\"?>\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\n\
+escaped 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 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/testsuite/tests/lib-str/t01.reference b/testsuite/tests/lib-str/t01.reference
new file mode 100644
index 00000000..0a719240
--- /dev/null
+++ b/testsuite/tests/lib-str/t01.reference
@@ -0,0 +1,106 @@
+
+Search for /the quick brown fox/
+  ....
+Search for /the quick brown fox/ (case-insensitive)
+  .....
+Search for /a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz/
+  ....................................
+Search for /^abc\(abc\)?zz/
+  .....
+Search for /^\(b+\|a\)\(b+\|a\)?c/
+  ..........
+Search for /r\(\(g*\|k\)y?\)*A/
+  ....
+Search for /A\(\(t\|v\)\(q?\|n\)\)*A/
+  .
+Search for /A\(\(b\(\(d\|l*\)?\|w\)\)*a\)A/
+  .
+Search for /\(\|f\)*x/
+  ....
+Search for /\(\|f\)+x/
+  ....
+Search for /A\(.?\)*A/
+  ....
+Search for /\([ab]*\)\1+c/
+  ...
+Search for /^\(\(b+\|a\)\(b+\|a\)?\)?bc/
+  .
+Search for /^\(\(b*\|ba\)\(b*\|ba\)?\)?bc/
+  .....
+Search for /[^a]/
+  ..
+Search for /[^a]/ (case-insensitive)
+  ..
+Search for /^[]abcde]/
+  .........
+Search for /^[]cde]/
+  ......
+Search for /^[^]abcde]/
+  .........
+Search for /^[^]cde]/
+  ......
+Search for /^ÿ/
+  .
+Search for /^[0-9]+$/
+  .............
+Search for /^.*nter/
+  ...
+Search for /^xxx[0-9]+$/
+  ...
+Search for /^.+[0-9][0-9][0-9]$/
+  .....
+Search for /^\([^!]+\)!\(.+\)=apquxz\.ixr\.zzz\.ac\.uk$/
+  .....
+Search for /\([0-9a-f:]+\)$/
+  ............
+Search for /^[a-z0-9][a-z0-9-]*\(\.[a-z0-9][A-Z0-9-]*\)*\.$/
+  .........
+Search for /^\*\.[a-z]\([a-z0-9-]*[a-z0-9]+\)?\(\.[a-z]\([a-z0-9-]*[a-z0-9]+\)?\)*$/
+  ........
+Search for /^[0-9a-fA-F]\(\.[0-9a-fA-F]\)*$/
+  .....
+Search for /^\".*\" *\(;.*\)?$/
+  ....
+Search for /^\(a\(b\(c\)\)\)\(d\(e\(f\)\)\)\(h\(i\(j\)\)\)$/
+  .
+Search for /^[.^$|()*+?{,}]+/
+  .
+Search for /\(cat\(a\(ract\|tonic\)\|erpillar\)\) \1\(\)2\(3\)/
+  ...
+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]/
+  .
+Search for /\ba/
+  ......
+Search for /a\b/
+  ......
+Search for /\([a-z]*\)b/
+  .
+Search for /\([a-z]+\)b/
+  .
+Search for /\([a-z]?\)b/
+  .
+Search for /^a/
+  ..
+Search for /a$/
+  ..
+Null characters in regexps
+  ..
+Many groups
+  .
+Backward search for /the quick/
+  ....
+Backward search for /a\([0-9]+\)/
+  ..
+Partial match for /partial match/
+  ...
+Partial match for /\(partial\)\|\(match\)/
+  ......
+Global replacement
+  ...
+First replacement
+  ..
+Splitting
+  ......
+XML tokenization
+  .........................................................................................................................
+All tests passed
diff --git a/testsuite/tests/lib-stream/Makefile b/testsuite/tests/lib-stream/Makefile
new file mode 100644
index 00000000..77b26912
--- /dev/null
+++ b/testsuite/tests/lib-stream/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=testing
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-stream/count_concat_bug.ml b/testsuite/tests/lib-stream/count_concat_bug.ml
new file mode 100644
index 00000000..97ec6bce
--- /dev/null
+++ b/testsuite/tests/lib-stream/count_concat_bug.ml
@@ -0,0 +1,57 @@
+let is_empty s =
+  try Stream.empty s; true with Stream.Failure -> false
+
+let test_icons =
+  let s = Stream.of_string "ab" in
+  let s = Stream.icons 'c' s in
+  Testing.test (Stream.next s = 'c');
+  Testing.test (Stream.next s = 'a');
+  Testing.test (Stream.next s = 'b');
+  Testing.test (is_empty s);
+  ()
+
+let test_lcons =
+  let s = Stream.of_string "ab" in
+  let s = Stream.lcons (fun () -> 'c') s in
+  Testing.test (Stream.next s = 'c');
+  Testing.test (Stream.next s = 'a');
+  Testing.test (Stream.next s = 'b');
+  Testing.test (is_empty s);
+  ()
+
+let test_iapp =
+  let s = Stream.of_string "ab" in
+  let s = Stream.iapp (Stream.of_list ['c']) s in
+  Testing.test (Stream.next s = 'c');
+  Testing.test (Stream.next s = 'a');
+  Testing.test (Stream.next s = 'b');
+  Testing.test (is_empty s);
+  ()
+
+let test_lapp_right =
+  let s1 = Stream.of_list ['c'] in
+  let s2 = Stream.of_string "ab" in
+  let s = Stream.lapp (fun () -> s1) s2 in
+  Testing.test (Stream.next s = 'c');
+  Testing.test (Stream.next s = 'a');
+  Testing.test (Stream.next s = 'b');
+  Testing.test (is_empty s);
+  ()
+
+let test_lapp_left =
+  let s1 = Stream.of_string "bc" in
+  let s2 = Stream.of_list ['a'] in
+  Testing.test (Stream.next s1 = 'b');
+  let s = Stream.lapp (fun () -> s1) s2 in
+  Testing.test (Stream.next s = 'c');
+  Testing.test (Stream.next s = 'a');
+  Testing.test (is_empty s);
+  ()
+
+let test_slazy =
+  let s = Stream.of_string "ab" in
+  Testing.test (Stream.next s = 'a');
+  let s = Stream.slazy (fun () -> s) in
+  Testing.test (Stream.next s = 'b');
+  Testing.test (is_empty s);
+  ()
diff --git a/testsuite/tests/lib-stream/count_concat_bug.reference b/testsuite/tests/lib-stream/count_concat_bug.reference
new file mode 100644
index 00000000..52e367ea
--- /dev/null
+++ b/testsuite/tests/lib-stream/count_concat_bug.reference
@@ -0,0 +1,2 @@
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
+All tests succeeded.
diff --git a/testsuite/tests/lib-string/Makefile b/testsuite/tests/lib-string/Makefile
new file mode 100644
index 00000000..b25e53f9
--- /dev/null
+++ b/testsuite/tests/lib-string/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=str
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str
+LD_PATH=$(TOPDIR)/otherlibs/str
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-string/test_string.ml b/testsuite/tests/lib-string/test_string.ml
new file mode 100644
index 00000000..96b8c50f
--- /dev/null
+++ b/testsuite/tests/lib-string/test_string.ml
@@ -0,0 +1,52 @@
+let rec build_string f n accu =
+  if n <= 0
+    then String.concat "" accu
+    else build_string f (n-1) (f (n-1) :: accu)
+;;
+
+let char n = String.make 1 (Char.chr n);;
+
+let reference n =
+  if n = 8 then "\\b"
+  else if n = 9 then "\\t"
+  else if n = 10 then "\\n"
+  else if n = 13 then "\\r"
+  else if n = Char.code '\"' then "\\\""
+  else if n = Char.code '\\' then "\\\\"
+  else if n < 32 || n > 126 then Printf.sprintf "\\%03d" n
+  else char n
+;;
+
+let raw_string = build_string char 256 [];;
+let ref_string = build_string reference 256 [];;
+
+if String.escaped raw_string <> ref_string then failwith "test:String.escaped";;
+
+
+let check_split sep s =
+  let l = String.split_on_char sep s in
+  assert(List.length l > 0);
+  assert(String.concat (String.make 1 sep) l = s);
+  List.iter (String.iter (fun c -> assert (c <> sep))) l
+;;
+
+let () =
+  let s = " abc def " in
+  for i = 0 to String.length s do
+    check_split ' ' (String.sub s 0 i)
+  done
+;;
+
+(* GPR#805/815/833 *)
+
+let ()  =
+  if Sys.word_size = 32 then begin
+    let big = String.make Sys.max_string_length 'x' in
+    let push x l = l := x :: !l in
+    let (+=) a b = a := !a + b in
+    let sz, l = ref 0, ref [] in
+    while !sz >= 0 do push big l; sz += Sys.max_string_length done;
+    while !sz <= 0 do push big l; sz += Sys.max_string_length done;
+    try ignore (String.concat "" !l); assert false
+    with Invalid_argument _ -> ()
+  end
diff --git a/testsuite/tests/lib-string/test_string.reference b/testsuite/tests/lib-string/test_string.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-systhreads/Makefile b/testsuite/tests/lib-systhreads/Makefile
new file mode 100644
index 00000000..280f16d5
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix threads
+ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
+	      -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-systhreads/testfork.ml b/testsuite/tests/lib-systhreads/testfork.ml
new file mode 100644
index 00000000..1c1f232f
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/testfork.ml
@@ -0,0 +1,31 @@
+(* POSIX threads and fork() *)
+
+let compute_thread c = ignore c
+(*
+  while true do
+    print_char c; flush stdout;
+    for i = 1 to 100000 do ignore(ref []) done
+  done
+*)
+
+let main () =
+  ignore(Thread.create compute_thread '1');
+  Thread.delay 1.0;
+  print_string "Forking..."; print_newline();
+  match Unix.fork() with
+  | 0 ->
+      Thread.delay 0.5;
+      print_string "In child..."; print_newline();
+      Gc.minor();
+      print_string "Child did minor GC."; print_newline();
+      ignore(Thread.create compute_thread '2');
+      Thread.delay 1.0;
+      print_string "Child is exiting."; print_newline();
+      exit 0
+  | pid ->
+      print_string "In parent..."; print_newline();
+      Thread.delay 4.0;
+      print_string "Parent is exiting."; print_newline();
+      exit 0
+
+let _ = main()
diff --git a/testsuite/tests/lib-systhreads/testfork.precheck b/testsuite/tests/lib-systhreads/testfork.precheck
new file mode 100644
index 00000000..0dfed5de
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/testfork.precheck
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+case `grep '^SYSTEM=' ../../../config/Makefile` in
+  SYSTEM=bsd_elf) exit 3;;
+esac
+
+case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in
+  *' unix'*) exit 0;;
+  *) exit 3;;
+esac
diff --git a/testsuite/tests/lib-systhreads/testfork.reference b/testsuite/tests/lib-systhreads/testfork.reference
new file mode 100644
index 00000000..fb7a3c29
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/testfork.reference
@@ -0,0 +1,6 @@
+Forking...
+In parent...
+In child...
+Child did minor GC.
+Child is exiting.
+Parent is exiting.
diff --git a/testsuite/tests/lib-threads/Makefile b/testsuite/tests/lib-threads/Makefile
new file mode 100644
index 00000000..8288dfdc
--- /dev/null
+++ b/testsuite/tests/lib-threads/Makefile
@@ -0,0 +1,33 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix threads
+ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
+	      -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+default:
+	@$(if $(filter msvc mingw,$(TOOLCHAIN)),$(MAKE) sigint.exe,true)
+	@$(SET_LD_PATH) $(MAKE) run-all
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+sigint.exe: sigint.$(O)
+	@$(CC) $(if $(filter msvc,$(CCOMPTYPE)),/Fe$@,-o $@) $^
+
+%.obj: %.c
+	@$(CC) -c $*.c > /dev/null
diff --git a/testsuite/tests/lib-threads/backtrace_threads.ml b/testsuite/tests/lib-threads/backtrace_threads.ml
new file mode 100644
index 00000000..348a5f7f
--- /dev/null
+++ b/testsuite/tests/lib-threads/backtrace_threads.ml
@@ -0,0 +1,18 @@
+
+let () = Printexc.record_backtrace true
+
+let () =
+   let bt =
+     try
+       Hashtbl.find (Hashtbl.create 1) 1;
+       assert false
+     with Not_found ->
+       Printexc.get_raw_backtrace ()
+   in
+   let t = Thread.create (fun () ->
+       try
+         Printexc.raise_with_backtrace Not_found bt
+       with Not_found -> ()
+     ) () in
+   Thread.join t;
+   flush stdout
diff --git a/testsuite/tests/lib-threads/backtrace_threads.reference b/testsuite/tests/lib-threads/backtrace_threads.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-threads/bank.ml b/testsuite/tests/lib-threads/bank.ml
new file mode 100644
index 00000000..800d332a
--- /dev/null
+++ b/testsuite/tests/lib-threads/bank.ml
@@ -0,0 +1,27 @@
+(* The bank account example, using events and channels *)
+
+open Printf
+open Event
+
+type account = int channel * int channel
+
+let account (put_ch, get_ch) =
+  let rec acc balance =
+    select [
+      wrap (send get_ch balance) (fun () -> acc balance);
+      wrap (receive put_ch) (fun amount ->
+        if balance + amount < 0 then failwith "negative balance";
+        acc (balance + amount))
+    ]
+  in acc 0
+
+let get ((put_ch, get_ch): account) = sync (receive get_ch)
+let put ((put_ch, get_ch): account) amount = sync (send put_ch amount)
+
+let _ =
+  let a : account = (new_channel(), new_channel()) in
+  ignore (Thread.create account a);
+  put a 100;
+  printf "Current balance: %d\n" (get a);
+  for i = 1 to 99 do put a (-2); put a 1 done;
+  printf "Final balance: %d\n" (get a)
diff --git a/testsuite/tests/lib-threads/bank.reference b/testsuite/tests/lib-threads/bank.reference
new file mode 100644
index 00000000..80ad5cd5
--- /dev/null
+++ b/testsuite/tests/lib-threads/bank.reference
@@ -0,0 +1,2 @@
+Current balance: 100
+Final balance: 1
diff --git a/testsuite/tests/lib-threads/beat.ml b/testsuite/tests/lib-threads/beat.ml
new file mode 100644
index 00000000..afc8166a
--- /dev/null
+++ b/testsuite/tests/lib-threads/beat.ml
@@ -0,0 +1,19 @@
+(* Test Thread.delay and its scheduling *)
+
+open Printf
+
+let tick (delay, count) =
+  while true do
+    Thread.delay delay;
+    incr count
+  done
+
+let _ =
+  let c1 = ref 0 and c2 = ref 0 in
+  ignore (Thread.create tick (0.333333333, c1));
+  ignore (Thread.create tick (0.5, c2));
+  Thread.delay 3.0;
+  let n1 = !c1 and n2 = !c2 in
+  if n1 >= 8 && n1 <= 10 && n2 >= 5 && n2 <= 7
+  then printf "passed\n"
+  else printf "FAILED (n1 = %d, n2 = %d)\n" n1 n2
diff --git a/testsuite/tests/lib-threads/beat.reference b/testsuite/tests/lib-threads/beat.reference
new file mode 100644
index 00000000..b0aad4de
--- /dev/null
+++ b/testsuite/tests/lib-threads/beat.reference
@@ -0,0 +1 @@
+passed
diff --git a/testsuite/tests/lib-threads/bufchan.ml b/testsuite/tests/lib-threads/bufchan.ml
new file mode 100644
index 00000000..b8ac55c2
--- /dev/null
+++ b/testsuite/tests/lib-threads/bufchan.ml
@@ -0,0 +1,51 @@
+open Event
+
+type 'a buffer_channel = {
+  input: 'a channel;
+  output: 'a channel;
+  thread: Thread.t;
+}
+
+let new_buffer_channel() =
+  let ic = new_channel() in
+  let oc = new_channel() in
+  let rec buffer_process front rear =
+    match (front, rear) with
+    | (["EOF"], []) -> Thread.exit ()
+    | ([], []) -> 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
+  let t = Thread.create (buffer_process []) [] in
+  { input = ic; output = oc; thread = t }
+
+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 _ =
+  let t = Thread.create f () in
+  g();
+  buffer_send box "EOF";
+  Thread.join box.thread;
+  Thread.join t
diff --git a/testsuite/tests/lib-threads/bufchan.reference b/testsuite/tests/lib-threads/bufchan.reference
new file mode 100644
index 00000000..35c80454
--- /dev/null
+++ b/testsuite/tests/lib-threads/bufchan.reference
@@ -0,0 +1,3 @@
+3
+un
+deux
diff --git a/testsuite/tests/lib-threads/close.ml b/testsuite/tests/lib-threads/close.ml
new file mode 100644
index 00000000..3af8ae31
--- /dev/null
+++ b/testsuite/tests/lib-threads/close.ml
@@ -0,0 +1,18 @@
+let main () =
+  let (rd, wr) = Unix.pipe() in
+  let t = Thread.create
+    (fun () ->
+      Thread.delay 1.0;
+      print_endline "closing fd...";
+      Unix.close wr;
+    )
+    () in
+  let buf = String.create 10 in
+  print_endline "reading...";
+  begin try ignore (Unix.read rd buf 0 10) with Unix.Unix_error _ -> () end;
+  print_endline "read returned";
+  t
+
+let t = Unix.handle_unix_error main ()
+
+let _ = Thread.join t
diff --git a/testsuite/tests/lib-threads/close.reference b/testsuite/tests/lib-threads/close.reference
new file mode 100644
index 00000000..bb5061c8
--- /dev/null
+++ b/testsuite/tests/lib-threads/close.reference
@@ -0,0 +1,3 @@
+reading...
+closing fd...
+read returned
diff --git a/testsuite/tests/lib-threads/fileio.ml b/testsuite/tests/lib-threads/fileio.ml
new file mode 100644
index 00000000..f9d97c94
--- /dev/null
+++ b/testsuite/tests/lib-threads/fileio.ml
@@ -0,0 +1,117 @@
+(* 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 = if Array.length Sys.argv > 1 then Sys.argv.(1) else "fileio.ml" in
+  let ofile = Filename.temp_file "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;
+  let linesfile = Filename.temp_file "lines" "" in
+  make_lines linesfile;
+  test "line per line"
+       copy_line copy_line linesfile ofile;
+  test_trunc_line ofile;
+  Sys.remove linesfile;
+  Sys.remove ofile
+
+let _ = Unix.handle_unix_error main (); exit 0
diff --git a/testsuite/tests/lib-threads/fileio.reference b/testsuite/tests/lib-threads/fileio.reference
new file mode 100644
index 00000000..24f04b9b
--- /dev/null
+++ b/testsuite/tests/lib-threads/fileio.reference
@@ -0,0 +1,22 @@
+256-byte chunks, 256-byte chunks
+passed
+4096-byte chunks, 4096-byte chunks
+passed
+65536-byte chunks, 65536-byte chunks
+passed
+256-byte chunks, 4096-byte chunks
+passed
+4096-byte chunks, 256-byte chunks
+passed
+4096-byte chunks, 65536-byte chunks
+passed
+263-byte chunks, 4011-byte chunks
+passed
+613-byte chunks, 1027-byte chunks
+passed
+0...8192 byte chunks
+passed
+line per line
+passed
+truncated line
+passed
diff --git a/testsuite/tests/lib-threads/pr4466.ml b/testsuite/tests/lib-threads/pr4466.ml
new file mode 100644
index 00000000..0598a54e
--- /dev/null
+++ b/testsuite/tests/lib-threads/pr4466.ml
@@ -0,0 +1,71 @@
+open Printf
+
+(* Regression test for PR#4466: select timeout with simultaneous read
+   and write on socket in Windows. *)
+
+(* Scenario:
+     - thread [server] implements a simple 'echo' server on a socket
+     - thread [reader] selects then reads from a socket connected to
+       the echo server and copies to standard output
+     - main program executes [writer], which writes to the same socket
+       (the one connected to the echo server)
+*)
+
+let serve_connection s =
+  let buf = Bytes.make 1024 '>' in
+  while true do
+    let n = Unix.recv s buf 2 (Bytes.length buf - 2) [] in
+    if n = 0 then begin
+      Unix.close s; Thread.exit ()
+    end else begin
+      ignore (Unix.send s buf 0 (n + 2) [])
+    end
+  done
+
+let server sock =
+  while true do
+    let (s, _) = Unix.accept sock in
+    ignore(Thread.create serve_connection s)
+  done
+
+let reader s =
+  let buf = Bytes.make 16 ' ' in
+  match Unix.select [s] [] [] 10.0 with
+  | (_::_, _, _) ->
+      printf "Selected\n%!";
+      let n = Unix.recv s buf 0 (Bytes.length buf) [] in
+      printf "Data read: %s\n%!" (Bytes.sub_string buf 0 n)
+  | ([], _, _) ->
+      printf "TIMEOUT\n%!"
+
+let writer s msg =
+  ignore (Unix.send_substring s msg 0 (String.length msg) [])
+
+let _ =
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
+  let serv =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.setsockopt serv Unix.SO_REUSEADDR true;
+  Unix.bind serv addr;
+  let addr = Unix.getsockname serv in
+  Unix.listen serv 5;
+  ignore (Thread.create server serv);
+  Thread.delay 0.2;
+  let client =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.connect client addr;
+  (* Send before select & read *)
+  writer client "1111";
+  let a = Thread.create reader client in
+  Thread.delay 0.1;
+  Thread.join a;
+  (* Select then send *)
+  let a = Thread.create reader client in
+  Thread.delay 0.1;
+  writer client "2222";
+  Thread.join a;
+  (* Select then send again *)
+  let a = Thread.create reader client in
+  Thread.delay 0.1;
+  writer client "3333";
+  Thread.join a
diff --git a/testsuite/tests/lib-threads/pr4466.reference b/testsuite/tests/lib-threads/pr4466.reference
new file mode 100644
index 00000000..ecfdf536
--- /dev/null
+++ b/testsuite/tests/lib-threads/pr4466.reference
@@ -0,0 +1,6 @@
+Selected
+Data read: >>1111
+Selected
+Data read: >>2222
+Selected
+Data read: >>3333
diff --git a/testsuite/tests/lib-threads/pr5325.ml b/testsuite/tests/lib-threads/pr5325.ml
new file mode 100644
index 00000000..884a9a3e
--- /dev/null
+++ b/testsuite/tests/lib-threads/pr5325.ml
@@ -0,0 +1,58 @@
+open Printf
+
+(* Regression test for PR#5325: simultaneous read and write on socket
+   in Windows. *)
+
+(* Scenario:
+     - thread [server] implements a simple 'echo' server on a socket
+     - thread [reader] reads from a socket connected to the echo server
+       and copies to standard output
+     - main program executes [writer], which writes to the same socket
+       (the one connected to the echo server)
+     - thread [timeout] causes a failure if nothing happens in 10 seconds.
+*)
+
+let serve_connection s =
+  let buf = Bytes.make 1024 '>' in
+  let n = Unix.read s buf 2 (Bytes.length buf - 2) in
+  ignore (Unix.write s buf 0 (n + 2));
+  Unix.close s
+
+let server sock =
+  while true do
+    let (s, _) = Unix.accept sock in
+    ignore(Thread.create serve_connection s)
+  done
+
+let timeout () =
+  Thread.delay 10.0;
+  printf "Time out, exiting...\n%!";
+  exit 2
+
+let reader s =
+  let buf = Bytes.make 1024 ' ' in
+  let n = Unix.read s buf 0 (Bytes.length buf) in
+  print_bytes (Bytes.sub buf 0 n); flush stdout
+
+let writer s msg =
+  ignore (Unix.write_substring s msg 0 (String.length msg));
+  Unix.shutdown s Unix.SHUTDOWN_SEND
+
+let _ =
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
+  let serv =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.setsockopt serv Unix.SO_REUSEADDR true;
+  Unix.bind serv addr;
+  let addr = Unix.getsockname serv in
+  Unix.listen serv 5;
+  ignore (Thread.create server serv);
+  ignore (Thread.create timeout ());
+  Thread.delay 0.5;
+  let client =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.connect client addr;
+  let rd = Thread.create reader client in
+  Thread.delay 0.5;
+  writer client "Client data\n";
+  Thread.join rd
diff --git a/testsuite/tests/lib-threads/pr5325.reference b/testsuite/tests/lib-threads/pr5325.reference
new file mode 100644
index 00000000..dd045794
--- /dev/null
+++ b/testsuite/tests/lib-threads/pr5325.reference
@@ -0,0 +1 @@
+>>Client data
diff --git a/testsuite/tests/lib-threads/prodcons.ml b/testsuite/tests/lib-threads/prodcons.ml
new file mode 100644
index 00000000..81e3ff18
--- /dev/null
+++ b/testsuite/tests/lib-threads/prodcons.ml
@@ -0,0 +1,62 @@
+(* 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.make 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 rec produce buff n max =
+  put buff n;
+  if n < max then produce buff (n+1) max
+
+let rec consume buff cur max =
+  let n = get buff in
+  if n <> cur then false
+  else if n = max then true
+  else consume buff (cur + 1) max
+
+let _ =
+  let buff1 = create 20 0 and buff2 = create 30 0 in
+  let ok1 = ref false and ok2 = ref false in
+  let _p1 = Thread.create (fun () -> produce buff1 0 10000) ()
+  and _p2 = Thread.create (fun () -> produce buff2 0 8000) ()
+  and c1 = Thread.create (fun () -> ok1 := consume buff1 0 10000) () in
+  ok2 := consume buff2 0 8000;
+  Thread.join c1;
+  if !ok1 && !ok2
+  then print_string "passed\n"
+  else print_string "FAILED\n"
diff --git a/testsuite/tests/lib-threads/prodcons.reference b/testsuite/tests/lib-threads/prodcons.reference
new file mode 100644
index 00000000..b0aad4de
--- /dev/null
+++ b/testsuite/tests/lib-threads/prodcons.reference
@@ -0,0 +1 @@
+passed
diff --git a/testsuite/tests/lib-threads/prodcons2.ml b/testsuite/tests/lib-threads/prodcons2.ml
new file mode 100644
index 00000000..0b80f5e2
--- /dev/null
+++ b/testsuite/tests/lib-threads/prodcons2.ml
@@ -0,0 +1,33 @@
+(* Producer-consumer with events and multiple producers *)
+
+open Event
+
+let rec produce chan n max =
+  sync (send chan n);
+  if n < max then produce chan (n + 1) max else sync (send chan (-1))
+
+let rec consume chans sum =
+  let rec mkreceive prev = function
+    | [] -> []
+    | chan :: rem as chans ->
+        wrap (receive chan) (fun n ->
+          if n < 0
+          then consume (List.rev_append rem prev) sum
+          else consume (List.rev_append chans prev) (sum + n))
+        :: mkreceive (chan :: prev) rem
+  in
+    if chans = [] then sum else select (mkreceive [] chans)
+
+let sum_0_n n = n * (n + 1) / 2
+
+let _ =
+  let chan1 = new_channel()
+  and chan2 = new_channel()
+  and chan3 = new_channel() in
+  ignore (Thread.create (fun () -> produce chan1 0 5000) ());
+  ignore (Thread.create (fun () -> produce chan2 0 2000) ());
+  ignore (Thread.create (fun () -> produce chan3 0 1000) ());
+  let n = consume [chan1; chan2; chan3] 0 in
+  if n = sum_0_n 5000 + sum_0_n 2000 + sum_0_n 1000
+  then print_string "passed\n"
+  else print_string "FAILED\n"
diff --git a/testsuite/tests/lib-threads/prodcons2.reference b/testsuite/tests/lib-threads/prodcons2.reference
new file mode 100644
index 00000000..b0aad4de
--- /dev/null
+++ b/testsuite/tests/lib-threads/prodcons2.reference
@@ -0,0 +1 @@
+passed
diff --git a/testsuite/tests/lib-threads/sieve.ml b/testsuite/tests/lib-threads/sieve.ml
new file mode 100644
index 00000000..13c494cd
--- /dev/null
+++ b/testsuite/tests/lib-threads/sieve.ml
@@ -0,0 +1,28 @@
+let sieve primes =
+  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 input =
+    let n = Event.sync (Event.receive input)
+    and output = Event.new_channel () in
+    Event.sync (Event.send primes n);
+    ignore(Thread.create filter output);
+    (* We remove from the output the multiples of n *)
+    while true do
+        let m = Event.sync (Event.receive input) in
+        (* print_int n; print_string ": "; print_int m; print_newline(); *)
+        if m mod n <> 0 then Event.sync (Event.send output m)
+      done in
+  ignore(Thread.create filter integers);
+  ignore(Thread.create enumerate 3)
+
+let primes = Event.new_channel ()
+
+let _ =
+  ignore(Thread.create sieve primes);
+  for i = 1 to 50 do
+    let n = Event.sync (Event.receive primes) in
+    print_int n; print_newline()
+  done
diff --git a/testsuite/tests/lib-threads/sieve.reference b/testsuite/tests/lib-threads/sieve.reference
new file mode 100644
index 00000000..ad2c8fd7
--- /dev/null
+++ b/testsuite/tests/lib-threads/sieve.reference
@@ -0,0 +1,50 @@
+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
diff --git a/testsuite/tests/lib-threads/sigint.c b/testsuite/tests/lib-threads/sigint.c
new file mode 100644
index 00000000..a975949a
--- /dev/null
+++ b/testsuite/tests/lib-threads/sigint.c
@@ -0,0 +1,37 @@
+#include <stdio.h>
+#include <windows.h>
+
+int main(int argc, char** argv)
+{
+  DWORD pid;
+  HANDLE hProcess;
+
+  if (argc != 2) {
+    printf("Usage: %s pid\n", argv[0]);
+    return 1;
+  }
+
+  pid = atoi(argv[1]);
+  hProcess = OpenProcess(SYNCHRONIZE, FALSE, pid);
+
+  if (!hProcess) {
+    printf("Process %lu not found!\n", pid);
+    return 1;
+  }
+
+  FreeConsole();
+
+  if (!AttachConsole(pid)) {
+    printf("Failed to attach to console of Process %lu\n", pid);
+    CloseHandle(hProcess);
+    return 1;
+  }
+
+  SetConsoleCtrlHandler(NULL, TRUE);
+  GenerateConsoleCtrlEvent(0, 0);
+  WaitForSingleObject(hProcess, INFINITE);
+  CloseHandle(hProcess);
+  FreeConsole();
+
+  return 0;
+}
diff --git a/testsuite/tests/lib-threads/signal.checker b/testsuite/tests/lib-threads/signal.checker
new file mode 100644
index 00000000..181d3c5a
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+sed -e 1q signal.result | grep -q '^[ab]*Got ctrl-C, exiting...$'
diff --git a/testsuite/tests/lib-threads/signal.ml b/testsuite/tests/lib-threads/signal.ml
new file mode 100644
index 00000000..b9ef7d63
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal.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 _ =
+  ignore (Sys.signal Sys.sigint (Sys.Signal_handle sighandler));
+  ignore (Thread.create (print_message 0.6666666666) 'a');
+  print_message 1.0 'b'
diff --git a/testsuite/tests/lib-threads/signal.precheck b/testsuite/tests/lib-threads/signal.precheck
new file mode 100644
index 00000000..d04af9a4
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal.precheck
@@ -0,0 +1 @@
+test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw"
diff --git a/testsuite/tests/lib-threads/signal.runner b/testsuite/tests/lib-threads/signal.runner
new file mode 100644
index 00000000..b90139a9
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal.runner
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+$RUNTIME ./program >signal.result &
+pid=$!
+sleep 2
+test -e ./sigint.exe && ./sigint $pid || kill -INT $pid
diff --git a/testsuite/tests/lib-threads/signal2.checker b/testsuite/tests/lib-threads/signal2.checker
new file mode 100644
index 00000000..56fe7db3
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal2.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+sed -e 1q signal2.result | grep -q '^[ab]*'
diff --git a/testsuite/tests/lib-threads/signal2.ml b/testsuite/tests/lib-threads/signal2.ml
new file mode 100644
index 00000000..b7cda56d
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal2.ml
@@ -0,0 +1,11 @@
+let print_message delay c =
+  while true do
+    print_char c; flush stdout; Thread.delay delay
+  done
+
+let _ =
+  ignore (Thread.sigmask Unix.SIG_BLOCK [Sys.sigint; Sys.sigterm]);
+  ignore (Thread.create (print_message 0.6666666666) 'a');
+  ignore (Thread.create (print_message 1.0) 'b');
+  let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in
+  Printf.printf "Got signal %d, exiting...\n" s
diff --git a/testsuite/tests/lib-threads/signal2.precheck b/testsuite/tests/lib-threads/signal2.precheck
new file mode 100644
index 00000000..72b0054c
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal2.precheck
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw"
diff --git a/testsuite/tests/lib-threads/signal2.runner b/testsuite/tests/lib-threads/signal2.runner
new file mode 100644
index 00000000..8369d636
--- /dev/null
+++ b/testsuite/tests/lib-threads/signal2.runner
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+$RUNTIME ./program >signal2.result &
+pid=$!
+sleep 2
+kill -INT $pid
+sleep 1
+kill -9 $pid 2>&- || true
diff --git a/testsuite/tests/lib-threads/sockets.ml b/testsuite/tests/lib-threads/sockets.ml
new file mode 100644
index 00000000..160446f6
--- /dev/null
+++ b/testsuite/tests/lib-threads/sockets.ml
@@ -0,0 +1,38 @@
+open Printf
+
+(* Threads and sockets *)
+
+let serve_connection s =
+  let buf = Bytes.make 1024 '>' in
+  let n = Unix.read s buf 2 (Bytes.length buf - 2) in
+  Thread.delay 1.0;
+  ignore (Unix.write s buf 0 (n + 2));
+  Unix.close s
+
+let server sock =
+  while true do
+    let (s, _) = Unix.accept sock in
+    ignore(Thread.create serve_connection s)
+  done
+
+let client (addr, msg) =
+  let sock =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.connect sock addr;
+  let buf = Bytes.make 1024 ' ' in
+  ignore(Unix.write_substring sock msg 0 (String.length msg));
+  let n = Unix.read sock buf 0 (Bytes.length buf) in
+  print_bytes (Bytes.sub buf 0 n); flush stdout
+
+let _ =
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
+  let sock =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.setsockopt sock Unix.SO_REUSEADDR true;
+  Unix.bind sock addr;
+  let addr = Unix.getsockname sock in
+  Unix.listen sock 5;
+  ignore (Thread.create server sock);
+  ignore (Thread.create client (addr, "Client #1\n"));
+  Thread.delay 0.5;
+  client (addr, "Client #2\n")
diff --git a/testsuite/tests/lib-threads/sockets.reference b/testsuite/tests/lib-threads/sockets.reference
new file mode 100644
index 00000000..a3f7067d
--- /dev/null
+++ b/testsuite/tests/lib-threads/sockets.reference
@@ -0,0 +1,2 @@
+>>Client #1
+>>Client #2
diff --git a/testsuite/tests/lib-threads/socketsbuf.ml b/testsuite/tests/lib-threads/socketsbuf.ml
new file mode 100644
index 00000000..7eafb1bd
--- /dev/null
+++ b/testsuite/tests/lib-threads/socketsbuf.ml
@@ -0,0 +1,40 @@
+open Printf
+
+(* Threads, sockets, and buffered I/O channels *)
+(* Serves as a regression test for PR#5578 *)
+
+let serve_connection s =
+  let ic = Unix.in_channel_of_descr s
+  and oc = Unix.out_channel_of_descr s in
+  let l = input_line ic in
+  fprintf oc ">>%s\n" l;
+  close_out oc
+
+let server sock =
+  while true do
+    let (s, _) = Unix.accept sock in
+    ignore(Thread.create serve_connection s)
+  done
+
+let client (addr, msg) =
+  let sock =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.connect sock addr;
+  let ic = Unix.in_channel_of_descr sock
+  and oc = Unix.out_channel_of_descr sock in
+  output_string oc msg; flush oc;
+  let l = input_line ic in
+  printf "%s\n%!" l
+
+let _ =
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
+  let sock =
+    Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
+  Unix.setsockopt sock Unix.SO_REUSEADDR true;
+  Unix.bind sock addr;
+  let addr = Unix.getsockname sock in
+  Unix.listen sock 5;
+  ignore (Thread.create server sock);
+  ignore (Thread.create client (addr, "Client #1\n"));
+  Thread.delay 0.5;
+  client (addr, "Client #2\n")
diff --git a/testsuite/tests/lib-threads/socketsbuf.reference b/testsuite/tests/lib-threads/socketsbuf.reference
new file mode 100644
index 00000000..a3f7067d
--- /dev/null
+++ b/testsuite/tests/lib-threads/socketsbuf.reference
@@ -0,0 +1,2 @@
+>>Client #1
+>>Client #2
diff --git a/testsuite/tests/lib-threads/swapchan.checker b/testsuite/tests/lib-threads/swapchan.checker
new file mode 100644
index 00000000..bf957add
--- /dev/null
+++ b/testsuite/tests/lib-threads/swapchan.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*          Damien Doligez, Projet Gallium, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 2015 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+$SORT swapchan.result | $DIFF swapchan.reference - >/dev/null
diff --git a/testsuite/tests/lib-threads/swapchan.ml b/testsuite/tests/lib-threads/swapchan.ml
new file mode 100644
index 00000000..1f80beb8
--- /dev/null
+++ b/testsuite/tests/lib-threads/swapchan.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/testsuite/tests/lib-threads/swapchan.reference b/testsuite/tests/lib-threads/swapchan.reference
new file mode 100644
index 00000000..58dc8b58
--- /dev/null
+++ b/testsuite/tests/lib-threads/swapchan.reference
@@ -0,0 +1,2 @@
+f G
+g F
diff --git a/testsuite/tests/lib-threads/tls.checker b/testsuite/tests/lib-threads/tls.checker
new file mode 100644
index 00000000..b1d036b0
--- /dev/null
+++ b/testsuite/tests/lib-threads/tls.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+LC_ALL=C $SORT tls.result | $DIFF tls.reference -
diff --git a/testsuite/tests/lib-threads/tls.ml b/testsuite/tests/lib-threads/tls.ml
new file mode 100644
index 00000000..6db93fa9
--- /dev/null
+++ b/testsuite/tests/lib-threads/tls.ml
@@ -0,0 +1,26 @@
+let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
+let private_data_lock = Mutex.create()
+let output_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;
+  Mutex.lock output_lock;
+  print_int id; print_string " --> "; print_string(get_private_data());
+  print_newline();
+  Mutex.unlock output_lock
+
+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/testsuite/tests/lib-threads/tls.reference b/testsuite/tests/lib-threads/tls.reference
new file mode 100644
index 00000000..5ff9295d
--- /dev/null
+++ b/testsuite/tests/lib-threads/tls.reference
@@ -0,0 +1,5 @@
+1 --> un
+2 --> deux
+3 --> trois
+4 --> quatre
+5 --> cinq
diff --git a/testsuite/tests/lib-threads/token1.reference b/testsuite/tests/lib-threads/token1.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-threads/token2.reference b/testsuite/tests/lib-threads/token2.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-threads/torture.ml b/testsuite/tests/lib-threads/torture.ml
new file mode 100644
index 00000000..9dba8add
--- /dev/null
+++ b/testsuite/tests/lib-threads/torture.ml
@@ -0,0 +1,44 @@
+(* Torture test - I/O interspersed with lots of GC *)
+
+let finished = ref false
+
+let gc_thread () =
+  while not !finished do
+(*    print_string "gc"; print_newline(); *)
+    Gc.minor();
+    Thread.yield()
+  done
+
+let writer_thread (oc, size) =
+  while not !finished do
+(*    print_string "writer "; print_int size; print_newline(); *)
+    let buff = Bytes.make size 'a' in
+    ignore(Unix.write oc buff 0 size)
+  done;
+  let buff = Bytes.make size 'b' in
+  ignore (Unix.write oc buff 0 size)
+
+let reader_thread (ic, size) =
+  while true do
+(*    print_string "reader "; print_int size; print_newline(); *)
+    let buff = Bytes.make 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 Bytes.get buff i = 'b' then Thread.exit()
+      else if Bytes.get buff i <> 'a' then print_string "error in reader_thread\n"
+    done
+  done
+
+let _ =
+  let t1 = Thread.create gc_thread () in
+  let (out1, in1) = Unix.pipe() in
+  let t2 = Thread.create writer_thread (in1, 4096) in
+  let t3 = Thread.create reader_thread (out1, 4096) in
+  let (out2, in2) = Unix.pipe() in
+  let t4 = Thread.create writer_thread (in2, 16) in
+  let t5 = Thread.create reader_thread (out2, 16) in
+  Thread.delay 3.0;
+  finished := true;
+  List.iter Thread.join [t1; t2; t3; t4; t5];
+  print_string "passed\n"
diff --git a/testsuite/tests/lib-threads/torture.reference b/testsuite/tests/lib-threads/torture.reference
new file mode 100644
index 00000000..b0aad4de
--- /dev/null
+++ b/testsuite/tests/lib-threads/torture.reference
@@ -0,0 +1 @@
+passed
diff --git a/testsuite/tests/lib-uchar/Makefile b/testsuite/tests/lib-uchar/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-uchar/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-uchar/test.ml b/testsuite/tests/lib-uchar/test.ml
new file mode 100644
index 00000000..3895c545
--- /dev/null
+++ b/testsuite/tests/lib-uchar/test.ml
@@ -0,0 +1,84 @@
+let assert_raise_invalid_argument f v =
+  assert (try ignore (f v); false with Invalid_argument _ -> true)
+
+let test_constants () =
+  assert (Uchar.(to_int min) = 0x0000);
+  assert (Uchar.(to_int max) = 0x10FFFF);
+  ()
+
+let test_succ () =
+  assert (Uchar.(to_int (succ min)) = 0x0001);
+  assert (Uchar.(to_int (succ (of_int 0xD7FF))) = 0xE000);
+  assert (Uchar.(to_int (succ (of_int 0xE000))) = 0xE001);
+  assert_raise_invalid_argument Uchar.succ Uchar.max;
+  ()
+
+let test_pred () =
+  assert_raise_invalid_argument Uchar.pred Uchar.min;
+  assert (Uchar.(to_int (pred (of_int 0xD7FF))) = 0xD7FE);
+  assert (Uchar.(to_int (pred (of_int 0xE000))) = 0xD7FF);
+  assert (Uchar.(to_int (pred max)) = 0x10FFFE);
+  ()
+
+let test_is_valid () =
+  assert (not (Uchar.is_valid (-1)));
+  assert (Uchar.is_valid 0x0000);
+  assert (Uchar.is_valid 0xD7FF);
+  assert (not (Uchar.is_valid 0xD800));
+  assert (not (Uchar.is_valid 0xDFFF));
+  assert (Uchar.is_valid 0xE000);
+  assert (Uchar.is_valid 0x10FFFF);
+  assert (not (Uchar.is_valid 0x110000));
+  assert (not (Uchar.is_valid min_int));
+  assert (not (Uchar.is_valid max_int));
+  ()
+
+let char_max = Uchar.of_int 0x00FF
+
+let test_is_char () =
+  assert (Uchar.(is_char Uchar.min));
+  assert (Uchar.(is_char char_max));
+  assert (Uchar.(not (is_char (of_int 0x0100))));
+  assert (not (Uchar.is_char Uchar.max));
+  ()
+
+let test_of_char () =
+  assert (Uchar.(equal (of_char '\xFF') char_max));
+  assert (Uchar.(equal (of_char '\x00') min));
+  ()
+
+let test_to_char () =
+  assert (Uchar.(to_char min) = '\x00');
+  assert (Uchar.(to_char char_max) = '\xFF');
+  assert_raise_invalid_argument Uchar.to_char (Uchar.succ char_max);
+  assert_raise_invalid_argument Uchar.to_char Uchar.max;
+  ()
+
+let test_equal () =
+  assert (Uchar.(equal min min));
+  assert (Uchar.(equal max max));
+  assert (not Uchar.(equal min max));
+  ()
+
+let test_compare () =
+  assert (Uchar.(compare min min) = 0);
+  assert (Uchar.(compare max max) = 0);
+  assert (Uchar.(compare min max) = (-1));
+  assert (Uchar.(compare max min) = 1);
+  ()
+
+let tests () =
+  test_constants ();
+  test_succ ();
+  test_pred ();
+  test_is_valid ();
+  test_is_char ();
+  test_of_char ();
+  test_to_char ();
+  test_equal ();
+  test_compare ();
+  ()
+
+let () =
+  tests ();
+  print_endline "OK"
diff --git a/testsuite/tests/lib-uchar/test.reference b/testsuite/tests/lib-uchar/test.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/lib-uchar/test.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/lib-unix/Makefile b/testsuite/tests/lib-unix/Makefile
new file mode 100644
index 00000000..789c5091
--- /dev/null
+++ b/testsuite/tests/lib-unix/Makefile
@@ -0,0 +1,36 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+ifeq ($(OS),Windows_NT)
+ADD_BYTERUN_FLAGS="-I $(OTOPDIR)/otherlibs/win32unix"
+endif
+
+default: reflector.exe fdstatus.exe cmdline_prog.exe
+	@$(MAKE) check
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+%.exe: %.c
+ifeq ($(CCOMPTYPE),msvc)
+	@set -o pipefail ; $(BYTECC) /Fe$*.exe $*.c | tail -n +2
+else
+	@$(BYTECC) -o $*.exe $*.c
+endif
diff --git a/testsuite/tests/lib-unix/cloexec.ml b/testsuite/tests/lib-unix/cloexec.ml
new file mode 100644
index 00000000..d7e1e292
--- /dev/null
+++ b/testsuite/tests/lib-unix/cloexec.ml
@@ -0,0 +1,51 @@
+(* This is a terrible hack that plays on the internal representation
+   of file descriptors.  The result is a number (as a string)
+   that the fdstatus.exe auxiliary program can use to check whether
+   the fd is open. *)
+
+let string_of_fd (fd: Unix.file_descr) : string =
+  match Sys.os_type with
+  | "Unix" | "Cygwin" ->  string_of_int (Obj.magic fd : int)
+  | "Win32" ->
+      if Sys.word_size = 32 then
+        Int32.to_string (Obj.magic fd : int32)
+      else
+        Int64.to_string (Obj.magic fd : int64)
+  | _ -> assert false
+
+let _ =
+  let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
+  let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
+  let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+  let d0 = Unix.dup f0 in
+  let d1 = Unix.dup ~cloexec:false f1 in
+  let d2 = Unix.dup ~cloexec:true f2 in
+  let (p0, p0') = Unix.pipe () in
+  let (p1, p1') = Unix.pipe ~cloexec:false () in
+  let (p2, p2') = Unix.pipe ~cloexec:true () in
+  let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
+  let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
+  let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
+  let (x0, x0') =
+    try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
+    with Invalid_argument _ -> (p0, p0') in
+    (* socketpair not available under Win32; keep the same output *)
+  let (x1, x1') =
+    try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
+    with Invalid_argument _ -> (p1, p1') in
+  let (x2, x2') =
+    try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
+    with Invalid_argument _ -> (p2, p2') in
+
+  let fds = [| f0;f1;f2; d0;d1;d2;
+               p0;p0';p1;p1';p2;p2';
+               s0;s1;s2;
+               x0;x0';x1;x1';x2;x2' |] in
+  let pid =
+    Unix.create_process
+      (Filename.concat Filename.current_dir_name "fdstatus.exe")
+      (Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
+      Unix.stdin Unix.stdout Unix.stderr in
+  ignore (Unix.waitpid [] pid);
+  Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
+  Sys.remove "tmp.txt"
diff --git a/testsuite/tests/lib-unix/cloexec.reference b/testsuite/tests/lib-unix/cloexec.reference
new file mode 100644
index 00000000..c6270172
--- /dev/null
+++ b/testsuite/tests/lib-unix/cloexec.reference
@@ -0,0 +1,21 @@
+#1: open
+#2: open
+#3: closed
+#4: open
+#5: open
+#6: closed
+#7: open
+#8: open
+#9: open
+#10: open
+#11: closed
+#12: closed
+#13: open
+#14: open
+#15: closed
+#16: open
+#17: open
+#18: open
+#19: open
+#20: closed
+#21: closed
diff --git a/testsuite/tests/lib-unix/cmdline_prog.c b/testsuite/tests/lib-unix/cmdline_prog.c
new file mode 100644
index 00000000..c67a7563
--- /dev/null
+++ b/testsuite/tests/lib-unix/cmdline_prog.c
@@ -0,0 +1,10 @@
+#include <stdio.h>
+
+int main (int argc, char *argv[])
+{
+  int i;
+  for (i = 1; i < argc; i ++) {
+    printf ("%s\n", argv[i]);
+  }
+  return 0;
+}
diff --git a/testsuite/tests/lib-unix/dup.ml b/testsuite/tests/lib-unix/dup.ml
new file mode 100644
index 00000000..d296cb97
--- /dev/null
+++ b/testsuite/tests/lib-unix/dup.ml
@@ -0,0 +1,5 @@
+let _ =
+  let f = Unix.dup ~cloexec:true Unix.stdout in
+  let txt = "Some output\n" in
+  ignore (Unix.write_substring f txt 0 (String.length txt));
+  Unix.close f
diff --git a/testsuite/tests/lib-unix/dup.reference b/testsuite/tests/lib-unix/dup.reference
new file mode 100644
index 00000000..85cc16f5
--- /dev/null
+++ b/testsuite/tests/lib-unix/dup.reference
@@ -0,0 +1 @@
+Some output
diff --git a/testsuite/tests/lib-unix/dup2.ml b/testsuite/tests/lib-unix/dup2.ml
new file mode 100644
index 00000000..055d7e5f
--- /dev/null
+++ b/testsuite/tests/lib-unix/dup2.ml
@@ -0,0 +1,24 @@
+let cat file =
+  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
+  let buf = Bytes.create 1024 in
+  let rec cat () =
+    let n = Unix.read fd buf 0 (Bytes.length buf) in
+    if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
+  in cat (); Unix.close fd
+
+let out fd txt =
+  ignore (Unix.write_substring fd txt 0 (String.length txt))
+
+let _ =
+  let fd =
+    Unix.(openfile "./tmp.txt"
+                   [O_WRONLY;O_TRUNC;O_CREAT;O_SHARE_DELETE]
+		   0o600) in
+  out fd "---\n";
+  Unix.dup2 ~cloexec:true fd Unix.stderr;
+  Unix.close fd;
+  out Unix.stderr "Some output\n";
+  cat "./tmp.txt";
+  Sys.remove "./tmp.txt"
+
+    
diff --git a/testsuite/tests/lib-unix/dup2.reference b/testsuite/tests/lib-unix/dup2.reference
new file mode 100644
index 00000000..2f5a485d
--- /dev/null
+++ b/testsuite/tests/lib-unix/dup2.reference
@@ -0,0 +1,2 @@
+---
+Some output
diff --git a/testsuite/tests/lib-unix/fdstatus.c b/testsuite/tests/lib-unix/fdstatus.c
new file mode 100644
index 00000000..be8c6e5c
--- /dev/null
+++ b/testsuite/tests/lib-unix/fdstatus.c
@@ -0,0 +1,73 @@
+/* Check if file descriptors are open or not */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef _WIN32
+
+#define WIN32_LEAN_AND_MEAN
+#include <wtypes.h>
+#include <winbase.h>
+#include <winerror.h>
+
+void process_fd(char * s)
+{
+  int fd;
+  HANDLE h;
+  DWORD flags;
+
+#ifdef _WIN64
+  h = (HANDLE) _atoi64(s);
+#else
+  h = (HANDLE) atoi(s);
+#endif
+  if (GetHandleInformation(h, &flags)) {
+    printf("open\n");
+  } else if (GetLastError() == ERROR_INVALID_HANDLE) {
+    printf("closed\n");
+  } else {
+    printf("error %d\n", GetLastError());
+  }
+}
+
+#else
+
+#include <limits.h>
+#include <string.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+void process_fd(char * s)
+{
+  long n;
+  int fd;
+  char * endp;
+  struct stat st;
+  n = strtol(s, &endp, 0);
+  if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
+    printf("parsing error\n");
+    return;
+  }
+  fd = (int) n;
+  if (fstat(fd, &st) != -1) {
+    printf("open\n");
+  } else if (errno == EBADF) {
+    printf("closed\n");
+  } else {
+    printf("error %s\n", strerror(errno));
+  }
+}
+
+#endif
+
+int main(int argc, char ** argv)
+{
+  int i;
+  for (i = 1; i < argc; i++) {
+    printf("#%d: ", i);
+    process_fd(argv[i]);
+  }
+  return 0;
+}
diff --git a/testsuite/tests/lib-unix/pipe_eof.ml b/testsuite/tests/lib-unix/pipe_eof.ml
new file mode 100644
index 00000000..19f5258e
--- /dev/null
+++ b/testsuite/tests/lib-unix/pipe_eof.ml
@@ -0,0 +1,34 @@
+let drain pipe =
+  let max = 2048 in
+  let buf = Buffer.create 2048 in
+  let tmp = Bytes.create max in
+  while begin
+    try
+      let len = Unix.read pipe tmp 0 max in
+      Buffer.add_subbytes buf tmp 0 len;
+      len > 0
+    with Unix.Unix_error (Unix.EPIPE, _, _) when false ->
+      false
+  end do () done;
+  Buffer.contents buf
+;;
+
+let run exe args =
+  let out_in, out_out = Unix.pipe () in
+  let err_in, err_out = Unix.pipe () in
+  let args = Array.append [| exe |] args in
+  let pid = Unix.create_process exe args Unix.stdin out_out err_out in
+  Unix.close out_out;
+  Unix.close err_out;
+  let output = drain out_in in
+  let error = drain err_in in
+  Unix.close out_in;
+  Unix.close err_in;
+  let _pid, status = Unix.waitpid [ ] pid in
+  status, output, error
+;;
+
+let _ =
+  ignore (run "cp" [||]);
+  print_endline "success"
+;;
diff --git a/testsuite/tests/lib-unix/pipe_eof.reference b/testsuite/tests/lib-unix/pipe_eof.reference
new file mode 100644
index 00000000..2e9ba477
--- /dev/null
+++ b/testsuite/tests/lib-unix/pipe_eof.reference
@@ -0,0 +1 @@
+success
diff --git a/testsuite/tests/lib-unix/redirections.ml b/testsuite/tests/lib-unix/redirections.ml
new file mode 100644
index 00000000..ed1712a4
--- /dev/null
+++ b/testsuite/tests/lib-unix/redirections.ml
@@ -0,0 +1,113 @@
+let cat file =
+  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
+  let buf = Bytes.create 1024 in
+  let rec cat () =
+    let n = Unix.read fd buf 0 (Bytes.length buf) in
+    if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
+  in cat (); Unix.close fd
+
+let out fd txt =
+  ignore (Unix.write_substring fd txt 0 (String.length txt))
+
+let refl =
+  Filename.concat Filename.current_dir_name "reflector.exe"
+
+let test_createprocess () =
+  let f_out =
+    Unix.(openfile "./tmpout.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
+  let f_err =
+    Unix.(openfile "./tmperr.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
+  let (p_exit, p_entrance) =
+    Unix.pipe ~cloexec:true () in
+  let pid =
+    Unix.create_process_env
+       refl
+       [| refl; "i2o"; "i2e"; "o"; "123"; "e"; "456"; "i2o"; "v"; "XVAR" |]
+       [| "XVAR=xvar" |]
+       p_exit f_out f_err in
+  out p_entrance "aaaa\n";
+  out p_entrance "bbbb\n";
+  Unix.close p_entrance;
+  let (_, status) = Unix.waitpid [] pid in
+  Unix.close p_exit; Unix.close f_out; Unix.close f_err;
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n";
+  out Unix.stdout "---- File tmpout.txt\n";
+  cat "./tmpout.txt";
+  out Unix.stdout "---- File tmperr.txt\n";
+  cat "./tmperr.txt";
+  Sys.remove "./tmpout.txt";
+  Sys.remove "./tmperr.txt"
+
+let test_2ampsup1 () =    (* 2>&1 redirection, cf. GPR#1105 *)
+  let pid =
+    Unix.create_process
+      refl
+      [| refl; "o"; "123"; "e"; "456"; "o"; "789" |]
+      Unix.stdin Unix.stdout Unix.stdout in
+  let (_, status) = Unix.waitpid [] pid in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_swap12 () =    (* swapping stdout and stderr *)
+  (* The test harness doesn't let us check contents of stderr,
+     so just output on stdout (after redirection) *)
+  let pid =
+    Unix.create_process
+      refl
+      [| refl; "e"; "123" |]
+      Unix.stdin Unix.stderr Unix.stdout in
+  let (_, status) = Unix.waitpid [] pid in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_in () =
+  let ic = Unix.open_process_in (refl ^ " o 123 o 456") in
+  out Unix.stdout (input_line ic ^ "\n");
+  out Unix.stdout (input_line ic ^ "\n");
+  let status = Unix.close_process_in ic in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_out () =
+  let oc = Unix.open_process_out (refl ^ " i2o i2o i2o") in
+  output_string oc "aa\nbbbb\n"; close_out oc;
+  let status = Unix.close_process_out oc in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_full () =
+  let ((o, i, e) as res) =
+    Unix.open_process_full
+      (refl ^ " o 123 i2o e 456 i2e v XVAR")
+      [|"XVAR=xvar"|] in
+  output_string i "aa\nbbbb\n"; close_out i;
+  for _i = 1 to 3 do 
+    out Unix.stdout (input_line o ^ "\n")
+  done;
+  for _i = 1 to 2 do
+    out Unix.stdout (input_line e ^ "\n")
+  done;
+  let status = Unix.close_process_full res in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let _ =
+  (* The following 'close' makes things more difficult.
+     Under Unix it works fine, but under Win32 create_process 
+     gives an error if one of the standard handles is closed. *)
+  (* Unix.close Unix.stdin; *)
+  out Unix.stdout "** create_process\n";
+  test_createprocess();
+  out Unix.stdout "** create_process 2>&1 redirection\n";
+  test_2ampsup1();
+  out Unix.stdout "** create_process swap 1-2\n";
+  test_swap12();
+  out Unix.stdout "** open_process_in\n";
+  test_open_process_in();
+  out Unix.stdout "** open_process_out\n";
+  test_open_process_out();
+  out Unix.stdout "** open_process_full\n";
+  test_open_process_full()
+
+
diff --git a/testsuite/tests/lib-unix/redirections.reference b/testsuite/tests/lib-unix/redirections.reference
new file mode 100644
index 00000000..c0da174c
--- /dev/null
+++ b/testsuite/tests/lib-unix/redirections.reference
@@ -0,0 +1,28 @@
+** create_process
+---- File tmpout.txt
+aaaa
+123
+<end of file>
+xvar
+---- File tmperr.txt
+bbbb
+456
+** create_process 2>&1 redirection
+123
+456
+789
+** create_process swap 1-2
+123
+** open_process_in
+123
+456
+** open_process_out
+aa
+bbbb
+<end of file>
+** open_process_full
+123
+aa
+xvar
+456
+bbbb
diff --git a/testsuite/tests/lib-unix/reflector.c b/testsuite/tests/lib-unix/reflector.c
new file mode 100644
index 00000000..f8bbbf31
--- /dev/null
+++ b/testsuite/tests/lib-unix/reflector.c
@@ -0,0 +1,74 @@
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#if defined(_WIN32)
+#include <fcntl.h>
+#include <io.h>
+#endif
+
+/* A tool to read data from standard input and send it to standard
+   output or standard error. */
+
+void copyline(FILE * in, FILE * out)
+{
+  int c;
+  do {
+    c = getc(in);
+    if (c == EOF) {
+      fputs("<end of file>\n", out);
+      break;
+    }
+    putc(c, out);
+  } while (c != '\n');
+  fflush(out);
+}
+
+/* Command language:
+     i2o       copy one line from stdin to stdout
+     i2e       copy one line from stdin to stderr
+     o <txt>   write <txt> plus newline to stdout
+     e <txt>   write <txt> plus newline to stderr
+     v <var>   write value of environment variable <env> to stdout
+*/
+
+int main(int argc, char ** argv)
+{
+  int i;
+  char * cmd;
+#if defined(_WIN32)
+  _setmode(_fileno(stdin), _O_BINARY);
+  _setmode(_fileno(stdout), _O_BINARY);
+  _setmode(_fileno(stderr), _O_BINARY);
+#endif
+  i = 1;
+  while (i < argc) {
+    cmd = argv[i];
+    if (strcmp(cmd, "i2o") == 0) {
+      copyline(stdin, stdout);
+      i++;
+    } else if (strcmp(cmd, "i2e") == 0) {
+      copyline(stdin, stderr);
+      i++;
+    } else if (strcmp(cmd, "o") == 0 && i + 1 < argc) {
+      fputs(argv[i + 1], stdout);
+      fputc('\n', stdout);
+      fflush(stdout);
+      i += 2;
+    } else if (strcmp(cmd, "e") == 0 && i + 1 < argc) {
+      fputs(argv[i + 1], stderr);
+      fputc('\n', stderr);
+      fflush(stderr);
+      i += 2;
+    } else if (strcmp(cmd, "v") == 0 && i + 1 < argc) {
+      char * v = getenv(argv[i + 1]);
+      fputs((v == NULL ? "<no such variable>" : v), stdout);
+      fputc('\n', stdout);
+      fflush(stdout);
+      i += 2;
+    } else {
+      fputs("<bad argument>\n", stderr);
+      return 2;
+    }
+  }
+  return 0;
+}
diff --git a/testsuite/tests/lib-unix/test_unix_cmdline.ml b/testsuite/tests/lib-unix/test_unix_cmdline.ml
new file mode 100644
index 00000000..f0f7679b
--- /dev/null
+++ b/testsuite/tests/lib-unix/test_unix_cmdline.ml
@@ -0,0 +1,28 @@
+open Unix
+
+let prog_name = "cmdline_prog.exe"
+
+let run args =
+  let out, inp = pipe () in
+  let in_chan = in_channel_of_descr out in
+  set_binary_mode_in in_chan false;
+  let pid = create_process ("./" ^ prog_name) (Array.of_list (prog_name :: args)) Unix.stdin inp Unix.stderr in
+  List.iter (fun arg ->
+      let s = input_line in_chan in
+      Printf.printf "%S -> %S [%s]\n" arg s (if s = arg then "OK" else "FAIL")
+    ) args;
+  close_in in_chan;
+  let _, exit = waitpid [] pid in
+  assert (exit = WEXITED 0)
+
+let () =
+  List.iter run
+    [
+      [""; ""; "\t \011"];
+      ["a"; "b"; "c.txt@!"];
+      ["\""];
+      [" "; " a "; "  \" \\\" "];
+      [" \\ \\ \\\\\\"];
+      [" \"hola \""];
+      ["a\tb"];
+    ]
diff --git a/testsuite/tests/lib-unix/test_unix_cmdline.reference b/testsuite/tests/lib-unix/test_unix_cmdline.reference
new file mode 100644
index 00000000..7d2f2c2a
--- /dev/null
+++ b/testsuite/tests/lib-unix/test_unix_cmdline.reference
@@ -0,0 +1,13 @@
+"" -> "" [OK]
+"" -> "" [OK]
+"\t \011" -> "\t \011" [OK]
+"a" -> "a" [OK]
+"b" -> "b" [OK]
+"c.txt@!" -> "c.txt@!" [OK]
+"\"" -> "\"" [OK]
+" " -> " " [OK]
+" a " -> " a " [OK]
+"  \" \\\" " -> "  \" \\\" " [OK]
+" \\ \\ \\\\\\" -> " \\ \\ \\\\\\" [OK]
+" \"hola \"" -> " \"hola \"" [OK]
+"a\tb" -> "a\tb" [OK]
diff --git a/testsuite/tests/link-test/Makefile b/testsuite/tests/link-test/Makefile
new file mode 100644
index 00000000..ffef5988
--- /dev/null
+++ b/testsuite/tests/link-test/Makefile
@@ -0,0 +1,65 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                     Thomas Refis, Jane Street Europe                   *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default:
+	@$(MAKE) byte
+	@if $(BYTECODE_ONLY) ; then \
+	  echo " ... testing native 'test.reference': => skipped"; \
+	else \
+	  $(MAKE) native; \
+	fi
+
+native:
+	@printf " ... testing native 'test.reference':"
+	@$(OCAMLOPT) -c submodule.ml
+	@$(OCAMLOPT) -c aliases.ml
+	@$(OCAMLOPT) -c external.mli external.ml
+	@$(OCAMLOPT) -c external_for_pack.mli external_for_pack.ml
+	@$(OCAMLOPT) -c test.ml
+	@$(OCAMLOPT) -a submodule.cmx aliases.cmx external.cmx \
+		external_for_pack.cmx -o mylib.cmxa
+	@$(OCAMLOPT) -c -for-pack P use_in_pack.ml
+	@$(OCAMLOPT) -pack use_in_pack.cmx -o p.cmx
+	@$(OCAMLOPT) mylib.cmxa p.cmx test.cmx -o test.native
+	@./test.native > test.result
+	@$(DIFF) test.result test.reference >/dev/null \
+	    && echo " => passed" || echo " => failed"
+
+byte:
+	@printf " ... testing byte 'test.reference':"
+	@$(OCAMLC) -c submodule.ml
+	@$(OCAMLC) -c aliases.ml
+	@$(OCAMLC) -c external.mli external.ml
+	@$(OCAMLC) -c external_for_pack.mli external_for_pack.ml
+	@$(OCAMLC) -c test.ml
+	@$(OCAMLC) -a submodule.cmo aliases.cmo external.cmo \
+		external_for_pack.cmo -o mylib.cma
+	@$(OCAMLC) -c -for-pack P use_in_pack.ml
+	@$(OCAMLC) -pack use_in_pack.cmo -o p.cmo
+	@$(OCAMLC) mylib.cma p.cmo test.cmo -o test.byte
+	@$(OCAMLRUN) ./test.byte > test.result
+	@$(DIFF) test.result test.reference >/dev/null \
+	    && echo " => passed" || echo " => failed"
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
+	@rm -f test.native test.byte
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
+COMPFLAGS = -no-alias-deps
diff --git a/testsuite/tests/link-test/aliases.ml b/testsuite/tests/link-test/aliases.ml
new file mode 100644
index 00000000..65fbc19f
--- /dev/null
+++ b/testsuite/tests/link-test/aliases.ml
@@ -0,0 +1 @@
+module Submodule = Submodule
diff --git a/testsuite/tests/link-test/external.ml b/testsuite/tests/link-test/external.ml
new file mode 100644
index 00000000..e2eb5b7f
--- /dev/null
+++ b/testsuite/tests/link-test/external.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked external"; flush stdout
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/external.mli b/testsuite/tests/link-test/external.mli
new file mode 100644
index 00000000..4b2548e8
--- /dev/null
+++ b/testsuite/tests/link-test/external.mli
@@ -0,0 +1 @@
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/external_for_pack.ml b/testsuite/tests/link-test/external_for_pack.ml
new file mode 100644
index 00000000..2d5be97c
--- /dev/null
+++ b/testsuite/tests/link-test/external_for_pack.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked external from pack"; flush stdout
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/external_for_pack.mli b/testsuite/tests/link-test/external_for_pack.mli
new file mode 100644
index 00000000..4b2548e8
--- /dev/null
+++ b/testsuite/tests/link-test/external_for_pack.mli
@@ -0,0 +1 @@
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/submodule.ml b/testsuite/tests/link-test/submodule.ml
new file mode 100644
index 00000000..b315f202
--- /dev/null
+++ b/testsuite/tests/link-test/submodule.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked"; flush stdout
+module M = struct end
diff --git a/testsuite/tests/link-test/test.ml b/testsuite/tests/link-test/test.ml
new file mode 100644
index 00000000..24d870ac
--- /dev/null
+++ b/testsuite/tests/link-test/test.ml
@@ -0,0 +1,2 @@
+include Aliases.Submodule.M
+let _, _ = External.frexp 3.
diff --git a/testsuite/tests/link-test/test.reference b/testsuite/tests/link-test/test.reference
new file mode 100644
index 00000000..b188f6c0
--- /dev/null
+++ b/testsuite/tests/link-test/test.reference
@@ -0,0 +1,3 @@
+linked
+linked external
+linked external from pack
diff --git a/testsuite/tests/link-test/use_in_pack.ml b/testsuite/tests/link-test/use_in_pack.ml
new file mode 100644
index 00000000..9d55b593
--- /dev/null
+++ b/testsuite/tests/link-test/use_in_pack.ml
@@ -0,0 +1 @@
+let _, _ = External_for_pack.frexp 12.
diff --git a/testsuite/tests/manual-intf-c/Makefile b/testsuite/tests/manual-intf-c/Makefile
new file mode 100644
index 00000000..4601ff99
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/Makefile
@@ -0,0 +1,40 @@
+# Tests from manual, section intf-c
+# main.ml: error message when equality is missing
+# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
+
+SOURCES = curses.ml prog.ml
+CSOURCES = curses_stubs.c
+CLIBS = -cclib "$(BYTECCLIBS)"
+LIBUNIX = -I $(BASEDIR)/../otherlibs/unix unix.cma
+
+# Disable this test until we figure out how to test for the availability
+# of curses.
+.PHONY: disable
+disable:
+	@printf " ... testing prog => skipped\n"
+	@printf " ... testing prog2 => skipped\n"
+
+.PHONY: default
+default: clean $(SOURCES) $(CSOURCES)
+	@printf " ... testing prog"
+	@$(MAKE) prog > /dev/null && echo " => passed" || echo " => failed"
+	@printf " ... testing prog2"
+	@$(MAKE) prog2 REDIRECT=">prog2.result 2>&1" \
+	  >/dev/null 2>/dev/null || :
+	@$(DIFF) prog2.reference prog2.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+# Should succeed
+prog:
+	$(OCAMLC) -custom -o prog $(LIBUNIX) $(SOURCES) $(CSOURCES) $(CLIBS)
+
+# Should fail
+prog2:  curses.cmo
+	$(OCAMLC) -custom -o prog2 $(LIBUNIX) prog.ml $(CSOURCES) $(CLIBS) $(REDIRECT)
+
+.PHONY: clean
+clean:
+	@rm -f *.cm* *.o *~ prog prog2
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/manual-intf-c/curses.ml b/testsuite/tests/manual-intf-c/curses.ml
new file mode 100644
index 00000000..1447f6bf
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/curses.ml
@@ -0,0 +1,13 @@
+(* File curses.ml -- declaration of primitives and data types *)
+type window                   (* The type "window" remains abstract *)
+external initscr: unit -> window = "caml_curses_initscr"
+external endwin: unit -> unit = "caml_curses_endwin"
+external refresh: unit -> unit = "caml_curses_refresh"
+external wrefresh : window -> unit = "caml_curses_wrefresh"
+external newwin: int -> int -> int -> int -> window = "caml_curses_newwin"
+external addch: char -> unit = "caml_curses_addch"
+external mvwaddch: window -> int -> int -> char -> unit = "caml_curses_mvwaddch"
+external addstr: string -> unit = "caml_curses_addstr"
+external mvwaddstr: window -> int -> int -> string -> unit
+         = "caml_curses_mvwaddstr"
+(* lots more omitted *)
diff --git a/testsuite/tests/manual-intf-c/curses_stubs.c b/testsuite/tests/manual-intf-c/curses_stubs.c
new file mode 100644
index 00000000..33c74a87
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/curses_stubs.c
@@ -0,0 +1,94 @@
+/* File curses_stubs.c -- stub code for curses */
+#include <curses.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+/* Encapsulation of opaque window handles (of type WINDOW *)
+   as OCaml custom blocks. */
+
+static struct custom_operations curses_window_ops = {
+  "fr.inria.caml.curses_windows",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+/* Accessing the WINDOW * part of an OCaml custom block */
+#define Window_val(v) (*((WINDOW **) Data_custom_val(v)))
+
+/* Allocating an OCaml custom block to hold the given WINDOW * */
+static value alloc_window(WINDOW * w)
+{
+  value v = alloc_custom(&curses_window_ops, sizeof(WINDOW *), 0, 1);
+  Window_val(v) = w;
+  return v;
+}
+
+value caml_curses_initscr(value unit)
+{
+  CAMLparam1 (unit);
+  CAMLreturn (alloc_window(initscr()));
+}
+
+value caml_curses_endwin(value unit)
+{
+  CAMLparam1 (unit);
+  endwin();
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_refresh(value unit)
+{
+  CAMLparam1 (unit);
+  refresh();
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_wrefresh(value win)
+{
+  CAMLparam1 (win);
+  wrefresh(Window_val(win));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_newwin(value nlines, value ncols, value x0, value y0)
+{
+  CAMLparam4 (nlines, ncols, x0, y0);
+  CAMLreturn (alloc_window(newwin(Int_val(nlines), Int_val(ncols),
+                                  Int_val(x0), Int_val(y0))));
+}
+
+value caml_curses_addch(value c)
+{
+  CAMLparam1 (c);
+  addch(Int_val(c));            /* Characters are encoded like integers */
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddch(value win, value x, value y, value c)
+{
+  CAMLparam4 (win, x, y, c);
+  mvwaddch(Window_val(win), Int_val(x), Int_val(y), Int_val(c));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_addstr(value s)
+{
+  CAMLparam1 (s);
+  addstr(String_val(s));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddstr(value win, value x, value y, value s)
+{
+  CAMLparam4 (win, x, y, s);
+  mvwaddstr(Window_val(win), Int_val(x), Int_val(y), String_val(s));
+  CAMLreturn (Val_unit);
+}
+
+/* This goes on for pages. */
diff --git a/testsuite/tests/manual-intf-c/prog.ml b/testsuite/tests/manual-intf-c/prog.ml
new file mode 100644
index 00000000..a913fd91
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/prog.ml
@@ -0,0 +1,9 @@
+(* File prog.ml -- main program using curses *)
+open Curses;;
+let main_window = initscr () in
+let small_window = newwin 10 5 20 10 in
+  mvwaddstr main_window 10 2 "Hello";
+  mvwaddstr small_window 4 3 "world";
+  refresh();
+  Unix.sleep 5;
+  endwin()
diff --git a/testsuite/tests/manual-intf-c/prog2.reference b/testsuite/tests/manual-intf-c/prog2.reference
new file mode 100644
index 00000000..06f5553f
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/prog2.reference
@@ -0,0 +1,2 @@
+File "curses_stubs.c", line 1:
+Error: Required module `Curses' is unavailable
diff --git a/testsuite/tests/match-exception-warnings/Makefile b/testsuite/tests/match-exception-warnings/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/match-exception-warnings/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml
new file mode 100644
index 00000000..742038db
--- /dev/null
+++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml
@@ -0,0 +1,12 @@
+(** Test exhaustiveness.
+
+    match clauses should continue to give warnings about inexhaustive
+    value-matching clauses when there is an exception-matching clause
+ *)
+
+let test_match_exhaustiveness () =
+    match None with
+    | exception e -> ()
+    | Some false -> ()
+    | None -> ()
+;;
diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
new file mode 100644
index 00000000..69ba3a45
--- /dev/null
+++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
@@ -0,0 +1,11 @@
+
+# * * * *               Characters 210-289:
+  ....match None with
+      | exception e -> ()
+      | Some false -> ()
+      | None -> ()
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some true
+val test_match_exhaustiveness : unit -> unit = <fun>
+# 
diff --git a/testsuite/tests/match-exception/Makefile b/testsuite/tests/match-exception/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/match-exception/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/match-exception/allocation.ml b/testsuite/tests/match-exception/allocation.ml
new file mode 100644
index 00000000..72055c3a
--- /dev/null
+++ b/testsuite/tests/match-exception/allocation.ml
@@ -0,0 +1,25 @@
+(** Test that matching multiple values doesn't allocate a block. *)
+
+let f x y =
+  match x, y with
+  | Some x, None
+  | None, Some x -> x + 1
+  | None, None -> 0
+  | Some x, Some y -> x + y
+  | exception _ -> -1
+
+let test_multiple_match_does_not_allocate =
+  let allocated_bytes = Gc.allocated_bytes () in
+  let allocated_bytes' = Gc.allocated_bytes () in
+  let a = Some 3 and b = None in
+  let allocated_bytes'' = Gc.allocated_bytes () in
+  let _ = f a b in
+  let allocated_bytes''' = Gc.allocated_bytes () in
+  if allocated_bytes' -. allocated_bytes
+     = allocated_bytes''' -. allocated_bytes''
+  then
+    Printf.printf "no allocations for multiple-value match\n"
+  else
+    Printf.printf "multiple-value match allocated %f bytes\n"
+      ((allocated_bytes''' -. allocated_bytes'') -.
+       (allocated_bytes' -. allocated_bytes))
diff --git a/testsuite/tests/match-exception/allocation.reference b/testsuite/tests/match-exception/allocation.reference
new file mode 100644
index 00000000..98056ce6
--- /dev/null
+++ b/testsuite/tests/match-exception/allocation.reference
@@ -0,0 +1 @@
+no allocations for multiple-value match
diff --git a/testsuite/tests/match-exception/exception_propagation.ml b/testsuite/tests/match-exception/exception_propagation.ml
new file mode 100644
index 00000000..eedde784
--- /dev/null
+++ b/testsuite/tests/match-exception/exception_propagation.ml
@@ -0,0 +1,17 @@
+(**
+   Test that match allows exceptions to propagate.
+*)
+let () =
+  try
+    match
+      (let _ = raise Not_found in
+       assert false)
+    with
+    | _ -> assert false
+    | exception Invalid_argument _ -> assert false
+  with
+    Not_found ->
+      print_endline "caught expected exception (Not_found)"
+  | _ ->
+    assert false
+;;
diff --git a/testsuite/tests/match-exception/exception_propagation.reference b/testsuite/tests/match-exception/exception_propagation.reference
new file mode 100644
index 00000000..a119b681
--- /dev/null
+++ b/testsuite/tests/match-exception/exception_propagation.reference
@@ -0,0 +1 @@
+caught expected exception (Not_found)
diff --git a/testsuite/tests/match-exception/match_failure.ml b/testsuite/tests/match-exception/match_failure.ml
new file mode 100644
index 00000000..40c60595
--- /dev/null
+++ b/testsuite/tests/match-exception/match_failure.ml
@@ -0,0 +1,19 @@
+(**
+   Test that value match failure in a match block raises Match_failure.
+*)
+let return_some_3 () = Some (1 + 2)
+;;
+
+let test_match_partial_match =
+  try
+    let _ = (match return_some_3 () with
+    | Some x when x < 3 -> "Some x"
+    | exception Failure _ -> "failure"
+    | exception Invalid_argument _ -> "invalid argument"
+    | None -> "None"
+    ) in
+    assert false
+  with
+    Match_failure _ ->
+      print_endline "match failure, as expected"
+;;
diff --git a/testsuite/tests/match-exception/match_failure.reference b/testsuite/tests/match-exception/match_failure.reference
new file mode 100644
index 00000000..6e17840f
--- /dev/null
+++ b/testsuite/tests/match-exception/match_failure.reference
@@ -0,0 +1 @@
+match failure, as expected
diff --git a/testsuite/tests/match-exception/nested_handlers.ml b/testsuite/tests/match-exception/nested_handlers.ml
new file mode 100644
index 00000000..7f2a6514
--- /dev/null
+++ b/testsuite/tests/match-exception/nested_handlers.ml
@@ -0,0 +1,45 @@
+(*
+  Test that multiple handlers coexist happily.
+*)
+
+let test_multiple_handlers =
+  let trace = ref [] in
+  let collect v = trace := v :: !trace in
+  let _ =
+    match
+      begin
+        match
+          begin
+            collect "one";
+            failwith "two"
+          end
+        with
+          () -> collect "failure one"
+        | exception (Failure x) ->
+          collect x;
+          failwith "three"
+      end
+    with
+      () ->
+        collect "failure two";
+    | exception (Failure x) ->
+      collect x;
+      match
+        begin
+          collect "four";
+          failwith "five"
+        end
+      with
+        () -> collect "failure three"
+      | exception (Failure x) ->
+        collect x
+  in
+  print_endline (String.concat " " !trace);
+  assert (!trace = [
+    "five";
+    "four";
+    "three";
+    "two";
+    "one";
+  ])
+;;
diff --git a/testsuite/tests/match-exception/nested_handlers.reference b/testsuite/tests/match-exception/nested_handlers.reference
new file mode 100644
index 00000000..e3052866
--- /dev/null
+++ b/testsuite/tests/match-exception/nested_handlers.reference
@@ -0,0 +1 @@
+five four three two one
diff --git a/testsuite/tests/match-exception/raise_from_success_continuation.ml b/testsuite/tests/match-exception/raise_from_success_continuation.ml
new file mode 100644
index 00000000..34fb6471
--- /dev/null
+++ b/testsuite/tests/match-exception/raise_from_success_continuation.ml
@@ -0,0 +1,15 @@
+(**
+  Test raising exceptions from a value-matching branch.
+*)
+let test_raise_from_val_handler =
+  let () = print_endline "test raise from val handler" in
+  let g () = List.find ((=)2) [1;2;4] in
+  let h () =
+    match
+      g ()
+    with exception _ -> 10
+    | _ -> raise Not_found
+  in
+  assert ((try h () with Not_found -> 20) = 20);
+  print_endline "raise from val handler succeeded"
+;;
diff --git a/testsuite/tests/match-exception/raise_from_success_continuation.reference b/testsuite/tests/match-exception/raise_from_success_continuation.reference
new file mode 100644
index 00000000..4cfe2160
--- /dev/null
+++ b/testsuite/tests/match-exception/raise_from_success_continuation.reference
@@ -0,0 +1,2 @@
+test raise from val handler
+raise from val handler succeeded
diff --git a/testsuite/tests/match-exception/streams.ml b/testsuite/tests/match-exception/streams.ml
new file mode 100644
index 00000000..43a31510
--- /dev/null
+++ b/testsuite/tests/match-exception/streams.ml
@@ -0,0 +1,37 @@
+(**
+   Test the stream example .
+*)
+type stream = Stream of (int * stream Lazy.t)
+;;
+
+exception End_of_stream
+;;
+
+let make_stream_up_to n =
+  let rec loop i =
+    if i = n then Stream (i, lazy (raise End_of_stream))
+    else Stream (i, lazy (loop (i + 1)))
+  in loop 0
+;;
+
+let stream_get (Stream (x, s)) = (x, Lazy.force s)
+;;
+
+let rec iter_stream_match f s =
+  match stream_get s
+  with exception End_of_stream -> ()
+  | (x, s') ->
+    begin
+      f x;
+      iter_stream_match f s'
+    end
+;;
+
+let test_iter_stream =
+  let limit = 10000000 in
+  try
+    iter_stream_match ignore (make_stream_up_to limit);
+    print_endline "iter_stream with handler case (match) is tail recursive"
+  with Stack_overflow ->
+    assert false
+;;
diff --git a/testsuite/tests/match-exception/streams.reference b/testsuite/tests/match-exception/streams.reference
new file mode 100644
index 00000000..13df4640
--- /dev/null
+++ b/testsuite/tests/match-exception/streams.reference
@@ -0,0 +1 @@
+iter_stream with handler case (match) is tail recursive
diff --git a/testsuite/tests/match-exception/tail_calls.ml b/testsuite/tests/match-exception/tail_calls.ml
new file mode 100644
index 00000000..61cf0266
--- /dev/null
+++ b/testsuite/tests/match-exception/tail_calls.ml
@@ -0,0 +1,21 @@
+(**
+    The success continuation expression is in tail position.
+*)
+
+let count_to_tr_match n =
+  let rec loop i =
+    match
+      i < n
+    with exception Not_found -> ()
+    | false -> ()
+    | true -> loop (i + 1)
+  in loop 0
+;;
+
+let test_tail_recursion =
+  try
+    count_to_tr_match 10000000;
+    print_endline "handler-case (match) is tail recursive"
+  with _ ->
+    assert false
+;;
diff --git a/testsuite/tests/match-exception/tail_calls.reference b/testsuite/tests/match-exception/tail_calls.reference
new file mode 100644
index 00000000..342bf24a
--- /dev/null
+++ b/testsuite/tests/match-exception/tail_calls.reference
@@ -0,0 +1 @@
+handler-case (match) is tail recursive
diff --git a/testsuite/tests/messages/Makefile b/testsuite/tests/messages/Makefile
new file mode 100644
index 00000000..07f67998
--- /dev/null
+++ b/testsuite/tests/messages/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/messages/precise_locations.ml b/testsuite/tests/messages/precise_locations.ml
new file mode 100644
index 00000000..997cb86e
--- /dev/null
+++ b/testsuite/tests/messages/precise_locations.ml
@@ -0,0 +1,93 @@
+type t = (unit, unit, unit, unit) bar
+;;
+(* PR#7315: we expect the error location on "bar" instead of "(...) bar" *)
+[%%expect{|
+Line _, characters 34-37:
+Error: Unbound type constructor bar
+|}];;
+
+function (x :
+#bar) -> ();;
+(* we expect the location on "bar" instead of "#bar" *)
+[%%expect{|
+Line _, characters 1-4:
+Error: Unbound class bar
+|}];;
+
+function
+#bar -> ()
+;;
+(* we expect the location on "bar" instead of "#bar" *)
+[%%expect{|
+Line _, characters 1-4:
+Error: Unbound type constructor bar
+|}];;
+
+new bar;;
+(* we expect the location on "bar" instead of "new bar" *)
+[%%expect{|
+Line _, characters 4-7:
+Error: Unbound class bar
+|}];;
+
+type t =
+  | Foo of unit [@deprecated]
+  | Bar;;
+#warnings "@3";;
+let x =
+Foo ();;
+(* "Foo ()": the whole construct, with arguments, is deprecated *)
+[%%expect{|
+type t = Foo of unit | Bar
+Line _, characters 0-6:
+Warning 3: deprecated: Foo
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+function
+Foo _ -> () | Bar -> ();;
+(* "Foo _", the whole construct is deprecated *)
+[%%expect{|
+Line _, characters 0-5:
+Warning 3: deprecated: Foo
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+
+
+open Foo;;
+(* the error location should be on "Foo" *)
+[%%expect{|
+Line _, characters 5-8:
+Error: Unbound module Foo
+|}];;
+
+#warnings "@33";; (* unused open statement *)
+include (struct
+open List
+end);;
+(* here we expect the error location to be
+   on "open List" as whole rather than "List" *)
+[%%expect{|
+Line _, characters 0-9:
+Warning 33: unused open List.
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+
+type unknown += Foo;;
+(* unknown, not the whole line *)
+[%%expect{|
+Line _, characters 5-12:
+Error: Unbound type constructor unknown
+|}];;
+
+type t = ..;;
+type t +=
+Foo = Foobar;;
+(* Foobar, not the whole line *)
+[%%expect{|
+type t = ..
+Line _, characters 6-12:
+Error: Unbound constructor Foobar
+|}];;
diff --git a/testsuite/tests/misc-kb/Makefile b/testsuite/tests/misc-kb/Makefile
new file mode 100644
index 00000000..1ce51aca
--- /dev/null
+++ b/testsuite/tests/misc-kb/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=terms equations orderings kb
+MAIN_MODULE=kbmain
+ADD_COMPFLAGS=-w a
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml
new file mode 100644
index 00000000..c8dbff05
--- /dev/null
+++ b/testsuite/tests/misc-kb/equations.ml
@@ -0,0 +1,100 @@
+(****************** 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/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli
new file mode 100644
index 00000000..99055ce2
--- /dev/null
+++ b/testsuite/tests/misc-kb/equations.mli
@@ -0,0 +1,18 @@
+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/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml
new file mode 100644
index 00000000..1e5fd2c7
--- /dev/null
+++ b/testsuite/tests/misc-kb/kb.ml
@@ -0,0 +1,173 @@
+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/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli
new file mode 100644
index 00000000..32768716
--- /dev/null
+++ b/testsuite/tests/misc-kb/kb.mli
@@ -0,0 +1,17 @@
+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/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml
new file mode 100644
index 00000000..e5c53dc8
--- /dev/null
+++ b/testsuite/tests/misc-kb/kbmain.ml
@@ -0,0 +1,67 @@
+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/testsuite/tests/misc-kb/kbmain.reference b/testsuite/tests/misc-kb/kbmain.reference
new file mode 100644
index 00000000..758a0b4d
--- /dev/null
+++ b/testsuite/tests/misc-kb/kbmain.reference
@@ -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/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml
new file mode 100644
index 00000000..b6ef8abf
--- /dev/null
+++ b/testsuite/tests/misc-kb/orderings.ml
@@ -0,0 +1,84 @@
+(*********************** 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/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli
new file mode 100644
index 00000000..d0493c52
--- /dev/null
+++ b/testsuite/tests/misc-kb/orderings.mli
@@ -0,0 +1,17 @@
+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/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml
new file mode 100644
index 00000000..f66c86fa
--- /dev/null
+++ b/testsuite/tests/misc-kb/terms.ml
@@ -0,0 +1,121 @@
+(****************** 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/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli
new file mode 100644
index 00000000..81ec58e7
--- /dev/null
+++ b/testsuite/tests/misc-kb/terms.mli
@@ -0,0 +1,17 @@
+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/testsuite/tests/misc-unsafe/Makefile b/testsuite/tests/misc-unsafe/Makefile
new file mode 100644
index 00000000..2afaa5d2
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+UNSAFE=ON
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc-unsafe/almabench.ml b/testsuite/tests/misc-unsafe/almabench.ml
new file mode 100644
index 00000000..54fc3108
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/almabench.ml
@@ -0,0 +1,327 @@
+(*
+ * ALMABENCH 1.0.1
+ *      OCaml     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/testsuite/tests/misc-unsafe/almabench.reference b/testsuite/tests/misc-unsafe/almabench.reference
new file mode 100644
index 00000000..5c1d8b89
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/almabench.reference
@@ -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/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml
new file mode 100644
index 00000000..7c030a85
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/fft.ml
@@ -0,0 +1,174 @@
+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.make (np+2) 0.0
+  and pxi = Array.make (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;
+  if abs_float !zr <= 1e-9 && abs_float !zi <= 1e-9
+  then print_string "ok"
+  else print_string "ERROR";
+  print_newline()
+
+let _ =
+  let np = ref 16 in for i = 1 to 15 do test !np; np := !np*2 done
diff --git a/testsuite/tests/misc-unsafe/fft.reference b/testsuite/tests/misc-unsafe/fft.reference
new file mode 100644
index 00000000..ce6544e9
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/fft.reference
@@ -0,0 +1,15 @@
+16... ok
+32... ok
+64... ok
+128... ok
+256... ok
+512... ok
+1024... ok
+2048... ok
+4096... ok
+8192... ok
+16384... ok
+32768... ok
+65536... ok
+131072... ok
+262144... ok
diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml
new file mode 100644
index 00000000..21491b70
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/quicksort.ml
@@ -0,0 +1,78 @@
+(* 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.make size 0 in
+  let check = Array.make 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/testsuite/tests/misc-unsafe/quicksort.reference b/testsuite/tests/misc-unsafe/quicksort.reference
new file mode 100644
index 00000000..2c94e483
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/quicksort.reference
@@ -0,0 +1,2 @@
+OK
+OK
diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
new file mode 100644
index 00000000..ccab81e0
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -0,0 +1,96 @@
+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/testsuite/tests/misc-unsafe/soli.reference b/testsuite/tests/misc-unsafe/soli.reference
new file mode 100644
index 00000000..b94045c3
--- /dev/null
+++ b/testsuite/tests/misc-unsafe/soli.reference
@@ -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/testsuite/tests/misc/Makefile b/testsuite/tests/misc/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/misc/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml
new file mode 100644
index 00000000..ce7d931d
--- /dev/null
+++ b/testsuite/tests/misc/bdd.ml
@@ -0,0 +1,217 @@
+(* Translated to OCaml 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.make (!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.make 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.make (!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.make cacheSize 0
+let andslot2  = Array.make cacheSize 0
+let andslot3  = Array.make cacheSize zero
+let xorslot1  = Array.make cacheSize 0
+let xorslot2  = Array.make cacheSize 0
+let xorslot3  = Array.make cacheSize zero
+let notslot1  = Array.make cacheSize 0
+let notslot2  = Array.make 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.make 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 10 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/testsuite/tests/misc/bdd.reference b/testsuite/tests/misc/bdd.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/misc/bdd.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml
new file mode 100644
index 00000000..38b0a4bd
--- /dev/null
+++ b/testsuite/tests/misc/boyer.ml
@@ -0,0 +1,878 @@
+(* 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]) ->
+        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 _ =
+  let ok = ref true in
+  for i = 1 to 10 do
+    if not (tautp (apply_subst subst term)) then ok := false
+  done;
+  if !ok then
+    print_string "Proved!\n"
+  else
+    print_string "Cannot prove!\n";
+  exit 0
diff --git a/testsuite/tests/misc/boyer.reference b/testsuite/tests/misc/boyer.reference
new file mode 100644
index 00000000..f38e3263
--- /dev/null
+++ b/testsuite/tests/misc/boyer.reference
@@ -0,0 +1 @@
+Proved!
diff --git a/testsuite/tests/misc/ephetest.ml b/testsuite/tests/misc/ephetest.ml
new file mode 100644
index 00000000..a125300c
--- /dev/null
+++ b/testsuite/tests/misc/ephetest.ml
@@ -0,0 +1,168 @@
+let debug = false
+
+open Printf
+open Ephemeron
+
+let is_true test s b = printf "%s %s: %s\n" test s (if b then "OK" else "FAIL")
+let is_false test s b = is_true test s (not b)
+
+let is_data_value test eph (v:int) =
+  match K1.get_data_copy eph with
+  | Some x ->
+      if !x = v
+      then printf "%s data set: OK\n" test
+      else printf "%s data set: FAIL(bad value %i)\n" test (!x)
+  | None -> printf "%s data set: FAIL\n" test
+
+let is_key_value test eph (v:int) =
+  match K1.get_key_copy eph with
+  | Some x ->
+      if !x = v
+      then printf "%s key set: OK\n" test
+      else printf "%s key set: FAIL(bad value %i)\n" test (!x)
+  | None -> printf "%s key unset: FAIL\n" test
+
+let is_key_unset test eph =
+  is_false test "key unset" (K1.check_key eph)
+
+let is_data_unset test eph =
+  is_false test "data unset" (K1.check_data eph)
+
+let make_ra () = ref (ref 1) [@@inline never]
+let make_rb () = ref (ref (ref 2)) [@@inline never]
+let ra = make_ra ()
+let rb = make_rb ()
+
+(** test: key alive data dangling *)
+let test1 () =
+  let test = "test1" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  K1.set_key eph (!ra);
+  K1.set_data eph (ref 42);
+  is_key_value test eph 1;
+  is_data_value test eph 42;
+  Gc.minor ();
+  is_key_value test eph 1;
+  is_data_value test eph 42;
+  Gc.full_major ();
+  is_key_value test eph 1;
+  is_data_value test eph 42;
+  ra := ref 12;
+  Gc.full_major ();
+  is_key_unset test eph;
+  is_data_unset test eph
+let () = (test1 [@inlined never]) ()
+
+(** test: key dangling data dangling *)
+let test2 () =
+  let test = "test2" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  K1.set_key eph (ref 125);
+  K1.set_data eph (ref 42);
+  is_key_value test eph 125;
+  is_data_value test eph 42;
+  ra := ref 13;
+  Gc.minor ();
+  is_key_unset test eph;
+  is_data_unset test eph
+let () = (test2 [@inlined never]) ()
+
+(** test: key dangling data alive *)
+let test3 () =
+  let test = "test3" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  K1.set_key eph (ref 125);
+  K1.set_data eph (!ra);
+  is_key_value test eph 125;
+  is_data_value test eph 13;
+  ra := ref 14;
+  Gc.minor ();
+  is_key_unset test eph;
+  is_data_unset test eph
+let () = (test3 [@inlined never]) ()
+
+(** test: key alive but one away, data dangling *)
+let test4 () =
+  let test = "test4" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  rb := ref (ref 3);
+  K1.set_key eph (!(!rb));
+  K1.set_data eph (ref 43);
+  is_key_value test eph 3;
+  is_data_value test eph 43;
+  Gc.minor ();
+  Gc.minor ();
+  is_key_value test eph 3;
+  is_data_value test eph 43
+let () = (test4 [@inlined never]) ()
+
+(** test: key dangling but one away, data dangling *)
+let test5 () =
+  let test = "test5" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  rb := ref (ref 3);
+  K1.set_key eph (!(!rb));
+  K1.set_data eph (ref 43);
+  is_key_value test eph 3;
+  is_data_value test eph 43;
+  !rb := ref 4;
+  Gc.minor ();
+  Gc.minor ();
+  is_key_unset test eph;
+  is_data_unset test eph
+let () = (test5 [@inlined never]) ()
+
+(** test: key accessible from data but all dangling *)
+let test6 () =
+  let test = "test6" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref ref) K1.t = K1.create () in
+  rb := ref (ref 3);
+  K1.set_key eph (!(!rb));
+  K1.set_data eph (ref (!(!rb)));
+  Gc.minor ();
+  is_key_value test eph 3;
+  !rb := ref 4;
+  Gc.full_major ();
+  is_key_unset test eph;
+  is_data_unset test eph
+let () = (test6 [@inlined never]) ()
+
+(** test: ephemeron accessible from data but they are dangling *)
+type t =
+  | No
+  | Ephe of (int ref, t) K1.t
+
+let rc = ref No
+
+let test7 () =
+  let test = "test7" in
+  Gc.minor ();
+  Gc.full_major ();
+  ra := ref 42;
+  let weak : t Weak.t = Weak.create 1 in
+  let eph : (int ref, t) K1.t ref = ref (K1.create ()) in
+  rc := Ephe !eph;
+  Weak.set weak 0 (Some !rc);
+  K1.set_key !eph !ra;
+  K1.set_data !eph !rc;
+  Gc.minor ();
+  is_true test "before" (Weak.check weak 0);
+  eph := K1.create ();
+  rc := No;
+  Gc.full_major ();
+  Gc.full_major ();
+  Gc.full_major ();
+  is_false test "after" (Weak.check weak 0)
+let () = (test7 [@inlined never]) ()
diff --git a/testsuite/tests/misc/ephetest.reference b/testsuite/tests/misc/ephetest.reference
new file mode 100644
index 00000000..2699fdf7
--- /dev/null
+++ b/testsuite/tests/misc/ephetest.reference
@@ -0,0 +1,29 @@
+test1 key set: OK
+test1 data set: OK
+test1 key set: OK
+test1 data set: OK
+test1 key set: OK
+test1 data set: OK
+test1 key unset: OK
+test1 data unset: OK
+test2 key set: OK
+test2 data set: OK
+test2 key unset: OK
+test2 data unset: OK
+test3 key set: OK
+test3 data set: OK
+test3 key unset: OK
+test3 data unset: OK
+test4 key set: OK
+test4 data set: OK
+test4 key set: OK
+test4 data set: OK
+test5 key set: OK
+test5 data set: OK
+test5 key unset: OK
+test5 data unset: OK
+test6 key set: OK
+test6 key unset: OK
+test6 data unset: OK
+test7 before: OK
+test7 after: OK
diff --git a/testsuite/tests/misc/ephetest2.ml b/testsuite/tests/misc/ephetest2.ml
new file mode 100644
index 00000000..61861df9
--- /dev/null
+++ b/testsuite/tests/misc/ephetest2.ml
@@ -0,0 +1,149 @@
+(***
+   This test evaluate boolean formula composed by conjunction and
+     disjunction using ephemeron:
+   - true == alive, false == garbage collected
+   - and == an n-ephemeron, or == many 1-ephemeron
+
+*)
+
+let nb_test = 4
+let max_level = 10
+ (** probability that a branch is not linked to a previous one *)
+let proba_no_shared = 0.2
+let arity_max = 4
+
+let proba_new = proba_no_shared ** (1./.(float_of_int max_level))
+
+open Format
+open Ephemeron
+
+let is_true test s b = printf "%s %s: %s\n" test s (if b then "OK" else "FAIL")
+let is_false test s b = is_true test s (not b)
+
+type varephe = int ref
+type ephe = (varephe,varephe) Kn.t
+
+type formula =
+  | Constant of bool
+  | And of var array
+  | Or of var array
+
+and var = {
+  form: formula;
+  value: bool;
+  ephe: varephe Weak.t;
+}
+
+let print_short_bool fmt b =
+  if b
+  then pp_print_string fmt "t"
+  else pp_print_string fmt "f"
+
+let rec pp_form fmt = function
+  | Constant b ->
+      fprintf fmt "%b" b
+  | And a      ->
+      fprintf fmt "And[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a
+  | Or a       ->
+      fprintf fmt  "Or[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a
+
+and pp_var fmt v =
+  fprintf fmt "%a%a:%a;@ "
+    print_short_bool v.value
+    print_short_bool (Weak.check v.ephe 0)
+    pp_form v.form
+
+type env = {
+  (** resizeable array for cheap *)
+  vars : (int,var) Hashtbl.t;
+  (** the ephemerons must be alive *)
+  ephes : ephe Stack.t;
+  (** keep alive the true constant *)
+  varephe_true : varephe Stack.t;
+(** keep temporarily alive the false constant *)
+  varephe_false : varephe Stack.t;
+}
+
+let new_env () = {
+  vars = Hashtbl.create 100;
+  ephes = Stack.create ();
+  varephe_true = Stack.create ();
+  varephe_false = Stack.create ();
+}
+
+let evaluate = function
+  | Constant b -> b
+  | And a -> Array.fold_left (fun acc e -> acc && e.value) true  a
+  | Or a  -> Array.fold_left (fun acc e -> acc || e.value) false a
+
+let get_ephe v =
+  match Weak.get v.ephe 0 with
+  | None ->
+      invalid_arg "Error: weak dead but nothing have been released"
+  | Some r -> r
+
+(** create a variable and its definition in the boolean world and
+    ephemerons world *)
+let rec create env rem_level (** remaining level *) =
+  let varephe = ref 1 in
+  let form =
+    if rem_level = 0 then (** Constant *)
+      if Random.bool ()
+      then (Stack.push varephe env.varephe_true ; Constant true )
+      else (Stack.push varephe env.varephe_false; Constant false)
+    else
+      let size = (Random.int (arity_max - 1)) + 2 in
+      let new_link _ =
+        if (Hashtbl.length env.vars) = 0 || Random.float 1. < proba_new
+        then create env (rem_level -1)
+        else Hashtbl.find env.vars (Random.int (Hashtbl.length env.vars))
+      in
+      let args = Array.init size new_link in
+      if Random.bool ()
+      then begin (** Or *)
+        Array.iter (fun v ->
+            let r = get_ephe v in
+            let e = Kn.create 1 in
+            Kn.set_key e 0 r;
+            Kn.set_data e varephe;
+            Stack.push e env.ephes
+          ) args; Or args
+      end
+      else begin (** And *)
+        let e = Kn.create (Array.length args) in
+        for i=0 to Array.length args - 1 do
+          Kn.set_key e i (get_ephe args.(i));
+        done;
+        Kn.set_data e varephe;
+        Stack.push e env.ephes;
+        And args
+      end
+  in
+  let create_weak e =
+    let w = Weak.create 1 in
+    Weak.set w 0 (Some e);
+    w
+  in
+  let v = {form; value = evaluate form;
+           ephe = create_weak varephe;
+          } in
+  Hashtbl.add env.vars (Hashtbl.length env.vars) v;
+  v
+
+
+let check_var v = v.value = Weak.check v.ephe 0
+
+let run test init =
+  Random.init init;
+  let env = new_env () in
+  let _top = create env max_level in
+  (** release false ref *)
+  Stack.clear env.varephe_false;
+  Gc.full_major ();
+  let res = Hashtbl.fold (fun _ v acc -> acc && check_var v) env.vars true in
+  is_true test "check" res
+
+let () =
+  for i = 0 to nb_test do
+    run ("test"^(string_of_int i)) i;
+  done
diff --git a/testsuite/tests/misc/ephetest2.reference b/testsuite/tests/misc/ephetest2.reference
new file mode 100644
index 00000000..db17cd7a
--- /dev/null
+++ b/testsuite/tests/misc/ephetest2.reference
@@ -0,0 +1,5 @@
+test0 check: OK
+test1 check: OK
+test2 check: OK
+test3 check: OK
+test4 check: OK
diff --git a/testsuite/tests/misc/ephetest3.ml b/testsuite/tests/misc/ephetest3.ml
new file mode 100644
index 00000000..5eed2cf3
--- /dev/null
+++ b/testsuite/tests/misc/ephetest3.ml
@@ -0,0 +1,121 @@
+(** This test weak table by application to the memoization of collatz
+    (also known as syracuse) algorithm suite computation *)
+
+(** We use Int64 because they are boxed *)
+
+(** number of element of the suite to compute (more are computed) *)
+let n = 1000
+
+let two = Int64.of_int 2
+let three = Int64.of_int 3
+
+let collatz x =
+  if Int64.equal (Int64.rem x two) Int64.zero
+  then Int64.div x two
+  else Int64.succ (Int64.mul x three)
+
+module S = struct
+  include Int64
+  let hash (x:t) = Hashtbl.hash x
+end
+
+let pp = Int64.to_string
+
+module HW = Ephemeron.K1.Make(S)
+module SW = Weak.Make(S)
+
+
+let sw = SW.create n
+let hashcons x = SW.merge sw x
+
+let hw = HW.create n
+
+let rec fill_hw x =
+  if not (HW.mem hw x) then begin
+    let y = hashcons (collatz x) in
+    HW.add hw x y;
+    fill_hw y
+  end
+
+exception InvariantBroken of string
+let test b = Printf.ksprintf (fun s -> if not b then raise (InvariantBroken s))
+
+let rec check_hw_aux cache x =
+  (** We use int so that the cache doesn't make x alive *)
+  if not (Hashtbl.mem cache (Int64.to_int x)) then begin
+    test (HW.mem hw x) "missing %s%!" (pp x);
+    let y =
+      try HW.find hw x
+      with Not_found ->
+        test (not (HW.mem hw x)) "key in the table but data missing %s!%!"
+          (pp x);
+        test false "missing %s%!" (pp x);
+        assert false
+    in
+    let y' = collatz x in
+    test (Int64.equal y y') "bad result for %s: %s instead of %s%!"
+      (pp x) (pp y) (pp y');
+    let y'' = hashcons y' in
+    test (y == y'') "bad result for %s: not physically equal%!" (pp x);
+    Hashtbl.add cache (Int64.to_int x) ();
+    check_hw_aux cache y
+  end
+
+let check_hw iter =
+  let cache = Hashtbl.create n in
+  iter (fun x -> check_hw_aux cache x)
+
+(** tests *)
+
+let run ~next ~check =
+  HW.reset hw;
+  SW.clear sw;
+  (* Gc.full_major (); *)
+  for x=0 to n do
+    let x' = next x in
+    fill_hw x';
+    check x;
+  done;
+  Gc.full_major ();
+  HW.clean hw;
+  Printf.printf "length: %i\n%!" (HW.length hw)
+
+let print_stats () =
+  let print_stats name stats =
+    Printf.printf "%s (%3i,%3i,%3i): %!"
+      name
+      stats.Hashtbl.num_bindings
+      stats.Hashtbl.num_buckets
+      stats.Hashtbl.max_bucket_length;
+    Array.iteri (fun i n -> Printf.printf "%i: %i, %!" i n)
+      stats.Hashtbl.bucket_histogram;
+    Printf.printf "\n%!";
+  in
+  print_stats "stats      : " (HW.stats hw);
+  print_stats "stats_alive: " (HW.stats_alive hw)
+
+let test_keep_last d d' =
+  Printf.printf "## Keep last %i alive, check each %i ##\n%!" (n/d) (n/d');
+  let keep_alive = Array.create (n/d) Int64.zero in
+  let next x =
+    let x' = hashcons (Int64.of_int x) in
+    Array.set keep_alive (x mod (n/d)) x';
+    x'
+  in
+  let check x =
+    if x mod (n/d') = 0 || x = n then begin
+      check_hw (fun f -> Array.iter f keep_alive)
+    end
+  in
+  run ~next ~check;
+  (** keep the array alive until the end *)
+  let s =
+    Array.fold_left (fun acc x -> Int64.add x acc) Int64.zero keep_alive in
+  Printf.printf "sum of kept alive %s\n%!" (pp s);
+  print_stats ();
+  Printf.printf "\n%!"
+
+let () =
+  test_keep_last 1 10;
+  test_keep_last 50 10;
+  test_keep_last 100 2
diff --git a/testsuite/tests/misc/ephetest3.reference b/testsuite/tests/misc/ephetest3.reference
new file mode 100644
index 00000000..4fd03fb9
--- /dev/null
+++ b/testsuite/tests/misc/ephetest3.reference
@@ -0,0 +1,18 @@
+## Keep last 1000 alive, check each 100 ##
+length: 2228
+sum of kept alive 500500
+stats      :  (2228,2048,  6): 0: 658, 1: 791, 2: 413, 3: 143, 4: 34, 5: 8, 6: 1, 
+stats_alive:  (2228,2048,  6): 0: 658, 1: 791, 2: 413, 3: 143, 4: 34, 5: 8, 6: 1, 
+
+## Keep last 20 alive, check each 100 ##
+length: 458
+sum of kept alive 19810
+stats      :  (458,2048,  3): 0: 1636, 1: 370, 2: 38, 3: 4, 
+stats_alive:  (458,2048,  3): 0: 1636, 1: 370, 2: 38, 3: 4, 
+
+## Keep last 10 alive, check each 500 ##
+length: 339
+sum of kept alive 9955
+stats      :  (339,2048,  3): 0: 1740, 1: 279, 2: 27, 3: 2, 
+stats_alive:  (339,2048,  3): 0: 1740, 1: 279, 2: 27, 3: 2, 
+
diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml
new file mode 100644
index 00000000..15228173
--- /dev/null
+++ b/testsuite/tests/misc/fib.ml
@@ -0,0 +1,9 @@
+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/testsuite/tests/misc/fib.reference b/testsuite/tests/misc/fib.reference
new file mode 100644
index 00000000..08c2ab3e
--- /dev/null
+++ b/testsuite/tests/misc/fib.reference
@@ -0,0 +1 @@
+1346269
diff --git a/testsuite/tests/misc/finaliser.ml b/testsuite/tests/misc/finaliser.ml
new file mode 100644
index 00000000..316c0da1
--- /dev/null
+++ b/testsuite/tests/misc/finaliser.ml
@@ -0,0 +1,68 @@
+
+
+let m = 1000
+let m' = 100
+let k = m*10
+
+(** the printing are not stable between ocamlc and ocamlopt *)
+let debug = false
+
+let gc_print where _ =
+  if debug then
+    let stat = Gc.quick_stat () in
+    Printf.printf "minor: %i major: %i %s\n%!"
+      stat.Gc.minor_collections
+      stat.Gc.major_collections
+      where
+
+let r = Array.init m (fun _ -> Array.make m 1)
+
+
+let () =
+  gc_print "[Before]" ();
+  let rec aux n =
+    if n < k then begin
+      r.(n mod m) <- (Array.make m' n);
+      begin match n mod m with
+      | 0 ->
+          (** finalise first major *)
+          gc_print (Printf.sprintf "[Create %i first]" n) ();
+          Gc.finalise (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(0)
+      | 1 ->
+          (** finalise last major *)
+          gc_print (Printf.sprintf "[Create %i last]" n) ();
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i last]" n)) r.(1)
+      | 2 ->
+          (** finalise first minor *)
+          let m = ref 1 in
+          gc_print (Printf.sprintf "[Create %i first minor]" n) ();
+          Gc.finalise
+            (gc_print (Printf.sprintf "[Finalise %i first minor]" n)) m
+      | 3 ->
+          (** finalise last minor *)
+          let m = ref 1 in
+          gc_print (Printf.sprintf "[Create %i last minor]" n) ();
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i last minor]" n)) m
+      | 4 ->
+          (** finalise first-last major *)
+          gc_print (Printf.sprintf "[Create %i first]" n) ();
+          Gc.finalise (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(4);
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(4)
+      | _ -> ()
+      end;
+      aux (n + 1)
+    end
+  in
+  aux 0;
+  gc_print "[Full major]" ();
+  Gc.full_major ();
+  gc_print "[Second full major]" ();
+  Gc.full_major ();
+  gc_print "[Third full major]" ();
+  Gc.full_major ();
+  ()
+
+let () = flush stdout
diff --git a/testsuite/tests/misc/finaliser.reference b/testsuite/tests/misc/finaliser.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/misc/gcwords.ml b/testsuite/tests/misc/gcwords.ml
new file mode 100644
index 00000000..80ecd34e
--- /dev/null
+++ b/testsuite/tests/misc/gcwords.ml
@@ -0,0 +1,24 @@
+type t = Leaf of int | Branch of t * t
+
+let a = [| 0.0 |]
+
+let rec allocate_lots m = function
+  | 0 -> Leaf m
+  | n -> Branch (allocate_lots m (n-1), allocate_lots (m+1) (n-1))
+
+let measure f =
+  let a = Gc.minor_words () in
+  f ();
+  let c = Gc.minor_words () in
+  c -. a
+
+let () =
+  let n = measure (fun () -> a.(0) <- Gc.minor_words ()) in
+  (* Gc.minor_words should not allocate, although bytecode
+     generally boxes the floats *)
+  assert (n < 10.);
+  if Sys.backend_type = Sys.Native then assert (n = 0.);
+  let n = measure (fun () -> Sys.opaque_identity (allocate_lots 42 10)) in
+  (* This should allocate > 3k words (varying slightly by unboxing) *)
+  assert (n > 3000.);
+  print_endline "ok"
diff --git a/testsuite/tests/misc/gcwords.reference b/testsuite/tests/misc/gcwords.reference
new file mode 100644
index 00000000..9766475a
--- /dev/null
+++ b/testsuite/tests/misc/gcwords.reference
@@ -0,0 +1 @@
+ok
diff --git a/testsuite/tests/misc/hamming.ml b/testsuite/tests/misc/hamming.ml
new file mode 100644
index 00000000..c98dea3d
--- /dev/null
+++ b/testsuite/tests/misc/hamming.ml
@@ -0,0 +1,91 @@
+(* 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/testsuite/tests/misc/hamming.reference b/testsuite/tests/misc/hamming.reference
new file mode 100644
index 00000000..af1339ef
--- /dev/null
+++ b/testsuite/tests/misc/hamming.reference
@@ -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/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml
new file mode 100644
index 00000000..a31b4166
--- /dev/null
+++ b/testsuite/tests/misc/nucleic.ml
@@ -0,0 +1,3223 @@
+(* 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/testsuite/tests/misc/nucleic.reference b/testsuite/tests/misc/nucleic.reference
new file mode 100644
index 00000000..14689cdb
--- /dev/null
+++ b/testsuite/tests/misc/nucleic.reference
@@ -0,0 +1 @@
+33.7976
diff --git a/testsuite/tests/misc/pr7168.ml b/testsuite/tests/misc/pr7168.ml
new file mode 100644
index 00000000..fb0ef7d2
--- /dev/null
+++ b/testsuite/tests/misc/pr7168.ml
@@ -0,0 +1,77 @@
+let rec f x =
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in  let x = x+x in  let x = x+x in  let x = x+x in
+  let x = x+x in
+  let _ = f x in
+  ()
+
+let _ =
+  if (Gc.get ()).Gc.stack_limit = 0 then begin
+    (* We are in native code. Skip the test because some platforms cannot
+       reliably detect stack overflow. *)
+    Printf.printf "OK\n"
+  end else begin
+    try f 1
+    with Stack_overflow -> Printf.printf "OK\n"
+  end
diff --git a/testsuite/tests/misc/pr7168.reference b/testsuite/tests/misc/pr7168.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/misc/pr7168.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml
new file mode 100644
index 00000000..0b9ac4c9
--- /dev/null
+++ b/testsuite/tests/misc/sieve.ml
@@ -0,0 +1,42 @@
+(* 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_string " "; print_int n) (sieve 50000);
+  print_newline();
+  exit 0
diff --git a/testsuite/tests/misc/sieve.reference b/testsuite/tests/misc/sieve.reference
new file mode 100644
index 00000000..24f5cc54
--- /dev/null
+++ b/testsuite/tests/misc/sieve.reference
@@ -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 40009 40013 40031 40037 40039 40063 40087 40093 40099 40111 40123 40127 40129 40151 40153 40163 40169 40177 40189 40193 40213 40231 40237 40241 40253 40277 40283 40289 40343 40351 40357 40361 40387 40423 40427 40429 40433 40459 40471 40483 40487 40493 40499 40507 40519 40529 40531 40543 40559 40577 40583 40591 40597 40609 40627 40637 40639 40693 40697 40699 40709 40739 40751 40759 40763 40771 40787 40801 40813 40819 40823 40829 40841 40847 40849 40853 40867 40879 40883 40897 40903 40927 40933 40939 40949 40961 40973 40993 41011 41017 41023 41039 41047 41051 41057 41077 41081 41113 41117 41131 41141 41143 41149 41161 41177 41179 41183 41189 41201 41203 41213 41221 41227 41231 41233 41243 41257 41263 41269 41281 41299 41333 41341 41351 41357 41381 41387 41389 41399 41411 41413 41443 41453 41467 41479 41491 41507 41513 41519 41521 41539 41543 41549 41579 41593 41597 41603 41609 41611 41617 41621 41627 41641 41647 41651 41659 41669 41681 41687 41719 41729 41737 41759 41761 41771 41777 41801 41809 41813 41843 41849 41851 41863 41879 41887 41893 41897 41903 41911 41927 41941 41947 41953 41957 41959 41969 41981 41983 41999 42013 42017 42019 42023 42043 42061 42071 42073 42083 42089 42101 42131 42139 42157 42169 42179 42181 42187 42193 42197 42209 42221 42223 42227 42239 42257 42281 42283 42293 42299 42307 42323 42331 42337 42349 42359 42373 42379 42391 42397 42403 42407 42409 42433 42437 42443 42451 42457 42461 42463 42467 42473 42487 42491 42499 42509 42533 42557 42569 42571 42577 42589 42611 42641 42643 42649 42667 42677 42683 42689 42697 42701 42703 42709 42719 42727 42737 42743 42751 42767 42773 42787 42793 42797 42821 42829 42839 42841 42853 42859 42863 42899 42901 42923 42929 42937 42943 42953 42961 42967 42979 42989 43003 43013 43019 43037 43049 43051 43063 43067 43093 43103 43117 43133 43151 43159 43177 43189 43201 43207 43223 43237 43261 43271 43283 43291 43313 43319 43321 43331 43391 43397 43399 43403 43411 43427 43441 43451 43457 43481 43487 43499 43517 43541 43543 43573 43577 43579 43591 43597 43607 43609 43613 43627 43633 43649 43651 43661 43669 43691 43711 43717 43721 43753 43759 43777 43781 43783 43787 43789 43793 43801 43853 43867 43889 43891 43913 43933 43943 43951 43961 43963 43969 43973 43987 43991 43997 44017 44021 44027 44029 44041 44053 44059 44071 44087 44089 44101 44111 44119 44123 44129 44131 44159 44171 44179 44189 44201 44203 44207 44221 44249 44257 44263 44267 44269 44273 44279 44281 44293 44351 44357 44371 44381 44383 44389 44417 44449 44453 44483 44491 44497 44501 44507 44519 44531 44533 44537 44543 44549 44563 44579 44587 44617 44621 44623 44633 44641 44647 44651 44657 44683 44687 44699 44701 44711 44729 44741 44753 44771 44773 44777 44789 44797 44809 44819 44839 44843 44851 44867 44879 44887 44893 44909 44917 44927 44939 44953 44959 44963 44971 44983 44987 45007 45013 45053 45061 45077 45083 45119 45121 45127 45131 45137 45139 45161 45179 45181 45191 45197 45233 45247 45259 45263 45281 45289 45293 45307 45317 45319 45329 45337 45341 45343 45361 45377 45389 45403 45413 45427 45433 45439 45481 45491 45497 45503 45523 45533 45541 45553 45557 45569 45587 45589 45599 45613 45631 45641 45659 45667 45673 45677 45691 45697 45707 45737 45751 45757 45763 45767 45779 45817 45821 45823 45827 45833 45841 45853 45863 45869 45887 45893 45943 45949 45953 45959 45971 45979 45989 46021 46027 46049 46051 46061 46073 46091 46093 46099 46103 46133 46141 46147 46153 46171 46181 46183 46187 46199 46219 46229 46237 46261 46271 46273 46279 46301 46307 46309 46327 46337 46349 46351 46381 46399 46411 46439 46441 46447 46451 46457 46471 46477 46489 46499 46507 46511 46523 46549 46559 46567 46573 46589 46591 46601 46619 46633 46639 46643 46649 46663 46679 46681 46687 46691 46703 46723 46727 46747 46751 46757 46769 46771 46807 46811 46817 46819 46829 46831 46853 46861 46867 46877 46889 46901 46919 46933 46957 46993 46997 47017 47041 47051 47057 47059 47087 47093 47111 47119 47123 47129 47137 47143 47147 47149 47161 47189 47207 47221 47237 47251 47269 47279 47287 47293 47297 47303 47309 47317 47339 47351 47353 47363 47381 47387 47389 47407 47417 47419 47431 47441 47459 47491 47497 47501 47507 47513 47521 47527 47533 47543 47563 47569 47581 47591 47599 47609 47623 47629 47639 47653 47657 47659 47681 47699 47701 47711 47713 47717 47737 47741 47743 47777 47779 47791 47797 47807 47809 47819 47837 47843 47857 47869 47881 47903 47911 47917 47933 47939 47947 47951 47963 47969 47977 47981 48017 48023 48029 48049 48073 48079 48091 48109 48119 48121 48131 48157 48163 48179 48187 48193 48197 48221 48239 48247 48259 48271 48281 48299 48311 48313 48337 48341 48353 48371 48383 48397 48407 48409 48413 48437 48449 48463 48473 48479 48481 48487 48491 48497 48523 48527 48533 48539 48541 48563 48571 48589 48593 48611 48619 48623 48647 48649 48661 48673 48677 48679 48731 48733 48751 48757 48761 48767 48779 48781 48787 48799 48809 48817 48821 48823 48847 48857 48859 48869 48871 48883 48889 48907 48947 48953 48973 48989 48991 49003 49009 49019 49031 49033 49037 49043 49057 49069 49081 49103 49109 49117 49121 49123 49139 49157 49169 49171 49177 49193 49199 49201 49207 49211 49223 49253 49261 49277 49279 49297 49307 49331 49333 49339 49363 49367 49369 49391 49393 49409 49411 49417 49429 49433 49451 49459 49463 49477 49481 49499 49523 49529 49531 49537 49547 49549 49559 49597 49603 49613 49627 49633 49639 49663 49667 49669 49681 49697 49711 49727 49739 49741 49747 49757 49783 49787 49789 49801 49807 49811 49823 49831 49843 49853 49871 49877 49891 49919 49921 49927 49937 49939 49943 49957 49991 49993 49999
diff --git a/testsuite/tests/misc/sorts.ml b/testsuite/tests/misc/sorts.ml
new file mode 100644
index 00000000..4c4d7126
--- /dev/null
+++ b/testsuite/tests/misc/sorts.ml
@@ -0,0 +1,4476 @@
+(* Test bench for sorting algorithms. *)
+
+
+(*
+  ocamlopt -noassert sorts.ml -cclib -lunix
+*)
+
+open Printf;;
+
+(*
+  Criteria:
+  0. stack overhead: at most log n.
+  1. stable or not.
+  2. space overhead.
+  3. speed.
+*)
+
+(************************************************************************)
+(* 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 : bytes;
+  s2 : bytes;
+  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; 193; 506;
+  1000; 1025; 1535; 2323;
+];;
+
+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: cascade pattern-matchings (delete pairs)
+         to do: intermediary closure for 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 try: *)
+(* list->array->list direct and array->list->array direct *)
+(* overhead = 1/3, 1/4, etc. *)
+(* overhead = sqrt (n) *)
+(* overhead = n/3 up to 30k, 30k up to 900M, sqrt (n) beyond *)
+
+(************************************************************************)
+(* 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 try 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 try partial application of trickledown (merge with down) *)
+(* FIXME try to expand maxson in trickledown; delete the 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 try cutoff for 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 ();;
diff --git a/testsuite/tests/misc/sorts.reference b/testsuite/tests/misc/sorts.reference
new file mode 100644
index 00000000..d311fcdd
--- /dev/null
+++ b/testsuite/tests/misc/sorts.reference
@@ -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.  193.  506. 1000. 1025. 1535.
+     2323.
+  List.sort with sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  List.sort with records (str)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+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.  193.  506. 1000. 1025. 1535.
+     2323.
+  Array.sort with sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  Array.sort with records (str)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+  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.  193.  506. 1000. 1025. 1535.
+     2323.
+Number of tests failed: 0
diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml
new file mode 100644
index 00000000..dbb17e2a
--- /dev/null
+++ b/testsuite/tests/misc/takc.ml
@@ -0,0 +1,8 @@
+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 200); print_newline(); exit 0
diff --git a/testsuite/tests/misc/takc.reference b/testsuite/tests/misc/takc.reference
new file mode 100644
index 00000000..50989ffe
--- /dev/null
+++ b/testsuite/tests/misc/takc.reference
@@ -0,0 +1 @@
+1400
diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml
new file mode 100644
index 00000000..6a6753b3
--- /dev/null
+++ b/testsuite/tests/misc/taku.ml
@@ -0,0 +1,8 @@
+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 200); print_newline(); exit 0
diff --git a/testsuite/tests/misc/taku.reference b/testsuite/tests/misc/taku.reference
new file mode 100644
index 00000000..50989ffe
--- /dev/null
+++ b/testsuite/tests/misc/taku.reference
@@ -0,0 +1 @@
+1400
diff --git a/testsuite/tests/misc/weaklifetime.ml b/testsuite/tests/misc/weaklifetime.ml
new file mode 100644
index 00000000..a05c1623
--- /dev/null
+++ b/testsuite/tests/misc/weaklifetime.ml
@@ -0,0 +1,62 @@
+Random.init 12345;;
+
+let size = 1000;;
+
+type block = int array;;
+
+type objdata =
+  | Present of block
+  | Absent of int  (* GC count at time of erase *)
+;;
+
+type bunch = {
+  objs : objdata array;
+  wp : block Weak.t;
+};;
+
+let data =
+  Array.init size (fun i ->
+    let n = 1 + Random.int size in
+    {
+      objs = Array.make n (Absent 0);
+      wp = Weak.create n;
+    }
+  )
+;;
+
+let gccount () = (Gc.quick_stat ()).Gc.major_collections;;
+
+(* Check the correctness condition on the data at (i,j):
+   1. if the block is present, the weak pointer must be full
+   2. if the block was removed at GC n, and the weak pointer is still
+      full, then the current GC must be at most n+1.
+
+   Then modify the data in one of the following ways:
+   1. if the block and weak pointer are absent, fill them
+   2. if the block and weak pointer are present, randomly erase the block
+*)
+let check_and_change i j =
+  let gc1 = gccount () in
+  match data.(i).objs.(j), Weak.check data.(i).wp j with
+  | Present x, false -> assert false
+  | Absent n, true -> assert (gc1 <= n+1)
+  | Absent _, false ->
+    let x = Array.make (1 + Random.int 10) 42 in
+    data.(i).objs.(j) <- Present x;
+    Weak.set data.(i).wp j (Some x);
+  | Present _, true ->
+    if Random.int 10 = 0 then begin
+      data.(i).objs.(j) <- Absent gc1;
+      let gc2 = gccount () in
+      if gc1 <> gc2 then data.(i).objs.(j) <- Absent gc2;
+    end
+;;
+
+let dummy = ref [||];;
+
+while gccount () < 20 do
+  dummy := Array.make (Random.int 300) 0;
+  let i = Random.int size in
+  let j = Random.int (Array.length data.(i).objs) in
+  check_and_change i j;
+done
diff --git a/testsuite/tests/misc/weaklifetime.reference b/testsuite/tests/misc/weaklifetime.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/misc/weaklifetime2.ml b/testsuite/tests/misc/weaklifetime2.ml
new file mode 100644
index 00000000..59f9ef4c
--- /dev/null
+++ b/testsuite/tests/misc/weaklifetime2.ml
@@ -0,0 +1,57 @@
+let n = 500
+let loop = 2
+
+let alive = ref (Array.init n (fun _ -> Array.make 10 0))
+
+let create_weaks () =
+  Array.init n (fun i ->
+      let w = Weak.create 1 in
+      Weak.set w 0 (Some (!alive.(i)));
+      w
+    )
+
+(** We are trying to keep the weak pointer of weak2 set when the
+    weak pointer of weak1 and weak3 are wrongly unset.
+    [weak1], [weak2] and [weak3] are identical.
+ *)
+
+let weak1 = create_weaks ()
+let weak2 = create_weaks ()
+let weak3 = create_weaks ()
+
+(** put the weak pointers in the major heap *)
+let () =
+  let dummy = ref [||] in
+  for l=0 to 10 do
+    dummy := Array.make 300 0
+  done
+
+let gccount () = (Gc.quick_stat ()).Gc.major_collections;;
+
+let () =
+  for _l=1 to loop do
+    let bad = ref 0 in
+    for i=0 to n-1 do
+      (** make *this* weak key alive *)
+      for _j=0 to n*10 do
+        ignore (Weak.get weak2.(i) 0);
+      done;
+      (** Check that if it is alive in weak2 it is alive in weak1 *)
+      if Weak.check weak2.(i) 0 &&
+         not (Weak.check weak1.(i) 0) &&
+         Weak.check weak2.(i) 0
+      then incr bad;
+      (** Check that if it is alive in weak2 it is alive in weak3
+          This case was failing before the addition of the clean phase in the gc
+      *)
+      if Weak.check weak2.(i) 0 &&
+         not (Weak.check weak3.(i) 0) &&
+         Weak.check weak2.(i) 0
+      then incr bad;
+      !alive.(i) <- Array.make 10 0;
+    done;
+    (* Printf.printf "bad: %i\  gccount:%i\n%!" !bad (gccount ()); *)
+    if !bad > 0
+    then Printf.printf "failing\n%!"
+    else Printf.printf "success\n%!"
+  done
diff --git a/testsuite/tests/misc/weaklifetime2.reference b/testsuite/tests/misc/weaklifetime2.reference
new file mode 100644
index 00000000..cfb2161c
--- /dev/null
+++ b/testsuite/tests/misc/weaklifetime2.reference
@@ -0,0 +1,2 @@
+success
+success
diff --git a/testsuite/tests/misc/weaktest.ml b/testsuite/tests/misc/weaktest.ml
new file mode 100644
index 00000000..a8e4b084
--- /dev/null
+++ b/testsuite/tests/misc/weaktest.ml
@@ -0,0 +1,67 @@
+let debug = false;;
+
+open Printf;;
+
+module Hashed = struct
+  type t = string list;;
+  let equal x y =
+    eprintf "equal: %s / %s\n" (List.hd x) (List.hd y);
+    x = y
+  ;;
+  let hash x = Hashtbl.hash (List.hd x);;
+end;;
+
+module HT = Weak.Make (Hashed);;
+
+let tbl = HT.create 7;;
+
+let r = ref [];;
+
+let bunch =
+  if Array.length Sys.argv < 2
+  then 10000
+  else int_of_string Sys.argv.(1)
+;;
+
+Random.init 314;;
+
+let random_string n =
+  String.init n (fun _ -> Char.chr (32 + Random.int 95))
+;;
+
+let added = ref 0;;
+let mistakes = ref 0;;
+
+let print_status () =
+  let (len, entries, sumbuck, buckmin, buckmed, buckmax) = HT.stats tbl in
+  if entries > bunch * (!added + 1) then begin
+    if debug then begin
+      printf "\n===================\n";
+      printf "len = %d\n" len;
+      printf "entries = %d\n" entries;
+      printf "sum of bucket sizes = %d\n" sumbuck;
+      printf "min bucket = %d\n" buckmin;
+      printf "med bucket = %d\n" buckmed;
+      printf "max bucket = %d\n" buckmax;
+      printf "GC count = %d\n" (Gc.quick_stat ()).Gc.major_collections;
+      flush stdout;
+    end;
+    incr mistakes;
+  end;
+  added := 0;
+;;
+
+Gc.create_alarm print_status;;
+
+for j = 0 to 99 do
+  r := [];
+  incr added;
+
+  for i = 1 to bunch do
+    let c = random_string 7 in
+    r := c :: !r;
+    HT.add tbl !r;
+  done;
+done;;
+
+if !mistakes < 5 then printf "pass\n" else printf "fail\n";;
diff --git a/testsuite/tests/misc/weaktest.reference b/testsuite/tests/misc/weaktest.reference
new file mode 100644
index 00000000..2ae28399
--- /dev/null
+++ b/testsuite/tests/misc/weaktest.reference
@@ -0,0 +1 @@
+pass
diff --git a/testsuite/tests/no-alias-deps/Makefile b/testsuite/tests/no-alias-deps/Makefile
new file mode 100644
index 00000000..d80c2ea5
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/Makefile
@@ -0,0 +1,37 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default: b.cmi c.cmi d.cmi aliases.ml
+	@$(OCAMLC) -c aliases.ml > aliases.ml.result 2>&1 || true
+	@$(OBJINFO) aliases.cmo | \
+	  sed -e "s/[a-f0-9]\{32\}/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/g" \
+	  > aliases.cmo.result 2>&1 || true
+	@for file in *.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
+
+b.cmi: b.cmi.pre
+	@cp b.cmi.pre b.cmi
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
+COMPFLAGS = -no-alias-deps
diff --git a/testsuite/tests/no-alias-deps/aliases.cmo.reference b/testsuite/tests/no-alias-deps/aliases.cmo.reference
new file mode 100644
index 00000000..b236b1dc
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/aliases.cmo.reference
@@ -0,0 +1,15 @@
+File aliases.cmo
+Unit name: Aliases
+Interfaces imported:
+	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa	Pervasives
+	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa	D
+	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa	CamlinternalFormatBasics
+	--------------------------------	C
+	--------------------------------	B
+	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa	Aliases
+	--------------------------------	A
+Required globals:
+	D
+	Pervasives
+Uses unsafe features: no
+Force link: no
diff --git a/testsuite/tests/no-alias-deps/aliases.ml b/testsuite/tests/no-alias-deps/aliases.ml
new file mode 100644
index 00000000..c74dcae6
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/aliases.ml
@@ -0,0 +1,5 @@
+module A' = A (* missing a.cmi *)
+module B' = B (* broken b.cmi *)
+module C' = C (* valid c.cmi *)
+module D' = D (* valid d.cmi *)
+let () = print_int D'.something
diff --git a/testsuite/tests/no-alias-deps/aliases.ml.reference b/testsuite/tests/no-alias-deps/aliases.ml.reference
new file mode 100644
index 00000000..ce6a3d1b
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/aliases.ml.reference
@@ -0,0 +1,5 @@
+File "_none_", line 1:
+Warning 49: no cmi file was found in path for module A
+File "_none_", line 1:
+Warning 49: no valid cmi file was found in path for module B. b.cmi
+is not a compiled interface
diff --git a/testsuite/tests/no-alias-deps/b.cmi.pre b/testsuite/tests/no-alias-deps/b.cmi.pre
new file mode 100644
index 00000000..b0aedf1b
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/b.cmi.pre
@@ -0,0 +1 @@
+Not a valid cmi file
diff --git a/testsuite/tests/no-alias-deps/c.mli b/testsuite/tests/no-alias-deps/c.mli
new file mode 100644
index 00000000..5d27914b
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/c.mli
@@ -0,0 +1 @@
+val something : int
diff --git a/testsuite/tests/no-alias-deps/d.mli b/testsuite/tests/no-alias-deps/d.mli
new file mode 100644
index 00000000..5d27914b
--- /dev/null
+++ b/testsuite/tests/no-alias-deps/d.mli
@@ -0,0 +1 @@
+val something : int
diff --git a/testsuite/tests/opaque/Makefile b/testsuite/tests/opaque/Makefile
new file mode 100644
index 00000000..247ee8ce
--- /dev/null
+++ b/testsuite/tests/opaque/Makefile
@@ -0,0 +1,75 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+.PHONY: default
+default:
+	@if $(BYTECODE_ONLY); then $(MAKE) skip ; else \
+	  $(MAKE) compile; \
+	fi
+
+.PHONY: skip
+skip:
+	@echo " ... testing 'test' with ordinary compilation => skipped"
+	@echo " ... testing 'test' with change to opaque interface => skipped"
+	@echo " ... testing 'test' with change to opaque implementation \
+	=> skipped"
+	@echo " ... testing 'test' with change to non-opaque implementation \
+	=> skipped"
+
+.PHONY: compile
+compile:
+	@$(OCAMLOPT) -I intf -opaque -c intf/opaque_intf.mli
+	@$(OCAMLOPT) -I intf -c intf/opaque_impl.mli
+	@$(OCAMLOPT) -I intf -c intf/regular.mli
+	@cp intf/*.mli intf/*.cmi fst
+	@cp intf/*.mli intf/*.cmi snd
+	@$(OCAMLOPT) -I fst -c fst/opaque_intf.ml
+	@$(OCAMLOPT) -I fst -opaque -c fst/opaque_impl.ml
+	@$(OCAMLOPT) -I fst -c fst/regular.ml
+	@$(OCAMLOPT) -I snd -c snd/opaque_intf.ml
+	@$(OCAMLOPT) -I snd -opaque -c snd/opaque_impl.ml
+	@$(OCAMLOPT) -I snd -c snd/regular.ml
+	@$(OCAMLOPT) -I fst -c test.ml
+	@
+	@printf " ... testing 'test' with ordinary compilation"; \
+          $(OCAMLOPT) fst/opaque_intf.cmx fst/opaque_impl.cmx \
+                        fst/regular.cmx test.cmx 2>/dev/null \
+            && echo " => passed" || echo " => failed"; \
+	 printf " ... testing 'test' with change to opaque interface"; \
+          $(OCAMLOPT) snd/opaque_intf.cmx fst/opaque_impl.cmx \
+                        fst/regular.cmx test.cmx 2>/dev/null \
+            && echo " => passed" || echo " => failed"; \
+	 printf " ... testing 'test' with change to opaque implementation"; \
+	  $(OCAMLOPT) fst/opaque_intf.cmx snd/opaque_impl.cmx \
+                        fst/regular.cmx test.cmx 2>/dev/null \
+            && echo " => passed" || echo " => failed"; \
+	 printf " ... testing 'test' with change to non-opaque implementation";\
+	  $(OCAMLOPT) fst/opaque_intf.cmx fst/opaque_impl.cmx \
+                        snd/regular.cmx test.cmx 2>/dev/null \
+            && echo " => failed" || echo " => passed"; \
+
+.PHONY: promote
+promote:
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.cmi *.cmx *.$(O) a.out camlprog.exe
+	@rm -f intf/*.cmi
+	@rm -f fst/*.cmi fst/*.cmx fst/*.$(O) fst/*.mli
+	@rm -f snd/*.cmi snd/*.cmx snd/*.$(O) snd/*.mli
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/opaque/fst/opaque_impl.ml b/testsuite/tests/opaque/fst/opaque_impl.ml
new file mode 100644
index 00000000..932c0d35
--- /dev/null
+++ b/testsuite/tests/opaque/fst/opaque_impl.ml
@@ -0,0 +1,2 @@
+
+let choose x y = x
diff --git a/testsuite/tests/opaque/fst/opaque_intf.ml b/testsuite/tests/opaque/fst/opaque_intf.ml
new file mode 100644
index 00000000..932c0d35
--- /dev/null
+++ b/testsuite/tests/opaque/fst/opaque_intf.ml
@@ -0,0 +1,2 @@
+
+let choose x y = x
diff --git a/testsuite/tests/opaque/fst/regular.ml b/testsuite/tests/opaque/fst/regular.ml
new file mode 100644
index 00000000..932c0d35
--- /dev/null
+++ b/testsuite/tests/opaque/fst/regular.ml
@@ -0,0 +1,2 @@
+
+let choose x y = x
diff --git a/testsuite/tests/opaque/intf/opaque_impl.mli b/testsuite/tests/opaque/intf/opaque_impl.mli
new file mode 100644
index 00000000..59d0a4c3
--- /dev/null
+++ b/testsuite/tests/opaque/intf/opaque_impl.mli
@@ -0,0 +1,2 @@
+
+val choose : 'a -> 'a -> 'a
diff --git a/testsuite/tests/opaque/intf/opaque_intf.mli b/testsuite/tests/opaque/intf/opaque_intf.mli
new file mode 100644
index 00000000..59d0a4c3
--- /dev/null
+++ b/testsuite/tests/opaque/intf/opaque_intf.mli
@@ -0,0 +1,2 @@
+
+val choose : 'a -> 'a -> 'a
diff --git a/testsuite/tests/opaque/intf/regular.mli b/testsuite/tests/opaque/intf/regular.mli
new file mode 100644
index 00000000..59d0a4c3
--- /dev/null
+++ b/testsuite/tests/opaque/intf/regular.mli
@@ -0,0 +1,2 @@
+
+val choose : 'a -> 'a -> 'a
diff --git a/testsuite/tests/opaque/snd/opaque_impl.ml b/testsuite/tests/opaque/snd/opaque_impl.ml
new file mode 100644
index 00000000..df8c0130
--- /dev/null
+++ b/testsuite/tests/opaque/snd/opaque_impl.ml
@@ -0,0 +1,2 @@
+
+let choose x y = y
diff --git a/testsuite/tests/opaque/snd/opaque_intf.ml b/testsuite/tests/opaque/snd/opaque_intf.ml
new file mode 100644
index 00000000..df8c0130
--- /dev/null
+++ b/testsuite/tests/opaque/snd/opaque_intf.ml
@@ -0,0 +1,2 @@
+
+let choose x y = y
diff --git a/testsuite/tests/opaque/snd/regular.ml b/testsuite/tests/opaque/snd/regular.ml
new file mode 100644
index 00000000..df8c0130
--- /dev/null
+++ b/testsuite/tests/opaque/snd/regular.ml
@@ -0,0 +1,2 @@
+
+let choose x y = y
diff --git a/testsuite/tests/opaque/test.ml b/testsuite/tests/opaque/test.ml
new file mode 100644
index 00000000..020c1385
--- /dev/null
+++ b/testsuite/tests/opaque/test.ml
@@ -0,0 +1,9 @@
+
+let () =
+  print_endline (Opaque_intf.choose "Opaque_intf: First" "Opaque_intf: Second")
+
+let () =
+  print_endline (Opaque_impl.choose "Opaque_impl: First" "Opaque_impl: Second")
+
+let () =
+  print_endline (Regular.choose "Regular: First" "Regular: Second")
diff --git a/testsuite/tests/parsetree/Makefile b/testsuite/tests/parsetree/Makefile
new file mode 100644
index 00000000..8e917a02
--- /dev/null
+++ b/testsuite/tests/parsetree/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/parsing
+MODULES=
+MAIN_MODULE=test
+LIBRARIES=../../../compilerlibs/ocamlcommon
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml
new file mode 100644
index 00000000..7742c599
--- /dev/null
+++ b/testsuite/tests/parsetree/source.ml
@@ -0,0 +1,7276 @@
+[@@@foo]
+
+let (x[@foo]) : unit [@foo] = ()[@foo]
+  [@@foo]
+
+type t =
+  | Foo of (t[@foo]) [@foo]
+[@@foo]
+
+[@@@foo]
+
+
+module M = struct
+  type t = {
+    l : (t [@foo]) [@foo]
+  }
+    [@@foo]
+    [@@foo]
+
+  [@@@foo]
+end[@foo]
+[@@foo]
+
+module type S = sig
+
+  include (module type of (M[@foo]))[@foo] with type t := M.t[@foo]
+    [@@foo]
+
+  [@@@foo]
+
+end[@foo]
+[@@foo]
+
+[@@@foo]
+type 'a with_default
+  =  ?size:int       (** default [42] *)
+  -> ?resizable:bool (** default [true] *)
+  -> 'a
+
+type obj = <
+  meth1 : int -> int;
+  (** method 1 *)
+
+  meth2: unit -> float (** method 2 *);
+>
+
+type var = [
+  | `Foo (** foo *)
+  | `Bar of int * string (** bar *)
+]
+
+[%%foo let x = 1 in x]
+let [%foo 2+1] : [%foo bar.baz] = [%foo "foo"]
+
+[%%foo module M = [%bar] ]
+let [%foo let () = () ] : [%foo type t = t ] = [%foo class c = object end]
+
+[%%foo: 'a list]
+let [%foo: [`Foo] ] : [%foo: t -> t ] = [%foo: < foo : t > ]
+
+[%%foo? _ ]
+[%%foo? Some y when y > 0]
+let [%foo? (Bar x | Baz x) ] : [%foo? #bar ] = [%foo? { x }]
+
+[%%foo: module M : [%baz]]
+let [%foo: include S with type t = t ]
+  : [%foo: val x : t  val y : t]
+  = [%foo: type t = t ]
+let int_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890z
+let float_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890.z
+
+let int32     = 1234l
+let int64     = 1234L
+let nativeint = 1234n
+
+let hex_without_modifier = 0x32f
+let hex_with_modifier    = 0x32g
+
+let float_without_modifer = 1.2e3
+let float_with_modifer    = 1.2g
+let%foo x = 42
+let%foo _ = () and _ = ()
+let%foo _ = ()
+
+(* Expressions *)
+let () =
+  let%foo[@foo] x = 3
+  and[@foo] y = 4 in
+  (let module%foo[@foo] M = M in ()) ;
+  (let open%foo[@foo] M in ()) ;
+  (fun%foo[@foo] x -> ()) ;
+  (function%foo[@foo] x -> ()) ;
+  (try%foo[@foo] () with _ -> ()) ;
+  (if%foo[@foo] () then () else ()) ;
+  while%foo[@foo] () do () done ;
+  for%foo[@foo] x = () to () do () done ;
+  assert%foo[@foo] true ;
+  lazy%foo[@foo] x ;
+  object%foo[@foo] end ;
+  begin%foo[@foo] 3 end ;
+  new%foo[@foo] x ;
+
+  match%foo[@foo] () with
+  (* Pattern expressions *)
+  | lazy%foo[@foo] x -> ()
+  | exception%foo[@foo] x -> ()
+
+(* Class expressions *)
+class x =
+  fun[@foo] x ->
+  let[@foo] x = 3 in
+  object[@foo]
+    inherit[@foo] x
+    val[@foo] x = 3
+    val[@foo] virtual x : t
+    val![@foo] mutable x = 3
+    method[@foo] x = 3
+    method[@foo] virtual x : t
+    method![@foo] private x = 3
+    initializer[@foo] x
+  end
+
+(* Class type expressions *)
+class type t =
+  object[@foo]
+    inherit[@foo] t
+    val[@foo] x : t
+    val[@foo] mutable x : t
+    method[@foo] x : t
+    method[@foo] private x : t
+    constraint[@foo] t = t'
+    [@@@abc]
+    [%%id]
+    [@@@aaa]
+  end
+
+(* Type expressions *)
+type t =
+  (module%foo[@foo] M)
+
+(* Module expressions *)
+module M =
+  functor[@foo] (M : S) ->
+    (val[@foo] x)
+    (struct[@foo] end)
+
+(* Module type expression *)
+module type S =
+  functor[@foo] (M:S) ->
+    (module type of[@foo] M) ->
+    (sig[@foo] end)
+
+(* Structure items *)
+let%foo[@foo] x = 4
+and[@foo] y = x
+
+type%foo[@foo] t = int
+and[@foo] t = int
+type%foo[@foo] t += T
+
+class%foo[@foo] x = x
+class type%foo[@foo] x = x
+external%foo[@foo] x : _  = ""
+exception%foo[@foo] X
+
+module%foo[@foo] M = M
+module%foo[@foo] rec M : S = M
+and[@foo] M : S = M
+module type%foo[@foo] S = S
+
+include%foo[@foo] M
+open%foo[@foo] M
+
+(* Signature items *)
+module type S = sig
+  val%foo[@foo] x : t
+  external%foo[@foo] x : t = ""
+
+  type%foo[@foo] t = int
+  and[@foo] t' = int
+  type%foo[@foo] t += T
+
+  exception%foo[@foo] X
+
+  module%foo[@foo] M : S
+  module%foo[@foo] rec M : S
+  and[@foo] M : S
+  module%foo[@foo] M = M
+
+  module type%foo[@foo] S = S
+
+  include%foo[@foo] M
+  open%foo[@foo] M
+
+  class%foo[@foo] x : t
+  class type%foo[@foo] x = x
+
+end
+
+type t = ..;;
+type t += A;;
+
+[%extension_constructor A];;
+([%extension_constructor A] : extension_constructor);;
+
+module M = struct
+  type extension_constructor = int
+end;;
+
+open M;;
+
+([%extension_constructor A] : extension_constructor);;
+
+(* By using two types we can have a recursive constraint *)
+type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
+and 'a name =
+  Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name
+;;
+
+exception Bad_cast
+;;
+
+class type castable =
+object
+  method cast: 'a.'a name -> 'a
+end
+;;
+
+(* Lets create a castable class with a name*)
+
+class type foo_t =
+object
+  inherit castable
+  method foo: string
+end
+;;
+
+type 'a class_name += Foo: foo_t class_name
+;;
+
+class foo: foo_t =
+object(self)
+  method cast: type a. a name -> a =
+    function
+        Class Foo -> (self :> foo_t)
+      | _ -> ((raise Bad_cast) : a)
+  method foo = "foo"
+end
+;;
+
+(* Now we can create a subclass of foo *)
+
+class type bar_t =
+object
+  inherit foo
+  method bar: string
+end
+;;
+
+type 'a class_name += Bar: bar_t class_name
+;;
+
+class bar: bar_t =
+object(self)
+  inherit foo as super
+  method cast: type a. a name -> a =
+    function
+        Class Bar -> (self :> bar_t)
+      | other -> super#cast other
+  method bar = "bar"
+  [@@@id]
+  [%%id]
+end
+;;
+
+(* Now lets create a mutable list of castable objects *)
+
+let clist :castable list ref = ref []
+;;
+
+let push_castable (c: #castable) =
+  clist := (c :> castable) :: !clist
+;;
+
+let pop_castable () =
+  match !clist with
+      c :: rest ->
+        clist := rest;
+        c
+    | [] -> raise Not_found
+;;
+
+(* We can add foos and bars to this list, and retrive them *)
+
+push_castable (new foo);;
+push_castable (new bar);;
+push_castable (new foo);;
+
+let c1: castable = pop_castable ();;
+let c2: castable = pop_castable ();;
+let c3: castable = pop_castable ();;
+
+(* We can also downcast these values to foos and bars *)
+
+let f1: foo = c1#cast (Class Foo);; (* Ok *)
+let f2: foo = c2#cast (Class Foo);; (* Ok *)
+let f3: foo = c3#cast (Class Foo);; (* Ok *)
+
+let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *)
+let b2: bar = c2#cast (Class Bar);; (* Ok *)
+let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *)
+
+type foo = ..
+;;
+
+type foo +=
+    A
+  | B of int
+;;
+
+let is_a x =
+  match x with
+    A -> true
+  | _ -> false
+;;
+
+(* The type must be open to create extension *)
+
+type foo
+;;
+
+type foo += A of int (* Error type is not open *)
+;;
+
+(* The type parameters must match *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+;;
+
+(* In a signature the type does not have to be open *)
+
+module type S =
+sig
+  type foo
+  type foo += A of float
+end
+;;
+
+(* But it must still be extensible *)
+
+module type S =
+sig
+  type foo = A of int
+  type foo += B of float (* Error foo does not have an extensible type *)
+end
+;;
+
+(* Signatures can change the grouping of extensions *)
+
+type foo = ..
+;;
+
+module M = struct
+  type foo +=
+      A of int
+    | B of string
+
+  type foo +=
+      C of int
+    | D of float
+end
+;;
+
+module type S = sig
+  type foo +=
+      B of string
+    | C of int
+
+  type foo += D of float
+
+  type foo += A of int
+end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Extensions can be GADTs *)
+
+type 'a foo = ..
+;;
+
+type _ foo +=
+    A : int -> int foo
+  | B : int foo
+;;
+
+let get_num : type a. a foo -> a -> a option = fun f i1 ->
+    match f with
+        A i2 -> Some (i1 + i2)
+     |  _ -> None
+;;
+
+(* Extensions must obey constraints *)
+
+type 'a foo = .. constraint 'a = [> `Var ]
+;;
+
+type 'a foo += A of 'a
+;;
+
+let a = A 9 (* ERROR: Constraints not met *)
+;;
+
+type 'a foo += B : int foo (* ERROR: Constraints not met *)
+;;
+
+(* Signatures can make an extension private *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A of int end
+;;
+
+let a1 = M.A 10
+;;
+
+module type S = sig type foo += private A of int end
+;;
+
+module M_S = (M : S)
+;;
+
+let is_s x =
+  match x with
+    M_S.A _ -> true
+  | _ -> false
+;;
+
+let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+;;
+
+(* Extensions can be rebound *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A1 of int end
+;;
+
+type foo += A2 = M.A1
+;;
+
+type bar = ..
+;;
+
+type bar += A3 = M.A1    (* Error: rebind wrong type *)
+;;
+
+module M = struct type foo += private B1 of int end
+;;
+
+type foo += private B2 = M.B1
+;;
+
+type foo += B3 = M.B1  (* Error: rebind private extension *)
+;;
+
+type foo += C = Unknown  (* Error: unbound extension *)
+;;
+
+(* Extensions can be rebound even if type is closed *)
+
+module M : sig type foo type foo += A1 of int end
+  = struct type foo = .. type foo += A1 of int end
+
+type M.foo += A2 = M.A1
+
+(* Rebinding handles abbreviations *)
+
+type 'a foo = ..
+;;
+
+type 'a foo1 = 'a foo = ..
+;;
+
+type 'a foo2 = 'a foo = ..
+;;
+
+type 'a foo1 +=
+    A of int
+  | B of 'a
+  | C : int foo1
+;;
+
+type 'a foo2 +=
+    D = A
+  | E = B
+  | F = C
+;;
+
+(* Extensions must obey variances *)
+
+type +'a foo = ..
+;;
+
+type 'a foo += A of (int -> 'a)
+;;
+
+type 'a foo += B of ('a -> int)
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type _ foo += C : ('a -> int) -> 'a foo
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type 'a bar = ..
+;;
+
+type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+;;
+
+(* Exceptions are compatible with extensions *)
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end
+;;
+
+module M : sig
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end = struct
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end
+;;
+
+exception Foo of int * float
+;;
+
+exception Bar : 'a list -> exn
+;;
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar = Bar
+  exception Foo = Foo
+end
+;;
+
+(* Test toplevel printing *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo of int * int option
+  | Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar but not Foo (which has been shadowed) *)
+;;
+
+exception Foo of int * int option
+;;
+
+exception Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar and part of Foo (which has been shadowed) *)
+;;
+
+(* Test Obj functions *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo
+  | Bar of int
+;;
+
+let extension_name e = Obj.extension_name (Obj.extension_constructor e);;
+let extension_id e = Obj.extension_id (Obj.extension_constructor e);;
+
+let n1 = extension_name Foo
+;;
+
+let n2 = extension_name (Bar 1)
+;;
+
+let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *)
+;;
+
+let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *)
+;;
+
+let is_foo x = (extension_id Foo) = (extension_id x)
+
+type foo += Foo
+;;
+
+let f = is_foo Foo
+;;
+
+let _ = Obj.extension_constructor 7 (* Invald_arg *)
+;;
+
+let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *)
+;;
+(* Typed names *)
+
+module Msg : sig
+
+  type 'a tag
+
+  type result = Result : 'a tag * 'a -> result
+
+  val write : 'a tag -> 'a -> unit
+
+  val read : unit -> result
+
+  type 'a tag += Int : int tag
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) : sig
+    type 'a tag += C : D.t tag
+  end
+
+end = struct
+
+  type 'a tag = ..
+
+  type ktag = T : 'a tag -> ktag
+
+  type 'a kind =
+  { tag : 'a tag;
+    label : string;
+    write : 'a -> string;
+    read : string -> 'a; }
+
+  type rkind = K : 'a kind -> rkind
+
+  type wkind = { f : 'a . 'a tag -> 'a kind }
+
+  let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13
+
+  let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13
+
+  let read_raw () : string * string = raise (Failure "Not implemented")
+
+  type result = Result : 'a tag * 'a -> result
+
+  let read () =
+    let label, content = read_raw () in
+      let K k = Hashtbl.find readTbl label in
+        let body = k.read content in
+          Result(k.tag, body)
+
+  let write_raw (label : string) (content : string) =
+    raise (Failure "Not implemented")
+
+  let write (tag : 'a tag) (body : 'a) =
+    let {f} = Hashtbl.find writeTbl (T tag) in
+    let k = f tag in
+    let content = k.write body in
+      write_raw k.label content
+
+  (* Add int kind *)
+
+  type 'a tag += Int : int tag
+
+  let ik =
+    { tag = Int;
+      label = "int";
+      write = string_of_int;
+      read = int_of_string }
+
+  let () = Hashtbl.add readTbl "int" (K ik)
+
+  let () =
+    let f (type t) (i : t tag) : t kind =
+      match i with
+        Int -> ik
+      | _ -> assert false
+    in
+      Hashtbl.add writeTbl (T Int) {f}
+
+  (* Support user defined kinds *)
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) = struct
+    type 'a tag += C : D.t tag
+    let k =
+      { tag = C;
+        label = D.label;
+        write = D.write;
+        read = D.read }
+    let () = Hashtbl.add readTbl D.label (K k)
+    let () =
+      let f (type t) (c : t tag) : t kind =
+        match c with
+          C -> k
+        | _ -> assert false
+      in
+        Hashtbl.add writeTbl (T C) {f}
+  end
+
+end;;
+
+let write_int i = Msg.write Msg.Int i;;
+
+module StrM = Msg.Define(struct
+  type t = string
+  let label = "string"
+  let read s = s
+  let write s = s
+end);;
+
+type 'a Msg.tag += String = StrM.C;;
+
+let write_string s = Msg.write String s;;
+
+let read_one () =
+  let Msg.Result(tag, body) = Msg.read () in
+  match tag with
+    Msg.Int -> print_int body
+  | String -> print_string body
+  | _ -> print_string "Unknown";;
+(* Example of algorithm parametrized with modules *)
+
+let sort (type s) set l =
+  let module Set = (val set : Set.S with type elt = s) in
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+let make_set (type s) cmp =
+  let module S = Set.Make(struct
+    type t = s
+    let compare = cmp
+  end) in
+  (module S : Set.S with type elt = s)
+
+let both l =
+  List.map
+    (fun set -> sort set l)
+    [ make_set compare; make_set (fun x y -> compare y x) ]
+
+let () =
+  print_endline (String.concat "  " (List.map (String.concat "/")
+                                              (both ["abc";"xyz";"def"])))
+
+
+(* Hiding the internal representation *)
+
+module type S = sig
+  type t
+  val to_string: t -> string
+  val apply: t -> t
+  val x: t
+end
+
+let create (type s) to_string apply x =
+  let module M = struct
+    type t = s
+    let to_string = to_string
+    let apply = apply
+    let x = x
+  end in
+  (module M : S with type t = s)
+
+let forget (type s) x =
+  let module M = (val x : S with type t = s) in
+  (module M : S)
+
+let print x =
+  let module M = (val x : S) in
+  print_endline (M.to_string M.x)
+
+let apply x =
+  let module M = (val x : S) in
+  let module N = struct
+    include M
+    let x = apply x
+  end in
+  (module N : S)
+
+let () =
+  let int = forget (create string_of_int succ 0) in
+  let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in
+  List.iter print (List.map apply [int; apply int; apply (apply str)])
+
+
+(* Existential types + type equality witnesses -> pseudo GADT *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = unit
+  let apply _ = Obj.magic
+  let refl = ()
+  let sym () = ()
+end
+
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = struct
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end
+
+open Typ
+
+let int = Int TypEq.refl
+
+let str = String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  let pair = (module P : PAIR with type t = s1 * s2) in
+  Pair pair
+
+module rec Print : sig
+  val to_string: 'a Typ.typ -> 'a -> string
+end = struct
+  let to_string (type s) t x =
+    match t with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair p ->
+        let module P = (val p : PAIR with type t = s) in
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1)
+                       (Print.to_string P.t2 x2)
+end
+
+let () =
+  print_endline (Print.to_string int 10);
+  print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456)))
+
+
+(* #6262: first-class modules and module type aliases *)
+
+module type S1 = sig end
+module type S2 = S1
+
+let _f (x : (module S1)) : (module S2) = x
+
+module X = struct
+  module type S
+end
+module Y = struct include X end
+
+let _f (x : (module X.S)) : (module Y.S) = x
+
+(* PR#6194, main example *)
+module type S3 = sig val x : bool end;;
+let f = function
+  | Some (module M : S3) when M.x ->1
+  | Some _ [@foooo]-> 2
+  | None -> 3
+;;
+print_endline (string_of_int (f (Some (module struct let x = false end))));;
+type 'a ty =
+  | Int : int ty
+  | Bool : bool ty
+
+let fbool (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+;;
+(* val fbool : 'a -> 'a ty -> 'a = <fun> *)
+(** OK: the return value is x of type t **)
+
+let fint (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+;;
+(* val fint : 'a -> 'a ty -> bool = <fun> *)
+(** OK: the return value is x > 0 of type bool;
+This has used the equation t = bool, not visible in the return type **)
+
+let f (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+  | Bool -> x
+(* val f : 'a -> 'a ty -> bool = <fun> *)
+
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+(* Error: This expression has type bool but an expression was expected of type
+t = int *)
+
+let id x = x;;
+let idb1 = (fun id -> let _ = id true in id) id;;
+let idb2 : bool -> bool = id;;
+let idb3 ( _ : bool ) = false;;
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb3 x
+  | Int -> x > 0
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb2 x
+  | Int -> x > 0
+(* Encoding generics using GADTs *)
+(* (c) Alain Frisch / Lexifi *)
+(* cf. http://www.lexifi.com/blog/dynamic-types *)
+
+(* Basic tag *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+;;
+
+(* Tagging data *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+
+exception VariantMismatch
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | _ -> raise VariantMismatch
+;;
+
+(* Handling records *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: 'a record -> 'a ty
+
+and 'a record =
+    {
+     path: string;
+     fields: 'a field_ list;
+    }
+
+and 'a field_ =
+  | Field: ('a, 'b) field -> 'a field_
+
+and ('a, 'b) field =
+    {
+     label: string;
+     field_type: 'b ty;
+     get: ('a -> 'b);
+    }
+;;
+
+(* Again *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+    | Record {fields} ->
+        VRecord
+          (List.map (fun (Field{field_type; label; get}) ->
+                       (label, variantize field_type (get x))) fields)
+;;
+
+(* Extraction *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: ('a, 'builder) record -> 'a ty
+
+and ('a, 'builder) record =
+    {
+     path: string;
+     fields: ('a, 'builder) field list;
+     create_builder: (unit -> 'builder);
+     of_builder: ('builder -> 'a);
+    }
+
+and ('a, 'builder) field =
+  | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+
+and ('a, 'builder, 'b) field_ =
+  {
+   label: string;
+   field_type: 'b ty;
+   get: ('a -> 'b);
+   set: ('builder -> 'b -> unit);
+  }
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | Record {fields; create_builder; of_builder}, VRecord fl ->
+        if List.length fields <> List.length fl then raise VariantMismatch;
+        let builder = create_builder () in
+        List.iter2
+          (fun (Field {label; field_type; set}) (lab, v) ->
+            if label <> lab then raise VariantMismatch;
+            set builder (devariantize field_type v)
+          )
+          fields fl;
+        of_builder builder
+    | _ -> raise VariantMismatch
+;;
+
+type my_record  =
+    {
+     a: int;
+     b: string list;
+    }
+
+let my_record =
+  let fields =
+    [
+     Field {label = "a"; field_type = Int;
+            get = (fun {a} -> a);
+            set = (fun (r, _) x -> r := Some x)};
+     Field {label = "b"; field_type = List String;
+            get = (fun {b} -> b);
+            set = (fun (_, r) x -> r := Some x)};
+    ]
+  in
+  let create_builder () = (ref None, ref None) in
+  let of_builder (a, b) =
+    match !a, !b with
+    | Some a, Some b -> {a; b}
+    | _ -> failwith "Some fields are missing in record of type my_record"
+  in
+  Record {path = "My_module.my_record"; fields; create_builder; of_builder}
+;;
+
+(* Extension to recursive types and polymorphic variants *)
+(* by Jacques Garrigue *)
+
+type noarg = Noarg
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  (* Support for type variables and recursive types *)
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  (* Change the representation of a type *)
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  (* Sum types (both normal sums and polymorphic variants) *)
+  | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+
+and ('a, 'e, 'b) ty_sum =
+    { sum_proj: 'a -> string * 'e ty_dyn option;
+      sum_cases: (string * ('e,'b) ty_case) list;
+      sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; }
+
+and 'e ty_dyn =              (* dynamic type *)
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =           (* selector from a list of types *)
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =          (* type a sum case *)
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+type _ ty_env =              (* type variable substitution *)
+  | Enil : unit ty_env
+  | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+;;
+
+(* Comparing selectors *)
+type (_,_) eq = Eq: ('a,'a) eq
+
+let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
+  fun s1 s2 ->
+    match s1, s2 with
+    | Thd, Thd -> Some Eq
+    | Ttl s1, Ttl s2 ->
+        (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
+    | _ -> None
+
+(* Auxiliary function to get the type of a case from its selector *)
+let rec get_case : type a b e.
+  (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option =
+  fun sel cases ->
+  match cases with
+  | (name, TCnoarg sel') :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, None
+      end
+  | (name, TCarg (sel', ty)) :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, Some ty
+      end
+  | [] -> raise Not_found
+;;
+
+(* Untyped representation of values *)
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+
+let may_map f = function Some x -> Some (f x) | None -> None
+
+let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
+  fun e ty v ->
+  match ty with
+  | Int -> VInt v
+  | String -> VString v
+  | List t -> VList (List.map (variantize e t) v)
+  | Option t -> VOption (may_map (variantize e t) v)
+  | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v))
+  | Rec t -> variantize (Econs (ty, e)) t v
+  | Pop t -> (match e with Econs (_, e') -> variantize e' t v)
+  | Var -> (match e with Econs (t, e') -> variantize e' t v)
+  | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v))
+  | Sum ops ->
+      let tag, arg = ops.sum_proj v in
+      VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
+;;
+
+let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
+  fun e ty v ->
+  match ty, v with
+  | Int, VInt x -> x
+  | String, VString x -> x
+  | List ty1, VList vl ->
+      List.map (devariantize e ty1) vl
+  | Pair (ty1, ty2), VPair (x1, x2) ->
+      (devariantize e ty1 x1, devariantize e ty2 x2)
+  | Rec t, _ -> devariantize (Econs (ty, e)) t v
+  | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v)
+  | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v)
+  | Conv (s, proj, inj, t), VConv (s', v) when s = s' ->
+      inj (devariantize e t v)
+  | Sum ops, VSum (tag, a) ->
+      begin try match List.assoc tag ops.sum_cases, a with
+      | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a)
+      | TCnoarg sel, None -> ops.sum_inj (sel, Noarg)
+      | _ -> raise VariantMismatch
+      with Not_found -> raise VariantMismatch
+      end
+  | _ -> raise VariantMismatch
+;;
+
+(* First attempt: represent 1-constructor variants using Conv *)
+let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+
+let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+let v = variantize Enil (ty Int);;
+let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+
+(* Can also use it to decompose a tuple *)
+
+let triple t1 t2 t3 =
+  Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+
+let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+
+(* Second attempt: introduce a real sum construct *)
+let ty_abc =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  let proj = function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None
+  (* Define inj in advance to be able to write the type annotation easily *)
+  and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c ->
+    [`A of int | `B of string | `C] = function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  in
+  (* Coherence of sum_inj and sum_cases is checked by the typing *)
+  Sum { sum_proj = proj; sum_inj = inj; sum_cases =
+        [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+          "C", TCnoarg (Ttl (Ttl Thd)) ] }
+;;
+
+let v = variantize Enil ty_abc (`A 3)
+let a = devariantize Enil ty_abc v
+
+(* And an example with recursion... *)
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum {
+       sum_proj = (function
+           `Nil -> "Nil", None
+         | `Cons p -> "Cons", Some (Tdyn (tcons, p)));
+       sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)];
+       sum_inj = fun (type c) ->
+         (function
+         | Thd, Noarg -> `Nil
+         | Ttl Thd, v -> `Cons v
+         : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
+         (* One can also write the type annotation directly *)
+     })
+
+let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
+
+
+(* Simpler but weaker approach *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a)
+             -> ('a, 'e) ty
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+let ty_abc : ([`A of int | `B of string | `C],'e) ty =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  Sum (
+  (function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None),
+  (function
+      "A", Some (Tdyn (Int, n)) -> `A n
+    | "B", Some (Tdyn (String, s)) -> `B s
+    | "C", None -> `C
+    | _ -> invalid_arg "ty_abc"))
+;;
+
+(* Breaks: no way to pattern-match on a full recursive type *)
+let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
+  let targ = Pair (Pop t, Var) in
+  Rec (Sum (
+  (function `Nil -> "Nil", None
+    | `Cons p -> "Cons", Some (Tdyn (targ, p))),
+  (function "Nil", None -> `Nil
+    | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+;;
+
+(* Define Sum using object instead of record for first-class polymorphism *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: < proj: 'a -> string * 'e ty_dyn option;
+           cases: (string * ('e,'b) ty_case) list;
+           inj: 'c. ('b,'c) ty_sel * 'c -> 'a >
+          -> ('a, 'e) ty
+
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
+  Sum (object
+    method proj = function
+        `A n -> "A", Some (Tdyn (Int, n))
+      | `B s -> "B", Some (Tdyn (String, s))
+      | `C -> "C", None
+    method cases =
+      [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+        "C", TCnoarg (Ttl (Ttl Thd)) ];
+    method inj : type c.
+        (int -> string -> noarg -> unit, c) ty_sel * c ->
+          [`A of int | `B of string | `C] =
+      function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  end)
+
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum (object
+    method proj = function
+        `Nil -> "Nil", None
+      | `Cons p -> "Cons", Some (Tdyn (tcons, p))
+    method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]
+    method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist
+    = function
+      | Thd, Noarg -> `Nil
+      | Ttl Thd, v -> `Cons v
+  end))
+;;
+
+(*
+type (_,_) ty_assoc =
+  | Anil : (unit,'e) ty_assoc
+  | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc
+
+and (_,_) ty_pvar =
+  | Pnil : ('a,'e) ty_pvar
+  | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar
+  | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar
+*)
+(*
+   An attempt at encoding omega examples from the 2nd Central European
+   Functional Programming School:
+     Generic Programming in Omega, by Tim Sheard and Nathan Linger
+          http://web.cecs.pdx.edu/~sheard/
+*)
+
+(* Basic types *)
+
+type ('a,'b) sum = Inl of 'a | Inr of 'b
+
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+;;
+
+(* 2: A simple example *)
+
+type (_,_) seq =
+  | Snil  : ('a,zero) seq
+  | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq
+;;
+
+let l1 = Scons (3, Scons (5, Snil)) ;;
+
+(* We do not have type level functions, so we need to use witnesses. *)
+(* We copy here the definitions from section 3.9 *)
+(* Note the addition of the ['a nat] argument to PlusZ, since we do not
+   have kinds *)
+type (_,_,_) plus =
+  | PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus
+;;
+
+let rec length : type a n. (a,n) seq -> n nat = function
+  | Snil -> NZ
+  | Scons (_, s) -> NS (length s)
+;;
+
+(* app returns the catenated lists with a witness proving that
+   the size is the sum of its two inputs *)
+type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app
+
+let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
+  fun xs ys ->
+  match xs with
+  | Snil -> App (ys, PlusZ (length ys))
+  | Scons (x, xs') ->
+      let App (xs'', pl) = app xs' ys in
+      App (Scons (x, xs''), PlusS pl)
+;;
+
+(* 3.1 Feature: kinds *)
+
+(* We do not have kinds, but we can encode them as predicates *)
+
+type tp = TP
+type nd = ND
+type ('a,'b) fk = FK
+type _ shape =
+  | Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
+;;
+type tt = TT
+type ff = FF
+type _ boolean =
+  | BT : tt boolean
+  | BF : ff boolean
+;;
+
+(* 3.3 Feature : GADTs *)
+
+type (_,_) path =
+  | Pnone : 'a -> (tp,'a) path
+  | Phere : (nd,'a) path
+  | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path
+  | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path
+;;
+type (_,_) tree =
+  | Ttip  : (tp,'a) tree
+  | Tnode : 'a -> (nd,'a) tree
+  | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree
+;;
+let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+;;
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
+  = fun eq n t ->
+    match t with
+    | Ttip -> []
+    | Tnode m ->
+        if eq n m then [Phere] else []
+    | Tfork (x, y) ->
+        List.map (fun x -> Pleft x) (find eq n x) @
+        List.map (fun x -> Pright x) (find eq n y)
+;;
+let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
+  match (p, t) with
+  | Pnone x, Ttip -> x
+  | Phere, Tnode y -> y
+  | Pleft p, Tfork(l,_) -> extract p l
+  | Pright p, Tfork(_,r) -> extract p r
+;;
+
+(* 3.4 Pattern : Witness *)
+
+type (_,_) le =
+  | LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+;;
+type _ even =
+  | EvenZ : zero even
+  | EvenSS : 'n even -> 'n succ succ even
+;;
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+;;
+let even0 : zero even = EvenZ
+let even2 : two even = EvenSS EvenZ
+let even4 : four even = EvenSS (EvenSS EvenZ)
+;;
+let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+;;
+let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
+  match p with
+  | PlusZ n -> LeZ n
+  | PlusS p' -> LeS (summandLessThanSum p')
+;;
+
+(* 3.8 Pattern: Leibniz Equality *)
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+
+let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
+  match a, b with
+  | NZ, NZ -> Some Eq
+  | NS a', NS b' ->
+      begin match sameNat a' b' with
+      | Some Eq -> Some Eq
+      | None -> None
+      end
+  | _ -> None
+;;
+
+(* Extra: associativity of addition *)
+
+let rec plus_func : type a b m n.
+  (a,b,m) plus -> (a,b,n) plus -> (m,n) equal =
+  fun p1 p2 ->
+  match p1, p2 with
+  | PlusZ _, PlusZ _ -> Eq
+  | PlusS p1', PlusS p2' ->
+      let Eq = plus_func p1' p2' in Eq
+
+let rec plus_assoc : type a b c ab bc m n.
+  (a,b,ab) plus -> (ab,c,m) plus ->
+  (b,c,bc) plus -> (a,bc,n) plus -> (m,n) equal = fun p1 p2 p3 p4 ->
+  match p1, p4 with
+  | PlusZ b, PlusZ bc ->
+      let Eq = plus_func p2 p3 in Eq
+  | PlusS p1', PlusS p4' ->
+      let PlusS p2' = p2 in
+      let Eq = plus_assoc p1' p2' p3 p4' in Eq
+;;
+
+(* 3.9 Computing Programs and Properties Simultaneously *)
+
+(* Plus and app1 are moved to section 2 *)
+
+let smaller : type a b. (a succ, b succ) le -> (a,b) le =
+  function LeS x -> x ;;
+
+type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
+
+(*
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b, le with
+  | NZ, m, _ -> Diff (m, PlusZ m)
+  | NS x, NZ, _ -> assert false
+  | NS x, NS y, q ->
+      match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+*)
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match le, a, b with
+  | LeZ _, _, m -> Diff (m, PlusZ m)
+  | LeS q, NS x, NS y ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b,le with (* warning *)
+  | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+  | NS x, NS y, LeS q ->
+      (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
+  | _ -> .
+;;
+
+let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
+  fun le b ->
+  match b,le with
+  | m, LeZ _ -> Diff (m, PlusZ m)
+  | NS y, LeS q ->
+      match diff q y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
+
+let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
+  | LeZ n -> LeZ (NS n)
+  | LeS le -> LeS (leS' le)
+;;
+
+let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
+  fun f s ->
+  match s with
+  | Snil -> Filter (LeZ NZ, Snil)
+  | Scons (a,l) ->
+      match filter f l with Filter (le, l') ->
+        if f a then Filter (LeS le, Scons (a, l'))
+        else Filter (leS' le, l')
+;;
+
+(* 4.1 AVL trees *)
+
+type (_,_,_) balance =
+  | Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+
+type _ avl =
+  | Leaf : zero avl
+  | Node :
+      ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl
+
+type avl' = Avl : 'h avl -> avl'
+;;
+
+let empty = Avl Leaf
+
+let rec elem : type h. int -> h avl -> bool = fun x t ->
+  match t with
+  | Leaf -> false
+  | Node (_, l, y, r) ->
+      x = y || if x < y then elem x l else elem x r
+;;
+
+let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL y tR ->
+  match tL with
+  | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR)))
+  | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR)))
+  | Node (Less, a, x, Node (Same, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (Less, b, z, c)) ->
+      Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (More, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
+;;
+let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL u tR ->
+  match tR with
+  | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b))
+  | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b))
+  | Node (More, Node (Same, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (Less, a, x, b), y, c) ->
+      Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (More, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
+;;
+let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
+  fun x t ->
+  match t with
+  | Leaf -> Inr (Node (Same, Leaf, x, Leaf))
+  | Node (bal, a, y, b) ->
+      if x = y then Inl t else
+      if x < y then begin
+        match ins x a with
+        | Inl a -> Inl (Node (bal, a, y, b))
+        | Inr a ->
+            match bal with
+            | Less -> Inl (Node (Same, a, y, b))
+            | Same -> Inr (Node (More, a, y, b))
+            | More -> rotr a y b
+      end else begin
+        match ins x b with
+        | Inl b -> Inl (Node (bal, a, y, b) : n avl)
+        | Inr b ->
+            match bal with
+            | More -> Inl (Node (Same, a, y, b) : n avl)
+            | Same -> Inr (Node (Less, a, y, b) : n succ avl)
+            | Less -> rotl a y b
+      end
+;;
+
+let insert x (Avl t) =
+  match ins x t with
+  | Inl t -> Avl t
+  | Inr t -> Avl t
+;;
+
+let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
+  function
+  | Node (Less, Leaf, x, r) -> (x, Inl r)
+  | Node (Same, Leaf, x, r) -> (x, Inl r)
+  | Node (bal, (Node _ as l) , x, r) ->
+      match del_min l with
+      | y, Inr l -> (y, Inr (Node (bal, l, x, r)))
+      | y, Inl l ->
+          (y, match bal with
+          | Same -> Inr (Node (Less, l, x, r))
+          | More -> Inl (Node (Same, l, x, r))
+          | Less -> rotl l x r)
+
+type _ avl_del =
+  | Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+
+let rec del : type n. int -> n avl -> n avl_del = fun y t ->
+  match t with
+  | Leaf -> Dsame Leaf
+  | Node (bal, l, x, r) ->
+      if x = y then begin
+        match r with
+        | Leaf ->
+            begin match bal with
+            | Same -> Ddecr (Eq, l)
+            | More -> Ddecr (Eq, l)
+            end
+        | Node _ ->
+            begin match bal, del_min r with
+            | _, (z, Inr r) -> Dsame (Node (bal, l, z, r))
+            | Same, (z, Inl r) -> Dsame (Node (More, l, z, r))
+            | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r))
+            | More, (z, Inl r) ->
+                match rotr l z r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else if y < x then begin
+        match del y l with
+        | Dsame l -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,l) ->
+            begin match bal with
+            | Same -> Dsame (Node (Less, l, x, r))
+            | More -> Ddecr (Eq, Node (Same, l, x, r))
+            | Less ->
+                match rotl l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else begin
+        match del y r with
+        | Dsame r -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,r) ->
+            begin match bal with
+            | Same -> Dsame (Node (More, l, x, r))
+            | Less -> Ddecr (Eq, Node (Same, l, x, r))
+            | More ->
+                match rotr l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end
+;;
+
+let delete x (Avl t) =
+  match del x t with
+  | Dsame t -> Avl t
+  | Ddecr (_, t) -> Avl t
+;;
+
+
+(* Exercise 22: Red-black trees *)
+
+type red = RED
+type black = BLACK
+type (_,_) sub_tree =
+  | Bleaf : (black, zero) sub_tree
+  | Rnode :
+      (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode :
+      ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+;;
+
+type dir = LeftD | RightD
+
+type (_,_) ctxt =
+  | CNil : (black,'n) ctxt
+  | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt
+  | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt
+;;
+
+let blacken = function
+    Rnode (l, e, r) -> Bnode (l, e, r)
+
+type _ crep =
+  | Red : red crep
+  | Black : black crep
+
+let color : type c n. (c,n) sub_tree -> c crep = function
+  | Bleaf -> Black
+  | Rnode _ -> Red
+  | Bnode _ -> Black
+;;
+
+let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
+  fun ct t ->
+  match ct with
+  | CNil -> Root t
+  | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t))
+  | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle))
+  | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
+  | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
+;;
+let recolor d1 pE sib d2 gE uncle t =
+  match d1, d2 with
+  | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
+  | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle)
+  | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
+  | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
+;;
+let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
+  match d1, d2 with
+  | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
+  | LeftD,  RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle))
+  | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
+  | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
+;;
+let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun t ct ->
+  match ct with
+  | CNil -> Root (blacken t)
+  | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t))
+  | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib))
+  | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) ->
+      match color uncle with
+      | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
+      | Black -> fill ct (rotate dir e sib dir' e' uncle t)
+;;
+let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun e t ct ->
+  match t with
+  | Rnode (l, e', r) ->
+      if e < e' then ins e l (CRed (e', RightD, r, ct))
+                else ins e r (CRed (e', LeftD, l, ct))
+  | Bnode (l, e', r) ->
+      if e < e' then ins e l (CBlk (e', RightD, r, ct))
+                else ins e r (CBlk (e', LeftD, l, ct))
+  | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
+;;
+let insert e (Root t) = ins e t CNil
+;;
+
+(* 5.7 typed object languages using GADTs *)
+
+type _ term =
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let ex1 = Ap (Add, Pair (Const 3, Const 5))
+let ex2 = Pair (ex1, Const 1)
+
+let rec eval_term : type a. a term -> a = function
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x<y
+  | Ap(f,x) -> eval_term f (eval_term x)
+  | Pair(x,y) -> (eval_term x, eval_term y)
+
+type _ rep =
+  | Rint  : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun  : 'a rep * 'b rep -> ('a -> 'b) rep
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
+  fun ra rb ->
+  match ra, rb with
+  | Rint, Rint -> Some Eq
+  | Rbool, Rbool -> Some Eq
+  | Rpair (a1, a2), Rpair (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | Rfun (a1, a2), Rfun (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | _ -> None
+;;
+
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+
+let rec assoc : type a. string -> a rep -> assoc list -> a =
+  fun x r -> function
+  | [] -> raise Not_found
+  | Assoc (x', r', v) :: env ->
+      if x = x' then
+        match rep_equal r r' with
+        | None -> failwith ("Wrong type for " ^ x)
+        | Some Eq -> v
+      else assoc x r env
+
+type _ term =
+  | Var   : string * 'a rep -> 'a term
+  | Abs   : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let rec eval_term : type a. assoc list -> a term -> a =
+  fun env -> function
+  | Var (x, r) -> assoc x r env
+  | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x<y
+  | Ap(f,x) -> eval_term env f (eval_term env x)
+  | Pair(x,y) -> (eval_term env x, eval_term env y)
+;;
+
+let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
+let ex4 = Ap (ex3, Const 3)
+
+let v4 = eval_term [] ex4
+;;
+
+(* 5.9/5.10 Language with binding *)
+
+type rnil = RNIL
+type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
+
+type _ is_row =
+  | Rnil  : rnil is_row
+  | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row
+
+type (_,_) lam =
+  | Const : int -> ('e, int) lam
+  | Var : 'a -> (('a,'t,'e) rcons, 't) lam
+  | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam
+  | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+
+type x = X
+type y = Y
+
+let ex1 = App (Var X, Shift (Var Y))
+let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
+;;
+
+type _ env =
+  | Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+
+let rec eval_lam : type e t. e env -> (e, t) lam -> t =
+  fun env m ->
+  match env, m with
+  | _, Const n -> n
+  | Econs (_, v, r), Var _ -> v
+  | Econs (_, _, r), Shift e -> eval_lam r e
+  | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
+  | _, App (f, x)    -> eval_lam env f (eval_lam env x)
+;;
+
+type add = Add
+type suc = Suc
+
+let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil)))
+
+let _0 : (_, int) lam = Var Zero
+let suc x = App (Shift (Var Suc : (_, int -> int) lam), x)
+let _1 = suc _0
+let _2 = suc _1
+let _3 = suc _2
+let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
+
+let double = Abs (X, App (App (Shift add, Var X), Var X))
+let ex3 = App (double, _3)
+;;
+
+let v3 = eval_lam env0 ex3
+;;
+
+(* 5.13: Constructing typing derivations at runtime *)
+
+(* Modified slightly to use the language of 5.10, since this is more fun.
+   Of course this works also with the language of 5.12. *)
+
+type _ rep =
+  | I : int rep
+  | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+
+let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
+  fun a b ->
+  match a, b with
+  | I, I -> Inr Eq
+  | Ar(x,y), Ar(s,t) ->
+      begin match compare x s with
+      | Inl _ as e -> e
+      | Inr Eq -> match compare y t with
+        | Inl _ as e -> e
+        | Inr Eq as e -> e
+      end
+  | I, Ar _ -> Inl "I <> Ar _"
+  | Ar _, I -> Inl "Ar _ <> I"
+;;
+
+type term =
+  | C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+
+type _ ctx =
+  | Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx
+;;
+
+type _ checked =
+  | Cerror of string
+  | Cok : ('e,'t) lam * 't rep -> 'e checked
+
+let rec lookup : type e. string -> e ctx -> e checked =
+  fun name ctx ->
+  match ctx with
+  | Cnil -> Cerror ("Name not found: " ^ name)
+  | Ccons (l,s,t,rs) ->
+      if s = name then Cok (Var l,t) else
+      match lookup name rs with
+      | Cerror m -> Cerror m
+      | Cok (v, t) -> Cok (Shift v, t)
+;;
+
+let rec tc : type n e. n nat -> e ctx -> term -> e checked =
+  fun n ctx t ->
+  match t with
+  | V s -> lookup s ctx
+  | Ap(f,x) ->
+      begin match tc n ctx f with
+      | Cerror _ as e -> e
+      | Cok (f', ft) -> match tc n ctx x with
+        | Cerror _ as e -> e
+        | Cok (x', xt) ->
+            match ft with
+            | Ar (a, b) ->
+                begin match compare a xt with
+                | Inl s -> Cerror s
+                | Inr Eq -> Cok (App (f',x'), b)
+                end
+            | _ -> Cerror "Non fun in Ap"
+      end
+  | Ab(s,t,body) ->
+      begin match tc (NS n) (Ccons (n, s, t, ctx)) body with
+      | Cerror _ as e -> e
+      | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))
+      end
+  | C m -> Cok (Const m, I)
+;;
+
+let ctx0 =
+  Ccons (Zero, "0", I,
+         Ccons (Suc, "S", Ar(I,I),
+                Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil)))
+
+let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
+let c1 = tc NZ ctx0 ex1;;
+let ex2 = Ap (ex1, C 3);;
+let c2 = tc NZ ctx0 ex2;;
+
+let eval_checked env = function
+  | Cerror s -> failwith s
+  | Cok (e, I) -> (eval_lam env e : int)
+  | Cok _ -> failwith "Can only evaluate expressions of type I"
+;;
+
+let v2 = eval_checked env0 c2 ;;
+
+(* 5.12 Soundness *)
+
+type pexp = PEXP
+type pval = PVAL
+type _ mode =
+  | Pexp : pexp mode
+  | Pval : pval mode
+
+type ('a,'b) tarr = TARR
+type tint = TINT
+
+type (_,_) rel =
+  | IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+
+type (_,_,_) lam =
+  | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam
+  | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam
+  | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam
+  | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+;;
+
+let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+
+let rec mode : type m e t. (m,e,t) lam -> m mode = function
+  | Lam (v, body) -> Pval
+  | Var v -> Pval
+  | Const (r, v) -> Pval
+  | Shift e -> mode e
+  | App _ -> Pexp
+;;
+
+type (_,_) sub =
+  | Id : ('r,'r) sub
+  | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub
+  | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub
+
+type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam'
+;;
+
+let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
+  fun t s ->
+  match t, s with
+  | _, Id -> Ex t
+  | Const(r,c), sub -> Ex (Const (r,c))
+  | Var v, Bind (x, e, r) -> Ex e
+  | Var v, Push sub -> Ex (Var v)
+  | Shift e, Bind (_, _, r) -> subst e r
+  | Shift e, Push sub ->
+      (match subst e sub with Ex a -> Ex (Shift a))
+  | App(f,x), sub ->
+      (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y)))
+  | Lam(v,x), sub ->
+      (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
+;;
+
+type closed = rnil
+
+type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;;
+
+let rec rule : type a b.
+  (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam =
+  fun v1 v2 ->
+  match v1, v2 with
+  | Lam(x,body), v ->
+      begin
+        match subst body (Bind (x, v, Id)) with Ex term ->
+        match mode term with
+        | Pexp -> Inl term
+        | Pval -> Inr term
+      end
+  | Const (IntTo b, f), Const (IntR, x) ->
+      Inr (Const (b, f x))
+;;
+let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
+  | Lam (v, body) -> Inr (Lam (v, body))
+  | Const (r, v)  -> Inr (Const (r, v))
+  | App (e1, e2) ->
+      match mode e1, mode e2 with
+      | Pexp, _->
+          begin match onestep e1 with
+          | Inl e -> Inl(App(e,e2))
+          | Inr v -> Inl(App(v,e2))
+          end
+      | Pval, Pexp ->
+          begin match onestep e2 with
+          | Inl e -> Inl(App(e1,e))
+          | Inr v -> Inl(App(e1,v))
+          end
+      | Pval, Pval -> rule e1 e2
+;;
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+   | _ -> .   (* error *)
+;;
+(* let x = f Tint (Tvar Zero) ;; *)
+type inkind = [ `Link | `Nonlink ]
+
+type _ inline_t =
+   | Text: string -> [< inkind > `Nonlink ] inline_t
+   | Bold: 'a inline_t list -> 'a inline_t
+   | Link: string -> [< inkind > `Link ] inline_t
+   | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+;;
+
+let uppercase seq =
+   let rec process: type a. a inline_t -> a inline_t = function
+       | Text txt       -> Text (String.uppercase_ascii txt)
+       | Bold xs        -> Bold (List.map process xs)
+       | Link lnk       -> Link lnk
+       | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
+   in List.map process seq
+;;
+
+type ast_t =
+   | Ast_Text of string
+   | Ast_Bold of ast_t list
+   | Ast_Link of string
+   | Ast_Mref of string * ast_t list
+;;
+
+let inlineseq_from_astseq seq =
+   let rec process_nonlink = function
+       | Ast_Text txt  -> Text txt
+       | Ast_Bold xs   -> Bold (List.map process_nonlink xs)
+       | _             -> assert false in
+   let rec process_any = function
+       | Ast_Text txt       -> Text txt
+       | Ast_Bold xs        -> Bold (List.map process_any xs)
+       | Ast_Link lnk       -> Link lnk
+       | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
+   in List.map process_any seq
+;;
+
+(* OK *)
+type _ linkp =
+ | Nonlink : [ `Nonlink ] linkp
+ | Maylink : inkind linkp
+;;
+let inlineseq_from_astseq seq =
+ let rec process : type a. a linkp -> ast_t -> a inline_t =
+   fun allow_link ast ->
+     match (allow_link, ast) with
+     | (Maylink, Ast_Text txt)    -> Text txt
+     | (Nonlink, Ast_Text txt)    -> Text txt
+     | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+     | (Maylink, Ast_Link lnk)    -> Link lnk
+     | (Nonlink, Ast_Link _)      -> assert false
+     | (Maylink, Ast_Mref (lnk, xs)) ->
+         Mref (lnk, List.map (process Nonlink) xs)
+     | (Nonlink, Ast_Mref _)      -> assert false
+   in List.map (process Maylink) seq
+;;
+
+(* Bad *)
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+;;
+let inlineseq_from_astseq seq =
+let rec process : type a. a linkp2 -> ast_t -> a inline_t =
+  fun allow_link ast ->
+    match (allow_link, ast) with
+    | (Kind _, Ast_Text txt)    -> Text txt
+    | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+    | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+    | (Kind Nonlink, Ast_Link _)      -> assert false
+    | (Kind Maylink, Ast_Mref (lnk, xs)) ->
+        Mref (lnk, List.map (process (Kind Nonlink)) xs)
+    | (Kind Nonlink, Ast_Mref _)      -> assert false
+  in List.map (process (Kind Maylink)) seq
+;;
+module Add (T : sig type two end) =
+struct
+  type _ t =
+  | One : [`One] t
+  | Two : T.two t
+
+  let add (type a) : a t * a t -> string = function
+    | One, One -> "two"
+    | Two, Two -> "four"
+end;;
+module B : sig
+ type (_, _) t = Eq: ('a, 'a) t
+ val f: 'a -> 'b -> ('a, 'b) t
+end
+=
+struct
+ type (_, _) t = Eq: ('a, 'a) t
+ let f t1 t2 = Obj.magic Eq
+end;;
+
+let of_type: type a. a -> a = fun x ->
+  match B.f x 4 with
+  | Eq -> 5
+;;
+type _ constant =
+  | Int: int -> int constant
+  | Bool: bool -> bool constant
+
+type (_, _, _) binop =
+  | Eq: ('a, 'a, bool) binop
+  | Leq: ('a, 'a, bool) binop
+  | Add: (int, int, int) binop
+
+let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant)
+         (y:b constant) : c constant =
+  match bop, x, y with
+  | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+  | Leq, Int x, Int y -> Bool (x <= y)
+  | Leq, Bool x, Bool y -> Bool (x <= y)
+  | Add, Int x, Int y -> Int (x + y)
+
+let _ = eval Eq (Int 2) (Int 3)
+type tag = [`TagA | `TagB | `TagC];;
+
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int] poly
+(* constraint 'a = [< `TagA of int | `TagB] *)
+;;
+
+let intA = function `TagA i -> i
+let intB = function `TagB -> 4
+;;
+
+let intAorB = function
+    `TagA i -> i
+  | `TagB -> 4
+;;
+
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly
+;;
+
+let example6 : type a. a wrapPoly -> (a -> int) =
+  fun w  ->
+    match w with
+    | WrapPoly ATag -> intA
+    | WrapPoly _ -> intA (* This should not be allowed *)
+;;
+
+let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+;;
+module F(S : sig type 'a t end) = struct
+  type _ ab =
+      A : int S.t ab
+    | B : float S.t ab
+
+  let f : int S.t ab -> float S.t ab -> string =
+    fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
+    | A, B -> "f A B"
+end;;
+
+module F(S : sig type 'a t end) = struct
+  type a = int * int
+  type b = int -> int
+
+  type _ ab =
+      A : a S.t ab
+    | B : b S.t ab
+
+  let f : a S.t ab -> b S.t ab -> string =
+    fun l r -> match l, r with
+    | A, B -> "f A B"
+end;;
+type (_, _) t =
+    Any : ('a, 'b) t
+  | Eq : ('a, 'a) t
+;;
+
+module M :
+sig
+  type s = private [> `A]
+  val eq : (s, [`A | `B]) t
+end =
+struct
+  type s = [`A | `B]
+  let eq = Eq
+end;;
+
+let f : (M.s, [`A | `B]) t -> string = function
+  | Any -> "Any"
+;;
+
+let () = print_endline (f M.eq) ;;
+
+module N :
+sig
+  type s = private < a : int; .. >
+  val eq : (s, <a : int; b : bool>) t
+end =
+struct
+  type s = <a : int; b : bool>
+  let eq = Eq
+end
+;;
+
+let f : (N.s, <a : int; b : bool>) t -> string = function
+  | Any -> "Any"
+;;
+type (_, _) comp =
+  | Eq : ('a, 'a) comp
+  | Diff : ('a, 'b) comp
+;;
+
+module U = struct type t = T end;;
+
+module M : sig
+  type t = T
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+
+module U = struct type t = {x : int} end;;
+
+module M : sig
+  type t = {x : int}
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+type 'a t = T of 'a
+type 'a s = S of 'a
+
+type (_, _) eq = Refl : ('a, 'a) eq;;
+
+let f : (int s, int t) eq -> unit = function Refl -> ();;
+
+module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
+struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+type _ nat =
+    Zero : [`Zero] nat
+  | Succ : 'a nat -> [`Succ of 'a] nat;;
+type 'a pre_nat = [`Zero | `Succ of 'a];;
+type aux =
+  | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;;
+
+let f (Aux x) =
+  match x with
+  | Succ Zero -> "1"
+  | Succ (Succ Zero) -> "2"
+  | Succ (Succ (Succ Zero)) -> "3"
+  | Succ (Succ (Succ (Succ Zero))) -> "4"
+  | _ -> .  (* error *)
+;;
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+type (_, _) t =
+ A : ('a, 'a) t
+| B : string -> ('a, 'b) t
+;;
+
+module M (A : sig module type T end) (B : sig module type T end) =
+struct
+ let f : ((module A.T), (module B.T)) t -> string = function
+   | B s -> s
+end;;
+
+module A = struct module type T = sig end end;;
+
+module N = M(A)(A);;
+
+let x = N.f A;;
+type 'a visit_action
+
+type insert
+
+type 'a local_visit_action
+
+type ('a, 'result, 'visit_action) context =
+  | Local : ('a, ('a * insert) as 'result, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+;;
+
+let vexpr (type visit_action)
+    : (_, _, visit_action) context -> _ -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+
+let vexpr (type visit_action)
+    : ('a, 'result, visit_action) context -> 'a -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+
+let vexpr (type result) (type visit_action)
+    : (unit, result, visit_action) context -> unit -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+module A = struct
+    type nil = Cstr
+  end
+open A
+;;
+
+type _ s =
+  | Nil : nil s
+  | Cons : 't s -> ('h -> 't) s
+
+type ('stack, 'typ) var =
+  | Head : (('typ -> _) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> ((_ -> 'tail) s, 'typ) var
+
+type _ lst =
+  | CNil : nil lst
+  | CCons : 'h * ('t lst) -> ('h -> 't) lst
+;;
+
+let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s ->
+  match n, s with
+  | Head, CCons (h, _) -> h
+  | Tail n', CCons (_, t) -> get_var n' t
+;;
+type 'a t = [< `Foo | `Bar] as 'a;;
+type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a;;
+
+type 'a first = First : 'a second -> ('b t as 'a) first
+and 'a second = Second : ('b s as 'a) second;;
+
+type aux = Aux : 'a t second * ('a -> int) -> aux;;
+
+let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
+
+let g (Aux(Second, f)) = f it;;
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
+
+module rec A :  sig type t = B.t list end =
+  struct type t = B.t list end
+and B : sig  type t val eq : (B.t list, t) eqp end =
+  struct
+    type t = A.t
+    let eq = Y
+  end;;
+
+f B.eq;;
+type (_, _) t =
+  | Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
+
+let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+
+let get1' = function
+  | (Cons (x, _) : (_ * 'a, 'a) t) -> x
+  | Nil -> assert false ;; (* ok *)
+type _ t =
+  Int : int -> int t | String : string -> string t | Same : 'l t -> 'l t;;
+let rec f = function Int x -> x | Same s -> f s;;
+type 'a tt = 'a t =
+  Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt;;
+type _ t = I : int t;;
+
+let f (type a) (x : a t) =
+  let module M = struct
+    let (I : a t) = x     (* fail because of toplevel let *)
+    let x = (I : a t)
+  end in
+  () ;;
+
+(* extra example by Stephen Dolan, using recursive modules *)
+(* Should not be allowed! *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+
+let bad (type a) =
+ let module N = struct
+   module rec M : sig
+     val e : (int, a) eq
+   end = struct
+     let (Refl : (int, a) eq) = M.e  (* must fail for soundness *)
+     let e : (int, a) eq = Refl
+   end
+ end in N.M.e
+;;
+type +'a n = private int
+type nil = private Nil_type
+type (_,_) elt =
+  | Elt_fine: 'nat n -> ('l,'nat * 'l) elt
+  | Elt: 'nat n -> ('l,'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t;;
+
+let undetected: ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j ->
+  let Cons(Elt dim, _) = sh in ()
+;;
+type _ t = T : int t;;
+
+(* Should raise Not_found *)
+let _ = match (raise Not_found : float t) with _ -> .;;
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
+type 'a t;;
+let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
+
+module F (T : sig type _ t end) = struct
+ let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
+end;;
+(* First-Order Unification by Structural Recursion *)
+(* Conor McBride, JFP 13(6) *)
+(* http://strictlypositive.org/publications.html *)
+
+(* This is a translation of the code part to ocaml *)
+(* Of course, we do not prove other properties, not even termination *)
+
+(* 2.2 Inductive Families *)
+
+type zero = Zero
+type _ succ = Succ
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+
+type _ fin =
+  | FZ : 'a succ fin
+  | FS : 'a fin -> 'a succ fin
+
+(* We cannot define
+     val empty : zero fin -> 'a
+   because we cannot write an empty pattern matching.
+   This might be useful to have *)
+
+(* In place, prove that the parameter is 'a succ *)
+type _ is_succ = IS : 'a succ is_succ
+
+let fin_succ : type n. n fin -> n is_succ = function
+  | FZ -> IS
+  | FS _ -> IS
+;;
+
+(* 3 First-Order Terms, Renaming and Substitution *)
+
+type 'a term =
+  | Var of 'a fin
+  | Leaf
+  | Fork of 'a term * 'a term
+
+let var x = Var x
+
+let lift r : 'm fin -> 'n term = fun x -> Var (r x)
+
+let rec pre_subst f = function
+  | Var x -> f x
+  | Leaf -> Leaf
+  | Fork (t1, t2) -> Fork (pre_subst f t1, pre_subst f t2)
+
+let comp_subst f g (x : 'a fin) = pre_subst f (g x)
+(*  val comp_subst :
+    ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term *)
+;;
+
+(* 4 The Occur-Check, through thick and thin *)
+
+let rec thin : type n. n succ fin -> n fin -> n succ fin =
+  fun x y -> match x, y with
+  | FZ, y    -> FS y
+  | FS x, FZ -> FZ
+  | FS x, FS y -> FS (thin x y)
+
+let bind t f =
+  match t with
+  | None   -> None
+  | Some x -> f x
+(* val bind : 'a option -> ('a -> 'b option) -> 'b option *)
+
+let rec thick : type n. n succ fin -> n succ fin -> n fin option =
+  fun x y -> match x, y with
+  | FZ, FZ   -> None
+  | FZ, FS y -> Some y
+  | FS x, FZ -> let IS = fin_succ x in Some FZ
+  | FS x, FS y ->
+      let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x))
+
+let rec check : type n. n succ fin -> n succ term -> n term option =
+  fun x t -> match t with
+  | Var y -> bind (thick x y) (fun x -> Some (Var x))
+  | Leaf  -> Some Leaf
+  | Fork (t1, t2) ->
+      bind (check x t1) (fun t1 ->
+        bind (check x t2) (fun t2 -> Some (Fork (t1, t2))))
+
+let subst_var x t' y =
+  match thick x y with
+  | None -> t'
+  | Some y' -> Var y'
+(* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *)
+
+let subst x t' = pre_subst (subst_var x t')
+(* val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term *)
+;;
+
+(* 5 A Refinement of Substitution *)
+
+type (_,_) alist =
+  | Anil  : ('n,'n) alist
+  | Asnoc : ('m,'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+
+let rec sub : type m n. (m,n) alist -> m fin -> n term = function
+  | Anil -> var
+  | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t)
+
+let rec append : type m n l. (m,n) alist -> (l,m) alist -> (l,n) alist =
+  fun r s -> match s with
+  | Anil -> r
+  | Asnoc (s, t, x) -> Asnoc (append r s, t, x)
+
+type _ ealist = EAlist : ('a,'b) alist -> 'a ealist
+
+let asnoc a t' x = EAlist (Asnoc (a, t', x))
+
+(* Extra work: we need sub to work on ealist too, for examples *)
+let rec weaken_fin : type n. n fin -> n succ fin = function
+  | FZ -> FZ
+  | FS x -> FS (weaken_fin x)
+
+let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t
+
+let rec weaken_alist : type m n. (m, n) alist -> (m succ, n succ) alist =
+  function
+    | Anil -> Anil
+    | Asnoc (s, t, x) -> Asnoc (weaken_alist s, weaken_term t, weaken_fin x)
+
+let rec sub' : type m. m ealist -> m fin -> m term = function
+  | EAlist Anil -> var
+  | EAlist (Asnoc (s, t, x)) ->
+      comp_subst (sub' (EAlist (weaken_alist s)))
+        (fun t' -> weaken_term (subst_var x t t'))
+
+let subst' d = pre_subst (sub' d)
+(*  val subst' : 'a ealist -> 'a term -> 'a term *)
+;;
+
+(* 6 First-Order Unification *)
+
+let flex_flex x y =
+  match thick x y with
+  | Some y' -> asnoc Anil (Var y') x
+  | None -> EAlist Anil
+(* val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist *)
+
+let flex_rigid x t =
+  bind (check x t) (fun t' -> Some (asnoc Anil t' x))
+(* val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option *)
+
+let rec amgu : type m. m term -> m term -> m ealist -> m ealist option =
+  fun s t acc -> match s, t, acc with
+  | Leaf, Leaf, _   -> Some acc
+  | Leaf, Fork _, _ -> None
+  | Fork _, Leaf, _ -> None
+  | Fork (s1, s2), Fork (t1, t2), _ ->
+      bind (amgu s1 t1 acc) (amgu s2 t2)
+  | Var x, Var y, EAlist Anil -> let IS = fin_succ x in Some (flex_flex x y)
+  | Var x, t,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | t, Var x,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | s, t, EAlist(Asnoc(d,r,z)) ->
+      bind (amgu (subst z r s) (subst z r t) (EAlist d))
+           (fun (EAlist d) -> Some (asnoc d r z))
+
+let mgu s t = amgu s t (EAlist Anil)
+(* val mgu : 'a term -> 'a term -> 'a ealist option *)
+;;
+
+let s = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+let t = Fork (Var (FS FZ), Var (FS FZ))
+let d = match mgu s t with Some x -> x | None -> failwith "mgu"
+let s' = subst' d s
+let t' = subst' d t
+;;
+(* Injectivity *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a b) (x : a) ->
+    let module M =
+      (functor (T : sig type 'a t end) ->
+       struct
+         let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+       end)
+        (struct type 'a t = unit end)
+    in M.f Refl
+;;
+
+(* Variance and subtyping *)
+
+type (_, +_) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let bad_proof (type a) =
+      (Refl : (< m : a>, <m : a>) eq :> (<m : a>, < >) eq) in
+    let downcast : type a. (a, < >) eq -> < > -> a =
+      fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
+    (downcast bad_proof ((object method m = x end) :> < >)) # m
+;;
+
+(* Record patterns *)
+
+type _ t =
+  | IntLit : int t
+  | BoolLit : bool t
+
+let check : type s . s t * s -> bool = function
+  | BoolLit, false -> false
+  | IntLit , 6 -> false
+;;
+
+type ('a, 'b) pair = { fst : 'a; snd : 'b }
+
+let check : type s . (s t, s) pair -> bool = function
+  | {fst = BoolLit; snd = false} -> false
+  | {fst = IntLit ; snd =  6} -> false
+;;
+module type S = sig type t [@@immediate] end;;
+module F (M : S) : S = M;;
+[%%expect{|
+module type S = sig type t [@@immediate] end
+module F : functor (M : S) -> S
+|}];;
+
+(* VALID DECLARATIONS *)
+
+module A = struct
+  (* Abstract types can be immediate *)
+  type t [@@immediate]
+
+  (* [@@immediate] tag here is unnecessary but valid since t has it *)
+  type s = t [@@immediate]
+
+  (* Again, valid alias even without tag *)
+  type r = s
+
+  (* Mutually recursive declarations work as well *)
+  type p = q [@@immediate]
+  and q = int
+end;;
+[%%expect{|
+module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+|}];;
+
+(* Valid using with constraints *)
+module type X = sig type t end;;
+module Y = struct type t = int end;;
+module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+[%%expect{|
+module type X = sig type t end
+module Y : sig type t = int end
+module Z : sig type t [@@immediate] end
+|}];;
+
+(* Valid using an explicit signature *)
+module M_valid : S = struct type t = int end;;
+module FM_valid = F (struct type t = int end);;
+[%%expect{|
+module M_valid : S
+module FM_valid : S
+|}];;
+
+(* Practical usage over modules *)
+module Foo : sig type t val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Foo : sig type t val x : t ref end
+|}];;
+
+module Bar : sig type t [@@immediate] val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Bar : sig type t [@@immediate] val x : t ref end
+|}];;
+
+let test f =
+  let start = Sys.time() in f ();
+  (Sys.time() -. start);;
+[%%expect{|
+val test : (unit -> 'a) -> float = <fun>
+|}];;
+
+let test_foo () =
+  for i = 0 to 100_000_000 do
+    Foo.x := !Foo.x
+  done;;
+[%%expect{|
+val test_foo : unit -> unit = <fun>
+|}];;
+
+let test_bar () =
+  for i = 0 to 100_000_000 do
+    Bar.x := !Bar.x
+  done;;
+[%%expect{|
+val test_bar : unit -> unit = <fun>
+|}];;
+
+(* Uncomment these to test. Should see substantial speedup!
+let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
+let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
+
+
+(* INVALID DECLARATIONS *)
+
+(* Cannot directly declare a non-immediate type as immediate *)
+module B = struct
+  type t = string [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-31:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Not guaranteed that t is immediate, so this is an invalid declaration *)
+module C = struct
+  type t
+  type s = t [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Can't ascribe to an immediate type signature with a non-immediate type *)
+module D : sig type t [@@immediate] end = struct
+  type t = string
+end;;
+[%%expect{|
+Line _, characters 42-70:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Same as above but with explicit signature *)
+module M_invalid : S = struct type t = string end;;
+module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line _, characters 23-49:
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Can't use a non-immediate type even if mutually recursive *)
+module E = struct
+  type t = s [@@immediate]
+  and s = string
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;
+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
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = eval1 (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 = eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+(* 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 : x:'b -> ?y:'c -> 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)
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+(* 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
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+type sexp = A of string | L of sexp list
+type 'a t = 'a array
+let _ = fun (_ : 'a t)  -> ()
+
+let array_of_sexp _ _ = [| |]
+let sexp_of_array _ _ = A "foo"
+let sexp_of_int _ = A "42"
+let int_of_sexp _ = 42
+
+let t_of_sexp : 'a . (sexp -> 'a) -> sexp -> 'a t=
+  let _tp_loc = "core_array.ml.t" in
+  fun _of_a  -> fun t  -> (array_of_sexp _of_a) t
+let _ = t_of_sexp
+let sexp_of_t : 'a . ('a -> sexp) -> 'a t -> sexp=
+  fun _of_a  -> fun v  -> (sexp_of_array _of_a) v
+let _ = sexp_of_t
+module T =
+  struct
+    module Int =
+      struct
+        type t_ = int array
+        let _ = fun (_ : t_)  -> ()
+
+        let t__of_sexp: sexp -> t_ =
+          let _tp_loc = "core_array.ml.T.Int.t_" in
+          fun t  -> (array_of_sexp int_of_sexp) t
+        let _ = t__of_sexp
+        let sexp_of_t_: t_ -> sexp =
+          fun v  -> (sexp_of_array sexp_of_int) v
+        let _ = sexp_of_t_
+      end
+  end
+module type Permissioned  =
+  sig
+    type ('a,-'perms) t
+  end
+module Permissioned :
+  sig
+    type ('a,-'perms) t
+    include
+      sig
+        val t_of_sexp :
+          (sexp -> 'a) ->
+            (sexp -> 'perms) -> sexp -> ('a,'perms) t
+        val sexp_of_t :
+          ('a -> sexp) ->
+            ('perms -> sexp) -> ('a,'perms) t -> sexp
+      end
+    module Int :
+    sig
+      type nonrec -'perms t = (int,'perms) t
+      include
+        sig
+          val t_of_sexp :
+            (sexp -> 'perms) -> sexp -> 'perms t
+          val sexp_of_t :
+            ('perms -> sexp) -> 'perms t -> sexp
+        end
+    end
+  end =
+  struct
+    type ('a,-'perms) t = 'a array
+    let _ = fun (_ : ('a,'perms) t)  -> ()
+
+    let t_of_sexp :
+      'a 'perms .
+        (sexp -> 'a) ->
+          (sexp -> 'perms) -> sexp -> ('a,'perms) t=
+      let _tp_loc = "core_array.ml.Permissioned.t" in
+      fun _of_a  -> fun _of_perms  -> fun t  -> (array_of_sexp _of_a) t
+    let _ = t_of_sexp
+    let sexp_of_t :
+      'a 'perms .
+        ('a -> sexp) ->
+          ('perms -> sexp) -> ('a,'perms) t -> sexp=
+      fun _of_a  -> fun _of_perms  -> fun v  -> (sexp_of_array _of_a) v
+    let _ = sexp_of_t
+    module Int =
+      struct
+        include T.Int
+        type -'perms t = t_
+        let _ = fun (_ : 'perms t)  -> ()
+
+        let t_of_sexp :
+          'perms . (sexp -> 'perms) -> sexp -> 'perms t=
+          let _tp_loc = "core_array.ml.Permissioned.Int.t" in
+          fun _of_perms  -> fun t  -> t__of_sexp t
+        let _ = t_of_sexp
+        let sexp_of_t :
+          'perms . ('perms -> sexp) -> 'perms t -> sexp=
+          fun _of_perms  -> fun v  -> sexp_of_t_ v
+        let _ = sexp_of_t
+      end
+  end
+type 'a  foo = {x: 'a; y: int}
+let r = {{x = 0; y = 0} with x = 0}
+let r' : string foo = r
+external foo : int = "%ignore";;
+let _ = foo ();;
+type 'a t = [`A of 'a t t] as 'a;; (* fails *)
+
+type 'a t = [`A of 'a t t];; (* fails *)
+
+type 'a t = [`A of 'a t t] constraint 'a = 'a t;;
+
+type 'a t = [`A of 'a t] constraint 'a = 'a t;;
+
+type 'a t = [`A of 'a] as 'a;;
+
+type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+
+type 'a t = 'a;;
+let f (x : 'a t as 'a) = ();; (* fails *)
+
+let f (x : 'a t) (y : 'a) = x = y;;
+
+(* PR#6505 *)
+module type PR6505 = sig
+  type 'o is_an_object = < .. > as 'o
+  and 'o abs constraint 'o = 'o is_an_object
+  val abs : 'o is_an_object -> 'o abs
+  val unabs : 'o abs -> 'o
+end;; (* fails *)
+(* PR#5835 *)
+let f ~x = x + 1;;
+f ?x:0;;
+
+(* PR#6352 *)
+let foo (f : unit -> unit) = ();;
+let g ?x () = ();;
+foo ((); g);;
+
+(* PR#5748 *)
+foo (fun ?opt () -> ()) ;; (* fails *)
+(* PR#5907 *)
+
+type 'a t = 'a;;
+let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+type ab = [ `A | `B ];;
+let f (x : [`A]) = match x with #ab -> 1;;
+let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+
+let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+
+(* PR#6787 *)
+let revapply x f = f x;;
+
+let f x (g : [< `Foo]) =
+  let y = `Bar x, g in
+  revapply y (fun ((`Bar i), _) -> i);;
+(* f : 'a -> [< `Foo ] -> 'a *)
+
+let rec x = [| x |]; 1.;;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+type 'a t
+type a
+
+let f : < .. > t -> unit = fun _ -> ();;
+
+let g : [< `b] t -> unit = fun _ -> ();;
+
+let h : [> `b] t -> unit = fun _ -> ();;
+
+let _ = fun (x : a t) -> f x;;
+
+let _ = fun (x : a t) -> g x;;
+
+let _ = fun (x : a t) -> h x;;
+(* PR#7012 *)
+
+type t = [ 'A_name | `Hi ];;
+
+let f (x:'id_arg) = x;;
+
+let f (x:'Id_arg) = x;;
+(* undefined labels *)
+type t = {x:int;y:int};;
+{x=3;z=2};;
+fun {x=3;z=2} -> ();;
+
+(* mixed labels *)
+{x=3; contents=2};;
+
+(* private types *)
+type u = private {mutable u:int};;
+{u=3};;
+fun x -> x.u <- 3;;
+
+(* Punning and abbreviations *)
+module M = struct
+  type t = {x: int; y: int}
+end;;
+
+let f {M.x; y} = x+y;;
+let r = {M.x=1; y=2};;
+let z = f r;;
+
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+
+(ZZZ.X : int option);;
+
+(* PR#5865 *)
+let f (x : Complex.t) = x.Complex.z;;
+(* PR#6394 *)
+
+module rec X : sig
+ type t = int * bool
+end = struct
+ type t = A | B
+ let f = function A | B -> 0
+end;;
+(* PR#6768 *)
+
+type _ prod = Prod : ('a * 'y) prod;;
+
+let f : type t. t prod -> _ = function Prod ->
+  let module M =
+    struct
+      type d = d * d
+    end
+  in ()
+;;
+let (a : M.a) = 2
+let (b : M.b) = 2
+let _ = A.a = B.b
+module Std = struct module Hash = Hashtbl end;;
+
+open Std;;
+module Hash1 : module type of Hash = Hash;;
+module Hash2 : sig include (module type of Hash) end = Hash;;
+let f1 (x : (_,_) Hash1.t) = (x : (_,_) Hashtbl.t);;
+let f2 (x : (_,_) Hash2.t) = (x : (_,_) Hashtbl.t);;
+
+(* Another case, not using include *)
+
+module Std2 = struct module M = struct type t end end;;
+module Std' = Std2;;
+module M' : module type of Std'.M = Std2.M;;
+let f3 (x : M'.t) = (x : Std2.M.t);;
+
+(* original report required Core_kernel:
+module type S = sig
+open Core_kernel.Std
+
+module Hashtbl1 : module type of Hashtbl
+module Hashtbl2 : sig
+  include (module type of Hashtbl)
+end
+
+module Coverage : Core_kernel.Std.Hashable
+
+type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t
+type doesnt_type = unit
+  constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t
+end
+*)
+module type INCLUDING = sig
+  include module type of List
+  include module type of ListLabels
+end
+
+module Including_typed: INCLUDING = struct
+  include List
+  include ListLabels
+end
+module X=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG) : SIG = struct type t=Y.t let x=Y.x end
+end;;
+module DUMMY=struct type t=int let x=2 end;;
+let x = (3 : X.F(DUMMY).t);;
+
+module X2=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG)(Z:SIG) = struct
+    type t=Y.t
+    let x=Y.x
+    type t'=Z.t
+    let x'=Z.x
+  end
+end;;
+let x = (3 : X2.F(DUMMY)(DUMMY).t);;
+let x = (3 : X2.F(DUMMY)(DUMMY).t');;
+module F (M : sig
+    type 'a t
+    type 'a u = string
+    val f : unit -> _ u t
+  end) = struct
+    let t = M.f ()
+  end
+type 't a = [ `A ]
+type 't wrap = 't constraint 't = [> 't wrap a ]
+type t = t a wrap
+
+module T = struct
+  let foo : 't wrap -> 't wrap -> unit = fun _ _ -> ()
+  let bar : ('a a wrap as 'a) = `A
+end
+
+module Good : sig
+  val bar: t
+  val foo: t -> t -> unit
+end = T
+
+module Bad : sig
+  val foo: t -> t -> unit
+  val bar: t
+end = T
+module M : sig
+  module type T
+  module F (X : T) : sig end
+end = struct
+  module type T = sig end
+  module F (X : T) = struct end
+end
+
+module type T = M.T
+
+module F : functor (X : T) -> sig end = M.F
+module type S = sig type t = { a : int; b : int; } end;;
+let f (module M : S with type t = int) = { M.a = 0 };;
+let flag = ref false
+module F(S : sig module type T end) (A : S.T) (B : S.T) =
+struct
+  module X = (val if !flag then (module A) else (module B) : S.T)
+end
+
+(* If the above were accepted, one could break soundness *)
+module type S = sig type t val x : t end
+module Float = struct type t = float let x = 0.0 end
+module Int = struct type t = int let x = 0 end
+
+module M = F(struct module type T = S end)
+
+let () = flag := false
+module M1 = M(Float)(Int)
+
+let () = flag := true
+module M2 = M(Float)(Int)
+
+let _ = [| M2.X.x; M1.X.x |]
+module type PR6513 = sig
+module type S = sig type u end
+
+module type T = sig
+  type 'a wrap
+  type uri
+end
+
+module Make: functor (Html5 : T with type 'a wrap = 'a) ->
+  S with type u = < foo : Html5.uri >
+end
+
+(* Requires -package tyxml
+module type PR6513_orig = sig
+module type S =
+sig
+        type t
+        type u
+end
+
+module Make: functor (Html5: Html5_sigs.T
+                             with type 'a Xml.wrap = 'a and
+                             type 'a wrap = 'a and
+                             type 'a list_wrap = 'a list)
+                     -> S with type t = Html5_types.div Html5.elt and
+                               type u = < foo: Html5.uri >
+end
+*)
+module type S = sig
+  include Set.S
+  module E : sig val x : int end
+end
+
+module Make(O : Set.OrderedType) : S with type elt = O.t =
+  struct
+    include Set.Make(O)
+    module E = struct let x = 1 end
+  end
+
+module rec A : Set.OrderedType = struct
+ type t = int
+  let compare = Pervasives.compare
+end
+and B : S = struct
+ module C = Make(A)
+ include C
+end
+module type S = sig
+  module type T
+  module X : T
+end
+
+module F (X : S) = X.X
+
+module M = struct
+  module type T = sig type t end
+  module X = struct type t = int end
+end
+
+type t = F(M).t
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end
+let should_reject =
+  let table = Hashtbl.create 1 in
+  fun x y -> Hashtbl.add table x y
+type 'a t = 'a option
+let is_some = function
+  | None -> false
+  | Some _ -> true
+
+let should_accept ?x () = is_some x
+include struct
+  let foo `Test = ()
+  let wrap f `Test = f
+  let bar = wrap ()
+end
+let f () =
+   let module S = String in
+   let module N = Map.Make(S) in
+   N.add "sum" 41 N.empty;;
+module X = struct module Y = struct module type S = sig type t end end end
+
+(* open X  (* works! *) *)
+module Y = X.Y
+
+type 'a arg_t = 'at constraint 'a = (module Y.S with type t = 'at)
+type t = (module X.Y.S with type t = unit)
+
+let f (x : t arg_t) = ()
+
+let () = f ()
+module type S =
+sig
+  type a
+  type b
+end
+module Foo
+    (Bar : S with type a = private [> `A])
+    (Baz : S with type b = private < b : Bar.b ; .. >) =
+struct
+end
+module A = struct
+ module type A_S = sig
+ end
+
+ type t = (module A_S)
+end
+
+module type S = sig type t end
+
+let f (type a) (module X : S with type t = a) = ()
+
+let _ = f (module A) (* ok *)
+
+module A_annotated_alias : S with type t = (module A.A_S) = A
+
+let _ = f (module A_annotated_alias) (* ok *)
+let _ = f (module A_annotated_alias : S with type t = (module A.A_S)) (* ok *)
+
+module A_alias = A
+module A_alias_expanded = struct include A_alias end
+
+let _ = f (module A_alias_expanded : S with type t = (module A.A_S)) (* ok *)
+let _ = f (module A_alias_expanded) (* ok *)
+
+let _ = f (module A_alias : S with type t = (module A.A_S)) (* doesn't type *)
+let _ = f (module A_alias) (* doesn't type either *)
+module Foo
+ (Bar : sig type a = private [> `A ] end)
+ (Baz : module type of struct include Bar end) =
+struct
+end
+module Bazoinks = struct type a = [ `A ] end
+module Bug = Foo(Bazoinks)(Bazoinks)
+(* PR#6992, reported by Stephen Dolan *)
+
+type (_, _) eq = Eq : ('a, 'a) eq
+let cast : type a b . (a, b) eq -> a -> b = fun Eq x -> x
+
+module Fix (F : sig type 'a f end) = struct
+  type 'a fix = ('a, 'a F.f) eq
+  let uniq (type a) (type b) (Eq : a fix) (Eq : b fix) : (a, b) eq = Eq
+end
+
+(* This would allow:
+module FixId = Fix (struct type 'a f = 'a end)
+ let bad : (int, string) eq = FixId.uniq Eq Eq
+ let _ = Printf.printf "Oh dear: %s" (cast bad 42)
+*)
+module M = struct
+ module type S = sig type a val v : a end
+ type 'a s = (module S with type a = 'a)
+end
+
+module B = struct
+ class type a = object method a : 'a. 'a M.s -> 'a end
+end
+
+module M' = M
+module B' = B
+
+class b : B.a = object
+ method a : 'a. 'a M.s -> 'a = fun (type a) ((module X) : (module M.S with type
+a = a)) -> X.v
+end
+
+class b' : B.a = object
+ method a : 'a. 'a M'.s -> 'a = fun (type a) ((module X) : (module M'.S with
+type a = a)) -> X.v
+end
+module type FOO = sig type t end
+module type BAR =
+sig
+  (* Works: module rec A : (sig include FOO with type t = < b:B.t > end) *)
+  module rec A : (FOO with type t = < b:B.t >)
+         and B : FOO
+end
+module A = struct module type S module S = struct end end
+module F (_ : sig end) = struct module type S module S = A.S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : A.S = X
+module F (_ : sig end) = struct module type S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : F(M).S = X
+module M :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    module Data = struct
+      type t = make_dec
+    end
+    let key = Fast.create ()
+  end
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* simpler version *)
+
+module Simple = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module Register (D:S) = struct let key = D.key end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+end;;
+module EM = Simple.Register(Simple.M);;
+Simple.M.key;;
+
+module Simple2 = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+  module Register (D:S) = struct let key = D.key end
+  module EM = Simple.Register(Simple.M)
+  let k : M.Data.t t = M.key
+end;;
+module rec M
+    : sig external f : int -> int = "%identity" end
+    = struct external f : int -> int = "%identity" end
+(* with module *)
+
+module type S = sig type t and s = t end;;
+module type S' = S with type t := int;;
+
+module type S = sig module rec M : sig end and N : sig end end;;
+module type S' = S with module M := String;;
+
+(* with module type *)
+(*
+module type S = sig module type T module F(X:T) : T end;;
+module type T0 = sig type t end;;
+module type S1 = S with module type T = T0;;
+module type S2 = S with module type T := T0;;
+module type S3 = S with module type T := sig type t = int end;;
+module H = struct
+  include (Hashtbl : module type of Hashtbl with
+           type statistics := Hashtbl.statistics
+           and module type S := Hashtbl.S
+           and module Make := Hashtbl.Make
+           and module MakeSeeded := Hashtbl.MakeSeeded
+           and module type SeededS := Hashtbl.SeededS
+           and module type HashedType := Hashtbl.HashedType
+           and module type SeededHashedType := Hashtbl.SeededHashedType)
+end;;
+*)
+
+(* A subtle problem appearing with -principal *)
+type -'a t
+class type c = object method m : [ `A ] t end;;
+module M : sig val v : (#c as 'a) -> 'a end =
+  struct let v x = ignore (x :> c); x end;;
+
+(* PR#4838 *)
+
+let id = let module M = struct end in fun x -> x;;
+
+(* PR#4511 *)
+
+let ko = let module M = struct end in fun _ -> ();;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+  struct type +'a t = private int end
+;;
+
+(* PR#6005 *)
+
+module type A = sig type t = X of int end;;
+type u = X of bool;;
+module type B = A with type t = u;; (* fail *)
+
+(* PR#5815 *)
+(* ---> duplicated exception name is now an error *)
+
+module type S = sig exception Foo of int  exception Foo of bool end;;
+
+(* PR#6410 *)
+
+module F(X : sig end) = struct let x = 3 end;;
+F.x;; (* fail *)
+module C = Char;;
+C.chr 66;;
+
+module C' : module type of Char = C;;
+C'.chr 66;;
+
+module C3 = struct include Char end;;
+C3.chr 66;;
+
+let f x = let module M = struct module L = List end in M.L.length x;;
+let g x = let module L = List in L.length (L.map succ x);;
+
+module F(X:sig end) = Char;;
+module C4 = F(struct end);;
+C4.chr 66;;
+
+module G(X:sig end) = struct module M = X end;; (* does not alias X *)
+module M = G(struct end);;
+
+module M' = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M'.N'.x;;
+
+module M'' : sig module N' : sig val x : int end end = M';;
+M''.N'.x;;
+module M2 = struct include M' end;;
+module M3 : sig module N' : sig val x : int end end = struct include M' end;;
+M3.N'.x;;
+module M3' : sig module N' : sig val x : int end end = M2;;
+M3'.N'.x;;
+
+module M4 : sig module N' : sig val x : int end end = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M4.N'.x;;
+
+module F(X:sig end) = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
+module M5 = G(struct end);;
+M5.N'.x;;
+
+module M = struct
+  module D = struct let y = 3 end
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+
+module M1 : sig module N : sig val x : int end module N' = N end = M;;
+M1.N'.x;;
+module M2 : sig module N' : sig val x : int end end =
+  (M : sig module N : sig val x : int end module N' = N end);;
+M2.N'.x;;
+
+open M;;
+N'.x;;
+
+module M = struct
+  module C = Char
+  module C' = C
+end;;
+module M1
+  : sig module C : sig val escaped : char -> string end module C' = C end
+  = M;; (* sound, but should probably fail *)
+M1.C'.escaped 'A';;
+module M2 : sig module C' : sig val chr : int -> char end end =
+  (M : sig module C : sig val chr : int -> char end module C' = C end);;
+M2.C'.chr 66;;
+
+StdLabels.List.map;;
+
+module Q = Queue;;
+exception QE = Q.Empty;;
+try Q.pop (Q.create ()) with QE -> "Ok";;
+
+module type Complex = module type of Complex with type t = Complex.t;;
+module M : sig module C : Complex end = struct module C = Complex end;;
+
+module C = Complex;;
+C.one.Complex.re;;
+include C;;
+
+module F(X:sig module C = Char end) = struct module C = X.C end;;
+
+(* Applicative functors *)
+module S = String
+module StringSet = Set.Make(String)
+module SSet = Set.Make(S);;
+let f (x : StringSet.t) = (x : SSet.t);;
+
+(* Also using include (cf. Leo's mail 2013-11-16) *)
+module F (M : sig end) : sig type t end = struct type t = int end
+module T = struct
+  module M = struct end
+  include F(M)
+end;;
+include T;;
+let f (x : t) : T.t = x ;;
+
+(* PR#4049 *)
+(* This works thanks to abbreviations *)
+module A = struct
+  module B = struct type t let compare x y = 0 end
+  module S = Set.Make(B)
+  let empty = S.empty
+end
+module A1 = A;;
+A1.empty = A.empty;;
+
+(* PR#3476 *)
+(* Does not work yet *)
+module FF(X : sig end) = struct type t end
+module M = struct
+  module X = struct end
+  module Y = FF (X) (* XXX *)
+  type t = Y.t
+end
+module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;;
+
+module G = F (M.Y);;
+(*module N = G (M);;
+module N = F (M.Y) (M);;*)
+
+(* PR#6307 *)
+
+module A1 = struct end
+module A2 = struct end
+module L1 = struct module X = A1 end
+module L2 = struct module X = A2 end;;
+
+module F (L : (module type of L1)) = struct end;;
+
+module F1 = F(L1);; (* ok *)
+module F2 = F(L2);; (* should succeed too *)
+
+(* Counter example: why we need to be careful with PR#6307 *)
+module Int = struct type t = int let compare = compare end
+module SInt = Set.Make(Int)
+type (_,_) eq = Eq : ('a,'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+
+module M = struct
+  module I = Int
+  type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+end;;
+module type S = module type of M;; (* keep alias *)
+
+module Int2 = struct type t = int let compare x y = compare y x end;;
+module type S' = sig
+  module I = Int2
+  include S with module I := I
+end;; (* fail *)
+
+(* (* if the above succeeded, one could break invariants *)
+module rec M2 : S' = M2;; (* should succeed! (but this is bad) *)
+
+let M2.W eq = W Eq;;
+
+let s = List.fold_right SInt.add [1;2;3] SInt.empty;;
+module SInt2 = Set.Make(Int2);;
+let conv : type a b. (a,b) eq -> a -> b = fun Eq x -> x;;
+let s' : SInt2.t = conv eq s;;
+SInt2.elements s';;
+SInt2.mem 2 s';; (* invariants are broken *)
+*)
+
+(* Check behavior with submodules *)
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+
+(* PR#6365 *)
+module type S = sig module M : sig type t val x : t end end;;
+module H = struct type t = A let x = A end;;
+module H' = H;;
+module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+
+(* PR#6376 *)
+module type Alias = sig module N : sig end module M = N end;;
+module F (X : sig end) = struct type t end;;
+module type A = Alias with module N := F(List);;
+module rec Bad : A = Bad;;
+
+(* Shinwell 2014-04-23 *)
+module B = struct
+ module R = struct
+   type t = string
+ end
+
+ module O = R
+end
+
+module K = struct
+ module E = B
+ module N = E.O
+end;;
+
+let x : K.N.t = "foo";;
+
+(* PR#6465 *)
+
+module M = struct type t = A module B = struct type u = B end end;;
+module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *)
+module P : sig type t = M.t = A module B = M.B end = struct include M end;;
+
+module type S = sig
+  module M : sig module P : sig end end
+  module Q = M
+end;;
+module type S = sig
+  module M : sig module N : sig end module P : sig end end
+  module Q : sig module N = M.N module P = M.P end
+end;;
+module R = struct
+  module M = struct module N = struct end module P = struct end end
+  module Q = M
+end;;
+module R' : S = R;; (* should be ok *)
+
+(* PR#6578 *)
+
+module M = struct let f x = x end
+module rec R : sig module M : sig val f : 'a -> 'a end end =
+  struct module M = M end;;
+R.M.f 3;;
+module rec R : sig module M = M end = struct module M = M end;;
+R.M.f 3;;
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+include D'
+(*
+let () =
+  print_endline (string_of_int D'.M.y)
+*)
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+(* No dependency on D *)
+let x = 3
+module M = struct let y = 5 end
+module type S = sig type u type t end;;
+module type S' = sig type t = int type u = bool end;;
+
+(* ok to convert between structurally equal signatures, and parameters
+   are inferred *)
+let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'));;
+let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'));;
+
+(* with subtyping it is also ok to forget some types *)
+module type S2 = sig type u type t type w end;;
+let g2 x = (x : (module S2 with type t = 'a and type u = 'b) :> (module S'));;
+let h x = (x : (module S2 with type t = 'a) :> (module S with type t = 'a));;
+let f2 (x : (module S2 with type t = 'a and type u = 'b)) =
+  (x : (module S'));; (* fail *)
+let k (x : (module S2 with type t = 'a)) =
+  (x : (module S with type t = 'a));; (* fail *)
+
+(* but you cannot forget values (no physical coercions) *)
+module type S3 = sig type u type t val x : int end;;
+let g3 x =
+  (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+(* Using generative functors *)
+
+(* Without type *)
+module type S = sig val x : int end;;
+let v = (module struct let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* ok *)
+module H (X : sig end) = (val v);; (* ok *)
+
+(* With type *)
+module type S = sig type t val x : t end;;
+let v = (module struct type t = int let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* fail *)
+module H() = F();; (* ok *)
+
+(* Alias *)
+module U = struct end;;
+module M = F(struct end);; (* ok *)
+module M = F(U);; (* fail *)
+
+(* Cannot coerce between applicative and generative *)
+module F1 (X : sig end) = struct end;;
+module F2 : functor () -> sig end = F1;; (* fail *)
+module F3 () = struct end;;
+module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+
+(* tests for shortened functor notation () *)
+module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;;
+module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) ->
+  struct end;;
+module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;;
+module GZ : functor (X: sig end) () (Z: sig end) -> sig end
+          = functor (X: sig end) () (Z: sig end) -> struct end;;
+module F (X : sig end) = struct type t = int end;;
+type t = F(Does_not_exist).t;;
+type expr =
+  [ `Abs of string * expr
+  | `App of expr * expr
+  ]
+
+class type exp =
+object
+  method eval : (string, exp) Hashtbl.t -> expr
+end;;
+
+class app e1 e2 : exp =
+object
+  val l = e1
+  val r = e2
+  method eval env =
+      match l with
+    | `Abs(var,body) ->
+        Hashtbl.add env var r;
+        body
+    | _ -> `App(l,r);
+end
+
+class virtual ['subject, 'event] observer =
+   object
+     method virtual notify : 'subject ->  'event -> unit
+   end
+
+class ['event] subject =
+   object (self : 'subject)
+     val mutable observers = ([]: (('subject, 'event) observer) list)
+     method add_observer obs = observers <- (obs :: observers)
+     method notify_observers (e : 'event) =
+         List.iter (fun x -> x#notify self e) observers
+   end
+
+type id = int
+
+class entity (id : id) =
+  object
+    val ent_destroy_subject = new subject
+    method destroy_subject : (id) subject = ent_destroy_subject
+
+    method entity_id = id
+  end
+
+class ['entity] entity_container =
+  object (self)
+    inherit ['entity, id] observer as observer
+
+    method add_entity (e : 'entity) =
+      e#destroy_subject#add_observer (self)
+
+    method notify _ id = ()
+  end
+
+let f (x : entity entity_container) = ()
+
+(*
+class world =
+  object
+    val entity_container : entity entity_container = new entity_container
+
+    method add_entity (s : entity) =
+      entity_container#add_entity (s :> entity)
+
+  end
+*)
+(* Two v's in the same class *)
+class c v = object initializer  print_endline v val v = 42 end;;
+new c "42";;
+
+(* Two hidden v's in the same class! *)
+class c (v : int) =
+  object
+    method v0 = v
+    inherit ((fun v -> object method v : string = v end) "42")
+  end;;
+(new c 42)#v0;;
+class virtual ['a] c =
+object (s : 'a)
+  method virtual m : 'b
+end
+
+let o =
+    object (s :'a)
+      inherit ['a] c
+      method m = 42
+    end
+module M :
+   sig
+     class x : int -> object method m : int end
+  end
+=
+struct
+  class x _ = object
+    method m = 42
+  end
+end;;
+module M : sig class c : 'a -> object val x : 'b end end =
+  struct class c x = object val x = x end end
+
+class c (x : int) = object inherit M.c x method x : bool = x end
+
+let r = (new c 2)#x;;
+(* test.ml *)
+class alfa = object(_:'self)
+  method x: 'a. ('a, out_channel, unit) format -> 'a = Printf.printf
+end
+
+class bravo a = object
+  val y = (a :> alfa)
+  initializer y#x "bravo initialized"
+end
+
+class charlie a = object
+  inherit bravo a
+  initializer y#x "charlie initialized"
+end
+(* 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
+class type foo_t =
+  object
+    method foo: string
+  end
+
+type 'a name =
+    Foo: foo_t name
+  | Int: int name
+;;
+
+class foo =
+  object(self)
+    method foo = "foo"
+    method cast =
+      function
+          Foo -> (self :> <foo : string>)
+  end
+;;
+
+class foo: foo_t =
+  object(self)
+    method foo = "foo"
+    method cast: type a. a name -> a =
+      function
+          Foo -> (self :> foo_t)
+        | _ -> raise Exit
+  end
+;;
+class type c = object end;;
+module type S = sig class c: c end;;
+class virtual name =
+object
+end
+
+and func (args_ty, ret_ty) =
+object(self)
+  inherit name
+
+  val mutable memo_args = None
+
+  method arguments =
+    match memo_args with
+    | Some xs -> xs
+    | None ->
+      let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+        memo_args <- Some args; args
+end
+
+and argument (func, ty) =
+object
+  inherit name
+end
+;;
+let f (x: #M.foo) = 0;;
+class type ['e] t = object('s)
+  method update : 'e -> 's
+end;;
+
+module type S = sig
+  class base : 'e -> ['e] t
+end;;
+type 'par t = 'par
+module M : sig val x : <m : 'a. 'a> end =
+  struct let x : <m : 'a. 'a t> = Obj.magic () end
+
+let ident v = v
+class alias = object method alias : 'a . 'a t -> 'a = ident end
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+type refer1 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+type refer2 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+
+(* Actually this should succeed ... *)
+let f (x : refer1) = (x : refer2)
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+module M : sig
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end = struct
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end
+(*
+  ocamlc -c pr3918a.mli pr3918b.mli
+  rm -f pr3918a.cmi
+  ocamlc -c pr3918c.ml
+*)
+
+open Pr3918b
+
+let f x = (x : 'a vlist :> 'b vlist)
+let f (x : 'a vlist) = (x : 'b vlist)
+module type Poly = sig
+  type 'a t = 'a constraint 'a = [> ]
+end
+
+module Combine (A : Poly) (B : Poly) = struct
+  type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t
+end
+
+module C = Combine
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+module type Priv = sig
+  type t = private int
+end
+
+module Make (Unit:sig end): Priv = struct type t = int end
+
+module A = Make (struct end)
+
+module type Priv' = sig
+  type t = private [> `A]
+end
+
+module Make' (Unit:sig end): Priv' = struct type t = [`A] end
+
+module A' = Make' (struct end)
+(* PR5057 *)
+
+module TT = struct
+  module IntSet = Set.Make(struct type t = int let compare = compare end)
+end
+
+let () =
+  let f flag =
+    let module T = TT in
+    let _ = match flag with `A -> 0 | `B r -> r in
+    let _ = match flag with `A -> T.IntSet.mem | `B r -> r in
+    ()
+  in
+  f `A
+(* This one should fail *)
+
+let f flag =
+  let module T = Set.Make(struct type t = int let compare = compare end) in
+  let _ = match flag with `A -> 0 | `B r -> r in
+  let _ = match flag with `A -> T.mem | `B r -> r in
+  ()
+module type S = sig
+ type +'a t
+
+ val foo : [`A] t -> unit
+ val bar : [< `A | `B] t -> unit
+end
+
+module Make(T : S) = struct
+ let f x =
+   T.foo x;
+   T.bar x;
+   (x :> [`A | `C] T.t)
+end
+type 'a termpc =
+    [`And of 'a * 'a
+    |`Or of 'a * 'a
+    |`Not of 'a
+    |`Atom of string
+    ]
+
+type 'a termk =
+    [`Dia of 'a
+    |`Box of 'a
+    |'a termpc
+    ]
+
+module type T = sig
+  type term
+  val map : (term -> term) -> term -> term
+  val nnf : term -> term
+  val nnf_not : term -> term
+end
+
+module Fpc(X : T with type term = private [> 'a termpc] as 'a) =
+  struct
+    type term = X.term termpc
+    let nnf = function
+      |`Not(`Atom _) as x -> x
+      |`Not x     -> X.nnf_not x
+      | x         -> X.map X.nnf x
+    let map f : term -> X.term = function
+      |`Not x    -> `Not (f x)
+      |`And(x,y) -> `And (f x, f y)
+      |`Or (x,y) -> `Or  (f x, f y)
+      |`Atom _ as x -> x
+    let nnf_not : term -> _ = function
+      |`Not x    -> X.nnf x
+      |`And(x,y) -> `Or  (X.nnf_not x, X.nnf_not y)
+      |`Or (x,y) -> `And (X.nnf_not x, X.nnf_not y)
+      |`Atom _ as x -> `Not x
+  end
+
+module Fk(X : T with type term = private [> 'a termk] as 'a) =
+  struct
+    type term = X.term termk
+    module Pc = Fpc(X)
+    let map f : term -> _ = function
+      |`Dia x -> `Dia (f x)
+      |`Box x -> `Box (f x)
+      |#termpc as x -> Pc.map f x
+    let nnf = Pc.nnf
+    let nnf_not : term -> _ = function
+      |`Dia x -> `Box (X.nnf_not x)
+      |`Box x -> `Dia (X.nnf_not x)
+      |#termpc as x -> Pc.nnf_not x
+  end
+type untyped;;
+type -'a typed = private untyped;;
+type -'typing wrapped = private sexp
+and +'a t = 'a typed wrapped
+and sexp = private untyped wrapped;;
+class type ['a] s3 = object
+  val underlying : 'a t
+end;;
+class ['a] s3object r : ['a] s3 = object
+  val underlying = r
+end;;
+module M (T:sig type t end)
+ = struct type t = private { t : T.t } end
+module P
+ = struct
+       module T = struct type t end
+       module R = M(T)
+ end
+module Foobar : sig
+  type t = private int
+end = struct
+  type t = int
+end;;
+
+module F0 : sig type t = private int end = Foobar;;
+
+let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+
+module F = Foobar;;
+
+let f (x : F.t) = (x : Foobar.t);;
+
+module M = struct type t = <m:int> end;;
+module M1 : sig type t = private <m:int; ..> end = M;;
+module M2 :  sig type t = private <m:int; ..> end = M1;;
+fun (x : M1.t) -> (x : M2.t);; (* fails *)
+
+module M3 : sig type t = private M1.t end = M1;;
+fun x -> (x : M3.t :> M1.t);;
+fun x -> (x : M3.t :> M.t);;
+module M4 : sig type t = private M3.t end = M2;; (* fails *)
+module M4 : sig type t = private M3.t end = M;; (* fails *)
+module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+module M5 : sig type t = private M1.t end = M3;;
+module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+
+module Bar : sig type t = private Foobar.t val f : int -> t end =
+  struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+
+module M : sig
+  type t = private T of int
+  val mk : int -> t
+end = struct
+  type t = T of int
+  let mk x = T(x)
+end;;
+
+module M1 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  type t = M.t
+  let mk = M.mk
+end;;
+
+module M2 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  include M
+end;;
+
+module M3 : sig
+  type t = M.t
+  val mk : int -> t
+end = M;;
+
+module M4 : sig
+    type t = M.t = T of int
+    val mk : int -> t
+  end = M;;
+(* Error: The variant or record definition does not match that of type M.t *)
+
+module M5 : sig
+  type t = M.t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M6 : sig
+  type t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M' : sig
+  type t_priv = private T of int
+  type t = t_priv
+  val mk : int -> t
+end = struct
+  type t_priv = T of int
+  type t = t_priv
+  let mk x = T(x)
+end;;
+
+module M3' : sig
+  type t = M'.t
+  val mk : int -> t
+end = M';;
+
+module M : sig type 'a t = private T of 'a end =
+  struct type 'a t = T of 'a end;;
+
+module M1 : sig type 'a t = 'a M.t = private T of 'a end =
+  struct type 'a t = 'a M.t = private T of 'a end;;
+
+(* PR#6090 *)
+module Test = struct type t = private A end
+module Test2 : module type of Test with type t = Test.t = Test;;
+let f (x : Test.t) = (x : Test2.t);;
+let f Test2.A = ();;
+let a = Test2.A;; (* fail *)
+(* The following should fail from a semantical point of view,
+   but allow it for backward compatibility *)
+module Test2 : module type of Test with type t = private Test.t = Test;;
+
+(* PR#6331 *)
+type t = private < x : int; .. > as 'a;;
+type t = private (< x : int; .. > as 'a) as 'a;;
+type t = private < x : int > as 'a;;
+type t = private (< x : int > as 'a) as 'b;;
+type 'a t = private < x : int; .. > as 'a;;
+type 'a t = private 'a constraint 'a = < x : int; .. >;;
+(* Bad (t = t) *)
+module rec A : sig type t = A.t end = struct type t = A.t end;;
+(* Bad (t = t) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* OK (t = int) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = int end = struct type t = int end;;
+(* Bad (t = int * t) *)
+module rec A : sig type t = int * A.t end = struct type t = int * A.t end;;
+(* Bad (t = t -> int) *)
+module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* OK (t = <m:t>) *)
+module rec A : sig type t = <m:B.t> end = struct type t = <m:B.t> end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = <m: 'a list A.t> end
+             = struct type 'a t = <m: 'a list A.t> end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = <m: 'a list B.t; n: 'a array B.t> end
+             = struct type 'a t = <m: 'a list B.t; n: 'a array B.t> end
+       and B : sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a B.t end
+             = struct type 'a t = 'a B.t end
+       and B : sig type 'a t = <m: 'a list A.t; n: 'a array A.t> end
+             = struct type 'a t = <m: 'a list A.t; n: 'a array A.t> end;;
+(* OK *)
+module rec A : sig type 'a t = 'a array B.t * 'a list B.t end
+             = struct type 'a t = 'a array B.t * 'a list B.t end
+       and B : sig type 'a t = <m: 'a B.t> end
+             = struct type 'a t = <m: 'a B.t> end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a list B.t end
+             = struct type 'a t = 'a list B.t end
+       and B : sig type 'a t = <m: 'a array B.t> end
+             = struct type 'a t = <m: 'a array B.t> end;;
+(* Bad (not regular) *)
+module rec M :
+    sig
+      class ['a] c : 'a -> object
+        method map : ('a -> 'b) -> 'b M.c
+      end
+    end
+  = struct
+      class ['a] c (x : 'a) = object
+        method map : 'b. ('a -> 'b) -> 'b M.c
+          = fun f -> new M.c (f x)
+      end
+    end;;
+(* OK *)
+class type [ 'node ] extension = object method node : 'node end
+and [ 'ext ] node = object constraint 'ext = 'ext node #extension [@id] end
+class x = object method node : x node = assert false end
+type t = x node;;
+(* Bad - PR 4261 *)
+
+module PR_4261 = struct
+  module type S =
+  sig
+    type t
+  end
+
+  module type T =
+  sig
+    module D : S
+    type t = D.t
+  end
+
+  module rec U : T with module D = U' = U
+  and U' : S with type t = U'.t = U
+end;;
+(* Bad - PR 4512 *)
+module type S' = sig type t = int end
+module rec M : S' with type t = M.t = struct type t = M.t end;;
+(* PR#4450 *)
+
+module PR_4450_1 = struct
+  module type MyT = sig type 'a t = Succ of 'a t end
+  module MyMap(X : MyT) = X
+  module rec MyList : MyT = MyMap(MyList)
+end;;
+
+module PR_4450_2 = struct
+  module type MyT = sig
+    type 'a wrap = My of 'a t
+    and 'a t = private < map : 'b. ('a -> 'b) ->'b wrap; .. >
+    val create : 'a list -> 'a t
+  end
+  module MyMap(X : MyT) = struct
+    include X
+    class ['a] c l = object (self)
+      method map : 'b. ('a -> 'b) -> 'b wrap =
+        fun f -> My (create (List.map f l))
+    end
+  end
+  module rec MyList : sig
+    type 'a wrap = My of 'a t
+    and 'a t = < map : 'b. ('a -> 'b) ->'b wrap >
+    val create : 'a list -> 'a t
+  end = struct
+    include MyMap(MyList)
+    let create l = new c l
+  end
+end;;
+(* A synthetic example of bootstrapped data structure
+   (suggested by J-C Filliatre) *)
+
+module type ORD = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type SET = sig
+  type elt
+  type t
+  val iter : (elt -> unit) -> t -> unit
+end
+
+type 'a tree = E | N of 'a tree * 'a * 'a tree
+
+module Bootstrap2
+  (MakeDiet : functor (X: ORD) -> SET with type t = X.t tree and type elt = X.t)
+  : SET with type elt = int =
+struct
+
+  type elt = int
+
+  module rec Elt : sig
+    type t = I of int * int | D of int * Diet.t * int
+    val compare : t -> t -> int
+    val iter : (int -> unit) -> t -> unit
+  end =
+  struct
+    type t = I of int * int | D of int * Diet.t * int
+    let compare x1 x2 = 0
+    let rec iter f = function
+      | I (l, r) -> for i = l to r do f i done
+      | D (_, d, _) -> Diet.iter (iter f) d
+  end
+
+  and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt)
+
+  type t = Diet.t
+  let iter f = Diet.iter (Elt.iter f)
+end
+(* PR 4470: simplified from OMake's sources *)
+
+module rec DirElt
+  : sig
+      type t = DirRoot | DirSub of DirHash.t
+    end
+  = struct
+      type t = DirRoot | DirSub of DirHash.t
+    end
+
+and DirCompare
+  : sig
+      type t = DirElt.t
+    end
+  = struct
+      type t = DirElt.t
+    end
+
+and DirHash
+  : sig
+      type t = DirElt.t list
+    end
+  = struct
+      type t = DirCompare.t list
+    end
+(* PR 4758, PR 4266 *)
+
+module PR_4758 = struct
+  module type S = sig end
+  module type Mod = sig
+    module Other : S
+  end
+  module rec A : S = struct end
+  and C : sig include Mod with module Other = A end = struct
+    module Other = A
+  end
+  module C' = C  (* check that we can take an alias *)
+  module F(X:sig end) = struct type t end
+  let f (x : F(C).t) = (x : F(C').t)
+end
+(* PR 4557 *)
+module PR_4557 = struct
+  module F ( X : Set.OrderedType ) = struct
+    module rec Mod : sig
+      module XSet :
+        sig
+          type elt = X.t
+          type t = Set.Make( X ).t
+        end
+      module XMap :
+        sig
+          type key = X.t
+          type 'a t = 'a Map.Make(X).t
+        end
+      type elt = X.t
+      type t = XSet.t XMap.t
+      val compare: t -> t -> int
+    end
+       =
+    struct
+      module XSet = Set.Make( X )
+      module XMap = Map.Make( X )
+
+      type elt = X.t
+      type t = XSet.t XMap.t
+      let compare = (fun x y -> 0)
+    end
+    and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+  end
+end
+module F ( X : Set.OrderedType ) = struct
+  module rec Mod : sig
+    module XSet :
+      sig
+        type elt = X.t
+        type t = Set.Make( X ).t
+      end
+    module XMap :
+      sig
+        type key = X.t
+        type 'a t = 'a Map.Make(X).t
+      end
+    type elt = X.t
+    type t = XSet.t XMap.t
+    val compare: t -> t -> int
+  end
+     =
+  struct
+    module XSet = Set.Make( X )
+    module XMap = Map.Make( X )
+
+    type elt = X.t
+    type t = XSet.t XMap.t
+    let compare = (fun x y -> 0)
+  end
+  and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+end
+(* Tests for recursive modules *)
+
+let test number result expected =
+  if result = expected
+  then Printf.printf "Test %d passed.\n" number
+  else Printf.printf "Test %d FAILED.\n" number;
+  flush stdout
+
+(* Tree of sets *)
+
+module rec A
+ : sig
+     type t = Leaf of int | Node of ASet.t
+     val compare: t -> t -> int
+   end
+ = struct
+     type t = Leaf of int | Node of ASet.t
+     let compare x y =
+       match (x,y) with
+         (Leaf i, Leaf j) -> Pervasives.compare i j
+       | (Leaf i, Node t) -> -1
+       | (Node s, Leaf j) -> 1
+       | (Node s, Node t) -> ASet.compare s t
+   end
+
+and ASet : Set.S with type elt = A.t = Set.Make(A)
+;;
+
+let _ =
+  let x = A.Node (ASet.add (A.Leaf 3) (ASet.singleton (A.Leaf 2))) in
+  let y = A.Node (ASet.add (A.Leaf 1) (ASet.singleton x)) in
+  test 10 (A.compare x x) 0;
+  test 11 (A.compare x (A.Leaf 3)) 1;
+  test 12 (A.compare (A.Leaf 0) x) (-1);
+  test 13 (A.compare y y) 0;
+  test 14 (A.compare x y) 1
+;;
+
+(* Simple value recursion *)
+
+module rec Fib
+  : sig val f : int -> int end
+  = struct let f x = if x < 2 then 1 else Fib.f(x-1) + Fib.f(x-2) end
+;;
+
+let _ =
+  test 20 (Fib.f 10) 89
+;;
+
+(* Update function by infix *)
+
+module rec Fib2
+  : sig val f : int -> int end
+  = struct let rec g x = Fib2.f(x-1) + Fib2.f(x-2)
+               and f x = if x < 2 then 1 else g x
+    end
+;;
+
+let _ =
+  test 21 (Fib2.f 10) 89
+;;
+
+(* Early application *)
+
+let _ =
+  let res =
+    try
+      let module A =
+        struct
+          module rec Bad
+            : sig val f : int -> int end
+            = struct let f = let y = Bad.f 5 in fun x -> x+y end
+          end in
+      false
+    with Undefined_recursive_module _ ->
+      true in
+  test 30 res true
+;;
+
+(* Early strict evaluation *)
+
+(*
+module rec Cyclic
+  : sig val x : int end
+  = struct let x = Cyclic.x + 1 end
+;;
+*)
+
+(* Reordering of evaluation based on dependencies *)
+
+module rec After
+  : sig val x : int end
+  = struct let x = Before.x + 1 end
+and Before
+  : sig val x : int end
+  = struct let x = 3 end
+;;
+
+let _ =
+  test 40 After.x 4
+;;
+
+(* Type identity between A.t and t within A's definition *)
+
+module rec Strengthen
+  : sig type t val f : t -> t end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen.t)
+      let f x = if true then A else Strengthen.f B
+    end
+;;
+
+module rec Strengthen2
+  : sig type t
+        val f : t -> t
+        module M : sig type u end
+        module R : sig type v end
+    end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen2.t)
+      let f x = if true then A else Strengthen2.f B
+      module M =
+        struct
+          type u = C
+          let _ = (C: Strengthen2.M.u)
+        end
+      module rec R : sig type v  = Strengthen2.R.v end =
+        struct
+          type v = D
+          let _ = (D : R.v)
+          let _ = (D : Strengthen2.R.v)
+        end
+    end
+;;
+
+(* Polymorphic recursion *)
+
+module rec PolyRec
+  : sig
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      val depth: 'a t -> int
+    end
+  = struct
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      let x = (PolyRec.Leaf 1 : int t)
+      let depth = function
+        Leaf x -> 0
+      | Node(l,r) -> 1 + max (PolyRec.depth l) (PolyRec.depth r)
+    end
+;;
+
+(* Wrong LHS signatures (PR#4336) *)
+
+(*
+module type ASig = sig type a val a:a val print:a -> unit end
+module type BSig = sig type b val b:b val print:b -> unit end
+
+module A = struct type a = int let a = 0 let print = print_int end
+module B = struct type b = float let b = 0.0 let print = print_float end
+
+module MakeA (Empty:sig end) : ASig = A
+module MakeB (Empty:sig end) : BSig = B
+
+module
+   rec NewA : ASig = MakeA (struct end)
+   and NewB : BSig with type b = NewA.a = MakeB (struct end);;
+
+*)
+
+(* Expressions and bindings *)
+
+module StringSet = Set.Make(String);;
+
+module rec Expr
+  : sig
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      val make_let: string -> t -> t -> t
+      val fv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      let make_let id e1 e2 = Binding([id, e1], e2)
+      let rec fv = function
+        Var s -> StringSet.singleton s
+      | Const n -> StringSet.empty
+      | Add(t1,t2) -> StringSet.union (fv t1) (fv t2)
+      | Binding(b,t) ->
+          StringSet.union (Binding.fv b)
+            (StringSet.diff (fv t) (Binding.bv b))
+      let rec simpl = function
+        Var s -> Var s
+      | Const n -> Const n
+      | Add(Const i, Const j) -> Const (i+j)
+      | Add(Const 0, t) -> simpl t
+      | Add(t, Const 0) -> simpl t
+      | Add(t1,t2) -> Add(simpl t1, simpl t2)
+      | Binding(b, t) -> Binding(Binding.simpl b, simpl t)
+    end
+
+and Binding
+  : sig
+      type t = (string * Expr.t) list
+      val fv: t -> StringSet.t
+      val bv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t = (string * Expr.t) list
+      let fv b =
+        List.fold_left (fun v (id,e) -> StringSet.union v (Expr.fv e))
+                       StringSet.empty b
+      let bv b =
+        List.fold_left (fun v (id,e) -> StringSet.add id v)
+                       StringSet.empty b
+      let simpl b =
+        List.map (fun (id,e) -> (id, Expr.simpl e)) b
+    end
+;;
+
+let _ =
+  let e = Expr.make_let "x" (Expr.Add (Expr.Var "y", Expr.Const 0))
+                            (Expr.Var "x") in
+  let e' = Expr.make_let "x" (Expr.Var "y") (Expr.Var "x") in
+  test 50 (StringSet.elements (Expr.fv e)) ["y"];
+  test 51 (Expr.simpl e) e'
+;;
+
+(* Okasaki's bootstrapping *)
+
+module type ORDERED =
+  sig
+    type t
+    val eq: t -> t -> bool
+    val lt: t -> t -> bool
+    val leq: t -> t -> bool
+  end
+
+module type HEAP =
+  sig
+    module Elem: ORDERED
+    type heap
+    val empty: heap
+    val isEmpty: heap -> bool
+    val insert: Elem.t -> heap -> heap
+    val merge: heap -> heap -> heap
+    val findMin: heap -> Elem.t
+    val deleteMin: heap -> heap
+  end
+
+module Bootstrap (MakeH: functor (Element:ORDERED) ->
+                                    HEAP with module Elem = Element)
+                 (Element: ORDERED) : HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    module rec BE
+    : sig type t = E | H of Elem.t * PrimH.heap
+          val eq: t -> t -> bool
+          val lt: t -> t -> bool
+          val leq: t -> t -> bool
+      end
+    = struct
+        type t = E | H of Elem.t * PrimH.heap
+        let leq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.leq x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> true
+        let eq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.eq x y
+          | H _, E -> false
+          | E, H _ -> false
+          | E, E -> true
+        let lt t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.lt x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> false
+      end
+    and PrimH
+    : HEAP with type Elem.t = BE.t
+    = MakeH(BE)
+    type heap = BE.t
+    let empty = BE.E
+    let isEmpty = function BE.E -> true | _ -> false
+    let rec merge x y =
+      match (x,y) with
+        (BE.E, _) -> y
+      | (_, BE.E) -> x
+      | (BE.H(e1,p1) as h1), (BE.H(e2,p2) as h2) ->
+          if Elem.leq e1 e2
+          then BE.H(e1, PrimH.insert h2 p1)
+          else BE.H(e2, PrimH.insert h1 p2)
+    let insert x h =
+      merge (BE.H(x, PrimH.empty)) h
+    let findMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, _) -> x
+    let deleteMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, p) ->
+          if PrimH.isEmpty p then BE.E else begin
+            match PrimH.findMin p with
+            | (BE.H(y, p1)) ->
+              let p2 = PrimH.deleteMin p in
+              BE.H(y, PrimH.merge p1 p2)
+            | BE.E -> assert false
+          end
+  end
+;;
+
+module LeftistHeap(Element: ORDERED): HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    type heap = E | T of int * Elem.t * heap * heap
+    let rank = function E -> 0 | T(r,_,_,_) -> r
+    let make x a b =
+      if rank a >= rank b
+      then T(rank b + 1, x, a, b)
+      else T(rank a + 1, x, b, a)
+    let empty = E
+    let isEmpty = function E -> true | _ -> false
+    let rec merge h1 h2 =
+      match (h1, h2) with
+        (_, E) -> h1
+      | (E, _) -> h2
+      | (T(_, x1, a1, b1), T(_, x2, a2, b2)) ->
+          if Elem.leq x1 x2
+          then make x1 a1 (merge b1 h2)
+          else make x2 a2 (merge h1 b2)
+    let insert x h = merge (T(1, x, E, E)) h
+    let findMin = function
+      E -> raise Not_found
+    | T(_, x, _, _) -> x
+    let deleteMin = function
+      E -> raise Not_found
+    | T(_, x, a, b) -> merge a b
+  end
+;;
+
+module Ints =
+  struct
+    type t = int
+    let eq = (=)
+    let lt = (<)
+    let leq = (<=)
+  end
+;;
+
+module C = Bootstrap(LeftistHeap)(Ints);;
+
+let _ =
+  let h = List.fold_right C.insert [6;4;8;7;3;1] C.empty in
+  test 60 (C.findMin h) 1;
+  test 61 (C.findMin (C.deleteMin h)) 3;
+  test 62 (C.findMin (C.deleteMin (C.deleteMin h))) 4
+;;
+
+(* Classes *)
+
+module rec Class1
+  : sig
+      class c : object method m : int -> int end
+    end
+  = struct
+      class c =
+        object
+          method m x = if x <= 0 then x else (new Class2.d)#m x
+        end
+    end
+and Class2
+  : sig
+      class d : object method m : int -> int end
+    end
+  = struct
+      class d =
+        object(self)
+          inherit Class1.c as super
+          method m (x:int) = super#m 0
+        end
+    end
+;;
+
+let _ =
+  test 70 ((new Class1.c)#m 7) 0
+;;
+
+let _ =
+  try
+    let module A = struct
+       module rec BadClass1
+         : sig
+             class c : object method m : int end
+           end
+         = struct
+             class c = object method m = 123 end
+           end
+       and BadClass2
+         : sig
+             val x: int
+           end
+         = struct
+             let x = (new BadClass1.c)#m
+           end
+    end in
+      test 71 true false
+  with Undefined_recursive_module _ ->
+    test 71 true true
+;;
+
+(* Coercions *)
+
+module rec Coerce1
+  : sig
+      val g: int -> int
+      val f: int -> int
+    end
+  = struct
+      module A = (Coerce1: sig val f: int -> int end)
+      let g x = x
+      let f x = if x <= 0 then 1 else A.f (x-1) * x
+    end
+;;
+
+let _ =
+  test 80 (Coerce1.f 10) 3628800
+;;
+
+module CoerceF(S: sig end) = struct
+  let f1 () = 1
+  let f2 () = 2
+  let f3 () = 3
+  let f4 () = 4
+  let f5 () = 5
+end
+
+module rec Coerce2: sig val f1: unit -> int end = CoerceF(Coerce3)
+       and Coerce3: sig end = struct end
+;;
+
+let _ =
+  test 81 (Coerce2.f1 ()) 1
+;;
+
+module Coerce4(A : sig val f : int -> int end) = struct
+  let x = 0
+  let at a = A.f a
+end
+
+module rec Coerce5
+  : sig val blabla: int -> int val f: int -> int end
+  = struct let blabla x = 0 let f x = 5 end
+and Coerce6
+  : sig val at: int -> int end
+  = Coerce4(Coerce5)
+
+let _ =
+  test 82 (Coerce6.at 100) 5
+;;
+
+(* Miscellaneous bug reports *)
+
+module rec F
+  : sig type t = X of int | Y of int
+        val f: t -> bool
+    end
+  = struct
+      type t = X of int | Y of int
+      let f = function
+        | X _ -> false
+        | _ -> true
+    end;;
+
+let _ =
+  test 100 (F.f (F.X 1)) false;
+  test 101 (F.f (F.Y 2)) true
+
+(* PR#4316 *)
+module G(S : sig val x : int Lazy.t end) = struct include S end
+
+module M1 = struct let x = lazy 3 end
+
+let _ = Lazy.force M1.x
+
+module rec M2 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 102 (Lazy.force M2.x) 3
+
+let _ = Gc.full_major()   (* will shortcut forwarding in M1.x *)
+
+module rec M3 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 103 (Lazy.force M3.x) 3
+
+
+(** Pure type-checking tests: see recmod/*.ml  *)
+type t = A of {x:int; mutable y:int};;
+let f (A r) = r;;  (* -> escape *)
+let f (A r) = r.x;; (* ok *)
+let f x = A {x; y = x};; (* ok *)
+let f (A r) = A {r with y = r.x + 1};; (* ok *)
+let f () = A {a = 1};; (* customized error message *)
+let f () = A {x = 1; y = 3};; (* ok *)
+
+type _ t = A: {x : 'a; y : 'b} -> 'a t;;
+let f (A {x; y}) = A {x; y = ()};;  (* ok *)
+let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *)
+
+module M = struct
+  type 'a t =
+    | A of {x : 'a}
+    | B: {u : 'b} -> unit t;;
+
+  exception Foo of {x : int};;
+end;;
+
+module N : sig
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'bla} -> unit t
+
+  exception Foo of {x : int}
+end = struct
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'z} -> unit t
+
+  exception Foo = M.Foo
+end;;
+
+
+module type S = sig exception A of {x:int}  end;;
+
+module F (X : sig val x : (module S) end) = struct
+  module A = (val X.x)
+end;;  (* -> this expression creates fresh types (not really!) *)
+
+
+module type S = sig
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+module M = struct
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+
+module M1 = struct
+  exception A of {x : int}
+end;;
+
+module M = struct
+  include M1
+  include M1
+end;;
+
+
+module type S1 = sig
+  exception A of {x : int}
+end;;
+
+module type S = sig
+  include S1
+  include S1
+end;;
+
+module M = struct
+  exception A = M1.A
+end;;
+
+module X1 = struct
+  type t = ..
+end;;
+module X2 = struct
+  type t = ..
+end;;
+module Z = struct
+  type X1.t += A of {x: int}
+  type X2.t += A of {x: int}
+end;;
+
+(* PR#6716 *)
+
+type _ c = C : [`A] c
+type t = T : {x:[<`A] c} -> t;;
+let f (T { x = C }) = ();;
+module M : sig
+  type 'a t
+  type u = u t and v = v t
+  val f : int -> u
+  val g : v -> bool
+end = struct
+  type 'a t = 'a
+  type u = int and v = bool
+  let f x = x
+  let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+module type T = sig type 'a t end
+module Fix (T : T) = struct type r = ('r T.t as 'r) end
+ type _ t =
+     X of string
+   | Y : bytes t
+
+let y : string t = Y
+let f : string A.t -> unit = function
+    A.X s -> print_endline s
+
+let () = f A.y
+module rec A : sig
+ type t
+end = struct
+ type t = { a : unit; b : unit }
+ let _ = { a = () }
+end
+;;
+type t = [`A | `B];;
+type 'a u = t;;
+let a : [< int u] = `A;;
+
+type 'a s = 'a;;
+let b : [< t s] = `B;;
+module Core = struct
+  module Int = struct
+    module T = struct
+      type t = int
+      let compare = compare
+      let (+) x y = x + y
+    end
+    include T
+    module Map = Map.Make(T)
+  end
+
+  module Std = struct
+    module Int = Int
+  end
+end
+;;
+
+open Core.Std
+;;
+
+let x = Int.Map.empty ;;
+let y = x + x ;;
+
+(* Avoid ambiguity *)
+
+module M = struct type t = A type u = C end
+module N = struct type t = B end
+open M open N;;
+A;;
+B;;
+C;;
+
+include M open M;;
+C;;
+
+module L = struct type v = V end
+open L;;
+V;;
+module L = struct type v = V end
+open L;;
+V;;
+
+
+type t1 = A;;
+module M1 = struct type u = v and v = t1 end;;
+module N1 = struct type u = v and v = M1.v end;;
+type t1 = B;;
+module N2 = struct type u = v and v = M1.v end;;
+
+
+(* PR#6566 *)
+module type PR6566 = sig type t = string end;;
+module PR6566 = struct type t = int end;;
+module PR6566' : PR6566 = PR6566;;
+
+module A = struct module B = struct type t = T end end;;
+module M2 = struct type u = A.B.t type foo = int type v = A.B.t end;;
+(* Adapted from: An Expressive Language of Signatures
+   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+
+module type VALUE = sig
+  type value (* a Lua value *)
+  type state (* the state of a Lua interpreter *)
+  type usert (* a user-defined value *)
+end;;
+
+module type CORE0 = sig
+  module V : VALUE
+  val setglobal : V.state -> string -> V.value -> unit
+  (* five more functions common to core and evaluator *)
+end;;
+
+module type CORE = sig
+  include CORE0
+  val apply : V.value -> V.state -> V.value list -> V.value
+  (* apply function f in state s to list of args *)
+end;;
+
+module type AST = sig
+  module Value : VALUE
+  type chunk
+  type program
+  val get_value : chunk -> Value.value
+end;;
+
+module type EVALUATOR = sig
+  module Value : VALUE
+  module Ast : (AST with module Value := Value)
+  type state = Value.state
+  type value = Value.value
+  exception Error of string
+  val compile : Ast.program -> string
+  include CORE0 with module V := Value
+end;;
+
+module type PARSER = sig
+  type chunk
+  val parse : string -> chunk
+end;;
+
+module type INTERP = sig
+  include EVALUATOR
+  module Parser : PARSER with type chunk = Ast.chunk
+  val dostring : state -> string -> value list
+  val mk : unit -> state
+end;;
+
+module type USERTYPE = sig
+  type t
+  val eq : t -> t -> bool
+  val to_string : t -> string
+end;;
+
+module type TYPEVIEW = sig
+  type combined
+  type t
+  val map : (combined -> t) * (t -> combined)
+end;;
+
+module type COMBINED_COMMON = sig
+  module T : sig type t end
+  module TV1 : TYPEVIEW with type combined := T.t
+  module TV2 : TYPEVIEW with type combined := T.t
+end;;
+
+module type COMBINED_TYPE = sig
+  module T : USERTYPE
+  include COMBINED_COMMON with module T := T
+end;;
+
+module type BARECODE = sig
+  type state
+  val init : state -> unit
+end;;
+
+module USERCODE(X : TYPEVIEW) = struct
+  module type F =
+      functor (C : CORE with type V.usert = X.combined) ->
+        BARECODE with type state := C.V.state
+end;;
+
+module Weapon = struct type t end;;
+
+module type WEAPON_LIB = sig
+  type t = Weapon.t
+  module T : USERTYPE with type t = t
+  module Make :
+    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
+end;;
+
+module type X = functor (X: CORE) -> BARECODE;;
+module type X = functor (_: CORE) -> BARECODE;;
+module M = struct
+  type t = int * (< m : 'a > as 'a)
+end;;
+
+module type S =
+    sig module M : sig type t end end with module M = M
+;;
+module type Printable = sig
+  type t
+  val print : Format.formatter -> t -> unit
+end;;
+module type Comparable = sig
+  type t
+  val compare : t -> t -> int
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t = t
+end;; (* Fails *)
+module type PrintableComparable = sig
+  type t
+  include Printable with type t := t
+  include Comparable with type t := t
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t := t
+end;;
+module type ComparableInt = Comparable with type t := int;;
+module type S = sig type t val f : t -> t end;;
+module type S' = S with type t := int;;
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
+module type S1 = S with type 'a t := 'a list;;
+module type S2 = sig
+  type 'a dict = (string * 'a) list
+  include S with type 'a t := 'a dict
+end;;
+
+
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
+module M = struct type exp = string type arg = int end;;
+module type S' = S with module T := M;;
+
+
+module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
+let property (type t) () =
+  let module M = struct exception E of t end in
+  (fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+;;
+
+let () =
+  let (int_inj, int_proj) = property () in
+  let (string_inj, string_proj) = property () in
+
+  let i = int_inj 3 in
+  let s = string_inj "abc" in
+
+  Printf.printf "%b\n%!" (int_proj i = None);
+  Printf.printf "%b\n%!" (int_proj s = None);
+  Printf.printf "%b\n%!" (string_proj i = None);
+  Printf.printf "%b\n%!" (string_proj s = None)
+;;
+
+let sort_uniq (type s) cmp l =
+  let module S = Set.Make(struct type t = s let compare = cmp end) in
+  S.elements (List.fold_right S.add l S.empty)
+;;
+
+let () =
+  print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ]))
+;;
+
+let f x (type a) (y : a) = (x = y);; (* Fails *)
+class ['a] c = object (self)
+  method m : 'a -> 'a = fun x -> x
+  method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
+end;; (* Fails *)
+
+external a : (int [@untagged]) -> unit = "a" "a_nat"
+external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
+external c : (int64 [@unboxed]) -> unit = "c" "c_nat"
+external d : (nativeint [@unboxed]) -> unit = "d" "d_nat"
+external e : (float [@unboxed]) -> unit = "e" "e_nat"
+
+type t = private int
+
+external f : (t [@untagged]) -> unit = "f" "f_nat"
+
+module M : sig
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end = struct
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end;;
+
+module Global_attributes = struct
+  [@@@ocaml.warning "-3"]
+
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  external b : float -> float = "b" "noalloc" "b_nat"
+  external c : float -> float = "c" "c_nat" "float"
+  external d : float -> float = "d" "noalloc"
+  external e : float -> float = "e"
+
+  (* Should output a warning: no native implementation provided *)
+  external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
+  external g : int32 -> int32 = "g" "g_nat" [@@unboxed] [@@noalloc]
+
+  external h : (int [@untagged]) -> (int [@untagged]) = "h" "h_nat" "noalloc"
+  external i : int -> int = "i" "i_nat" [@@untagged] [@@noalloc]
+end;;
+
+module Old_style_warning = struct
+  [@@@ocaml.warning "+3"]
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  external b : float -> float = "b" "noalloc" "b_nat"
+  external c : float -> float = "c" "c_nat" "float"
+  external d : float -> float = "d" "noalloc"
+  external e : float -> float = "c" "float"
+end
+
+(* Bad: attributes not reported in the interface *)
+
+module Bad1 : sig
+  external f : int -> int = "f" "f_nat"
+end = struct
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end;;
+
+module Bad2 : sig
+  external f : int -> int = "a" "a_nat"
+end = struct
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end;;
+
+module Bad3 : sig
+  external f : float -> float = "f" "f_nat"
+end = struct
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end;;
+
+module Bad4 : sig
+  external f : float -> float = "a" "a_nat"
+end = struct
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end;;
+
+(* Bad: attributes in the interface but not in the implementation *)
+
+module Bad5 : sig
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end = struct
+  external f : int -> int = "f" "f_nat"
+end;;
+
+module Bad6 : sig
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end = struct
+  external f : int -> int = "a" "a_nat"
+end;;
+
+module Bad7 : sig
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end = struct
+  external f : float -> float = "f" "f_nat"
+end;;
+
+module Bad8 : sig
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end = struct
+  external f : float -> float = "a" "a_nat"
+end;;
+
+(* Bad: unboxed or untagged with the wrong type *)
+
+external g : (float [@untagged]) -> float = "g" "g_nat";;
+external h : (int [@unboxed]) -> float = "h" "h_nat";;
+
+(* Bad: unboxing the function type *)
+external i : int -> float [@unboxed] = "i" "i_nat";;
+
+(* Bad: unboxing a "deep" sub-type. *)
+external j : int -> (float [@unboxed]) * float = "j" "j_nat";;
+
+(* This should be rejected, but it is quite complicated to do
+   in the current state of things *)
+
+external k : int -> (float [@unboxd]) = "k" "k_nat";;
+
+(* Bad: old style annotations + new style attributes *)
+
+external l : float -> float = "l" "l_nat" "float" [@@unboxed];;
+external m : (float [@unboxed]) -> float = "m" "m_nat" "float";;
+external n : float -> float = "n" "noalloc" [@@noalloc];;
+
+(* Warnings: unboxed / untagged without any native implementation *)
+external o : (float[@unboxed]) -> float = "o";;
+external p : float -> (float[@unboxed]) = "p";;
+external q : (int[@untagged]) -> float = "q";;
+external r : int -> (int[@untagged]) = "r";;
+external s : int -> int = "s" [@@untagged];;
+external t : float -> float = "t" [@@unboxed];;
+let _ = ignore (+);;
+let _ = raise Exit 3;;
+(* comment 9644 of PR#6000 *)
+
+fun b -> if b then format_of_string "x" else "y";;
+fun b -> if b then "x" else format_of_string "y";;
+fun b : (_,_,_) format -> if b then "x" else "y";;
+
+(* PR#7135 *)
+
+module PR7135 = struct
+  module M : sig type t = private int end =  struct type t = int end
+  include M
+
+  let lift2 (f : int -> int -> int) (x : t) (y : t) =
+    f (x :> int) (y :> int)
+end;;
+
+(* exemple of non-ground coercion *)
+
+module Test1 = struct
+  type t = private int
+  let f x = let y = if true then x else (x:t) in (y :> int)
+end;;
+(* Warn about all relevant cases when possible *)
+let f = function
+    None, None -> 1
+  | Some _, Some _ -> 2;;
+
+(* Exhaustiveness check is very slow *)
+type _ t =
+  A : int t | B : bool t | C : char t | D : float t
+type (_,_,_,_) u = U : (int, int, int, int) u
+type v = E | F | G
+;;
+
+let f : type a b c d e f g.
+      a t * b t * c t * d t * e t * f t * g t * v
+       * (a,b,c,d) u * (e,f,g,g) u -> int =
+ function A, A, A, A, A, A, A, _, U, U -> 1
+   | _, _, _, _, _, _, _, G, _, _ -> 1
+   (*| _ -> _ *)
+;;
+
+(* Unused cases *)
+let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
+let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
+let f (x : int t option) = match x with None -> 1 | _ -> 2;;
+let f (x : int t option) = match x with None -> 1;; (* warn *)
+
+(* Example with record, type, single case *)
+
+type 'a box = Box of 'a
+type 'a pair = {left: 'a; right: 'a};;
+
+let f : (int t box pair * bool) option -> unit = function None -> ();;
+let f : (string t box pair * bool) option -> unit = function None -> ();;
+
+
+(* Examples from ML2015 paper *)
+
+type _ t =
+  | Int : int t
+  | Bool : bool t
+;;
+
+let f : type a. a t -> a = function
+  | Int -> 1
+  | Bool -> true
+;;
+let g : int t -> int = function
+  | Int -> 1
+;;
+let h : type a. a t -> a t -> bool =
+  fun x y -> match x, y with
+  | Int, Int -> true
+  | Bool, Bool -> true
+;;
+type (_, _) cmp =
+ | Eq : ('a, 'a) cmp
+ | Any: ('a, 'b) cmp
+module A : sig type a type b val eq : (a, b) cmp end
+  = struct type a type b = a let eq = Eq end
+;;
+let f : (A.a, A.b) cmp -> unit = function Any -> ()
+;;
+let deep : char t option -> char =
+  function None -> 'c'
+;;
+type zero = Zero
+type _ succ = Succ
+;;
+type (_,_,_) plus =
+  | Plus0 : (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus ->
+       ('a succ, 'b, 'c succ) plus
+;;
+let trivial : (zero succ, zero, zero) plus option -> bool =
+  function None -> false
+;;
+let easy : (zero, zero succ, zero) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option  -> bool =
+  function None -> false | Some (PlusS _) -> .
+;;
+let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool =
+  fun p1 p2 ->
+    match p1, p2 with
+    | Plus0, Plus0 -> true
+;;
+
+
+(* Empty match *)
+
+type _ t = Int : int t;;
+let f (x : bool t) = match x with _ -> . ;; (* ok *)
+
+
+(* trefis in PR#6437 *)
+
+let f () = match None with _ -> .;; (* error *)
+let g () = match None with _ -> () | exception _ -> .;; (* error *)
+let h () = match None with _ -> .  | exception _ -> .;; (* error *)
+let f x = match x with _ -> () | None -> .;; (* do not warn *)
+
+(* #7059, all clauses guarded *)
+
+let f x y = match 1 with 1 when x = y -> 1;;
+open CamlinternalOO;;
+type _ choice = Left : label choice | Right : tag choice;;
+let f : label choice -> bool = function Left -> true;; (* warn *)
+exception A;;
+type a = A;;
+
+A;;
+raise A;;
+fun (A : a) -> ();;
+function Not_found -> 1 | A -> 2 | _ -> 3;;
+try raise A with A -> 2;;
+module TypEq = struct
+ type (_, _) t = Eq : ('a, 'a) t
+end
+
+module type T = sig
+ type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
+ val is_t : unit -> unit is_t option
+end
+
+module Make (M : T) =
+ struct
+   let _ =
+     match M.is_t () with
+     | None -> 0
+     | Some _ -> 0
+   let f () =
+     match M.is_t () with None -> 0
+end;;
+
+module Make2 (M : T) = struct
+  type t = T of unit M.is_t
+  let g : t -> int = function _ -> .
+end;;
+type t = A : t;;
+
+module X1 : sig end = struct
+  let _f ~x (* x unused argument *) = function
+    | A -> let x = () in x
+end;;
+
+module X2 : sig end = struct
+  let x = 42 (* unused value *)
+  let _f = function
+    | A -> let x = () in x
+end;;
+
+module X3 : sig end = struct
+  module O = struct let x = 42 (* unused *) end
+  open O (* unused open *)
+
+  let _f = function
+    | A -> let x = () in x
+end;;
+(* Use type information *)
+module M1 = struct
+  type t = {x: int; y: int}
+  type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+  open M1
+  let f1 (r:t) = r.x (* ok *)
+  let f2 r = ignore (r:t); r.x (* non principal *)
+
+  let f3 (r: t) =
+    match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+  open M1
+  let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+  open M1
+  let f r =
+    ignore (r: t);
+    match r with
+       {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+  type t = {x:int}
+  type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+let f ({x}:M.t) = x;; (* warning *)
+
+module M = struct
+  type t = {x: int; y: int}
+end;;
+module N = struct
+  type u = {x: bool; y: bool}
+end;;
+module OK = struct
+  open M
+  open N
+  let f (r:M.t) = r.x
+end;;
+
+module M = struct
+  type t = {x:int}
+  module N = struct type s = t = {x:int} end
+  type u = {x:bool}
+end;;
+module OK = struct
+  open M.N
+  let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+  type u = {x:bool;y:int;z:char}
+  type t = {x:int;y:bool}
+end;;
+module OK = struct
+  open M
+  let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+  open M
+  let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+  type u = {x:int;y:bool}
+  type t = {x:bool;y:int;z:char}
+  let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+  type foo = {x:int; y:int}
+  type bar = {x:int}
+  let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+  type foo = { x: int; y: int }
+  type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+  open M
+  let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+  include M
+  type other = { a: int; b: int }
+end;;
+module F6 = struct
+  open M
+  let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+  open M
+  let r = {x=1; y=2}
+  let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+  type t = {x:int; yyy:int}
+  let a : t = {x=1;yyz=2}
+end;;
+
+(* PR#6004 *)
+
+type t = A
+type s = A
+
+class f (_ : t) = object end;;
+class g = f A;; (* ok *)
+
+class f (_ : 'a) (_ : 'a) = object end;;
+class g = f (A : t) A;; (* warn with -principal *)
+
+
+(* PR#5980 *)
+
+module Shadow1 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+  let y : t = {x = 0}
+end;;
+module Shadow2 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open shadows label 'x' *)
+  let y = {x = ""}
+end;;
+
+(* PR#6235 *)
+
+module P6235 = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f (u : u) = match u with `Key {loc} -> loc
+end;;
+
+(* Remove interaction between branches *)
+
+module P6235' = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f = function
+    | (_ : u) when false -> ""
+    |`Key {loc} -> loc
+end;;
+module Unused : sig
+end = struct
+  type unused = int
+end
+;;
+
+module Unused_nonrec : sig
+end = struct
+  type nonrec used = int
+  type nonrec unused = used
+end
+;;
+
+module Unused_rec : sig
+end = struct
+  type unused = A of unused
+end
+;;
+
+module Unused_exception : sig
+end = struct
+  exception Nobody_uses_me
+end
+;;
+
+module Unused_extension_constructor : sig
+  type t = ..
+end = struct
+  type t = ..
+  type t += Nobody_uses_me
+end
+;;
+
+module Unused_exception_outside_patterns : sig
+  val falsity : exn -> bool
+end = struct
+  exception Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_extension_outside_patterns : sig
+  type t = ..
+  val falsity : t -> bool
+end = struct
+  type t = ..
+  type t += Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_private_exception : sig
+  type exn += private Private_exn
+end = struct
+  exception Private_exn
+end
+;;
+
+module Unused_private_extension : sig
+  type t = ..
+  type t += private Private_ext
+end = struct
+  type t = ..
+  type t += Private_ext
+end
+;;
+
+for i = 10 downto 0 do () done
+
+type t = < foo: int [@foo] >
+
+let _ = [%foo: < foo : t > ]
+
+type foo += private A of int
+
+let f : 'a 'b 'c. < .. > = assert false
+
+let () =
+  let module M = (functor (T : sig end) -> struct end)(struct end) in ()
+
+class c = object inherit ((fun () -> object end [@wee]: object end) ()) end
+
+
+let f = function x[@wee] -> ()
+let f = function
+  | '1'..'9' | '1' .. '8'-> ()
+  | 'a'..'z' -> ()
+
+let f = function
+  | [| x1; x2 |] -> ()
+  | [| |] -> ()
+  | [|x|][@foo] -> ()
+  | _ -> ()
+
+let g = function
+  | {l=x} -> ()
+  | {l1=x; l2=y}[@foo] -> ()
+  | {l1=x; l2=y; _} -> ()
+
+let h = fun ?l:(p=1) ?y:u ?x:(x=3) -> 2
+
+let _ = function
+  | a, s, ba1, ba2, ba3, bg -> begin
+      ignore (Array.get x 1 + Array.get [| |] 0 +
+              Array.get [| 1 |] 1 + Array.get [|1; 2|] 2);
+      ignore ([String.get s 1; String.get "" 2; String.get "123" 3]);
+      ignore (ba1.{0} + ba2.{1, 2} + ba3.{3, 4, 5})
+      ignore (bg.{1, 2, 3, 4})
+    end
+  | b, s, ba1, ba2, ba3, bg -> begin
+      y.(0) <- 1; s.[1] <- 'c';
+      ba1.{1} <- 2; ba2.{1, 2} <- 3; ba3.{1, 2, 3} <- 4;
+      bg.{1, 2, 3, 4, 5} <- 0
+    end
+
+let f (type t) () =
+  let exception F of t in ();
+  let exception G of t in ();
+  let exception E of t in
+  (fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+
+let inj1, proj1 = f ()
+let inj2, proj2 = f ()
+
+let () = proj1 (inj1 42)
+let () = proj1 (inj2 42)
+
+let _ = ~-1
+
+class id = [%exp]
+(* checkpoint *)
+
+(* Subtyping is "syntactic" *)
+let _ = fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
+(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
+
+class ['a] c () = object
+  method f = (new c (): int c)
+end and ['a] d () = object
+  inherit ['a] c ()
+end;;
+
+(* PR#7329 Pattern open *)
+let _ =
+  let module M = struct type t = { x : int } end in
+  let f M.(x) = () in
+  let g M.{x} = () in
+  let h = function M.[] | M.[a] | M.(a::q) -> () in
+  let i = function M.[||] | M.[|x|]  -> true | _ -> false in
+  ()
+
+class ['a] c () = object
+  constraint 'a = < .. > -> unit
+  method m  = (fun x -> () : 'a)
+end
+
+let f: type a'.a' = assert false
+let foo : type a' b'. a' -> b' = fun a -> assert false
+let foo : type t' . t' = fun (type t') -> (assert false : t')
+let foo : 't . 't = fun (type t) -> (assert false : t)
+let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false
+
+let f x =
+  x.contents <- (print_string "coucou" ; x.contents)
+
+let ( ~$ ) x = Some x
+let g x =
+  ~$ (x.contents)
+
+let ( ~$ ) x y = (x, y)
+let g x y =
+  ~$ (x.contents) (y.contents)
diff --git a/testsuite/tests/parsetree/test.ml b/testsuite/tests/parsetree/test.ml
new file mode 100644
index 00000000..86ed3c8c
--- /dev/null
+++ b/testsuite/tests/parsetree/test.ml
@@ -0,0 +1,108 @@
+(* (c) Alain Frisch / Lexifi *)
+(* cf. PR#7200 *)
+
+let diff =
+  match Array.to_list Sys.argv with
+  | [_; diff] -> diff
+  | _ -> "diff -u"
+
+let report_err exn =
+  match exn with
+    | Sys_error msg ->
+        Format.printf "@[I/O error:@ %s@]@." msg
+    | x ->
+        match Location.error_of_exn x with
+        | Some err ->
+            Format.printf "@[%a@]@."
+              Location.report_error err
+        | None -> raise x
+
+let remove_locs =
+  let open Ast_mapper in
+  { default_mapper with
+    location = (fun _mapper _loc -> Location.none);
+    attributes =
+      (fun mapper attrs ->
+         let attrs = default_mapper.attributes mapper attrs in
+         List.filter (fun (s, _) -> s.Location.txt <> "#punning#")
+           attrs (* this is to accomodate a LexiFi custom extension *)
+      )
+  }
+
+let from_file parse_fun filename =
+  Location.input_name := filename;
+  let ic = open_in filename in
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf filename;
+  let ast = parse_fun lexbuf in
+  close_in ic;
+  ast
+
+let from_string parse_fun str =
+  Location.input_name := "<str>";
+  let lexbuf = Lexing.from_string str in
+  Location.init lexbuf "<str>";
+  parse_fun lexbuf
+
+let to_string print_fun ast =
+  Format.fprintf Format.str_formatter "%a@." print_fun ast;
+  Format.flush_str_formatter ()
+
+let to_tmp_file print_fun ast =
+  let fn, oc = Filename.open_temp_file "ocamlparse" ".txt" in
+  output_string oc (to_string print_fun ast);
+  close_out oc;
+  fn
+
+let test parse_fun pprint print map filename =
+  match from_file parse_fun filename with
+  | exception exn ->
+      Printf.printf "%s: FAIL, CANNOT PARSE\n" filename;
+      report_err exn;
+      print_endline "====================================================="
+  | ast ->
+      let str = to_string pprint ast in
+      match from_string parse_fun str with
+      | exception exn ->
+          Printf.printf "%s: FAIL, CANNOT REPARSE\n" filename;
+          report_err exn;
+          print_endline str;
+          print_endline "====================================================="
+      | ast2 ->
+          let ast = map remove_locs remove_locs ast in
+          let ast2 = map remove_locs remove_locs ast2 in
+          if ast <> ast2 then begin
+            Printf.printf "%s:  FAIL, REPARSED AST IS DIFFERENT\n%!" filename;
+            let f1 = to_tmp_file print ast in
+            let f2 = to_tmp_file print ast2 in
+            let cmd = Printf.sprintf "%s %s %s" diff
+                (Filename.quote f1) (Filename.quote f2) in
+            let _ret = Sys.command cmd in
+            print_endline"====================================================="
+          end
+
+let test parse_fun pprint print map filename =
+  try test parse_fun pprint print map filename
+  with exn -> report_err exn
+
+let rec process path =
+  if Sys.is_directory path then
+    let files = Sys.readdir path in
+    Array.iter (fun s -> process (Filename.concat path s)) files
+  else if Filename.check_suffix path ".ml" then
+    test
+      Parse.implementation
+      Pprintast.structure
+      Printast.implementation
+      (fun mapper -> mapper.Ast_mapper.structure)
+      path
+  else if Filename.check_suffix path ".mli" then
+    test
+      Parse.interface
+      Pprintast.signature
+      Printast.interface
+      (fun mapper -> mapper.Ast_mapper.signature)
+      path
+
+let () =
+  process "source.ml"
diff --git a/testsuite/tests/parsetree/test.reference b/testsuite/tests/parsetree/test.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/parsing/Makefile b/testsuite/tests/parsing/Makefile
new file mode 100644
index 00000000..eac3f246
--- /dev/null
+++ b/testsuite/tests/parsing/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+TOPFLAGS+=-dparsetree
+include $(BASEDIR)/makefiles/Makefile.dparsetree
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/parsing/attributes.ml b/testsuite/tests/parsing/attributes.ml
new file mode 100644
index 00000000..8276380e
--- /dev/null
+++ b/testsuite/tests/parsing/attributes.ml
@@ -0,0 +1,34 @@
+[@@@foo]
+
+let (x[@foo]) : unit [@foo] = ()[@foo]
+  [@@foo]
+
+type t =
+  | Foo of (t[@foo]) [@foo]
+[@@foo]
+
+[@@@foo]
+
+
+module M = struct
+  type t = {
+    l : (t [@foo]) [@foo]
+  }
+    [@@foo]
+    [@@foo]
+
+  [@@@foo]
+end[@foo]
+[@@foo]
+
+module type S = sig
+
+  include (module type of (M[@foo]))[@foo] with type t := M.t[@foo]
+    [@@foo]
+
+  [@@@foo]
+
+end[@foo]
+[@@foo]
+
+[@@@foo]
diff --git a/testsuite/tests/parsing/attributes.ml.reference b/testsuite/tests/parsing/attributes.ml.reference
new file mode 100644
index 00000000..c6e8ad8d
--- /dev/null
+++ b/testsuite/tests/parsing/attributes.ml.reference
@@ -0,0 +1,153 @@
+[
+  structure_item (attributes.ml[1,0+0]..[1,0+8])
+    Pstr_attribute "foo"
+    []
+  structure_item (attributes.ml[3,10+0]..[4,49+9])
+    Pstr_value Nonrec
+    [
+      <def>
+          attribute "foo"
+            []
+        pattern (attributes.ml[3,10+4]..[3,10+38]) ghost
+          Ppat_constraint
+          pattern (attributes.ml[3,10+4]..[3,10+13])
+            attribute "foo"
+              []
+            Ppat_var "x" (attributes.ml[3,10+5]..[3,10+6])
+          core_type (attributes.ml[3,10+16]..[3,10+20])
+            attribute "foo"
+              []
+            Ptyp_constr "unit" (attributes.ml[3,10+16]..[3,10+20])
+            []
+        expression (attributes.ml[3,10+30]..[3,10+32])
+          attribute "foo"
+            []
+          Pexp_construct "()" (attributes.ml[3,10+30]..[3,10+32])
+          None
+    ]
+  structure_item (attributes.ml[6,60+0]..[8,97+7])
+    Pstr_type Rec
+    [
+      type_declaration "t" (attributes.ml[6,60+5]..[6,60+6]) (attributes.ml[6,60+0]..[8,97+7])
+        attribute "foo"
+          []
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_variant
+            [
+              (attributes.ml[7,69+2]..[7,69+27])
+                "Foo" (attributes.ml[7,69+4]..[7,69+7])
+                attribute "foo"
+                  []
+                [
+                  core_type (attributes.ml[7,69+12]..[7,69+13])
+                    attribute "foo"
+                      []
+                    Ptyp_constr "t" (attributes.ml[7,69+12]..[7,69+13])
+                    []
+                ]
+                None
+            ]
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+  structure_item (attributes.ml[10,106+0]..[10,106+8])
+    Pstr_attribute "foo"
+    []
+  structure_item (attributes.ml[13,117+0]..[22,224+7])
+    Pstr_module
+    "M" (attributes.ml[13,117+7]..[13,117+8])
+      attribute "foo"
+        []
+      module_expr (attributes.ml[13,117+11]..[21,214+3])
+        attribute "foo"
+          []
+        Pmod_structure
+        [
+          structure_item (attributes.ml[14,135+2]..[18,190+11])
+            Pstr_type Rec
+            [
+              type_declaration "t" (attributes.ml[14,135+7]..[14,135+8]) (attributes.ml[14,135+2]..[18,190+11])
+                attribute "foo"
+                  []
+                attribute "foo"
+                  []
+                ptype_params =
+                  []
+                ptype_cstrs =
+                  []
+                ptype_kind =
+                  Ptype_record
+                    [
+                      (attributes.ml[15,148+4]..[15,148+25])
+                        attribute "foo"
+                          []
+                        Immutable
+                        "l" (attributes.ml[15,148+4]..[15,148+5])                        core_type (attributes.ml[15,148+9]..[15,148+10])
+                          attribute "foo"
+                            []
+                          Ptyp_constr "t" (attributes.ml[15,148+9]..[15,148+10])
+                          []
+                    ]
+                ptype_private = Public
+                ptype_manifest =
+                  None
+            ]
+          structure_item (attributes.ml[20,203+2]..[20,203+10])
+            Pstr_attribute "foo"
+            []
+        ]
+  structure_item (attributes.ml[24,233+0]..[32,357+7])
+    Pstr_modtype "S" (attributes.ml[24,233+12]..[24,233+13])
+      attribute "foo"
+        []
+      module_type (attributes.ml[24,233+16]..[31,347+3])
+        attribute "foo"
+          []
+        Pmty_signature
+        [
+          signature_item (attributes.ml[26,254+2]..[27,322+11])
+            Psig_include
+            module_type (attributes.ml[26,254+10]..[26,254+61])
+              attribute "foo"
+                []
+              Pmty_with
+              module_type (attributes.ml[26,254+11]..[26,254+35])
+                attribute "foo"
+                  []
+                Pmty_typeof
+                module_expr (attributes.ml[26,254+27]..[26,254+28])
+                  attribute "foo"
+                    []
+                  Pmod_ident "M" (attributes.ml[26,254+27]..[26,254+28])
+              [
+                Pwith_typesubst
+                  type_declaration "t" (attributes.ml[26,254+53]..[26,254+54]) (attributes.ml[26,254+48]..[26,254+61])
+                    ptype_params =
+                      []
+                    ptype_cstrs =
+                      []
+                    ptype_kind =
+                      Ptype_abstract
+                    ptype_private = Public
+                    ptype_manifest =
+                      Some
+                        core_type (attributes.ml[26,254+58]..[26,254+61])
+                          Ptyp_constr "M.t" (attributes.ml[26,254+58]..[26,254+61])
+                          []
+              ]
+              attribute "foo"
+                []
+          signature_item (attributes.ml[29,335+2]..[29,335+10])
+            Psig_attribute "foo"
+            []
+        ]
+  structure_item (attributes.ml[34,366+0]..[34,366+8])
+    Pstr_attribute "foo"
+    []
+]
+
diff --git a/testsuite/tests/parsing/docstrings.ml b/testsuite/tests/parsing/docstrings.ml
new file mode 100644
index 00000000..ea847113
--- /dev/null
+++ b/testsuite/tests/parsing/docstrings.ml
@@ -0,0 +1,16 @@
+type 'a with_default
+  =  ?size:int       (** default [42] *)
+  -> ?resizable:bool (** default [true] *)
+  -> 'a
+
+type obj = <
+  meth1 : int -> int;
+  (** method 1 *)
+
+  meth2: unit -> float (** method 2 *);
+>
+
+type var = [
+  | `Foo (** foo *)
+  | `Bar of int * string (** bar *)
+]
diff --git a/testsuite/tests/parsing/docstrings.ml.reference b/testsuite/tests/parsing/docstrings.ml.reference
new file mode 100644
index 00000000..da40ede7
--- /dev/null
+++ b/testsuite/tests/parsing/docstrings.ml.reference
@@ -0,0 +1,146 @@
+[
+  structure_item (docstrings.ml[1,0+0]..[4,105+7])
+    Pstr_type Rec
+    [
+      type_declaration "with_default" (docstrings.ml[1,0+8]..[1,0+20]) (docstrings.ml[1,0+0]..[4,105+7])
+        ptype_params =
+          [
+            core_type (docstrings.ml[1,0+5]..[1,0+7])
+              Ptyp_var a
+          ]
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          Some
+            core_type (docstrings.ml[2,21+5]..[4,105+7])
+              Ptyp_arrow
+              Optional "size"
+              core_type (docstrings.ml[2,21+11]..[2,21+14])
+                attribute "ocaml.doc"
+                  [
+                    structure_item (docstrings.ml[2,21+21]..[2,21+40])
+                      Pstr_eval
+                      expression (docstrings.ml[2,21+21]..[2,21+40])
+                        Pexp_constant PConst_string(" default [42] ",None)
+                  ]
+                Ptyp_constr "int" (docstrings.ml[2,21+11]..[2,21+14])
+                []
+              core_type (docstrings.ml[3,62+5]..[4,105+7])
+                Ptyp_arrow
+                Optional "resizable"
+                core_type (docstrings.ml[3,62+16]..[3,62+20])
+                  attribute "ocaml.doc"
+                    [
+                      structure_item (docstrings.ml[3,62+21]..[3,62+42])
+                        Pstr_eval
+                        expression (docstrings.ml[3,62+21]..[3,62+42])
+                          Pexp_constant PConst_string(" default [true] ",None)
+                    ]
+                  Ptyp_constr "bool" (docstrings.ml[3,62+16]..[3,62+20])
+                  []
+                core_type (docstrings.ml[4,105+5]..[4,105+7])
+                  Ptyp_var a
+    ]
+  structure_item (docstrings.ml[6,114+0]..[11,208+1])
+    Pstr_type Rec
+    [
+      type_declaration "obj" (docstrings.ml[6,114+5]..[6,114+8]) (docstrings.ml[6,114+0]..[11,208+1])
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          Some
+            core_type (docstrings.ml[6,114+11]..[11,208+1])
+              Ptyp_object Closed
+                method meth1
+                  attribute "ocaml.doc"
+                    [
+                      structure_item (docstrings.ml[8,149+2]..[8,149+17])
+                        Pstr_eval
+                        expression (docstrings.ml[8,149+2]..[8,149+17])
+                          Pexp_constant PConst_string(" method 1 ",None)
+                    ]
+                  core_type (docstrings.ml[7,127+10]..[7,127+20])
+                    Ptyp_arrow
+                    Nolabel
+                    core_type (docstrings.ml[7,127+10]..[7,127+13])
+                      Ptyp_constr "int" (docstrings.ml[7,127+10]..[7,127+13])
+                      []
+                    core_type (docstrings.ml[7,127+17]..[7,127+20])
+                      Ptyp_constr "int" (docstrings.ml[7,127+17]..[7,127+20])
+                      []
+                method meth2
+                  attribute "ocaml.doc"
+                    [
+                      structure_item (docstrings.ml[10,168+23]..[10,168+38])
+                        Pstr_eval
+                        expression (docstrings.ml[10,168+23]..[10,168+38])
+                          Pexp_constant PConst_string(" method 2 ",None)
+                    ]
+                  core_type (docstrings.ml[10,168+9]..[10,168+22])
+                    Ptyp_arrow
+                    Nolabel
+                    core_type (docstrings.ml[10,168+9]..[10,168+13])
+                      Ptyp_constr "unit" (docstrings.ml[10,168+9]..[10,168+13])
+                      []
+                    core_type (docstrings.ml[10,168+17]..[10,168+22])
+                      Ptyp_constr "float" (docstrings.ml[10,168+17]..[10,168+22])
+                      []
+    ]
+  structure_item (docstrings.ml[13,211+0]..[16,280+1])
+    Pstr_type Rec
+    [
+      type_declaration "var" (docstrings.ml[13,211+5]..[13,211+8]) (docstrings.ml[13,211+0]..[16,280+1])
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          Some
+            core_type (docstrings.ml[13,211+11]..[16,280+1])
+              Ptyp_variant closed=Closed
+              [
+                Rtag "Foo" true
+                    attribute "ocaml.doc"
+                      [
+                        structure_item (docstrings.ml[14,224+9]..[14,224+19])
+                          Pstr_eval
+                          expression (docstrings.ml[14,224+9]..[14,224+19])
+                            Pexp_constant PConst_string(" foo ",None)
+                      ]
+                  []
+                Rtag "Bar" false
+                    attribute "ocaml.doc"
+                      [
+                        structure_item (docstrings.ml[15,244+25]..[15,244+35])
+                          Pstr_eval
+                          expression (docstrings.ml[15,244+25]..[15,244+35])
+                            Pexp_constant PConst_string(" bar ",None)
+                      ]
+                  [
+                    core_type (docstrings.ml[15,244+12]..[15,244+24])
+                      Ptyp_tuple
+                      [
+                        core_type (docstrings.ml[15,244+12]..[15,244+15])
+                          Ptyp_constr "int" (docstrings.ml[15,244+12]..[15,244+15])
+                          []
+                        core_type (docstrings.ml[15,244+18]..[15,244+24])
+                          Ptyp_constr "string" (docstrings.ml[15,244+18]..[15,244+24])
+                          []
+                      ]
+                  ]
+              ]
+              None
+    ]
+]
+
diff --git a/testsuite/tests/parsing/extensions.ml b/testsuite/tests/parsing/extensions.ml
new file mode 100644
index 00000000..e0feab8b
--- /dev/null
+++ b/testsuite/tests/parsing/extensions.ml
@@ -0,0 +1,18 @@
+
+[%%foo let x = 1 in x]
+let [%foo 2+1] : [%foo bar.baz] = [%foo "foo"]
+
+[%%foo module M = [%bar] ]
+let [%foo let () = () ] : [%foo type t = t ] = [%foo class c = object end]
+
+[%%foo: 'a list]
+let [%foo: [`Foo] ] : [%foo: t -> t ] = [%foo: < foo : t > ]
+
+[%%foo? _ ]
+[%%foo? Some y when y > 0]
+let [%foo? (Bar x | Baz x) ] : [%foo? #bar ] = [%foo? { x }]
+
+[%%foo: module M : [%baz]]
+let [%foo: include S with type t = t ]
+  : [%foo: val x : t  val y : t]
+  = [%foo: type t = t ]
diff --git a/testsuite/tests/parsing/extensions.ml.reference b/testsuite/tests/parsing/extensions.ml.reference
new file mode 100644
index 00000000..e904d7e9
--- /dev/null
+++ b/testsuite/tests/parsing/extensions.ml.reference
@@ -0,0 +1,326 @@
+[
+  structure_item (extensions.ml[2,1+0]..[2,1+22])
+    Pstr_extension "foo"
+    [
+      structure_item (extensions.ml[2,1+7]..[2,1+21])
+        Pstr_eval
+        expression (extensions.ml[2,1+7]..[2,1+21])
+          Pexp_let Nonrec
+          [
+            <def>
+              pattern (extensions.ml[2,1+11]..[2,1+12])
+                Ppat_var "x" (extensions.ml[2,1+11]..[2,1+12])
+              expression (extensions.ml[2,1+15]..[2,1+16])
+                Pexp_constant PConst_int (1,None)
+          ]
+          expression (extensions.ml[2,1+20]..[2,1+21])
+            Pexp_ident "x" (extensions.ml[2,1+20]..[2,1+21])
+    ]
+  structure_item (extensions.ml[3,24+0]..[3,24+46])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extensions.ml[3,24+4]..[3,24+46]) ghost
+          Ppat_constraint
+          pattern (extensions.ml[3,24+4]..[3,24+14])
+            Ppat_extension "foo"
+            [
+              structure_item (extensions.ml[3,24+10]..[3,24+13])
+                Pstr_eval
+                expression (extensions.ml[3,24+10]..[3,24+13])
+                  Pexp_apply
+                  expression (extensions.ml[3,24+11]..[3,24+12])
+                    Pexp_ident "+" (extensions.ml[3,24+11]..[3,24+12])
+                  [
+                    <arg>
+                    Nolabel
+                      expression (extensions.ml[3,24+10]..[3,24+11])
+                        Pexp_constant PConst_int (2,None)
+                    <arg>
+                    Nolabel
+                      expression (extensions.ml[3,24+12]..[3,24+13])
+                        Pexp_constant PConst_int (1,None)
+                  ]
+            ]
+          core_type (extensions.ml[3,24+17]..[3,24+31])
+            Ptyp_extension "foo"
+            [
+              structure_item (extensions.ml[3,24+23]..[3,24+30])
+                Pstr_eval
+                expression (extensions.ml[3,24+23]..[3,24+30])
+                  Pexp_field
+                  expression (extensions.ml[3,24+23]..[3,24+26])
+                    Pexp_ident "bar" (extensions.ml[3,24+23]..[3,24+26])
+                  "baz" (extensions.ml[3,24+27]..[3,24+30])
+            ]
+        expression (extensions.ml[3,24+34]..[3,24+46])
+          Pexp_extension "foo"
+          [
+            structure_item (extensions.ml[3,24+40]..[3,24+45])
+              Pstr_eval
+              expression (extensions.ml[3,24+40]..[3,24+45])
+                Pexp_constant PConst_string("foo",None)
+          ]
+    ]
+  structure_item (extensions.ml[5,72+0]..[5,72+26])
+    Pstr_extension "foo"
+    [
+      structure_item (extensions.ml[5,72+7]..[5,72+24])
+        Pstr_module
+        "M" (extensions.ml[5,72+14]..[5,72+15])
+          module_expr (extensions.ml[5,72+18]..[5,72+24])
+            Pmod_extension "bar"
+            []
+    ]
+  structure_item (extensions.ml[6,99+0]..[6,99+74])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extensions.ml[6,99+4]..[6,99+74]) ghost
+          Ppat_constraint
+          pattern (extensions.ml[6,99+4]..[6,99+23])
+            Ppat_extension "foo"
+            [
+              structure_item (extensions.ml[6,99+10]..[6,99+21])
+                Pstr_value Nonrec
+                [
+                  <def>
+                    pattern (extensions.ml[6,99+14]..[6,99+16])
+                      Ppat_construct "()" (extensions.ml[6,99+14]..[6,99+16])
+                      None
+                    expression (extensions.ml[6,99+19]..[6,99+21])
+                      Pexp_construct "()" (extensions.ml[6,99+19]..[6,99+21])
+                      None
+                ]
+            ]
+          core_type (extensions.ml[6,99+26]..[6,99+44])
+            Ptyp_extension "foo"
+            [
+              structure_item (extensions.ml[6,99+32]..[6,99+42])
+                Pstr_type Rec
+                [
+                  type_declaration "t" (extensions.ml[6,99+37]..[6,99+38]) (extensions.ml[6,99+32]..[6,99+42])
+                    ptype_params =
+                      []
+                    ptype_cstrs =
+                      []
+                    ptype_kind =
+                      Ptype_abstract
+                    ptype_private = Public
+                    ptype_manifest =
+                      Some
+                        core_type (extensions.ml[6,99+41]..[6,99+42])
+                          Ptyp_constr "t" (extensions.ml[6,99+41]..[6,99+42])
+                          []
+                ]
+            ]
+        expression (extensions.ml[6,99+47]..[6,99+74])
+          Pexp_extension "foo"
+          [
+            structure_item (extensions.ml[6,99+53]..[6,99+73])
+              Pstr_class
+              [
+                class_declaration (extensions.ml[6,99+53]..[6,99+73])
+                  pci_virt = Concrete
+                  pci_params =
+                    []
+                  pci_name = "c" (extensions.ml[6,99+59]..[6,99+60])
+                  pci_expr =
+                    class_expr (extensions.ml[6,99+63]..[6,99+73])
+                      Pcl_structure
+                      class_structure
+                        pattern (extensions.ml[6,99+69]..[6,99+69]) ghost
+                          Ppat_any
+                        []
+              ]
+          ]
+    ]
+  structure_item (extensions.ml[8,175+0]..[8,175+16])
+    Pstr_extension "foo"
+    core_type (extensions.ml[8,175+8]..[8,175+15])
+      Ptyp_constr "list" (extensions.ml[8,175+11]..[8,175+15])
+      [
+        core_type (extensions.ml[8,175+8]..[8,175+10])
+          Ptyp_var a
+      ]
+  structure_item (extensions.ml[9,192+0]..[9,192+60])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extensions.ml[9,192+4]..[9,192+60]) ghost
+          Ppat_constraint
+          pattern (extensions.ml[9,192+4]..[9,192+19])
+            Ppat_extension "foo"
+            core_type (extensions.ml[9,192+11]..[9,192+17])
+              Ptyp_variant closed=Closed
+              [
+                Rtag "Foo" true
+                  []
+              ]
+              None
+          core_type (extensions.ml[9,192+22]..[9,192+37])
+            Ptyp_extension "foo"
+            core_type (extensions.ml[9,192+29]..[9,192+35])
+              Ptyp_arrow
+              Nolabel
+              core_type (extensions.ml[9,192+29]..[9,192+30])
+                Ptyp_constr "t" (extensions.ml[9,192+29]..[9,192+30])
+                []
+              core_type (extensions.ml[9,192+34]..[9,192+35])
+                Ptyp_constr "t" (extensions.ml[9,192+34]..[9,192+35])
+                []
+        expression (extensions.ml[9,192+40]..[9,192+60])
+          Pexp_extension "foo"
+          core_type (extensions.ml[9,192+47]..[9,192+58])
+            Ptyp_object Closed
+              method foo
+                core_type (extensions.ml[9,192+55]..[9,192+56])
+                  Ptyp_constr "t" (extensions.ml[9,192+55]..[9,192+56])
+                  []
+    ]
+  structure_item (extensions.ml[11,254+0]..[11,254+11])
+    Pstr_extension "foo"
+    pattern (extensions.ml[11,254+8]..[11,254+9])
+      Ppat_any
+  structure_item (extensions.ml[12,266+0]..[12,266+26])
+    Pstr_extension "foo"
+    pattern (extensions.ml[12,266+8]..[12,266+14])
+      Ppat_construct "Some" (extensions.ml[12,266+8]..[12,266+12])
+      Some
+        pattern (extensions.ml[12,266+13]..[12,266+14])
+          Ppat_var "y" (extensions.ml[12,266+13]..[12,266+14])
+    <when>
+      expression (extensions.ml[12,266+20]..[12,266+25])
+        Pexp_apply
+        expression (extensions.ml[12,266+22]..[12,266+23])
+          Pexp_ident ">" (extensions.ml[12,266+22]..[12,266+23])
+        [
+          <arg>
+          Nolabel
+            expression (extensions.ml[12,266+20]..[12,266+21])
+              Pexp_ident "y" (extensions.ml[12,266+20]..[12,266+21])
+          <arg>
+          Nolabel
+            expression (extensions.ml[12,266+24]..[12,266+25])
+              Pexp_constant PConst_int (0,None)
+        ]
+  structure_item (extensions.ml[13,293+0]..[13,293+60])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extensions.ml[13,293+4]..[13,293+60]) ghost
+          Ppat_constraint
+          pattern (extensions.ml[13,293+4]..[13,293+28])
+            Ppat_extension "foo"
+            pattern (extensions.ml[13,293+11]..[13,293+26])
+              Ppat_or
+              pattern (extensions.ml[13,293+12]..[13,293+17])
+                Ppat_construct "Bar" (extensions.ml[13,293+12]..[13,293+15])
+                Some
+                  pattern (extensions.ml[13,293+16]..[13,293+17])
+                    Ppat_var "x" (extensions.ml[13,293+16]..[13,293+17])
+              pattern (extensions.ml[13,293+20]..[13,293+25])
+                Ppat_construct "Baz" (extensions.ml[13,293+20]..[13,293+23])
+                Some
+                  pattern (extensions.ml[13,293+24]..[13,293+25])
+                    Ppat_var "x" (extensions.ml[13,293+24]..[13,293+25])
+          core_type (extensions.ml[13,293+31]..[13,293+44])
+            Ptyp_extension "foo"
+            pattern (extensions.ml[13,293+38]..[13,293+42])
+              Ppat_type
+              "bar" (extensions.ml[13,293+39]..[13,293+42])
+        expression (extensions.ml[13,293+47]..[13,293+60])
+          Pexp_extension "foo"
+          pattern (extensions.ml[13,293+54]..[13,293+59])
+            Ppat_record Closed
+            [
+              "x" (extensions.ml[13,293+56]..[13,293+57])
+                pattern (extensions.ml[13,293+56]..[13,293+57])
+                  Ppat_var "x" (extensions.ml[13,293+56]..[13,293+57])
+            ]
+    ]
+  structure_item (extensions.ml[15,355+0]..[15,355+26])
+    Pstr_extension "foo"
+    [
+      signature_item (extensions.ml[15,355+8]..[15,355+25])
+        Psig_module "M" (extensions.ml[15,355+15]..[15,355+16])
+        module_type (extensions.ml[15,355+19]..[15,355+25])
+          Pmod_extension "baz"
+          []
+    ]
+  structure_item (extensions.ml[16,382+0]..[18,454+23])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extensions.ml[16,382+4]..[18,454+23]) ghost
+          Ppat_constraint
+          pattern (extensions.ml[16,382+4]..[16,382+38])
+            Ppat_extension "foo"
+            [
+              signature_item (extensions.ml[16,382+11]..[16,382+36])
+                Psig_include
+                module_type (extensions.ml[16,382+19]..[16,382+36])
+                  Pmty_with
+                  module_type (extensions.ml[16,382+19]..[16,382+20])
+                    Pmty_ident "S" (extensions.ml[16,382+19]..[16,382+20])
+                  [
+                    Pwith_type "t" (extensions.ml[16,382+31]..[16,382+32])
+                      type_declaration "t" (extensions.ml[16,382+31]..[16,382+32]) (extensions.ml[16,382+26]..[16,382+36])
+                        ptype_params =
+                          []
+                        ptype_cstrs =
+                          []
+                        ptype_kind =
+                          Ptype_abstract
+                        ptype_private = Public
+                        ptype_manifest =
+                          Some
+                            core_type (extensions.ml[16,382+35]..[16,382+36])
+                              Ptyp_constr "t" (extensions.ml[16,382+35]..[16,382+36])
+                              []
+                  ]
+            ]
+          core_type (extensions.ml[17,421+4]..[17,421+32])
+            Ptyp_extension "foo"
+            [
+              signature_item (extensions.ml[17,421+11]..[17,421+20])
+                Psig_value
+                value_description "x" (extensions.ml[17,421+15]..[17,421+16]) (extensions.ml[17,421+11]..[17,421+20])
+                  core_type (extensions.ml[17,421+19]..[17,421+20])
+                    Ptyp_constr "t" (extensions.ml[17,421+19]..[17,421+20])
+                    []
+                  []
+              signature_item (extensions.ml[17,421+22]..[17,421+31])
+                Psig_value
+                value_description "y" (extensions.ml[17,421+26]..[17,421+27]) (extensions.ml[17,421+22]..[17,421+31])
+                  core_type (extensions.ml[17,421+30]..[17,421+31])
+                    Ptyp_constr "t" (extensions.ml[17,421+30]..[17,421+31])
+                    []
+                  []
+            ]
+        expression (extensions.ml[18,454+4]..[18,454+23])
+          Pexp_extension "foo"
+          [
+            signature_item (extensions.ml[18,454+11]..[18,454+21])
+              Psig_type Rec
+              [
+                type_declaration "t" (extensions.ml[18,454+16]..[18,454+17]) (extensions.ml[18,454+11]..[18,454+21])
+                  ptype_params =
+                    []
+                  ptype_cstrs =
+                    []
+                  ptype_kind =
+                    Ptype_abstract
+                  ptype_private = Public
+                  ptype_manifest =
+                    Some
+                      core_type (extensions.ml[18,454+20]..[18,454+21])
+                        Ptyp_constr "t" (extensions.ml[18,454+20]..[18,454+21])
+                        []
+              ]
+          ]
+    ]
+]
+
+File "extensions.ml", line 2, characters 3-6:
+Error: Uninterpreted extension 'foo'.
diff --git a/testsuite/tests/parsing/int_and_float_with_modifier.ml b/testsuite/tests/parsing/int_and_float_with_modifier.ml
new file mode 100644
index 00000000..06384257
--- /dev/null
+++ b/testsuite/tests/parsing/int_and_float_with_modifier.ml
@@ -0,0 +1,14 @@
+let int_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890z
+let float_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890.z
+
+let int32     = 1234l
+let int64     = 1234L
+let nativeint = 1234n
+
+let hex_without_modifier = 0x32f
+let hex_with_modifier    = 0x32g
+
+let float_without_modifer = 1.2e3
+let float_with_modifer    = 1.2g
diff --git a/testsuite/tests/parsing/int_and_float_with_modifier.ml.reference b/testsuite/tests/parsing/int_and_float_with_modifier.ml.reference
new file mode 100644
index 00000000..fd3bee0e
--- /dev/null
+++ b/testsuite/tests/parsing/int_and_float_with_modifier.ml.reference
@@ -0,0 +1,86 @@
+[
+  structure_item (int_and_float_with_modifier.ml[1,0+0]..[2,31+57])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[1,0+4]..[1,0+28])
+          Ppat_var "int_with_custom_modifier" (int_and_float_with_modifier.ml[1,0+4]..[1,0+28])
+        expression (int_and_float_with_modifier.ml[2,31+2]..[2,31+57])
+          Pexp_constant PConst_int (1234567890_1234567890_1234567890_1234567890_1234567890,Some z)
+    ]
+  structure_item (int_and_float_with_modifier.ml[3,89+0]..[4,122+58])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[3,89+4]..[3,89+30])
+          Ppat_var "float_with_custom_modifier" (int_and_float_with_modifier.ml[3,89+4]..[3,89+30])
+        expression (int_and_float_with_modifier.ml[4,122+2]..[4,122+58])
+          Pexp_constant PConst_float (1234567890_1234567890_1234567890_1234567890_1234567890.,Some z)
+    ]
+  structure_item (int_and_float_with_modifier.ml[6,182+0]..[6,182+21])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[6,182+4]..[6,182+9])
+          Ppat_var "int32" (int_and_float_with_modifier.ml[6,182+4]..[6,182+9])
+        expression (int_and_float_with_modifier.ml[6,182+16]..[6,182+21])
+          Pexp_constant PConst_int (1234,Some l)
+    ]
+  structure_item (int_and_float_with_modifier.ml[7,204+0]..[7,204+21])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[7,204+4]..[7,204+9])
+          Ppat_var "int64" (int_and_float_with_modifier.ml[7,204+4]..[7,204+9])
+        expression (int_and_float_with_modifier.ml[7,204+16]..[7,204+21])
+          Pexp_constant PConst_int (1234,Some L)
+    ]
+  structure_item (int_and_float_with_modifier.ml[8,226+0]..[8,226+21])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[8,226+4]..[8,226+13])
+          Ppat_var "nativeint" (int_and_float_with_modifier.ml[8,226+4]..[8,226+13])
+        expression (int_and_float_with_modifier.ml[8,226+16]..[8,226+21])
+          Pexp_constant PConst_int (1234,Some n)
+    ]
+  structure_item (int_and_float_with_modifier.ml[10,249+0]..[10,249+32])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[10,249+4]..[10,249+24])
+          Ppat_var "hex_without_modifier" (int_and_float_with_modifier.ml[10,249+4]..[10,249+24])
+        expression (int_and_float_with_modifier.ml[10,249+27]..[10,249+32])
+          Pexp_constant PConst_int (0x32f,None)
+    ]
+  structure_item (int_and_float_with_modifier.ml[11,282+0]..[11,282+32])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[11,282+4]..[11,282+21])
+          Ppat_var "hex_with_modifier" (int_and_float_with_modifier.ml[11,282+4]..[11,282+21])
+        expression (int_and_float_with_modifier.ml[11,282+27]..[11,282+32])
+          Pexp_constant PConst_int (0x32,Some g)
+    ]
+  structure_item (int_and_float_with_modifier.ml[13,316+0]..[13,316+33])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[13,316+4]..[13,316+25])
+          Ppat_var "float_without_modifer" (int_and_float_with_modifier.ml[13,316+4]..[13,316+25])
+        expression (int_and_float_with_modifier.ml[13,316+28]..[13,316+33])
+          Pexp_constant PConst_float (1.2e3,None)
+    ]
+  structure_item (int_and_float_with_modifier.ml[14,350+0]..[14,350+32])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (int_and_float_with_modifier.ml[14,350+4]..[14,350+22])
+          Ppat_var "float_with_modifer" (int_and_float_with_modifier.ml[14,350+4]..[14,350+22])
+        expression (int_and_float_with_modifier.ml[14,350+28]..[14,350+32])
+          Pexp_constant PConst_float (1.2,Some g)
+    ]
+]
+
+File "int_and_float_with_modifier.ml", line 2, characters 2-57:
+Error: Unknown modifier 'z' for literal 1234567890_1234567890_1234567890_1234567890_1234567890z
diff --git a/testsuite/tests/parsing/pr6865.ml b/testsuite/tests/parsing/pr6865.ml
new file mode 100644
index 00000000..78cd602f
--- /dev/null
+++ b/testsuite/tests/parsing/pr6865.ml
@@ -0,0 +1,3 @@
+let%foo x = 42
+let%foo _ = () and _ = ()
+let%foo _ = ()
diff --git a/testsuite/tests/parsing/pr6865.ml.reference b/testsuite/tests/parsing/pr6865.ml.reference
new file mode 100644
index 00000000..72abd40e
--- /dev/null
+++ b/testsuite/tests/parsing/pr6865.ml.reference
@@ -0,0 +1,52 @@
+[
+  structure_item (pr6865.ml[1,0+0]..[1,0+14]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (pr6865.ml[1,0+0]..[1,0+14])
+        Pstr_value Nonrec
+        [
+          <def>
+            pattern (pr6865.ml[1,0+8]..[1,0+9])
+              Ppat_var "x" (pr6865.ml[1,0+8]..[1,0+9])
+            expression (pr6865.ml[1,0+12]..[1,0+14])
+              Pexp_constant PConst_int (42,None)
+        ]
+    ]
+  structure_item (pr6865.ml[2,15+0]..[2,15+25]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (pr6865.ml[2,15+0]..[2,15+25])
+        Pstr_value Nonrec
+        [
+          <def>
+            pattern (pr6865.ml[2,15+8]..[2,15+9])
+              Ppat_any
+            expression (pr6865.ml[2,15+12]..[2,15+14])
+              Pexp_construct "()" (pr6865.ml[2,15+12]..[2,15+14])
+              None
+          <def>
+            pattern (pr6865.ml[2,15+19]..[2,15+20])
+              Ppat_any
+            expression (pr6865.ml[2,15+23]..[2,15+25])
+              Pexp_construct "()" (pr6865.ml[2,15+23]..[2,15+25])
+              None
+        ]
+    ]
+  structure_item (pr6865.ml[3,41+0]..[3,41+14]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (pr6865.ml[3,41+0]..[3,41+14])
+        Pstr_value Nonrec
+        [
+          <def>
+            pattern (pr6865.ml[3,41+8]..[3,41+9])
+              Ppat_any
+            expression (pr6865.ml[3,41+12]..[3,41+14])
+              Pexp_construct "()" (pr6865.ml[3,41+12]..[3,41+14])
+              None
+        ]
+    ]
+]
+
+File "pr6865.ml", line 1, characters 4-7:
+Error: Uninterpreted extension 'foo'.
diff --git a/testsuite/tests/parsing/pr7165.ml b/testsuite/tests/parsing/pr7165.ml
new file mode 100644
index 00000000..ba6835b4
--- /dev/null
+++ b/testsuite/tests/parsing/pr7165.ml
@@ -0,0 +1,4 @@
+(* this is a lexer directive with an out-of-bound integer;
+   it should result in a lexing error instead of an
+   uncaught exception as in PR#7165 *)
+#9342101923012312312
diff --git a/testsuite/tests/parsing/pr7165.ml.reference b/testsuite/tests/parsing/pr7165.ml.reference
new file mode 100644
index 00000000..fd59df84
--- /dev/null
+++ b/testsuite/tests/parsing/pr7165.ml.reference
@@ -0,0 +1,2 @@
+File "pr7165.ml", line 4, characters 0-21:
+Error: Invalid lexer directive "#9342101923012312312": line number out of range
diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml b/testsuite/tests/parsing/shortcut_ext_attr.ml
new file mode 100644
index 00000000..7f6d1f51
--- /dev/null
+++ b/testsuite/tests/parsing/shortcut_ext_attr.ml
@@ -0,0 +1,114 @@
+
+(* Expressions *)
+let () =
+  let%foo[@foo] x = 3
+  and[@foo] y = 4 in
+  (let module%foo[@foo] M = M in ()) ;
+  (let open%foo[@foo] M in ()) ;
+  (fun%foo[@foo] x -> ()) ;
+  (function%foo[@foo] x -> ()) ;
+  (try%foo[@foo] () with _ -> ()) ;
+  (if%foo[@foo] () then () else ()) ;
+  while%foo[@foo] () do () done ;
+  for%foo[@foo] x = () to () do () done ;
+  () ;%foo () ;
+  assert%foo[@foo] true ;
+  lazy%foo[@foo] x ;
+  object%foo[@foo] end ;
+  begin%foo[@foo] 3 end ;
+  new%foo[@foo] x ;
+
+  match%foo[@foo] () with
+  (* Pattern expressions *)
+  | lazy%foo[@foo] x -> ()
+  | exception%foo[@foo] x -> ()
+
+
+(* Class expressions *)
+class x =
+  fun[@foo] x ->
+  let[@foo] x = 3 in
+  object[@foo]
+    inherit[@foo] x
+    val[@foo] x = 3
+    val[@foo] virtual x : t
+    val![@foo] mutable x = 3
+    method[@foo] x = 3
+    method[@foo] virtual x : t
+    method![@foo] private x = 3
+    initializer[@foo] x
+  end
+
+(* Class type expressions *)
+class type t =
+  object[@foo]
+    inherit[@foo] t
+    val[@foo] x : t
+    val[@foo] mutable x : t
+    method[@foo] x : t
+    method[@foo] private x : t
+    constraint[@foo] t = t'
+  end
+
+(* Type expressions *)
+type t =
+  (module%foo[@foo] M)
+
+(* Module expressions *)
+module M =
+  functor[@foo] (M : S) ->
+    (val[@foo] x)
+    (struct[@foo] end)
+
+(* Module type expression *)
+module type S =
+  functor[@foo] (M:S) ->
+    (module type of[@foo] M) ->
+    (sig[@foo] end)
+
+(* Structure items *)
+let%foo[@foo] x = 4
+and[@foo] y = x
+
+type%foo[@foo] t = int
+and[@foo] t = int
+type%foo[@foo] t += T
+
+class%foo[@foo] x = x
+class type%foo[@foo] x = x
+external%foo[@foo] x : _  = ""
+exception%foo[@foo] X
+
+module%foo[@foo] M = M
+module%foo[@foo] rec M : S = M
+and[@foo] M : S = M
+module type%foo[@foo] S = S
+
+include%foo[@foo] M
+open%foo[@foo] M
+
+(* Signature items *)
+module type S = sig
+  val%foo[@foo] x : t
+  external%foo[@foo] x : t = ""
+
+  type%foo[@foo] t = int
+  and[@foo] t' = int
+  type%foo[@foo] t += T
+
+  exception%foo[@foo] X
+
+  module%foo[@foo] M : S
+  module%foo[@foo] rec M : S
+  and[@foo] M : S
+  module%foo[@foo] M = M
+
+  module type%foo[@foo] S = S
+
+  include%foo[@foo] M
+  open%foo[@foo] M
+
+  class%foo[@foo] x : t
+  class type%foo[@foo] x = x
+
+end
diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
new file mode 100644
index 00000000..c3101349
--- /dev/null
+++ b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
@@ -0,0 +1,978 @@
+[
+  structure_item (shortcut_ext_attr.ml[3,19+0]..[24,570+31])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
+          Ppat_construct "()" (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
+          None
+        expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) ghost
+          Pexp_extension "foo"
+          [
+            structure_item (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
+              Pstr_eval
+              expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
+                Pexp_let Nonrec
+                [
+                  <def>
+                      attribute "foo"
+                        []
+                    pattern (shortcut_ext_attr.ml[4,28+16]..[4,28+17])
+                      Ppat_var "x" (shortcut_ext_attr.ml[4,28+16]..[4,28+17])
+                    expression (shortcut_ext_attr.ml[4,28+20]..[4,28+21])
+                      Pexp_constant PConst_int (3,None)
+                  <def>
+                      attribute "foo"
+                        []
+                    pattern (shortcut_ext_attr.ml[5,50+12]..[5,50+13])
+                      Ppat_var "y" (shortcut_ext_attr.ml[5,50+12]..[5,50+13])
+                    expression (shortcut_ext_attr.ml[5,50+16]..[5,50+17])
+                      Pexp_constant PConst_int (4,None)
+                ]
+                expression (shortcut_ext_attr.ml[6,71+2]..[24,570+31])
+                  Pexp_sequence
+                  expression (shortcut_ext_attr.ml[6,71+2]..[6,71+36])
+                    Pexp_extension "foo"
+                    [
+                      structure_item (shortcut_ext_attr.ml[6,71+3]..[6,71+35])
+                        Pstr_eval
+                        expression (shortcut_ext_attr.ml[6,71+3]..[6,71+35])
+                          attribute "foo"
+                            []
+                          Pexp_letmodule "M" (shortcut_ext_attr.ml[6,71+24]..[6,71+25])
+                          module_expr (shortcut_ext_attr.ml[6,71+28]..[6,71+29])
+                            Pmod_ident "M" (shortcut_ext_attr.ml[6,71+28]..[6,71+29])
+                          expression (shortcut_ext_attr.ml[6,71+33]..[6,71+35])
+                            Pexp_construct "()" (shortcut_ext_attr.ml[6,71+33]..[6,71+35])
+                            None
+                    ]
+                  expression (shortcut_ext_attr.ml[7,110+2]..[24,570+31])
+                    Pexp_sequence
+                    expression (shortcut_ext_attr.ml[7,110+2]..[7,110+30])
+                      Pexp_extension "foo"
+                      [
+                        structure_item (shortcut_ext_attr.ml[7,110+3]..[7,110+29])
+                          Pstr_eval
+                          expression (shortcut_ext_attr.ml[7,110+3]..[7,110+29])
+                            attribute "foo"
+                              []
+                            Pexp_open Fresh ""M" (shortcut_ext_attr.ml[7,110+22]..[7,110+23])"
+                            expression (shortcut_ext_attr.ml[7,110+27]..[7,110+29])
+                              Pexp_construct "()" (shortcut_ext_attr.ml[7,110+27]..[7,110+29])
+                              None
+                      ]
+                    expression (shortcut_ext_attr.ml[8,143+2]..[24,570+31])
+                      Pexp_sequence
+                      expression (shortcut_ext_attr.ml[8,143+2]..[8,143+25])
+                        Pexp_extension "foo"
+                        [
+                          structure_item (shortcut_ext_attr.ml[8,143+3]..[8,143+24])
+                            Pstr_eval
+                            expression (shortcut_ext_attr.ml[8,143+3]..[8,143+24])
+                              attribute "foo"
+                                []
+                              Pexp_fun
+                              Nolabel
+                              None
+                              pattern (shortcut_ext_attr.ml[8,143+17]..[8,143+18])
+                                Ppat_var "x" (shortcut_ext_attr.ml[8,143+17]..[8,143+18])
+                              expression (shortcut_ext_attr.ml[8,143+22]..[8,143+24])
+                                Pexp_construct "()" (shortcut_ext_attr.ml[8,143+22]..[8,143+24])
+                                None
+                        ]
+                      expression (shortcut_ext_attr.ml[9,171+2]..[24,570+31])
+                        Pexp_sequence
+                        expression (shortcut_ext_attr.ml[9,171+2]..[9,171+30])
+                          Pexp_extension "foo"
+                          [
+                            structure_item (shortcut_ext_attr.ml[9,171+3]..[9,171+29])
+                              Pstr_eval
+                              expression (shortcut_ext_attr.ml[9,171+3]..[9,171+29])
+                                attribute "foo"
+                                  []
+                                Pexp_function
+                                [
+                                  <case>
+                                    pattern (shortcut_ext_attr.ml[9,171+22]..[9,171+23])
+                                      Ppat_var "x" (shortcut_ext_attr.ml[9,171+22]..[9,171+23])
+                                    expression (shortcut_ext_attr.ml[9,171+27]..[9,171+29])
+                                      Pexp_construct "()" (shortcut_ext_attr.ml[9,171+27]..[9,171+29])
+                                      None
+                                ]
+                          ]
+                        expression (shortcut_ext_attr.ml[10,204+2]..[24,570+31])
+                          Pexp_sequence
+                          expression (shortcut_ext_attr.ml[10,204+2]..[10,204+33])
+                            Pexp_extension "foo"
+                            [
+                              structure_item (shortcut_ext_attr.ml[10,204+3]..[10,204+32])
+                                Pstr_eval
+                                expression (shortcut_ext_attr.ml[10,204+3]..[10,204+32])
+                                  attribute "foo"
+                                    []
+                                  Pexp_try
+                                  expression (shortcut_ext_attr.ml[10,204+17]..[10,204+19])
+                                    Pexp_construct "()" (shortcut_ext_attr.ml[10,204+17]..[10,204+19])
+                                    None
+                                  [
+                                    <case>
+                                      pattern (shortcut_ext_attr.ml[10,204+25]..[10,204+26])
+                                        Ppat_any
+                                      expression (shortcut_ext_attr.ml[10,204+30]..[10,204+32])
+                                        Pexp_construct "()" (shortcut_ext_attr.ml[10,204+30]..[10,204+32])
+                                        None
+                                  ]
+                            ]
+                          expression (shortcut_ext_attr.ml[11,240+2]..[24,570+31])
+                            Pexp_sequence
+                            expression (shortcut_ext_attr.ml[11,240+2]..[11,240+35])
+                              Pexp_extension "foo"
+                              [
+                                structure_item (shortcut_ext_attr.ml[11,240+3]..[11,240+34])
+                                  Pstr_eval
+                                  expression (shortcut_ext_attr.ml[11,240+3]..[11,240+34])
+                                    attribute "foo"
+                                      []
+                                    Pexp_ifthenelse
+                                    expression (shortcut_ext_attr.ml[11,240+16]..[11,240+18])
+                                      Pexp_construct "()" (shortcut_ext_attr.ml[11,240+16]..[11,240+18])
+                                      None
+                                    expression (shortcut_ext_attr.ml[11,240+24]..[11,240+26])
+                                      Pexp_construct "()" (shortcut_ext_attr.ml[11,240+24]..[11,240+26])
+                                      None
+                                    Some
+                                      expression (shortcut_ext_attr.ml[11,240+32]..[11,240+34])
+                                        Pexp_construct "()" (shortcut_ext_attr.ml[11,240+32]..[11,240+34])
+                                        None
+                              ]
+                            expression (shortcut_ext_attr.ml[12,278+2]..[24,570+31])
+                              Pexp_sequence
+                              expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) ghost
+                                Pexp_extension "foo"
+                                [
+                                  structure_item (shortcut_ext_attr.ml[12,278+2]..[12,278+31])
+                                    Pstr_eval
+                                    expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31])
+                                      attribute "foo"
+                                        []
+                                      Pexp_while
+                                      expression (shortcut_ext_attr.ml[12,278+18]..[12,278+20])
+                                        Pexp_construct "()" (shortcut_ext_attr.ml[12,278+18]..[12,278+20])
+                                        None
+                                      expression (shortcut_ext_attr.ml[12,278+24]..[12,278+26])
+                                        Pexp_construct "()" (shortcut_ext_attr.ml[12,278+24]..[12,278+26])
+                                        None
+                                ]
+                              expression (shortcut_ext_attr.ml[13,312+2]..[24,570+31])
+                                Pexp_sequence
+                                expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) ghost
+                                  Pexp_extension "foo"
+                                  [
+                                    structure_item (shortcut_ext_attr.ml[13,312+2]..[13,312+39])
+                                      Pstr_eval
+                                      expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39])
+                                        attribute "foo"
+                                          []
+                                        Pexp_for Up
+                                        pattern (shortcut_ext_attr.ml[13,312+16]..[13,312+17])
+                                          Ppat_var "x" (shortcut_ext_attr.ml[13,312+16]..[13,312+17])
+                                        expression (shortcut_ext_attr.ml[13,312+20]..[13,312+22])
+                                          Pexp_construct "()" (shortcut_ext_attr.ml[13,312+20]..[13,312+22])
+                                          None
+                                        expression (shortcut_ext_attr.ml[13,312+26]..[13,312+28])
+                                          Pexp_construct "()" (shortcut_ext_attr.ml[13,312+26]..[13,312+28])
+                                          None
+                                        expression (shortcut_ext_attr.ml[13,312+32]..[13,312+34])
+                                          Pexp_construct "()" (shortcut_ext_attr.ml[13,312+32]..[13,312+34])
+                                          None
+                                  ]
+                                expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                  Pexp_extension "foo"
+                                  [
+                                    structure_item (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                      Pstr_eval
+                                      expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                        Pexp_sequence
+                                        expression (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
+                                          Pexp_construct "()" (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
+                                          None
+                                        expression (shortcut_ext_attr.ml[14,354+11]..[24,570+31])
+                                          Pexp_sequence
+                                          expression (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
+                                            Pexp_construct "()" (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
+                                            None
+                                          expression (shortcut_ext_attr.ml[15,370+2]..[24,570+31])
+                                            Pexp_sequence
+                                            expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) ghost
+                                              Pexp_extension "foo"
+                                              [
+                                                structure_item (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
+                                                  Pstr_eval
+                                                  expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
+                                                    attribute "foo"
+                                                      []
+                                                    Pexp_assert
+                                                    expression (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
+                                                      Pexp_construct "true" (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
+                                                      None
+                                              ]
+                                            expression (shortcut_ext_attr.ml[16,396+2]..[24,570+31])
+                                              Pexp_sequence
+                                              expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) ghost
+                                                Pexp_extension "foo"
+                                                [
+                                                  structure_item (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
+                                                    Pstr_eval
+                                                    expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
+                                                      attribute "foo"
+                                                        []
+                                                      Pexp_lazy
+                                                      expression (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
+                                                        Pexp_ident "x" (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
+                                                ]
+                                              expression (shortcut_ext_attr.ml[17,417+2]..[24,570+31])
+                                                Pexp_sequence
+                                                expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) ghost
+                                                  Pexp_extension "foo"
+                                                  [
+                                                    structure_item (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
+                                                      Pstr_eval
+                                                      expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
+                                                        attribute "foo"
+                                                          []
+                                                        Pexp_object
+                                                        class_structure
+                                                          pattern (shortcut_ext_attr.ml[17,417+18]..[17,417+18]) ghost
+                                                            Ppat_any
+                                                          []
+                                                  ]
+                                                expression (shortcut_ext_attr.ml[18,442+2]..[24,570+31])
+                                                  Pexp_sequence
+                                                  expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) ghost
+                                                    Pexp_extension "foo"
+                                                    [
+                                                      structure_item (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
+                                                        Pstr_eval
+                                                        expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
+                                                          attribute "foo"
+                                                            []
+                                                          Pexp_constant PConst_int (3,None)
+                                                    ]
+                                                  expression (shortcut_ext_attr.ml[19,468+2]..[24,570+31])
+                                                    Pexp_sequence
+                                                    expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) ghost
+                                                      Pexp_extension "foo"
+                                                      [
+                                                        structure_item (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
+                                                          Pstr_eval
+                                                          expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
+                                                            attribute "foo"
+                                                              []
+                                                            Pexp_new "x" (shortcut_ext_attr.ml[19,468+16]..[19,468+17])
+                                                      ]
+                                                    expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) ghost
+                                                      Pexp_extension "foo"
+                                                      [
+                                                        structure_item (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
+                                                          Pstr_eval
+                                                          expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
+                                                            attribute "foo"
+                                                              []
+                                                            Pexp_match
+                                                            expression (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
+                                                              Pexp_construct "()" (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
+                                                              None
+                                                            [
+                                                              <case>
+                                                                pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20]) ghost
+                                                                  Ppat_extension "foo"
+                                                                  pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20])
+                                                                    attribute "foo"
+                                                                      []
+                                                                    Ppat_lazy
+                                                                    pattern (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
+                                                                      Ppat_var "x" (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
+                                                                expression (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
+                                                                  Pexp_construct "()" (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
+                                                                  None
+                                                              <case>
+                                                                pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25]) ghost
+                                                                  Ppat_extension "foo"
+                                                                  pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25])
+                                                                    attribute "foo"
+                                                                      []
+                                                                    Ppat_exception
+                                                                    pattern (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
+                                                                      Ppat_var "x" (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
+                                                                expression (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
+                                                                  Pexp_construct "()" (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
+                                                                  None
+                                                            ]
+                                                      ]
+                                  ]
+          ]
+    ]
+  structure_item (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
+    Pstr_class
+    [
+      class_declaration (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
+        pci_virt = Concrete
+        pci_params =
+          []
+        pci_name = "x" (shortcut_ext_attr.ml[28,628+6]..[28,628+7])
+        pci_expr =
+          class_expr (shortcut_ext_attr.ml[29,638+12]..[40,898+5])
+            attribute "foo"
+              []
+            Pcl_fun
+            Nolabel
+            None
+            pattern (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
+              Ppat_var "x" (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
+            class_expr (shortcut_ext_attr.ml[30,655+2]..[40,898+5])
+              Pcl_let Nonrec
+              [
+                <def>
+                    attribute "foo"
+                      []
+                  pattern (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
+                    Ppat_var "x" (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
+                  expression (shortcut_ext_attr.ml[30,655+16]..[30,655+17])
+                    Pexp_constant PConst_int (3,None)
+              ]
+              class_expr (shortcut_ext_attr.ml[31,676+2]..[40,898+5])
+                attribute "foo"
+                  []
+                Pcl_structure
+                class_structure
+                  pattern (shortcut_ext_attr.ml[31,676+14]..[31,676+14]) ghost
+                    Ppat_any
+                  [
+                    class_field (shortcut_ext_attr.ml[32,691+4]..[32,691+19])
+                        attribute "foo"
+                          []
+                      Pcf_inherit Fresh
+                        class_expr (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
+                          Pcl_constr "x" (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
+                          []
+                        None
+                    class_field (shortcut_ext_attr.ml[33,711+4]..[33,711+19])
+                        attribute "foo"
+                          []
+                      Pcf_val Immutable
+                        "x" (shortcut_ext_attr.ml[33,711+14]..[33,711+15])
+                        Concrete Fresh
+                        expression (shortcut_ext_attr.ml[33,711+18]..[33,711+19])
+                          Pexp_constant PConst_int (3,None)
+                    class_field (shortcut_ext_attr.ml[34,731+4]..[34,731+27])
+                        attribute "foo"
+                          []
+                      Pcf_val Immutable
+                        "x" (shortcut_ext_attr.ml[34,731+22]..[34,731+23])
+                        Virtual
+                        core_type (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
+                          Ptyp_constr "t" (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
+                          []
+                    class_field (shortcut_ext_attr.ml[35,759+4]..[35,759+28])
+                        attribute "foo"
+                          []
+                      Pcf_val Mutable
+                        "x" (shortcut_ext_attr.ml[35,759+23]..[35,759+24])
+                        Concrete Override
+                        expression (shortcut_ext_attr.ml[35,759+27]..[35,759+28])
+                          Pexp_constant PConst_int (3,None)
+                    class_field (shortcut_ext_attr.ml[36,788+4]..[36,788+22])
+                        attribute "foo"
+                          []
+                      Pcf_method Public
+                        "x" (shortcut_ext_attr.ml[36,788+17]..[36,788+18])
+                        Concrete Fresh
+                        expression (shortcut_ext_attr.ml[36,788+10]..[36,788+22]) ghost
+                          Pexp_poly
+                          expression (shortcut_ext_attr.ml[36,788+21]..[36,788+22])
+                            Pexp_constant PConst_int (3,None)
+                          None
+                    class_field (shortcut_ext_attr.ml[37,811+4]..[37,811+30])
+                        attribute "foo"
+                          []
+                      Pcf_method Public
+                        "x" (shortcut_ext_attr.ml[37,811+25]..[37,811+26])
+                        Virtual
+                        core_type (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
+                          Ptyp_constr "t" (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
+                          []
+                    class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+31])
+                        attribute "foo"
+                          []
+                      Pcf_method Private
+                        "x" (shortcut_ext_attr.ml[38,842+26]..[38,842+27])
+                        Concrete Override
+                        expression (shortcut_ext_attr.ml[38,842+10]..[38,842+31]) ghost
+                          Pexp_poly
+                          expression (shortcut_ext_attr.ml[38,842+30]..[38,842+31])
+                            Pexp_constant PConst_int (3,None)
+                          None
+                    class_field (shortcut_ext_attr.ml[39,874+4]..[39,874+23])
+                        attribute "foo"
+                          []
+                      Pcf_initializer
+                        expression (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
+                          Pexp_ident "x" (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
+                  ]
+    ]
+  structure_item (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
+    Pstr_class_type
+    [
+      class_type_declaration (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
+        pci_virt = Concrete
+        pci_params =
+          []
+        pci_name = "t" (shortcut_ext_attr.ml[43,934+11]..[43,934+12])
+        pci_expr =
+          class_type (shortcut_ext_attr.ml[44,949+2]..[51,1114+5])
+            attribute "foo"
+              []
+            Pcty_signature
+            class_signature
+              core_type (shortcut_ext_attr.ml[44,949+14]..[44,949+14])
+                Ptyp_any
+              [
+                class_type_field (shortcut_ext_attr.ml[45,964+4]..[45,964+19])
+                    attribute "foo"
+                      []
+                  Pctf_inherit
+                  class_type (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
+                    Pcty_constr "t" (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
+                    []
+                class_type_field (shortcut_ext_attr.ml[46,984+4]..[46,984+19])
+                    attribute "foo"
+                      []
+                  Pctf_val "x" Immutable Concrete
+                    core_type (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
+                      []
+                class_type_field (shortcut_ext_attr.ml[47,1004+4]..[47,1004+27])
+                    attribute "foo"
+                      []
+                  Pctf_val "x" Mutable Concrete
+                    core_type (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
+                      []
+                class_type_field (shortcut_ext_attr.ml[48,1032+4]..[48,1032+22])
+                    attribute "foo"
+                      []
+                  Pctf_method "x" Public Concrete
+                    core_type (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
+                      []
+                class_type_field (shortcut_ext_attr.ml[49,1055+4]..[49,1055+30])
+                    attribute "foo"
+                      []
+                  Pctf_method "x" Private Concrete
+                    core_type (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
+                      []
+                class_type_field (shortcut_ext_attr.ml[50,1086+4]..[50,1086+27])
+                    attribute "foo"
+                      []
+                  Pctf_constraint
+                    core_type (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
+                      []
+                    core_type (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
+                      Ptyp_constr "t'" (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
+                      []
+              ]
+    ]
+  structure_item (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
+    Pstr_type Rec
+    [
+      type_declaration "t" (shortcut_ext_attr.ml[54,1144+5]..[54,1144+6]) (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          Some
+            core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22]) ghost
+              Ptyp_extension "foo"
+              core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22])
+                attribute "foo"
+                  []
+                Ptyp_package "M" (shortcut_ext_attr.ml[55,1153+20]..[55,1153+21])
+                []
+    ]
+  structure_item (shortcut_ext_attr.ml[58,1202+0]..[61,1258+22])
+    Pstr_module
+    "M" (shortcut_ext_attr.ml[58,1202+7]..[58,1202+8])
+      module_expr (shortcut_ext_attr.ml[59,1213+2]..[61,1258+22])
+        attribute "foo"
+          []
+        Pmod_functor "M" (shortcut_ext_attr.ml[59,1213+17]..[59,1213+18])
+        module_type (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
+          Pmty_ident "S" (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
+        module_expr (shortcut_ext_attr.ml[60,1240+4]..[61,1258+22])
+          Pmod_apply
+          module_expr (shortcut_ext_attr.ml[60,1240+4]..[60,1240+17])
+            attribute "foo"
+              []
+            Pmod_unpack
+            expression (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
+              Pexp_ident "x" (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
+          module_expr (shortcut_ext_attr.ml[61,1258+5]..[61,1258+21])
+            attribute "foo"
+              []
+            Pmod_structure
+            []
+  structure_item (shortcut_ext_attr.ml[64,1311+0]..[67,1384+19])
+    Pstr_modtype "S" (shortcut_ext_attr.ml[64,1311+12]..[64,1311+13])
+      module_type (shortcut_ext_attr.ml[65,1327+2]..[67,1384+19])
+        attribute "foo"
+          []
+        Pmty_functor "M" (shortcut_ext_attr.ml[65,1327+17]..[65,1327+18])
+        module_type (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
+          Pmty_ident "S" (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
+        module_type (shortcut_ext_attr.ml[66,1352+4]..[67,1384+19])
+          Pmty_functor "_" (_none_[1,0+-1]..[1,0+-1]) ghost
+          module_type (shortcut_ext_attr.ml[66,1352+5]..[66,1352+27])
+            attribute "foo"
+              []
+            Pmty_typeof
+            module_expr (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
+              Pmod_ident "M" (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
+          module_type (shortcut_ext_attr.ml[67,1384+5]..[67,1384+18])
+            attribute "foo"
+              []
+            Pmty_signature
+            []
+  structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15])
+        Pstr_value Nonrec
+        [
+          <def>
+              attribute "foo"
+                []
+            pattern (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
+              Ppat_var "x" (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
+            expression (shortcut_ext_attr.ml[70,1427+18]..[70,1427+19])
+              Pexp_constant PConst_int (4,None)
+          <def>
+              attribute "foo"
+                []
+            pattern (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
+              Ppat_var "y" (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
+            expression (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
+              Pexp_ident "x" (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
+        ]
+    ]
+  structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17])
+        Pstr_type Rec
+        [
+          type_declaration "t" (shortcut_ext_attr.ml[73,1464+15]..[73,1464+16]) (shortcut_ext_attr.ml[73,1464+0]..[73,1464+22])
+            attribute "foo"
+              []
+            ptype_params =
+              []
+            ptype_cstrs =
+              []
+            ptype_kind =
+              Ptype_abstract
+            ptype_private = Public
+            ptype_manifest =
+              Some
+                core_type (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
+                  Ptyp_constr "int" (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
+                  []
+          type_declaration "t" (shortcut_ext_attr.ml[74,1487+10]..[74,1487+11]) (shortcut_ext_attr.ml[74,1487+0]..[74,1487+17])
+            attribute "foo"
+              []
+            ptype_params =
+              []
+            ptype_cstrs =
+              []
+            ptype_kind =
+              Ptype_abstract
+            ptype_private = Public
+            ptype_manifest =
+              Some
+                core_type (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
+                  Ptyp_constr "int" (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
+                  []
+        ]
+    ]
+  structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21])
+        Pstr_typext
+        type_extension
+          attribute "foo"
+            []
+          ptyext_path = "t" (shortcut_ext_attr.ml[75,1505+15]..[75,1505+16])
+          ptyext_params =
+            []
+          ptyext_constructors =
+            [
+              extension_constructor (shortcut_ext_attr.ml[75,1505+20]..[75,1505+21])
+                pext_name = "T"
+                pext_kind =
+                  Pext_decl
+                    []
+                    None
+            ]
+          ptyext_private = Public
+    ]
+  structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
+        Pstr_class
+        [
+          class_declaration (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
+            attribute "foo"
+              []
+            pci_virt = Concrete
+            pci_params =
+              []
+            pci_name = "x" (shortcut_ext_attr.ml[77,1528+16]..[77,1528+17])
+            pci_expr =
+              class_expr (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
+                Pcl_constr "x" (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
+                []
+        ]
+    ]
+  structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
+        Pstr_class_type
+        [
+          class_type_declaration (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
+            attribute "foo"
+              []
+            pci_virt = Concrete
+            pci_params =
+              []
+            pci_name = "x" (shortcut_ext_attr.ml[78,1550+21]..[78,1550+22])
+            pci_expr =
+              class_type (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
+                Pcty_constr "x" (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
+                []
+        ]
+    ]
+  structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
+        Pstr_primitive
+        value_description "x" (shortcut_ext_attr.ml[79,1577+19]..[79,1577+20]) (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
+          attribute "foo"
+            []
+          core_type (shortcut_ext_attr.ml[79,1577+23]..[79,1577+24])
+            Ptyp_any
+          [
+            ""
+          ]
+    ]
+  structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
+        Pstr_exception
+        extension_constructor (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
+          attribute "foo"
+            []
+          pext_name = "X"
+          pext_kind =
+            Pext_decl
+              []
+              None
+    ]
+  structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22])
+        Pstr_module
+        "M" (shortcut_ext_attr.ml[82,1631+17]..[82,1631+18])
+          attribute "foo"
+            []
+          module_expr (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
+            Pmod_ident "M" (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
+    ]
+  structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19])
+        Pstr_recmodule
+        [
+          "M" (shortcut_ext_attr.ml[83,1654+21]..[83,1654+22])
+            attribute "foo"
+              []
+            module_expr (shortcut_ext_attr.ml[83,1654+23]..[83,1654+30])
+              Pmod_constraint
+              module_expr (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
+                Pmod_ident "M" (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
+              module_type (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
+                Pmty_ident "S" (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
+          "M" (shortcut_ext_attr.ml[84,1685+10]..[84,1685+11])
+            attribute "foo"
+              []
+            module_expr (shortcut_ext_attr.ml[84,1685+12]..[84,1685+19])
+              Pmod_constraint
+              module_expr (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
+                Pmod_ident "M" (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
+              module_type (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
+                Pmty_ident "S" (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
+        ]
+    ]
+  structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27])
+        Pstr_modtype "S" (shortcut_ext_attr.ml[85,1705+22]..[85,1705+23])
+          attribute "foo"
+            []
+          module_type (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
+            Pmty_ident "S" (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
+    ]
+  structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19])
+        Pstr_include          attribute "foo"
+            []
+        module_expr (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
+          Pmod_ident "M" (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
+    ]
+  structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) ghost
+    Pstr_extension "foo"
+    [
+      structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16])
+        Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
+          attribute "foo"
+            []
+    ]
+  structure_item (shortcut_ext_attr.ml[91,1794+0]..[114,2190+3])
+    Pstr_modtype "S" (shortcut_ext_attr.ml[91,1794+12]..[91,1794+13])
+      module_type (shortcut_ext_attr.ml[91,1794+16]..[114,2190+3])
+        Pmty_signature
+        [
+          signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
+                Psig_value
+                value_description "x" (shortcut_ext_attr.ml[92,1814+16]..[92,1814+17]) (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
+                  attribute "foo"
+                    []
+                  core_type (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
+                    Ptyp_constr "t" (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
+                    []
+                  []
+            ]
+          signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
+                Psig_value
+                value_description "x" (shortcut_ext_attr.ml[93,1836+21]..[93,1836+22]) (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
+                  attribute "foo"
+                    []
+                  core_type (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
+                    Ptyp_constr "t" (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
+                    []
+                  [
+                    ""
+                  ]
+            ]
+          signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20])
+                Psig_type Rec
+                [
+                  type_declaration "t" (shortcut_ext_attr.ml[95,1869+17]..[95,1869+18]) (shortcut_ext_attr.ml[95,1869+2]..[95,1869+24])
+                    attribute "foo"
+                      []
+                    ptype_params =
+                      []
+                    ptype_cstrs =
+                      []
+                    ptype_kind =
+                      Ptype_abstract
+                    ptype_private = Public
+                    ptype_manifest =
+                      Some
+                        core_type (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
+                          Ptyp_constr "int" (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
+                          []
+                  type_declaration "t'" (shortcut_ext_attr.ml[96,1894+12]..[96,1894+14]) (shortcut_ext_attr.ml[96,1894+2]..[96,1894+20])
+                    attribute "foo"
+                      []
+                    ptype_params =
+                      []
+                    ptype_cstrs =
+                      []
+                    ptype_kind =
+                      Ptype_abstract
+                    ptype_private = Public
+                    ptype_manifest =
+                      Some
+                        core_type (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
+                          Ptyp_constr "int" (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
+                          []
+                ]
+            ]
+          signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23])
+                Psig_typext
+                type_extension
+                  attribute "foo"
+                    []
+                  ptyext_path = "t" (shortcut_ext_attr.ml[97,1915+17]..[97,1915+18])
+                  ptyext_params =
+                    []
+                  ptyext_constructors =
+                    [
+                      extension_constructor (shortcut_ext_attr.ml[97,1915+22]..[97,1915+23])
+                        pext_name = "T"
+                        pext_kind =
+                          Pext_decl
+                            []
+                            None
+                    ]
+                  ptyext_private = Public
+            ]
+          signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
+                Psig_exception
+                extension_constructor (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
+                  attribute "foo"
+                    []
+                  pext_name = "X"
+                  pext_kind =
+                    Pext_decl
+                      []
+                      None
+            ]
+          signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24])
+                Psig_module "M" (shortcut_ext_attr.ml[101,1965+19]..[101,1965+20])
+                  attribute "foo"
+                    []
+                module_type (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
+                  Pmty_ident "S" (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
+            ]
+          signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17])
+                Psig_recmodule
+                [
+                  "M" (shortcut_ext_attr.ml[102,1990+23]..[102,1990+24])
+                    attribute "foo"
+                      []
+                    module_type (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
+                      Pmty_ident "S" (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
+                  "M" (shortcut_ext_attr.ml[103,2019+12]..[103,2019+13])
+                    attribute "foo"
+                      []
+                    module_type (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
+                      Pmty_ident "S" (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
+                ]
+            ]
+          signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24])
+                Psig_module "M" (shortcut_ext_attr.ml[104,2037+19]..[104,2037+20])
+                  attribute "foo"
+                    []
+                module_type (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
+                  Pmty_alias "M" (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
+            ]
+          signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29])
+                Psig_modtype "S" (shortcut_ext_attr.ml[106,2063+24]..[106,2063+25])
+                  attribute "foo"
+                    []
+                  module_type (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
+                    Pmty_ident "S" (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
+            ]
+          signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21])
+                Psig_include
+                module_type (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
+                  Pmty_ident "M" (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
+                  attribute "foo"
+                    []
+            ]
+          signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18])
+                Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
+                  attribute "foo"
+                    []
+            ]
+          signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
+                Psig_class
+                [
+                  class_description (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
+                    attribute "foo"
+                      []
+                    pci_virt = Concrete
+                    pci_params =
+                      []
+                    pci_name = "x" (shortcut_ext_attr.ml[111,2136+18]..[111,2136+19])
+                    pci_expr =
+                      class_type (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
+                        Pcty_constr "t" (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
+                        []
+                ]
+            ]
+          signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) ghost
+            Psig_extension "foo"
+            [
+              signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
+                Psig_class_type
+                [
+                  class_type_declaration (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
+                    attribute "foo"
+                      []
+                    pci_virt = Concrete
+                    pci_params =
+                      []
+                    pci_name = "x" (shortcut_ext_attr.ml[112,2160+23]..[112,2160+24])
+                    pci_expr =
+                      class_type (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
+                        Pcty_constr "x" (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
+                        []
+                ]
+            ]
+        ]
+]
+
+File "shortcut_ext_attr.ml", line 4, characters 6-9:
+Error: Uninterpreted extension 'foo'.
diff --git a/testsuite/tests/ppx-attributes/Makefile b/testsuite/tests/ppx-attributes/Makefile
new file mode 100644
index 00000000..bf9c06cf
--- /dev/null
+++ b/testsuite/tests/ppx-attributes/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                              Peter Zotov                               *
+#*                                                                        *
+#*   Copyright 2014 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/ppx-attributes/warning.ml b/testsuite/tests/ppx-attributes/warning.ml
new file mode 100644
index 00000000..f50c3d60
--- /dev/null
+++ b/testsuite/tests/ppx-attributes/warning.ml
@@ -0,0 +1,47 @@
+[@@@ocaml.warning "@A"]
+
+(* Fixture *)
+
+module type DEPRECATED = sig end
+[@@ocaml.deprecated]
+
+module T = struct
+  type deprecated
+  [@@ocaml.deprecated]
+end
+
+(* Structure items *)
+
+let _ = let x = 1 in ()
+[@@ocaml.warning "-26"]
+
+include (struct let _ = let x = 1 in () end)
+[@@ocaml.warning "-26"]
+
+module A = struct let _ = let x = 1 in () end
+[@@ocaml.warning "-26"]
+
+module rec B : sig type t end = struct type t = T.deprecated end
+[@@ocaml.warning "-3"]
+
+module type T = sig type t = T.deprecated end
+[@@ocaml.warning "-3"]
+
+(* Signature items *)
+
+module type S = sig
+  val x : T.deprecated
+  [@@ocaml.warning "-3"]
+
+  module AA : sig type t = T.deprecated end
+  [@@ocaml.warning "-3"]
+
+  module rec BB : sig type t = T.deprecated end
+  [@@ocaml.warning "-3"]
+
+  module type T = sig type t = T.deprecated end
+  [@@ocaml.warning "-3"]
+
+  include DEPRECATED
+  [@@ocaml.warning "-3"]
+end
diff --git a/testsuite/tests/ppx-attributes/warning.reference b/testsuite/tests/ppx-attributes/warning.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/prim-bigstring/Makefile b/testsuite/tests/prim-bigstring/Makefile
new file mode 100644
index 00000000..379dba99
--- /dev/null
+++ b/testsuite/tests/prim-bigstring/Makefile
@@ -0,0 +1,8 @@
+BASEDIR=../..
+LIBRARIES=unix bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+              -I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/prim-bigstring/bigstring_access.ml b/testsuite/tests/prim-bigstring/bigstring_access.ml
new file mode 100644
index 00000000..512181f0
--- /dev/null
+++ b/testsuite/tests/prim-bigstring/bigstring_access.ml
@@ -0,0 +1,119 @@
+
+open Bigarray
+type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t
+
+external caml_bigstring_get_16 :
+      bigstring -> int -> int = "%caml_bigstring_get16"
+external caml_bigstring_get_32 :
+      bigstring -> int -> int32 = "%caml_bigstring_get32"
+external caml_bigstring_get_64 :
+      bigstring -> int -> int64 = "%caml_bigstring_get64"
+
+external caml_bigstring_set_16 :
+      bigstring -> int -> int -> unit = "%caml_bigstring_set16"
+external caml_bigstring_set_32 :
+      bigstring -> int -> int32 -> unit = "%caml_bigstring_set32"
+external caml_bigstring_set_64 :
+      bigstring -> int -> int64 -> unit = "%caml_bigstring_set64"
+
+let bigstring_of_string s =
+  let a = Array1.create char c_layout (String.length s) in
+  for i = 0 to String.length s - 1 do
+    a.{i} <- s.[i]
+  done;
+  a
+
+let s = bigstring_of_string (String.make 10 '\x00')
+let empty_s = bigstring_of_string ""
+
+let assert_bound_check2 f v1 v2 =
+  try
+    ignore(f v1 v2);
+    assert false
+  with
+     | Invalid_argument("index out of bounds") -> ()
+
+let assert_bound_check3 f v1 v2 v3 =
+  try
+    ignore(f v1 v2 v3);
+    assert false
+  with
+     | Invalid_argument("index out of bounds") -> ()
+
+let () =
+  assert_bound_check2 caml_bigstring_get_16 s (-1);
+  assert_bound_check2 caml_bigstring_get_16 s 9;
+  assert_bound_check2 caml_bigstring_get_32 s (-1);
+  assert_bound_check2 caml_bigstring_get_32 s 7;
+  assert_bound_check2 caml_bigstring_get_64 s (-1);
+  assert_bound_check2 caml_bigstring_get_64 s 3;
+
+  assert_bound_check3 caml_bigstring_set_16 s (-1) 0;
+  assert_bound_check3 caml_bigstring_set_16 s 9 0;
+  assert_bound_check3 caml_bigstring_set_32 s (-1) 0l;
+  assert_bound_check3 caml_bigstring_set_32 s 7 0l;
+  assert_bound_check3 caml_bigstring_set_64 s (-1) 0L;
+  assert_bound_check3 caml_bigstring_set_64 s 3 0L;
+
+  assert_bound_check2 caml_bigstring_get_16 empty_s 0;
+  assert_bound_check2 caml_bigstring_get_32 empty_s 0;
+  assert_bound_check2 caml_bigstring_get_64 empty_s 0;
+
+  assert_bound_check3 caml_bigstring_set_16 empty_s 0 0;
+  assert_bound_check3 caml_bigstring_set_32 empty_s 0 0l;
+  assert_bound_check3 caml_bigstring_set_64 empty_s 0 0L
+
+external bswap16: int -> int = "%bswap16"
+external bswap32: int32 -> int32 = "%bswap_int32"
+external bswap64: int64 -> int64 = "%bswap_int64"
+
+let swap16 x =
+  if Sys.big_endian
+  then bswap16 x
+  else x
+
+let swap32 x =
+  if Sys.big_endian
+  then bswap32 x
+  else x
+
+let swap64 x =
+  if Sys.big_endian
+  then bswap64 x
+  else x
+
+let () =
+  caml_bigstring_set_16 s 0 (swap16 0x1234);
+  Printf.printf "%x %x %x\n%!"
+                (swap16 (caml_bigstring_get_16 s 0))
+                (swap16 (caml_bigstring_get_16 s 1))
+                (swap16 (caml_bigstring_get_16 s 2));
+  caml_bigstring_set_16 s 0 (swap16 0xFEDC);
+  Printf.printf "%x %x %x\n%!"
+                (swap16 (caml_bigstring_get_16 s 0))
+                (swap16 (caml_bigstring_get_16 s 1))
+                (swap16 (caml_bigstring_get_16 s 2))
+
+let () =
+  caml_bigstring_set_32 s 0 (swap32 0x12345678l);
+  Printf.printf "%lx %lx %lx\n%!"
+                (swap32 (caml_bigstring_get_32 s 0))
+                (swap32 (caml_bigstring_get_32 s 1))
+                (swap32 (caml_bigstring_get_32 s 2));
+  caml_bigstring_set_32 s 0 (swap32 0xFEDCBA09l);
+  Printf.printf "%lx %lx %lx\n%!"
+                (swap32 (caml_bigstring_get_32 s 0))
+                (swap32 (caml_bigstring_get_32 s 1))
+                (swap32 (caml_bigstring_get_32 s 2))
+
+let () =
+  caml_bigstring_set_64 s 0 (swap64 0x1234567890ABCDEFL);
+  Printf.printf "%Lx %Lx %Lx\n%!"
+                (swap64 (caml_bigstring_get_64 s 0))
+                (swap64 (caml_bigstring_get_64 s 1))
+                (swap64 (caml_bigstring_get_64 s 2));
+  caml_bigstring_set_64 s 0 (swap64 0xFEDCBA0987654321L);
+  Printf.printf "%Lx %Lx %Lx\n%!"
+                (swap64 (caml_bigstring_get_64 s 0))
+                (swap64 (caml_bigstring_get_64 s 1))
+                (swap64 (caml_bigstring_get_64 s 2))
diff --git a/testsuite/tests/prim-bigstring/bigstring_access.reference b/testsuite/tests/prim-bigstring/bigstring_access.reference
new file mode 100644
index 00000000..22b25add
--- /dev/null
+++ b/testsuite/tests/prim-bigstring/bigstring_access.reference
@@ -0,0 +1,6 @@
+1234 12 0
+fedc fe 0
+12345678 123456 1234
+fedcba09 fedcba fedc
+1234567890abcdef 1234567890abcd 1234567890ab
+fedcba0987654321 fedcba09876543 fedcba098765
diff --git a/testsuite/tests/prim-bigstring/string_access.ml b/testsuite/tests/prim-bigstring/string_access.ml
new file mode 100644
index 00000000..48964c0b
--- /dev/null
+++ b/testsuite/tests/prim-bigstring/string_access.ml
@@ -0,0 +1,106 @@
+
+external caml_string_get_16 : string -> int -> int = "%caml_string_get16"
+external caml_string_get_32 : string -> int -> int32 = "%caml_string_get32"
+external caml_string_get_64 : string -> int -> int64 = "%caml_string_get64"
+
+external caml_string_set_16 : string -> int -> int -> unit =
+  "%caml_string_set16"
+external caml_string_set_32 : string -> int -> int32 -> unit =
+  "%caml_string_set32"
+external caml_string_set_64 : string -> int -> int64 -> unit =
+  "%caml_string_set64"
+
+let s = String.make 10 '\x00'
+let empty_s = ""
+
+let assert_bound_check2 f v1 v2 =
+  try
+    ignore(f v1 v2);
+    assert false
+  with
+     | Invalid_argument("index out of bounds") -> ()
+
+let assert_bound_check3 f v1 v2 v3 =
+  try
+    ignore(f v1 v2 v3);
+    assert false
+  with
+     | Invalid_argument("index out of bounds") -> ()
+
+let () =
+  assert_bound_check2 caml_string_get_16 s (-1);
+  assert_bound_check2 caml_string_get_16 s 9;
+  assert_bound_check2 caml_string_get_32 s (-1);
+  assert_bound_check2 caml_string_get_32 s 7;
+  assert_bound_check2 caml_string_get_64 s (-1);
+  assert_bound_check2 caml_string_get_64 s 3;
+
+  assert_bound_check3 caml_string_set_16 s (-1) 0;
+  assert_bound_check3 caml_string_set_16 s 9 0;
+  assert_bound_check3 caml_string_set_32 s (-1) 0l;
+  assert_bound_check3 caml_string_set_32 s 7 0l;
+  assert_bound_check3 caml_string_set_64 s (-1) 0L;
+  assert_bound_check3 caml_string_set_64 s 3 0L;
+
+  assert_bound_check2 caml_string_get_16 empty_s 0;
+  assert_bound_check2 caml_string_get_32 empty_s 0;
+  assert_bound_check2 caml_string_get_64 empty_s 0;
+
+  assert_bound_check3 caml_string_set_16 empty_s 0 0;
+  assert_bound_check3 caml_string_set_32 empty_s 0 0l;
+  assert_bound_check3 caml_string_set_64 empty_s 0 0L
+
+external bswap16: int -> int = "%bswap16"
+external bswap32: int32 -> int32 = "%bswap_int32"
+external bswap64: int64 -> int64 = "%bswap_int64"
+
+let swap16 x =
+  if Sys.big_endian
+  then bswap16 x
+  else x
+
+let swap32 x =
+  if Sys.big_endian
+  then bswap32 x
+  else x
+
+let swap64 x =
+  if Sys.big_endian
+  then bswap64 x
+  else x
+
+let () =
+  caml_string_set_16 s 0 (swap16 0x1234);
+  Printf.printf "%x %x %x\n%!"
+                (swap16 (caml_string_get_16 s 0))
+                (swap16 (caml_string_get_16 s 1))
+                (swap16 (caml_string_get_16 s 2));
+  caml_string_set_16 s 0 (swap16 0xFEDC);
+  Printf.printf "%x %x %x\n%!"
+                (swap16 (caml_string_get_16 s 0))
+                (swap16 (caml_string_get_16 s 1))
+                (swap16 (caml_string_get_16 s 2))
+
+let () =
+  caml_string_set_32 s 0 (swap32 0x12345678l);
+  Printf.printf "%lx %lx %lx\n%!"
+                (swap32 (caml_string_get_32 s 0))
+                (swap32 (caml_string_get_32 s 1))
+                (swap32 (caml_string_get_32 s 2));
+  caml_string_set_32 s 0 (swap32 0xFEDCBA09l);
+  Printf.printf "%lx %lx %lx\n%!"
+                (swap32 (caml_string_get_32 s 0))
+                (swap32 (caml_string_get_32 s 1))
+                (swap32 (caml_string_get_32 s 2))
+
+let () =
+  caml_string_set_64 s 0 (swap64 0x1234567890ABCDEFL);
+  Printf.printf "%Lx %Lx %Lx\n%!"
+                (swap64 (caml_string_get_64 s 0))
+                (swap64 (caml_string_get_64 s 1))
+                (swap64 (caml_string_get_64 s 2));
+  caml_string_set_64 s 0 (swap64 0xFEDCBA0987654321L);
+  Printf.printf "%Lx %Lx %Lx\n%!"
+                (swap64 (caml_string_get_64 s 0))
+                (swap64 (caml_string_get_64 s 1))
+                (swap64 (caml_string_get_64 s 2))
diff --git a/testsuite/tests/prim-bigstring/string_access.reference b/testsuite/tests/prim-bigstring/string_access.reference
new file mode 100644
index 00000000..22b25add
--- /dev/null
+++ b/testsuite/tests/prim-bigstring/string_access.reference
@@ -0,0 +1,6 @@
+1234 12 0
+fedc fe 0
+12345678 123456 1234
+fedcba09 fedcba fedc
+1234567890abcdef 1234567890abcd 1234567890ab
+fedcba0987654321 fedcba09876543 fedcba098765
diff --git a/testsuite/tests/prim-bswap/Makefile b/testsuite/tests/prim-bswap/Makefile
new file mode 100644
index 00000000..956ab4a7
--- /dev/null
+++ b/testsuite/tests/prim-bswap/Makefile
@@ -0,0 +1,17 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                    Benedikt Meurer, os-cillation GmbH                 #
+#                                                                       #
+#     Copyright 1998 Institut National de Recherche en Informatique     #
+#     et en Automatique. Copyright 2013 Benedikt Meurer. All rights     #
+#     reserved.  This file is distributed  under the terms of the Q     #
+#     Public License version 1.0.                                       #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/prim-bswap/bswap.ml b/testsuite/tests/prim-bswap/bswap.ml
new file mode 100644
index 00000000..9d757335
--- /dev/null
+++ b/testsuite/tests/prim-bswap/bswap.ml
@@ -0,0 +1,17 @@
+open Printf
+
+external bswap16: int -> int = "%bswap16"
+external bswap32: int32 -> int32 = "%bswap_int32"
+external bswap64: int64 -> int64 = "%bswap_int64"
+
+let d16 = [0x11223344;
+           0x0000f0f0]
+let d32 = [0x11223344l;
+           0xf0f0f0f0l]
+let d64 = [0x1122334455667788L;
+           0xf0f0f0f0f0f0f0f0L]
+
+let _ =
+  List.iter (fun x -> printf "%x\n" (bswap16 x)) d16;
+  List.iter (fun x -> printf "%lx\n" (bswap32 x)) d32;
+  List.iter (fun x -> printf "%Lx\n" (bswap64 x)) d64
diff --git a/testsuite/tests/prim-bswap/bswap.reference b/testsuite/tests/prim-bswap/bswap.reference
new file mode 100644
index 00000000..c08abb7f
--- /dev/null
+++ b/testsuite/tests/prim-bswap/bswap.reference
@@ -0,0 +1,6 @@
+4433
+f0f0
+44332211
+f0f0f0f0
+8877665544332211
+f0f0f0f0f0f0f0f0
diff --git a/testsuite/tests/prim-revapply/Makefile b/testsuite/tests/prim-revapply/Makefile
new file mode 100644
index 00000000..ef0afea5
--- /dev/null
+++ b/testsuite/tests/prim-revapply/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
new file mode 100644
index 00000000..1a169e18
--- /dev/null
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -0,0 +1,36 @@
+external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      f @@ 3; (* 6 *)
+      g @@ f @@ 3; (* 36 *)
+      f @@ g @@ 3; (* 18 *)
+      h @@ g @@ f @@ 3; (* 37 *)
+      add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
+    ]
+external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      f @@ 3; (* 6 *)
+      g @@ f @@ 3; (* 36 *)
+      f @@ g @@ 3; (* 18 *)
+      h @@ g @@ f @@ 3; (* 37 *)
+      add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
+    ]
diff --git a/testsuite/tests/prim-revapply/apply.reference b/testsuite/tests/prim-revapply/apply.reference
new file mode 100644
index 00000000..07fc0dc4
--- /dev/null
+++ b/testsuite/tests/prim-revapply/apply.reference
@@ -0,0 +1,10 @@
+6
+36
+18
+37
+260
+6
+36
+18
+37
+260
diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
new file mode 100644
index 00000000..f8b0dc2e
--- /dev/null
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -0,0 +1,18 @@
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      3 |> f; (* 6 *)
+      3 |> f |> g; (* 36 *)
+      3 |> g |> f; (* 18 *)
+      3 |> f |> g |> h; (* 37 *)
+      3 |> add 2 |> add 3 |> f |> g |> add 4; (* 260 *)
+    ]
diff --git a/testsuite/tests/prim-revapply/revapply.reference b/testsuite/tests/prim-revapply/revapply.reference
new file mode 100644
index 00000000..fbca4428
--- /dev/null
+++ b/testsuite/tests/prim-revapply/revapply.reference
@@ -0,0 +1,5 @@
+6
+36
+18
+37
+260
diff --git a/testsuite/tests/regression/missing_set_of_closures/Makefile b/testsuite/tests/regression/missing_set_of_closures/Makefile
new file mode 100644
index 00000000..9a1ba941
--- /dev/null
+++ b/testsuite/tests/regression/missing_set_of_closures/Makefile
@@ -0,0 +1,45 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+.PHONY: default
+default:
+	@if $(BYTECODE_ONLY); then $(MAKE) skip ; else \
+	  $(MAKE) compile; \
+	fi
+
+.PHONY: skip
+skip:
+	@echo " ... testing 'missing_set_of_closures' => skipped"
+
+.PHONY: compile
+compile:
+	@$(OCAMLOPT) -c a.ml
+	@$(OCAMLOPT) -c b.ml
+	@$(OCAMLOPT) -c b2.ml
+	@cp b.cmx b.cmi b2.cmx b2.cmi dir/
+	@cd dir; printf " ... testing 'missing_set_of_closures'"; \
+	  $(OCAMLOPT) -w -58 -c c.ml \
+            && echo " => passed" || echo " => failed"; \
+
+.PHONY: promote
+promote:
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.cmi *.cmx *.$(O) dir/*.cmi dir/*.cmx  dir/*.$(O)
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/regression/missing_set_of_closures/a.ml b/testsuite/tests/regression/missing_set_of_closures/a.ml
new file mode 100644
index 00000000..c675669d
--- /dev/null
+++ b/testsuite/tests/regression/missing_set_of_closures/a.ml
@@ -0,0 +1,9 @@
+module type Ret = sig
+  val g : int -> int -> int
+end
+
+module F() : Ret = struct
+  let n = Sys.opaque_identity 42
+  let rec f = ((fun x -> x + n) [@inline never])
+  and g = ((fun x -> f) [@inline])
+end [@@inline never]
diff --git a/testsuite/tests/regression/missing_set_of_closures/b.ml b/testsuite/tests/regression/missing_set_of_closures/b.ml
new file mode 100644
index 00000000..e510a50c
--- /dev/null
+++ b/testsuite/tests/regression/missing_set_of_closures/b.ml
@@ -0,0 +1,4 @@
+
+let g =
+  let module X = A.F() in
+  X.g
diff --git a/testsuite/tests/regression/missing_set_of_closures/b2.ml b/testsuite/tests/regression/missing_set_of_closures/b2.ml
new file mode 100644
index 00000000..5436467a
--- /dev/null
+++ b/testsuite/tests/regression/missing_set_of_closures/b2.ml
@@ -0,0 +1,2 @@
+
+let f = B.g 3
diff --git a/testsuite/tests/regression/missing_set_of_closures/dir/c.ml b/testsuite/tests/regression/missing_set_of_closures/dir/c.ml
new file mode 100644
index 00000000..e2ce54fe
--- /dev/null
+++ b/testsuite/tests/regression/missing_set_of_closures/dir/c.ml
@@ -0,0 +1,2 @@
+
+let f = B2.f
diff --git a/testsuite/tests/regression/pr3612/Makefile b/testsuite/tests/regression/pr3612/Makefile
new file mode 100644
index 00000000..866927b3
--- /dev/null
+++ b/testsuite/tests/regression/pr3612/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                       Pierre Chambart, OCamlPro                        *
+#*                                                                        *
+#*   Copyright 2014 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr3612
+C_FILES=custom_finalize
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr3612/custom_finalize.c b/testsuite/tests/regression/pr3612/custom_finalize.c
new file mode 100644
index 00000000..d09fc6d9
--- /dev/null
+++ b/testsuite/tests/regression/pr3612/custom_finalize.c
@@ -0,0 +1,65 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                        Pierre Chambart, OCamlPro                       */
+/*                                                                        */
+/*   Copyright 2014 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/custom.h>
+
+static int free_counter = 0;
+static int alloc_counter = 0;
+
+static void caml_test_finalize(value v)
+{
+  free_counter++;
+}
+
+static void caml_test_serialize(value v,
+                                uintnat * wsize_32,
+                                uintnat * wsize_64)
+{
+  *wsize_32 = 0;
+  *wsize_64 = 0;
+}
+
+uintnat caml_test_deserialize(void * dst)
+{
+  alloc_counter++;
+  return 0;
+}
+
+static struct custom_operations caml_test_ops = {
+  "_test",
+  caml_test_finalize,
+  custom_compare_default,
+  custom_hash_default,
+  caml_test_serialize,
+  caml_test_deserialize,
+  custom_compare_ext_default
+};
+
+value caml_test_pr3612_alloc(value unit)
+{
+  return caml_alloc_custom(&caml_test_ops, 0, 0, 1);
+}
+
+value caml_test_pr3612_counter(value unit)
+{
+  return Val_int(alloc_counter-free_counter);
+}
+
+CAMLprim value caml_test_pr3612_init(value unit)
+{
+  caml_register_custom_operations(&caml_test_ops);
+  return Val_unit;
+}
diff --git a/testsuite/tests/regression/pr3612/pr3612.ml b/testsuite/tests/regression/pr3612/pr3612.ml
new file mode 100644
index 00000000..70f42740
--- /dev/null
+++ b/testsuite/tests/regression/pr3612/pr3612.ml
@@ -0,0 +1,21 @@
+type t
+
+external test_alloc : unit -> t = "caml_test_pr3612_alloc"
+external get_counter : unit -> int = "caml_test_pr3612_counter"
+(* The number of deserialized blocs minus the number of freed blocs *)
+
+external init : unit -> unit = "caml_test_pr3612_init"
+
+let test s =
+  for i = 0 to 1_000_000 do
+    ignore (Marshal.from_string s 0)
+  done
+
+let f () =
+  init ();
+  let s = Marshal.to_string (test_alloc ()) [] in
+  test s;
+  Gc.full_major ();
+  print_int (get_counter ());
+  print_newline ()
+let () = (f [@inlined never]) ()
diff --git a/testsuite/tests/regression/pr3612/pr3612.reference b/testsuite/tests/regression/pr3612/pr3612.reference
new file mode 100644
index 00000000..3a2e3f49
--- /dev/null
+++ b/testsuite/tests/regression/pr3612/pr3612.reference
@@ -0,0 +1 @@
+-1
diff --git a/testsuite/tests/regression/pr5080-notes/Makefile b/testsuite/tests/regression/pr5080-notes/Makefile
new file mode 100644
index 00000000..57f971c1
--- /dev/null
+++ b/testsuite/tests/regression/pr5080-notes/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
+MAIN_MODULE = pr5080_notes_ok
+
+include ../../../makefiles/Makefile.okbad
+include ../../../makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
new file mode 100644
index 00000000..175bc8b7
--- /dev/null
+++ b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
@@ -0,0 +1,4 @@
+let marshal_int f  =
+  match [] with
+  | _ :: `INT n :: _ -> f n
+  | _ -> failwith "marshal_int"
diff --git a/testsuite/tests/regression/pr5233/Makefile b/testsuite/tests/regression/pr5233/Makefile
new file mode 100644
index 00000000..46dd3025
--- /dev/null
+++ b/testsuite/tests/regression/pr5233/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr5233
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr5233/pr5233.ml b/testsuite/tests/regression/pr5233/pr5233.ml
new file mode 100644
index 00000000..b7fddd7f
--- /dev/null
+++ b/testsuite/tests/regression/pr5233/pr5233.ml
@@ -0,0 +1,53 @@
+open Printf;;
+
+(* PR#5233: Create a dangling pointer and use it to access random parts
+   of the heap. *)
+
+(* The buggy weak array will end up in smuggle. *)
+let smuggle = ref (Weak.create 1);;
+
+(* This will be the weak array (W). *)
+let t = ref (Weak.create 1);;
+
+(* Set a finalisation function on W. *)
+Gc.finalise (fun w -> smuggle := w) !t;;
+
+(* Free W and run its finalisation function. *)
+t := Weak.create 1;;
+Gc.full_major ();;
+
+(* smuggle now contains W, whose pointers are not erased, even
+   when the contents is deallocated. *)
+
+let size = 1_000_000;;
+
+let check o =
+  printf "checking...";
+  match o with
+  | None -> printf " no value\n";
+  | Some s ->
+     printf " value found  /  testing...";
+     for i = 0 to size - 1 do
+       if s.[i] != ' ' then failwith "bad";
+     done;
+     printf " ok\n";
+;;
+
+let f () =
+  Weak.set !smuggle 0 (Some (String.make size ' '));
+
+  (* Check the data just to make sure. *)
+  check (Weak.get !smuggle 0);
+
+  (* Get a dangling pointer in W. *)
+  Gc.full_major ();
+
+  (* Fill the heap with other stuff. *)
+  let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu) in
+  let _r : int list = fill ((Gc.stat ()).Gc.heap_words / 3) [] in
+  Gc.minor ();
+
+  (* Now follow the dangling pointer and exhibit the problem. *)
+  check (Weak.get !smuggle 0)
+
+let () = (f [@inlined never]) ()
diff --git a/testsuite/tests/regression/pr5233/pr5233.reference b/testsuite/tests/regression/pr5233/pr5233.reference
new file mode 100644
index 00000000..ef728f63
--- /dev/null
+++ b/testsuite/tests/regression/pr5233/pr5233.reference
@@ -0,0 +1,2 @@
+checking... value found  /  testing... ok
+checking... no value
diff --git a/testsuite/tests/regression/pr5757/Makefile b/testsuite/tests/regression/pr5757/Makefile
new file mode 100644
index 00000000..7c03bb00
--- /dev/null
+++ b/testsuite/tests/regression/pr5757/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr5757
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr5757/pr5757.ml b/testsuite/tests/regression/pr5757/pr5757.ml
new file mode 100644
index 00000000..4bd8d85f
--- /dev/null
+++ b/testsuite/tests/regression/pr5757/pr5757.ml
@@ -0,0 +1,5 @@
+Random.init 3;;
+for i = 0 to 100_000 do
+  ignore (Bytes.create (Random.int 1_000_000))
+done;;
+Printf.printf "hello world\n";;
diff --git a/testsuite/tests/regression/pr5757/pr5757.reference b/testsuite/tests/regression/pr5757/pr5757.reference
new file mode 100644
index 00000000..3b18e512
--- /dev/null
+++ b/testsuite/tests/regression/pr5757/pr5757.reference
@@ -0,0 +1 @@
+hello world
diff --git a/testsuite/tests/regression/pr6024/Makefile b/testsuite/tests/regression/pr6024/Makefile
new file mode 100644
index 00000000..c6ff3e5f
--- /dev/null
+++ b/testsuite/tests/regression/pr6024/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr6024
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr6024/pr6024.ml b/testsuite/tests/regression/pr6024/pr6024.ml
new file mode 100644
index 00000000..7798a5ff
--- /dev/null
+++ b/testsuite/tests/regression/pr6024/pr6024.ml
@@ -0,0 +1 @@
+Format.printf "@[%@-@@-@]@.";;
diff --git a/testsuite/tests/regression/pr6024/pr6024.reference b/testsuite/tests/regression/pr6024/pr6024.reference
new file mode 100644
index 00000000..67182723
--- /dev/null
+++ b/testsuite/tests/regression/pr6024/pr6024.reference
@@ -0,0 +1 @@
+@-@-
diff --git a/testsuite/tests/regression/pr7042/Makefile b/testsuite/tests/regression/pr7042/Makefile
new file mode 100644
index 00000000..97995415
--- /dev/null
+++ b/testsuite/tests/regression/pr7042/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr7042
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr7042/pr7042.ml b/testsuite/tests/regression/pr7042/pr7042.ml
new file mode 100644
index 00000000..3fa80abe
--- /dev/null
+++ b/testsuite/tests/regression/pr7042/pr7042.ml
@@ -0,0 +1,4 @@
+let _ =
+  let a = [| 0.0; -. 0.0 |] in
+  Printf.printf "%Lx %Lx\n"
+                (Int64.bits_of_float a.(0)) (Int64.bits_of_float a.(1))
diff --git a/testsuite/tests/regression/pr7042/pr7042.reference b/testsuite/tests/regression/pr7042/pr7042.reference
new file mode 100644
index 00000000..c6a412a4
--- /dev/null
+++ b/testsuite/tests/regression/pr7042/pr7042.reference
@@ -0,0 +1 @@
+0 8000000000000000
diff --git a/testsuite/tests/regression/pr7426/Makefile b/testsuite/tests/regression/pr7426/Makefile
new file mode 100644
index 00000000..8b245519
--- /dev/null
+++ b/testsuite/tests/regression/pr7426/Makefile
@@ -0,0 +1,20 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAIN_MODULE=pr7426
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr7426/pr7426.ml b/testsuite/tests/regression/pr7426/pr7426.ml
new file mode 100644
index 00000000..55aa4bfa
--- /dev/null
+++ b/testsuite/tests/regression/pr7426/pr7426.ml
@@ -0,0 +1 @@
+class some_class = object val some_val = 0.0 end
diff --git a/testsuite/tests/regression/pr7426/pr7426.reference b/testsuite/tests/regression/pr7426/pr7426.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/required-external/Makefile b/testsuite/tests/required-external/Makefile
new file mode 100644
index 00000000..0285e743
--- /dev/null
+++ b/testsuite/tests/required-external/Makefile
@@ -0,0 +1,18 @@
+# Ensure that calling an external C primite forces linking
+# the module that defines it
+
+MAIN_MODULE = main
+LIBRARIES = lib
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+main.cmo: lib.cma
+main.cmx: lib.cmxa
+
+lib.cma: file.cmo
+	@$(OCAMLC) -a -o $@ $<
+
+lib.cmxa: file.cmx
+	@$(OCAMLOPT) -a -o $@ $<
diff --git a/testsuite/tests/required-external/file.ml b/testsuite/tests/required-external/file.ml
new file mode 100644
index 00000000..f90910a8
--- /dev/null
+++ b/testsuite/tests/required-external/file.ml
@@ -0,0 +1,7 @@
+external getcwd : unit -> string = "caml_sys_getcwd"
+
+let f () = ()
+
+let () =
+  print_endline "Module `File' is linked";
+  flush stdout
diff --git a/testsuite/tests/required-external/main.ml b/testsuite/tests/required-external/main.ml
new file mode 100644
index 00000000..32d16576
--- /dev/null
+++ b/testsuite/tests/required-external/main.ml
@@ -0,0 +1,2 @@
+let () =
+  ignore (File.getcwd ())
diff --git a/testsuite/tests/required-external/main.reference b/testsuite/tests/required-external/main.reference
new file mode 100644
index 00000000..12971896
--- /dev/null
+++ b/testsuite/tests/required-external/main.reference
@@ -0,0 +1 @@
+Module `File' is linked
diff --git a/testsuite/tests/runtime-C-exceptions/Makefile b/testsuite/tests/runtime-C-exceptions/Makefile
new file mode 100644
index 00000000..da534b75
--- /dev/null
+++ b/testsuite/tests/runtime-C-exceptions/Makefile
@@ -0,0 +1,7 @@
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=test
+C_FILES=stub_test
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/runtime-C-exceptions/stub_test.c b/testsuite/tests/runtime-C-exceptions/stub_test.c
new file mode 100644
index 00000000..b7ffd242
--- /dev/null
+++ b/testsuite/tests/runtime-C-exceptions/stub_test.c
@@ -0,0 +1,20 @@
+#include <string.h>
+#include "caml/memory.h"
+#include "caml/alloc.h"
+#include "caml/mlvalues.h"
+#include "caml/fail.h"
+
+char *some_dynamic_string_that_should_be_freed()
+{
+    return strdup("bar");
+}
+
+CAMLexport value dynamic_invalid_argument(value unit)
+{
+    CAMLparam1(unit);
+    char *dynamic_msg = some_dynamic_string_that_should_be_freed();
+    value msg = caml_copy_string(dynamic_msg);
+    free(dynamic_msg);
+    caml_invalid_argument_value(msg);
+    CAMLnoreturn;
+}
diff --git a/testsuite/tests/runtime-C-exceptions/test.ml b/testsuite/tests/runtime-C-exceptions/test.ml
new file mode 100644
index 00000000..794e27cb
--- /dev/null
+++ b/testsuite/tests/runtime-C-exceptions/test.ml
@@ -0,0 +1,11 @@
+external failwith_from_ocaml : string -> 'a = "caml_failwith_value"
+
+external dynamic_invalid_argument : unit -> 'a = "dynamic_invalid_argument"
+
+let () =
+  try failwith_from_ocaml ("fo" ^ "o")
+  with Failure foo -> print_endline foo
+
+let () =
+  try dynamic_invalid_argument ()
+  with Invalid_argument bar -> print_endline bar
diff --git a/testsuite/tests/runtime-C-exceptions/test.reference b/testsuite/tests/runtime-C-exceptions/test.reference
new file mode 100644
index 00000000..3bd1f0e2
--- /dev/null
+++ b/testsuite/tests/runtime-C-exceptions/test.reference
@@ -0,0 +1,2 @@
+foo
+bar
diff --git a/testsuite/tests/runtime-errors/Makefile b/testsuite/tests/runtime-errors/Makefile
new file mode 100644
index 00000000..cee8ca8c
--- /dev/null
+++ b/testsuite/tests/runtime-errors/Makefile
@@ -0,0 +1,79 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+.PHONY: default
+default:
+	@$(MAKE) compile
+	@$(MAKE) run
+
+.PHONY: compile
+compile:
+	@for f in *.ml; do \
+	  F=`basename $$f .ml`; \
+	  rm -f $$F.bytecode $$F.native $$F.native.exe; \
+	  $(OCAMLC) -w a -o $$F.bytecode $$f; \
+	  if $(BYTECODE_ONLY); then : ; else \
+	    $(OCAMLOPT) -w a -o $$F.native$(EXE) $$f; \
+	  fi; \
+	done
+	@grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/config/s.h \
+	  || rm -f stackoverflow.native$(EXE)
+
+# Cygwin doesn't allow the stack limit to be changed - the 4096 is
+# intended to be larger than the its default stack size. The logic
+# causes the test to be skipped if the stacksize cannot be brought
+# below this value (uname -s value exits with an error status in Cygwin)
+.PHONY: run
+run:
+	@ul=`ulimit -s`; \
+	 if ( [ "$$ul" = "unlimited" ] || [ $$ul -gt 4096 ] ) ; then \
+	   ulimit -s 1024 && ul=1 || ul=0 ; \
+	 else \
+	   ul=1; \
+	 fi; \
+	 for f in *.bytecode; do \
+	  printf " ... testing '$$f':"; \
+	  if [ $$ul -eq 1 ] ; then \
+	    $(OCAMLRUN) ./$$f >$$f.result 2>&1 || true; \
+	    DIFF="$(DIFF)" sh $$f.checker \
+	    && echo " => passed" || echo " => failed"; \
+	  else \
+	    echo " => unexpected error"; \
+	  fi; \
+	  fn=`basename $$f bytecode`native; \
+	  if $(BYTECODE_ONLY) || [ ! -f "$${fn}$(EXE)" ] ; then \
+	    echo " ... testing '$$fn': => skipped" ; \
+	  else \
+	    printf " ... testing '$$fn':"; \
+	    if [ $$ul -eq 1 ] ; then \
+	      ./$${fn}$(EXE) >$$fn.result 2>&1 || true; \
+	      DIFF="$(DIFF)" sh $$fn.checker \
+	      && echo " => passed" || echo " => failed"; \
+	    else \
+	      echo " => unexpected error"; \
+	    fi; \
+	  fi; \
+	done
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.bytecode *.native *.native.exe *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker
new file mode 100644
index 00000000..c850ba05
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+$DIFF stackoverflow.bytecode.reference stackoverflow.bytecode.result
diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
new file mode 100644
index 00000000..a5bbdea3
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
@@ -0,0 +1,4 @@
+x = 20000
+x = 10000
+x = 0
+Stack overflow caught
diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
new file mode 100644
index 00000000..ab53b8b0
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -0,0 +1,15 @@
+let rec f x =
+  if not (x = 0 || x = 10000 || x = 20000)
+  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/testsuite/tests/runtime-errors/stackoverflow.native.checker b/testsuite/tests/runtime-errors/stackoverflow.native.checker
new file mode 100644
index 00000000..f640718a
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.native.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+$DIFF stackoverflow.native.reference stackoverflow.native.result
diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.reference b/testsuite/tests/runtime-errors/stackoverflow.native.reference
new file mode 100644
index 00000000..a5bbdea3
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.native.reference
@@ -0,0 +1,4 @@
+x = 20000
+x = 10000
+x = 0
+Stack overflow caught
diff --git a/testsuite/tests/runtime-errors/syserror.bytecode.checker b/testsuite/tests/runtime-errors/syserror.bytecode.checker
new file mode 100644
index 00000000..6433b148
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.bytecode.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+grep 'Fatal error: exception Sys_error' syserror.bytecode.result >/dev/null
diff --git a/testsuite/tests/runtime-errors/syserror.bytecode.reference b/testsuite/tests/runtime-errors/syserror.bytecode.reference
new file mode 100644
index 00000000..3f6219a2
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.bytecode.reference
@@ -0,0 +1 @@
+Fatal error: exception Sys_error("titi:/toto: No such file or directory")
diff --git a/testsuite/tests/runtime-errors/syserror.ml b/testsuite/tests/runtime-errors/syserror.ml
new file mode 100644
index 00000000..46f62ead
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.ml
@@ -0,0 +1 @@
+let channel = open_out "titi:/toto"
diff --git a/testsuite/tests/runtime-errors/syserror.native.checker b/testsuite/tests/runtime-errors/syserror.native.checker
new file mode 100644
index 00000000..41448fff
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.native.checker
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+grep 'Fatal error: exception Sys_error' syserror.native.result >/dev/null
diff --git a/testsuite/tests/runtime-errors/syserror.native.reference b/testsuite/tests/runtime-errors/syserror.native.reference
new file mode 100644
index 00000000..3f6219a2
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.native.reference
@@ -0,0 +1 @@
+Fatal error: exception Sys_error("titi:/toto: No such file or directory")
diff --git a/testsuite/tests/self-contained-toplevel/Makefile b/testsuite/tests/self-contained-toplevel/Makefile
new file mode 100644
index 00000000..5126305b
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/Makefile
@@ -0,0 +1,34 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2016 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=ocaml
+MODULES=foo cached_cmi
+MAIN_MODULE=main
+COMPFLAGS=-I $(OTOPDIR)/typing -I $(OTOPDIR)/toplevel
+LIBRARIES=../../../compilerlibs/ocamlcommon \
+          ../../../compilerlibs/ocamlbytecomp \
+          ../../../compilerlibs/ocamltoplevel
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+BYTECODE_ONLY=true
+GENERATED_SOURCES+=cached_cmi.ml
+EXEC_ARGS=$(OCFLAGS) -noinit input.ml
+
+cached_cmi.ml: foo.cmi gen_cached_cmi.ml
+	@$(OCAML) ../../../compilerlibs/ocamlcommon.cma -I $(OTOPDIR)/typing \
+	          gen_cached_cmi.ml > $@
diff --git a/testsuite/tests/self-contained-toplevel/foo.ml b/testsuite/tests/self-contained-toplevel/foo.ml
new file mode 100644
index 00000000..2747ada0
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/foo.ml
@@ -0,0 +1 @@
+let value = "Hello, world!"
diff --git a/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml b/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml
new file mode 100644
index 00000000..176c3b2e
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml
@@ -0,0 +1,4 @@
+let () =
+  let cmi = Cmi_format.read_cmi "foo.cmi" in
+  let data = Marshal.to_string cmi [] in
+  Printf.printf "let foo = %S\n" data
diff --git a/testsuite/tests/self-contained-toplevel/input.ml b/testsuite/tests/self-contained-toplevel/input.ml
new file mode 100644
index 00000000..46072371
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/input.ml
@@ -0,0 +1 @@
+print_endline Foo.value;;
diff --git a/testsuite/tests/self-contained-toplevel/main.ml b/testsuite/tests/self-contained-toplevel/main.ml
new file mode 100644
index 00000000..606c4df5
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/main.ml
@@ -0,0 +1,13 @@
+let () =
+  (* Make sure it's no longer available on disk *)
+  if Sys.file_exists "foo.cmi" then Sys.remove "foo.cmi";
+  let old_loader = !Env.Persistent_signature.load in
+  Env.Persistent_signature.load := (fun ~unit_name ->
+    match unit_name with
+    | "Foo" ->
+      Some { Env.Persistent_signature.
+             filename = Sys.executable_name
+           ; cmi      = Marshal.from_string Cached_cmi.foo 0
+           }
+    | _ -> old_loader unit_name);
+  Topmain.main ()
diff --git a/testsuite/tests/self-contained-toplevel/main.reference b/testsuite/tests/self-contained-toplevel/main.reference
new file mode 100644
index 00000000..af5626b4
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/main.reference
@@ -0,0 +1 @@
+Hello, world!
diff --git a/testsuite/tests/tool-command-line/Makefile b/testsuite/tests/tool-command-line/Makefile
new file mode 100644
index 00000000..148dafa2
--- /dev/null
+++ b/testsuite/tests/tool-command-line/Makefile
@@ -0,0 +1,54 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                          Bernhard Schommer                             *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+
+default:
+	@$(MAKE) byte
+	@if $(BYTECODE_ONLY); then $(MAKE) opt-skipped ; else \
+          $(MAKE) opt; \
+        fi
+
+byte:
+	@$(OCAMLC) unknown-file 2>&1 | grep "don't know what to do with unknown-file" \
+	> unknown-file.byte.result  || true
+	@for file in *.byte.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+opt:
+	@$(OCAMLOPT) unknown-file  2>&1 | grep "don't know what to do with unknown-file"\
+	> unknown-file.opt.result || true
+	@for file in *.opt.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+opt-skipped:
+	@for file in *.opt.reference; do \
+	  printf " ... testing '$$file':"; \
+          echo " => skipped"; \
+	done
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-command-line/unknown-file b/testsuite/tests/tool-command-line/unknown-file
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/tool-command-line/unknown-file.byte.reference b/testsuite/tests/tool-command-line/unknown-file.byte.reference
new file mode 100644
index 00000000..9182c8a7
--- /dev/null
+++ b/testsuite/tests/tool-command-line/unknown-file.byte.reference
@@ -0,0 +1 @@
+don't know what to do with unknown-file
diff --git a/testsuite/tests/tool-command-line/unknown-file.opt.reference b/testsuite/tests/tool-command-line/unknown-file.opt.reference
new file mode 100644
index 00000000..9182c8a7
--- /dev/null
+++ b/testsuite/tests/tool-command-line/unknown-file.opt.reference
@@ -0,0 +1 @@
+don't know what to do with unknown-file
diff --git a/testsuite/tests/tool-debugger/basic/Makefile b/testsuite/tests/tool-debugger/basic/Makefile
new file mode 100644
index 00000000..d732007a
--- /dev/null
+++ b/testsuite/tests/tool-debugger/basic/Makefile
@@ -0,0 +1,61 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*            Damien Doligez, EPI Gallium, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../../..
+MAIN_MODULE=debuggee
+ADD_COMPFLAGS=-g -custom
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(MAKE) compile; \
+	  $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
+	fi
+
+.PHONY: compile
+compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo
+	@rm -f program.byte program.byte.exe
+	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
+	           $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+	           $(MAIN_MODULE).cmo
+	@mkdir -p compiler-libs
+	@cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
+
+.PHONY: run
+run:
+	@printf " ... testing with ocamlc"
+	@rm -f $(MAIN_MODULE).result
+	@echo 'source input_script' | \
+	 $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
+	             program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \
+	 && sed -e '/Debugger version/d' -e '/^Time:/d' -e '$$d' \
+	        $(MAIN_MODULE).raw.result >$(MAIN_MODULE).result \
+	 && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
+	 && echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result program.byte program.byte.exe \
+	       program.native program.native.exe \
+	       $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
+	@rm -rf compiler-libs
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-debugger/basic/debuggee.ml b/testsuite/tests/tool-debugger/basic/debuggee.ml
new file mode 100644
index 00000000..341d0b36
--- /dev/null
+++ b/testsuite/tests/tool-debugger/basic/debuggee.ml
@@ -0,0 +1,2 @@
+print_endline Sys.argv.(1);;
+print_endline (Sys.getenv "foo");;
diff --git a/testsuite/tests/tool-debugger/basic/debuggee.reference b/testsuite/tests/tool-debugger/basic/debuggee.reference
new file mode 100644
index 00000000..e998926c
--- /dev/null
+++ b/testsuite/tests/tool-debugger/basic/debuggee.reference
@@ -0,0 +1,5 @@
+
+(ocd) Loading program... done.
+arg1
+notbar
+Program exit.
diff --git a/testsuite/tests/tool-debugger/basic/input_script b/testsuite/tests/tool-debugger/basic/input_script
new file mode 100755
index 00000000..2caf06dd
--- /dev/null
+++ b/testsuite/tests/tool-debugger/basic/input_script
@@ -0,0 +1,5 @@
+set arguments arg1 arg2
+environment foo=bar
+environment foo=notbar
+run
+quit
diff --git a/testsuite/tests/tool-debugger/find-artifacts/Makefile b/testsuite/tests/tool-debugger/find-artifacts/Makefile
new file mode 100644
index 00000000..13fe316a
--- /dev/null
+++ b/testsuite/tests/tool-debugger/find-artifacts/Makefile
@@ -0,0 +1,70 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*            Damien Doligez, EPI Gallium, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../../..
+MAIN_MODULE=debuggee
+ADD_COMPFLAGS=-g -custom
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(MAKE) compile; \
+	  $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
+	fi
+
+.PHONY: compile
+compile: $(ML_FILES) $(CMO_FILES)
+	@rm -rf out
+	@rm -f program.byte program.byte.exe
+	@mkdir out
+	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/blah.cmo -c \
+	           $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+	           in/blah.ml
+	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/foo.cmo -c \
+	           $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+	           -I out in/foo.ml
+	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
+	           $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+						 out/blah.cmo out/foo.cmo
+	@mkdir -p compiler-libs
+	@cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
+
+.PHONY: run
+run:
+	@printf " ... testing with ocamlc"
+	@rm -f $(MAIN_MODULE).result
+	@echo 'source input_script' | \
+	 $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
+	             program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \
+	 && sed -e '/Debugger version/d' -e '/^Time:/d' \
+	        -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \
+	        $(MAIN_MODULE).raw.result | tr -d '\r' >$(MAIN_MODULE).result \
+	 && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
+	 && echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result program.byte program.byte.exe \
+	       program.native program.native.exe \
+	       $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
+	@rm -rf compiler-libs out
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference
new file mode 100644
index 00000000..06564f90
--- /dev/null
+++ b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference
@@ -0,0 +1,6 @@
+
+(ocd) Loading program... done.
+Breakpoint: 1
+10   <|b|>print x;
+x: Blah.blah = Foo
+y: Blah.blah = Bar "hi"
diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml
new file mode 100644
index 00000000..462c07b2
--- /dev/null
+++ b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml
@@ -0,0 +1,3 @@
+type blah =
+  | Foo
+  | Bar of string
diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml
new file mode 100644
index 00000000..8d992673
--- /dev/null
+++ b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml
@@ -0,0 +1,13 @@
+open Blah
+
+let print = function
+  | Foo -> print_endline "Foo";
+  | Bar s -> print_endline ("Bar(" ^ s ^ ")")
+
+let main () =
+  let x = Foo in
+  let y = Bar "hi" in
+  print x;
+  print y
+
+let _ = main ()
diff --git a/testsuite/tests/tool-debugger/find-artifacts/input_script b/testsuite/tests/tool-debugger/find-artifacts/input_script
new file mode 100644
index 00000000..4b907c5a
--- /dev/null
+++ b/testsuite/tests/tool-debugger/find-artifacts/input_script
@@ -0,0 +1,5 @@
+break @ Foo 10
+run
+print x
+print y
+quit
diff --git a/testsuite/tests/tool-debugger/no_debug_event/Makefile b/testsuite/tests/tool-debugger/no_debug_event/Makefile
new file mode 100644
index 00000000..7ddafa35
--- /dev/null
+++ b/testsuite/tests/tool-debugger/no_debug_event/Makefile
@@ -0,0 +1,60 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*            Damien Doligez, EPI Gallium, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 2013 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../../..
+ADD_COMPFLAGS=-g -custom
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(MAKE) compile; \
+	  $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
+	fi
+
+.PHONY: compile
+compile: $(ML_FILES) $(CMO_FILES)
+	@rm -f c$(EXE)
+	@$(OCAMLC) $(ADD_COMPFLAGS) -c a.ml -for-pack foo
+	@$(OCAMLC) $(ADD_COMPFLAGS) a.cmo -pack -o foo.cmo
+	@$(OCAMLC) $(ADD_COMPFLAGS) -c b.ml
+	@$(OCAMLC) $(ADD_COMPFLAGS) foo.cmo b.cmo -o c$(EXE)
+	@mkdir -p compiler-libs
+	@cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
+
+.PHONY: run
+run:
+	@printf " ... testing with ocamlc"
+	@rm -f noev.result
+	@echo 'source input_script' | \
+	 $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
+	             c$(EXE) >noev.raw.result 2>&1 \
+	 && sed -e '/Debugger version/d' -e '/^Time:/d' \
+	        -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \
+	        noev.raw.result >noev.result \
+	 && $(DIFF) noev.reference noev.result >/dev/null \
+	 && echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.cm* c$(EXE)
+	@rm -rf compiler-libs
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-debugger/no_debug_event/a.ml b/testsuite/tests/tool-debugger/no_debug_event/a.ml
new file mode 100644
index 00000000..0547b3d0
--- /dev/null
+++ b/testsuite/tests/tool-debugger/no_debug_event/a.ml
@@ -0,0 +1 @@
+let x = 1
diff --git a/testsuite/tests/tool-debugger/no_debug_event/b.ml b/testsuite/tests/tool-debugger/no_debug_event/b.ml
new file mode 100644
index 00000000..83502097
--- /dev/null
+++ b/testsuite/tests/tool-debugger/no_debug_event/b.ml
@@ -0,0 +1,3 @@
+let () =
+  print_int Foo.A.x;
+  print_newline ()
diff --git a/testsuite/tests/tool-debugger/no_debug_event/input_script b/testsuite/tests/tool-debugger/no_debug_event/input_script
new file mode 100644
index 00000000..58afc787
--- /dev/null
+++ b/testsuite/tests/tool-debugger/no_debug_event/input_script
@@ -0,0 +1,2 @@
+run
+quit
diff --git a/testsuite/tests/tool-debugger/no_debug_event/noev.reference b/testsuite/tests/tool-debugger/no_debug_event/noev.reference
new file mode 100644
index 00000000..d4a69fc9
--- /dev/null
+++ b/testsuite/tests/tool-debugger/no_debug_event/noev.reference
@@ -0,0 +1,4 @@
+
+(ocd) Loading program... done.
+1
+Program exit.
diff --git a/testsuite/tests/tool-lexyacc/Makefile b/testsuite/tests/tool-lexyacc/Makefile
new file mode 100644
index 00000000..479e8a25
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/Makefile
@@ -0,0 +1,25 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=syntax gram_aux grammar scan_aux scanner lexgen output
+MAIN_MODULE=main
+LEX_MODULES=scanner
+YACC_MODULES=grammar
+ADD_COMPFLAGS=-w a
+EXEC_ARGS=input
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-lexyacc/gram_aux.ml b/testsuite/tests/tool-lexyacc/gram_aux.ml
new file mode 100644
index 00000000..019565f8
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/gram_aux.ml
@@ -0,0 +1,32 @@
+(* 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/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly
new file mode 100644
index 00000000..02a7155e
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/grammar.mly
@@ -0,0 +1,99 @@
+/* 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/testsuite/tests/tool-lexyacc/input b/testsuite/tests/tool-lexyacc/input
new file mode 100644
index 00000000..6739bc30
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/input
@@ -0,0 +1,134 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml
new file mode 100644
index 00000000..ff34fe01
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/lexgen.ml
@@ -0,0 +1,256 @@
+(* 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), ((ToAction n2) :: r2 as s2) ->
+      t1 :: merge_trans r1 s2
+  | ((ToAction n1) :: r1 as s1), ((OnChars n2 as t2) :: r2) ->
+      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.make 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.make 256 []
+  and shift = Array.make 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.make (number_of_states()) (Perform 0) in
+  List.iter (fun (auto, i) -> v.(i) <- auto) states;
+  (initial_states, v, actions)
diff --git a/testsuite/tests/tool-lexyacc/main.ml b/testsuite/tests/tool-lexyacc/main.ml
new file mode 100644
index 00000000..16b9a3a9
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/main.ml
@@ -0,0 +1,105 @@
+(* 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; *) ignore dest_name;
+  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 ->
+        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/testsuite/tests/tool-lexyacc/main.reference b/testsuite/tests/tool-lexyacc/main.reference
new file mode 100644
index 00000000..f3dac422
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/main.reference
@@ -0,0 +1,312 @@
+66 states, 44 actions.
+
+open Syntax
+open Grammar
+open Scan_aux
+
+let rec action_43 lexbuf = (
+ comment lexbuf )
+and action_42 lexbuf = (
+ raise(Lexical_error "unterminated comment") )
+and action_41 lexbuf = (
+ reset_string_buffer();
+      string lexbuf;
+      reset_string_buffer();
+      comment lexbuf )
+and action_40 lexbuf = (
+ decr comment_depth;
+      if !comment_depth = 0 then () else comment lexbuf )
+and action_39 lexbuf = (
+ incr comment_depth; comment lexbuf )
+and action_38 lexbuf = (
+ raise(Lexical_error "bad character constant") )
+and action_37 lexbuf = (
+ char_for_decimal_code lexbuf 1 )
+and action_36 lexbuf = (
+ char_for_backslash (Lexing.lexeme_char lexbuf 1) )
+and action_35 lexbuf = (
+ Lexing.lexeme_char lexbuf 0 )
+and action_34 lexbuf = (
+ store_string_char(Lexing.lexeme_char lexbuf 0);
+      string lexbuf )
+and action_33 lexbuf = (
+ raise(Lexical_error "unterminated string") )
+and action_32 lexbuf = (
+ store_string_char(char_for_decimal_code lexbuf 1);
+      string lexbuf )
+and action_31 lexbuf = (
+ store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+      string lexbuf )
+and action_30 lexbuf = (
+ string lexbuf )
+and action_29 lexbuf = (
+ () )
+and action_28 lexbuf = (
+ action lexbuf )
+and action_27 lexbuf = (
+ raise (Lexical_error "unterminated action") )
+and action_26 lexbuf = (
+ comment_depth := 1;
+      comment lexbuf;
+      action lexbuf )
+and action_25 lexbuf = (
+ let _ = char lexbuf in action lexbuf )
+and action_24 lexbuf = (
+ reset_string_buffer();
+      string lexbuf;
+      reset_string_buffer();
+      action lexbuf )
+and action_23 lexbuf = (
+ decr brace_depth;
+      if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf )
+and action_22 lexbuf = (
+ incr brace_depth;
+      action lexbuf )
+and action_21 lexbuf = (
+ raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) )
+and action_20 lexbuf = (
+ raise(Lexical_error "unterminated lexer definition") )
+and action_19 lexbuf = (
+ Tdash )
+and action_18 lexbuf = (
+ Tcaret )
+and action_17 lexbuf = (
+ Trparen )
+and action_16 lexbuf = (
+ Tlparen )
+and action_15 lexbuf = (
+ Tplus )
+and action_14 lexbuf = (
+ Tmaybe )
+and action_13 lexbuf = (
+ Tstar )
+and action_12 lexbuf = (
+ Trbracket )
+and action_11 lexbuf = (
+ Tlbracket )
+and action_10 lexbuf = (
+ Teof )
+and action_9 lexbuf = (
+ Tunderscore )
+and action_8 lexbuf = (
+ Tor )
+and action_7 lexbuf = (
+ Tend )
+and action_6 lexbuf = (
+ Tequal )
+and action_5 lexbuf = (
+ let n1 = Lexing.lexeme_end lexbuf in
+        brace_depth := 1;
+        let n2 = action lexbuf in
+          Taction(Location(n1, n2)) )
+and action_4 lexbuf = (
+ Tchar(char lexbuf) )
+and action_3 lexbuf = (
+ reset_string_buffer();
+      string lexbuf;
+      Tstring(get_stored_string()) )
+and action_2 lexbuf = (
+ match Lexing.lexeme lexbuf with
+        "rule" -> Trule
+      | "parse" -> Tparse
+      | "and" -> Tand
+      | "eof" -> Teof
+      | s -> Tident s )
+and action_1 lexbuf = (
+ comment_depth := 1;
+      comment lexbuf;
+      main lexbuf )
+and action_0 lexbuf = (
+ main lexbuf )
+and state_0 lexbuf =
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A' -> state_51 lexbuf
+ |  ' '|'\013'|'\n'|'\t' -> state_40 lexbuf
+ |  '|' -> action_8 lexbuf
+ |  '{' -> action_5 lexbuf
+ |  'e' -> state_56 lexbuf
+ |  '_' -> state_55 lexbuf
+ |  '^' -> action_18 lexbuf
+ |  ']' -> action_12 lexbuf
+ |  '[' -> action_11 lexbuf
+ |  '?' -> action_14 lexbuf
+ |  '=' -> action_6 lexbuf
+ |  ';' -> state_48 lexbuf
+ |  '-' -> action_19 lexbuf
+ |  '+' -> action_15 lexbuf
+ |  '*' -> action_13 lexbuf
+ |  ')' -> action_17 lexbuf
+ |  '(' -> state_43 lexbuf
+ |  '\'' -> action_4 lexbuf
+ |  '"' -> action_3 lexbuf
+ |  '\000' -> action_20 lexbuf
+ |  _ -> action_21 lexbuf
+and state_1 lexbuf =
+  match lexing.next_char lexbuf with
+    '}' -> action_23 lexbuf
+ |  '{' -> action_22 lexbuf
+ |  '(' -> state_34 lexbuf
+ |  '\'' -> action_25 lexbuf
+ |  '"' -> action_24 lexbuf
+ |  '\000' -> action_27 lexbuf
+ |  _ -> action_28 lexbuf
+and state_2 lexbuf =
+  match lexing.next_char lexbuf with
+    '\\' -> state_24 lexbuf
+ |  '"' -> action_29 lexbuf
+ |  '\000' -> action_33 lexbuf
+ |  _ -> action_34 lexbuf
+and state_3 lexbuf =
+  match lexing.next_char lexbuf with
+    '\\' -> state_13 lexbuf
+ |  '\000' -> lexing.backtrack lexbuf
+ |  _ -> state_12 lexbuf
+and state_4 lexbuf =
+  match lexing.next_char lexbuf with
+    '*' -> state_9 lexbuf
+ |  '(' -> state_8 lexbuf
+ |  '"' -> action_41 lexbuf
+ |  '\000' -> action_42 lexbuf
+ |  _ -> action_43 lexbuf
+and state_8 lexbuf =
+  Lexing.set_backtrack lexbuf action_43;
+  match lexing.next_char lexbuf with
+    '*' -> action_39 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_9 lexbuf =
+  Lexing.set_backtrack lexbuf action_43;
+  match lexing.next_char lexbuf with
+    ')' -> action_40 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_12 lexbuf =
+  Lexing.set_backtrack lexbuf action_38;
+  match lexing.next_char lexbuf with
+    '\'' -> action_35 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_13 lexbuf =
+  Lexing.set_backtrack lexbuf action_38;
+  match lexing.next_char lexbuf with
+    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_15 lexbuf
+ |  't'|'r'|'n'|'b'|'\\'|'\'' -> state_14 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_14 lexbuf =
+  match lexing.next_char lexbuf with
+    '\'' -> action_36 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_15 lexbuf =
+  match lexing.next_char lexbuf with
+    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_16 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_16 lexbuf =
+  match lexing.next_char lexbuf with
+    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_17 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_17 lexbuf =
+  match lexing.next_char lexbuf with
+    '\'' -> action_37 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_24 lexbuf =
+  Lexing.set_backtrack lexbuf action_34;
+  match lexing.next_char lexbuf with
+    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_27 lexbuf
+ |  't'|'r'|'n'|'b'|'\\'|'"' -> action_31 lexbuf
+ |  ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_25 lexbuf =
+  Lexing.set_backtrack lexbuf action_30;
+  match lexing.next_char lexbuf with
+    ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_27 lexbuf =
+  match lexing.next_char lexbuf with
+    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_28 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_28 lexbuf =
+  match lexing.next_char lexbuf with
+    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> action_32 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_34 lexbuf =
+  Lexing.set_backtrack lexbuf action_28;
+  match lexing.next_char lexbuf with
+    '*' -> action_26 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_40 lexbuf =
+  Lexing.set_backtrack lexbuf action_0;
+  match lexing.next_char lexbuf with
+    ' '|'\013'|'\n'|'\t' -> state_65 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_43 lexbuf =
+  Lexing.set_backtrack lexbuf action_16;
+  match lexing.next_char lexbuf with
+    '*' -> action_1 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_48 lexbuf =
+  Lexing.set_backtrack lexbuf action_21;
+  match lexing.next_char lexbuf with
+    ';' -> action_7 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_51 lexbuf =
+  Lexing.set_backtrack lexbuf action_2;
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  '_' -> state_60 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_55 lexbuf =
+  Lexing.set_backtrack lexbuf action_9;
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_56 lexbuf =
+  Lexing.set_backtrack lexbuf action_2;
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  'o' -> state_61 lexbuf
+ |  '_' -> state_60 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_59 lexbuf =
+  Lexing.set_backtrack lexbuf action_2;
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  '_' -> state_60 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_60 lexbuf =
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_61 lexbuf =
+  Lexing.set_backtrack lexbuf action_2;
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  'f' -> state_62 lexbuf
+ |  '_' -> state_60 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_62 lexbuf =
+  Lexing.set_backtrack lexbuf action_2;
+  match lexing.next_char lexbuf with
+    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
+ |  '_' -> state_60 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and state_65 lexbuf =
+  Lexing.set_backtrack lexbuf action_0;
+  match lexing.next_char lexbuf with
+    ' '|'\013'|'\n'|'\t' -> state_65 lexbuf
+ |  _ -> lexing.backtrack lexbuf
+and main lexbuf =
+  Lexing.init lexbuf;
+  state_0 lexbuf
+
+and action lexbuf =
+  Lexing.init lexbuf;
+  state_1 lexbuf
+
+and string lexbuf =
+  Lexing.init lexbuf;
+  state_2 lexbuf
+
+and char lexbuf =
+  Lexing.init lexbuf;
+  state_3 lexbuf
+
+and comment lexbuf =
+  Lexing.init lexbuf;
+  state_4 lexbuf
diff --git a/testsuite/tests/tool-lexyacc/output.ml b/testsuite/tests/tool-lexyacc/output.ml
new file mode 100644
index 00000000..973aa5e4
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/output.ml
@@ -0,0 +1,152 @@
+(* 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 = Bytes.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 (Bytes.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 "\nand "; output_entries rest
+
+
+(* All together *)
+
+let output_lexdef header (initial_st, st, actions) =
+  print_int (Array.length st); print_string " states, ";
+  print_int (List.length actions); print_string " actions.";
+  print_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/testsuite/tests/tool-lexyacc/scan_aux.ml b/testsuite/tests/tool-lexyacc/scan_aux.ml
new file mode 100644
index 00000000..96362fce
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/scan_aux.ml
@@ -0,0 +1,45 @@
+(* Auxiliaries for the lexical analyzer *)
+
+let brace_depth = ref 0
+let comment_depth = ref 0
+
+exception Lexical_error of string
+
+let initial_string_buffer = Bytes.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 >= Bytes.length !string_buff then begin
+      let new_buff = Bytes.create (Bytes.length !string_buff * 2) in
+      Bytes.blit new_buff 0 !string_buff 0 (Bytes.length !string_buff);
+      string_buff := new_buff
+    end
+  end;
+  Bytes.unsafe_set !string_buff !string_index c;
+  incr string_index
+
+let get_stored_string () =
+  let s = Bytes.sub_string !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/testsuite/tests/tool-lexyacc/scanner.mll b/testsuite/tests/tool-lexyacc/scanner.mll
new file mode 100644
index 00000000..f21fd7cd
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/scanner.mll
@@ -0,0 +1,118 @@
+(* 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/testsuite/tests/tool-lexyacc/syntax.ml b/testsuite/tests/tool-lexyacc/syntax.ml
new file mode 100644
index 00000000..f692e6f6
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/syntax.ml
@@ -0,0 +1,26 @@
+(* 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/testsuite/tests/tool-ocaml/Makefile b/testsuite/tests/tool-ocaml/Makefile
new file mode 100644
index 00000000..cd4578d7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/Makefile
@@ -0,0 +1,36 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+SHOULD_FAIL=t060-raise.ml
+
+compile: lib.cmo
+	@for file in t*.ml; do \
+	  printf " ... testing '$$file'"; \
+	  if [ `echo $(SHOULD_FAIL) | grep $$file` ]; then \
+	    $(OCAML) -w a lib.cmo $$file 2>/dev/null \
+	    && echo " => failed" || echo " => passed"; \
+	  else \
+	    $(OCAML) -w a lib.cmo $$file 2>/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  fi; \
+	done
+
+promote:
+
+clean: defaultclean
+	@rm -f ./a.out
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocaml/lib.ml b/testsuite/tests/tool-ocaml/lib.ml
new file mode 100644
index 00000000..9ab74271
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/lib.ml
@@ -0,0 +1,42 @@
+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;;
diff --git a/testsuite/tests/tool-ocaml/t000.ml b/testsuite/tests/tool-ocaml/t000.ml
new file mode 100644
index 00000000..27520c66
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t000.ml
@@ -0,0 +1,7 @@
+(* empty file *)
+
+(**
+       0 ATOM0
+       1 SETGLOBAL T000
+       3 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t010-const0.ml b/testsuite/tests/tool-ocaml/t010-const0.ml
new file mode 100644
index 00000000..65bb3ded
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t010-const0.ml
@@ -0,0 +1,8 @@
+0;;
+
+(**
+       0 CONST0
+       1 ATOM0
+       2 SETGLOBAL T010-const0
+       4 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t010-const1.ml b/testsuite/tests/tool-ocaml/t010-const1.ml
new file mode 100644
index 00000000..8238b4fc
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t010-const1.ml
@@ -0,0 +1,8 @@
+1;;
+
+(**
+       0 CONST1
+       1 ATOM0
+       2 SETGLOBAL T010-const1
+       4 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t010-const2.ml b/testsuite/tests/tool-ocaml/t010-const2.ml
new file mode 100644
index 00000000..8bbffdbc
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t010-const2.ml
@@ -0,0 +1,8 @@
+2;;
+
+(**
+       0 CONST2
+       1 ATOM0
+       2 SETGLOBAL T010-const2
+       4 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t010-const3.ml b/testsuite/tests/tool-ocaml/t010-const3.ml
new file mode 100644
index 00000000..e5767ccc
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t010-const3.ml
@@ -0,0 +1,8 @@
+3;;
+
+(**
+       0 CONST3
+       1 ATOM0
+       2 SETGLOBAL T010-const3
+       4 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t011-constint.ml b/testsuite/tests/tool-ocaml/t011-constint.ml
new file mode 100644
index 00000000..104f6050
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t011-constint.ml
@@ -0,0 +1,8 @@
+4;;
+
+(**
+       0 CONSTINT 4
+       2 ATOM0
+       3 SETGLOBAL T011-constint
+       5 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t020.ml b/testsuite/tests/tool-ocaml/t020.ml
new file mode 100644
index 00000000..afbce871
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t021-pushconst1.ml b/testsuite/tests/tool-ocaml/t021-pushconst1.ml
new file mode 100644
index 00000000..863bd89a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t021-pushconst2.ml b/testsuite/tests/tool-ocaml/t021-pushconst2.ml
new file mode 100644
index 00000000..9e7e42a9
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t021-pushconst3.ml b/testsuite/tests/tool-ocaml/t021-pushconst3.ml
new file mode 100644
index 00000000..5a674f6a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t022-pushconstint.ml b/testsuite/tests/tool-ocaml/t022-pushconstint.ml
new file mode 100644
index 00000000..f1c71ea5
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t040-makeblock1.ml b/testsuite/tests/tool-ocaml/t040-makeblock1.ml
new file mode 100644
index 00000000..87458cd9
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t040-makeblock2.ml b/testsuite/tests/tool-ocaml/t040-makeblock2.ml
new file mode 100644
index 00000000..d64c3401
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t040-makeblock3.ml b/testsuite/tests/tool-ocaml/t040-makeblock3.ml
new file mode 100644
index 00000000..03c79818
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t041-makeblock.ml b/testsuite/tests/tool-ocaml/t041-makeblock.ml
new file mode 100644
index 00000000..4d38eac8
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t050-getglobal.ml b/testsuite/tests/tool-ocaml/t050-getglobal.ml
new file mode 100644
index 00000000..7481ca2a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t050-getglobal.ml
@@ -0,0 +1,8 @@
+[1];;
+
+(**
+       0 GETGLOBAL <0>(1, 0)
+       2 ATOM0
+       3 SETGLOBAL T050-getglobal
+       5 STOP
+**)
diff --git a/testsuite/tests/tool-ocaml/t050-pushgetglobal.ml b/testsuite/tests/tool-ocaml/t050-pushgetglobal.ml
new file mode 100644
index 00000000..62be92f0
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t051-getglobalfield.ml b/testsuite/tests/tool-ocaml/t051-getglobalfield.ml
new file mode 100644
index 00000000..eb3b6108
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t051-pushgetglobalfield.ml b/testsuite/tests/tool-ocaml/t051-pushgetglobalfield.ml
new file mode 100644
index 00000000..3e8a37e6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t060-raise.ml b/testsuite/tests/tool-ocaml/t060-raise.ml
new file mode 100644
index 00000000..aff2e387
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t070-branch.ml b/testsuite/tests/tool-ocaml/t070-branch.ml
new file mode 100644
index 00000000..92e00c09
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t070-branchif.ml b/testsuite/tests/tool-ocaml/t070-branchif.ml
new file mode 100644
index 00000000..26675771
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t070-branchifnot.ml b/testsuite/tests/tool-ocaml/t070-branchifnot.ml
new file mode 100644
index 00000000..d8fa5950
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t071-boolnot.ml b/testsuite/tests/tool-ocaml/t071-boolnot.ml
new file mode 100644
index 00000000..8993d134
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t080-eq.ml b/testsuite/tests/tool-ocaml/t080-eq.ml
new file mode 100644
index 00000000..53d82f2e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t080-geint.ml b/testsuite/tests/tool-ocaml/t080-geint.ml
new file mode 100644
index 00000000..9da5078f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t080-gtint.ml b/testsuite/tests/tool-ocaml/t080-gtint.ml
new file mode 100644
index 00000000..dfefd259
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t080-leint.ml b/testsuite/tests/tool-ocaml/t080-leint.ml
new file mode 100644
index 00000000..04880dc0
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t080-ltint.ml b/testsuite/tests/tool-ocaml/t080-ltint.ml
new file mode 100644
index 00000000..8f23f297
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t080-neq.ml b/testsuite/tests/tool-ocaml/t080-neq.ml
new file mode 100644
index 00000000..a43d84c9
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc0.ml b/testsuite/tests/tool-ocaml/t090-acc0.ml
new file mode 100644
index 00000000..669249b6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc1.ml b/testsuite/tests/tool-ocaml/t090-acc1.ml
new file mode 100644
index 00000000..33f3e4e3
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc2.ml b/testsuite/tests/tool-ocaml/t090-acc2.ml
new file mode 100644
index 00000000..415727a1
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc3.ml b/testsuite/tests/tool-ocaml/t090-acc3.ml
new file mode 100644
index 00000000..4faf079c
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc4.ml b/testsuite/tests/tool-ocaml/t090-acc4.ml
new file mode 100644
index 00000000..0d4bd892
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc5.ml b/testsuite/tests/tool-ocaml/t090-acc5.ml
new file mode 100644
index 00000000..a4176c75
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc6.ml b/testsuite/tests/tool-ocaml/t090-acc6.ml
new file mode 100644
index 00000000..db456b38
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t090-acc7.ml b/testsuite/tests/tool-ocaml/t090-acc7.ml
new file mode 100644
index 00000000..c53003c6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t091-acc.ml b/testsuite/tests/tool-ocaml/t091-acc.ml
new file mode 100644
index 00000000..06c2ad8d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc.ml b/testsuite/tests/tool-ocaml/t092-pushacc.ml
new file mode 100644
index 00000000..75eac87f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc0.ml b/testsuite/tests/tool-ocaml/t092-pushacc0.ml
new file mode 100644
index 00000000..756304df
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc1.ml b/testsuite/tests/tool-ocaml/t092-pushacc1.ml
new file mode 100644
index 00000000..e5cd00af
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc2.ml b/testsuite/tests/tool-ocaml/t092-pushacc2.ml
new file mode 100644
index 00000000..b1c66c4d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc3.ml b/testsuite/tests/tool-ocaml/t092-pushacc3.ml
new file mode 100644
index 00000000..0713c0b6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc4.ml b/testsuite/tests/tool-ocaml/t092-pushacc4.ml
new file mode 100644
index 00000000..9052f7f6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc5.ml b/testsuite/tests/tool-ocaml/t092-pushacc5.ml
new file mode 100644
index 00000000..0f5e32e7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc6.ml b/testsuite/tests/tool-ocaml/t092-pushacc6.ml
new file mode 100644
index 00000000..a3de52ca
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t092-pushacc7.ml b/testsuite/tests/tool-ocaml/t092-pushacc7.ml
new file mode 100644
index 00000000..cd1481d2
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t093-pushacc.ml b/testsuite/tests/tool-ocaml/t093-pushacc.ml
new file mode 100644
index 00000000..8e756b1c
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t100-pushtrap.ml b/testsuite/tests/tool-ocaml/t100-pushtrap.ml
new file mode 100644
index 00000000..8eae20e5
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t101-poptrap.ml b/testsuite/tests/tool-ocaml/t101-poptrap.ml
new file mode 100644
index 00000000..cbb5944f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-addint.ml b/testsuite/tests/tool-ocaml/t110-addint.ml
new file mode 100644
index 00000000..39aa844d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-andint.ml b/testsuite/tests/tool-ocaml/t110-andint.ml
new file mode 100644
index 00000000..44017ece
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-asrint-1.ml b/testsuite/tests/tool-ocaml/t110-asrint-1.ml
new file mode 100644
index 00000000..bab98685
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-asrint-2.ml b/testsuite/tests/tool-ocaml/t110-asrint-2.ml
new file mode 100644
index 00000000..be714867
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-divint-1.ml b/testsuite/tests/tool-ocaml/t110-divint-1.ml
new file mode 100644
index 00000000..2c1c5b94
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-divint-2.ml b/testsuite/tests/tool-ocaml/t110-divint-2.ml
new file mode 100644
index 00000000..effdf34b
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-divint-3.ml b/testsuite/tests/tool-ocaml/t110-divint-3.ml
new file mode 100644
index 00000000..3ccc1512
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-lslint.ml b/testsuite/tests/tool-ocaml/t110-lslint.ml
new file mode 100644
index 00000000..bb25709e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-lsrint.ml b/testsuite/tests/tool-ocaml/t110-lsrint.ml
new file mode 100644
index 00000000..21994a0b
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-modint-1.ml b/testsuite/tests/tool-ocaml/t110-modint-1.ml
new file mode 100644
index 00000000..97eaacdd
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-modint-2.ml b/testsuite/tests/tool-ocaml/t110-modint-2.ml
new file mode 100644
index 00000000..edc7ceb0
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-mulint.ml b/testsuite/tests/tool-ocaml/t110-mulint.ml
new file mode 100644
index 00000000..6c963f6a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-negint.ml b/testsuite/tests/tool-ocaml/t110-negint.ml
new file mode 100644
index 00000000..aef6121d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-offsetint.ml b/testsuite/tests/tool-ocaml/t110-offsetint.ml
new file mode 100644
index 00000000..7793d003
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-orint.ml b/testsuite/tests/tool-ocaml/t110-orint.ml
new file mode 100644
index 00000000..bb5e9453
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-subint.ml b/testsuite/tests/tool-ocaml/t110-subint.ml
new file mode 100644
index 00000000..06a23dd6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t110-xorint.ml b/testsuite/tests/tool-ocaml/t110-xorint.ml
new file mode 100644
index 00000000..ae248d23
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t120-getstringchar.ml b/testsuite/tests/tool-ocaml/t120-getstringchar.ml
new file mode 100644
index 00000000..a663ecf4
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t121-setstringchar.ml b/testsuite/tests/tool-ocaml/t121-setstringchar.ml
new file mode 100644
index 00000000..ea19572e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t121-setstringchar.ml
@@ -0,0 +1,31 @@
+open Lib;;
+let x = Bytes.of_string "foo" in
+x.[2] <- 'x';
+if Bytes.get 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/testsuite/tests/tool-ocaml/t130-getvectitem.ml b/testsuite/tests/tool-ocaml/t130-getvectitem.ml
new file mode 100644
index 00000000..964ebc9f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t130-vectlength.ml b/testsuite/tests/tool-ocaml/t130-vectlength.ml
new file mode 100644
index 00000000..aee59441
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t131-setvectitem.ml b/testsuite/tests/tool-ocaml/t131-setvectitem.ml
new file mode 100644
index 00000000..b813e91b
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t140-switch-1.ml b/testsuite/tests/tool-ocaml/t140-switch-1.ml
new file mode 100644
index 00000000..9e3eee15
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t140-switch-2.ml b/testsuite/tests/tool-ocaml/t140-switch-2.ml
new file mode 100644
index 00000000..ecc5772a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t140-switch-3.ml b/testsuite/tests/tool-ocaml/t140-switch-3.ml
new file mode 100644
index 00000000..316461df
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t140-switch-4.ml b/testsuite/tests/tool-ocaml/t140-switch-4.ml
new file mode 100644
index 00000000..6f72ba35
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t141-switch-5.ml b/testsuite/tests/tool-ocaml/t141-switch-5.ml
new file mode 100644
index 00000000..e5b49e6a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t141-switch-6.ml b/testsuite/tests/tool-ocaml/t141-switch-6.ml
new file mode 100644
index 00000000..5a720327
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t141-switch-7.ml b/testsuite/tests/tool-ocaml/t141-switch-7.ml
new file mode 100644
index 00000000..a7082d08
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t142-switch-8.ml b/testsuite/tests/tool-ocaml/t142-switch-8.ml
new file mode 100644
index 00000000..d32346fc
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t142-switch-9.ml b/testsuite/tests/tool-ocaml/t142-switch-9.ml
new file mode 100644
index 00000000..5fbda767
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t142-switch-A.ml b/testsuite/tests/tool-ocaml/t142-switch-A.ml
new file mode 100644
index 00000000..fc8aa5c6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t150-push-1.ml b/testsuite/tests/tool-ocaml/t150-push-1.ml
new file mode 100644
index 00000000..7319388a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t150-push-2.ml b/testsuite/tests/tool-ocaml/t150-push-2.ml
new file mode 100644
index 00000000..c0837bf1
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t160-closure.ml b/testsuite/tests/tool-ocaml/t160-closure.ml
new file mode 100644
index 00000000..2d2f0cce
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t161-apply1.ml b/testsuite/tests/tool-ocaml/t161-apply1.ml
new file mode 100644
index 00000000..2892cbe7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t162-return.ml b/testsuite/tests/tool-ocaml/t162-return.ml
new file mode 100644
index 00000000..1e08ab4e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t163.ml b/testsuite/tests/tool-ocaml/t163.ml
new file mode 100644
index 00000000..e2760b97
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t164-apply2.ml b/testsuite/tests/tool-ocaml/t164-apply2.ml
new file mode 100644
index 00000000..ae908538
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t164-apply3.ml b/testsuite/tests/tool-ocaml/t164-apply3.ml
new file mode 100644
index 00000000..a05aac2a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t165-apply.ml b/testsuite/tests/tool-ocaml/t165-apply.ml
new file mode 100644
index 00000000..e4787321
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t170-envacc2.ml b/testsuite/tests/tool-ocaml/t170-envacc2.ml
new file mode 100644
index 00000000..8e9a0219
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t170-envacc3.ml b/testsuite/tests/tool-ocaml/t170-envacc3.ml
new file mode 100644
index 00000000..d0be88ce
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t170-envacc4.ml b/testsuite/tests/tool-ocaml/t170-envacc4.ml
new file mode 100644
index 00000000..9764c3b2
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t171-envacc.ml b/testsuite/tests/tool-ocaml/t171-envacc.ml
new file mode 100644
index 00000000..a83295b8
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t172-pushenvacc1.ml b/testsuite/tests/tool-ocaml/t172-pushenvacc1.ml
new file mode 100644
index 00000000..ba615ba7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t172-pushenvacc2.ml b/testsuite/tests/tool-ocaml/t172-pushenvacc2.ml
new file mode 100644
index 00000000..afdbcc5d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t172-pushenvacc3.ml b/testsuite/tests/tool-ocaml/t172-pushenvacc3.ml
new file mode 100644
index 00000000..308fd5ed
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t172-pushenvacc4.ml b/testsuite/tests/tool-ocaml/t172-pushenvacc4.ml
new file mode 100644
index 00000000..feba1281
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t173-pushenvacc.ml b/testsuite/tests/tool-ocaml/t173-pushenvacc.ml
new file mode 100644
index 00000000..ffddf8d7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t180-appterm1.ml b/testsuite/tests/tool-ocaml/t180-appterm1.ml
new file mode 100644
index 00000000..a0006caf
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t180-appterm2.ml b/testsuite/tests/tool-ocaml/t180-appterm2.ml
new file mode 100644
index 00000000..850301d0
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t180-appterm3.ml b/testsuite/tests/tool-ocaml/t180-appterm3.ml
new file mode 100644
index 00000000..eedc52e5
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t181-appterm.ml b/testsuite/tests/tool-ocaml/t181-appterm.ml
new file mode 100644
index 00000000..2222bc40
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t190-makefloatblock-1.ml b/testsuite/tests/tool-ocaml/t190-makefloatblock-1.ml
new file mode 100644
index 00000000..1d906c9c
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t190-makefloatblock-2.ml b/testsuite/tests/tool-ocaml/t190-makefloatblock-2.ml
new file mode 100644
index 00000000..bb06aba8
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t190-makefloatblock-3.ml b/testsuite/tests/tool-ocaml/t190-makefloatblock-3.ml
new file mode 100644
index 00000000..581439df
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t191-vectlength.ml b/testsuite/tests/tool-ocaml/t191-vectlength.ml
new file mode 100644
index 00000000..6cd19667
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t192-getfloatfield-1.ml b/testsuite/tests/tool-ocaml/t192-getfloatfield-1.ml
new file mode 100644
index 00000000..bd8109f4
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t192-getfloatfield-2.ml b/testsuite/tests/tool-ocaml/t192-getfloatfield-2.ml
new file mode 100644
index 00000000..0c62a4b0
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t193-setfloatfield-1.ml b/testsuite/tests/tool-ocaml/t193-setfloatfield-1.ml
new file mode 100644
index 00000000..c679c43a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t193-setfloatfield-2.ml b/testsuite/tests/tool-ocaml/t193-setfloatfield-2.ml
new file mode 100644
index 00000000..2088257a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t200-getfield0.ml b/testsuite/tests/tool-ocaml/t200-getfield0.ml
new file mode 100644
index 00000000..b3f59fe5
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t200-getfield1.ml b/testsuite/tests/tool-ocaml/t200-getfield1.ml
new file mode 100644
index 00000000..4dcb2f7c
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t200-getfield2.ml b/testsuite/tests/tool-ocaml/t200-getfield2.ml
new file mode 100644
index 00000000..02f3234f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t200-getfield3.ml b/testsuite/tests/tool-ocaml/t200-getfield3.ml
new file mode 100644
index 00000000..b8ba042e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t201-getfield.ml b/testsuite/tests/tool-ocaml/t201-getfield.ml
new file mode 100644
index 00000000..91f86fb7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t210-setfield0.ml b/testsuite/tests/tool-ocaml/t210-setfield0.ml
new file mode 100644
index 00000000..b7fce85a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t210-setfield1.ml b/testsuite/tests/tool-ocaml/t210-setfield1.ml
new file mode 100644
index 00000000..7bb65c55
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t210-setfield2.ml b/testsuite/tests/tool-ocaml/t210-setfield2.ml
new file mode 100644
index 00000000..4cd42ecf
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t210-setfield3.ml b/testsuite/tests/tool-ocaml/t210-setfield3.ml
new file mode 100644
index 00000000..7df75362
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t211-setfield.ml b/testsuite/tests/tool-ocaml/t211-setfield.ml
new file mode 100644
index 00000000..47e3b7db
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t220-assign.ml b/testsuite/tests/tool-ocaml/t220-assign.ml
new file mode 100644
index 00000000..ecb57e60
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t230-check_signals.ml b/testsuite/tests/tool-ocaml/t230-check_signals.ml
new file mode 100644
index 00000000..41e82d8c
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t240-c_call1.ml b/testsuite/tests/tool-ocaml/t240-c_call1.ml
new file mode 100644
index 00000000..70809c75
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t240-c_call1.ml
@@ -0,0 +1,27 @@
+open Lib;;
+if Pervasives.int_of_string "123" <> 123 then raise Not_found;;
+(** test for fix of bug 6649: http://caml.inria.fr/mantis/view.php?id=6649 *)
+if Pervasives.int_of_string "+123" <> 123 then raise Not_found;;
+
+if Int32.of_string "+123" <> Int32.of_int 123 then raise Not_found;;
+if Int64.of_string "+123" <> Int64.of_int 123 then raise Not_found;;
+if Nativeint.of_string "+123" <> Nativeint.of_int 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/testsuite/tests/tool-ocaml/t240-c_call2.ml b/testsuite/tests/tool-ocaml/t240-c_call2.ml
new file mode 100644
index 00000000..733b3412
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t240-c_call3.ml b/testsuite/tests/tool-ocaml/t240-c_call3.ml
new file mode 100644
index 00000000..4e91c3fd
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t240-c_call3.ml
@@ -0,0 +1,23 @@
+open Lib;;
+if Hashtbl.hash_param 5 6 [1;2;3] <> 697606130 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/testsuite/tests/tool-ocaml/t240-c_call4.ml b/testsuite/tests/tool-ocaml/t240-c_call4.ml
new file mode 100644
index 00000000..8297eb14
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t240-c_call4.ml
@@ -0,0 +1,32 @@
+open Lib;;
+let s = Bytes.of_string "abcdefgh" in
+Bytes.unsafe_fill s 0 6 'x';
+if Bytes.get 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/testsuite/tests/tool-ocaml/t240-c_call5.ml b/testsuite/tests/tool-ocaml/t240-c_call5.ml
new file mode 100644
index 00000000..535bb377
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t240-c_call5.ml
@@ -0,0 +1,33 @@
+open Lib;;
+let s = Bytes.of_string "abcdefgh" in
+Bytes.unsafe_blit s 3 s 0 3;
+if Bytes.get 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/testsuite/tests/tool-ocaml/t250-closurerec-1.ml b/testsuite/tests/tool-ocaml/t250-closurerec-1.ml
new file mode 100644
index 00000000..283b17a3
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t250-closurerec-2.ml b/testsuite/tests/tool-ocaml/t250-closurerec-2.ml
new file mode 100644
index 00000000..ffe3d481
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t251-pushoffsetclosure0.ml b/testsuite/tests/tool-ocaml/t251-pushoffsetclosure0.ml
new file mode 100644
index 00000000..1ea295a3
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t251-pushoffsetclosure2.ml b/testsuite/tests/tool-ocaml/t251-pushoffsetclosure2.ml
new file mode 100644
index 00000000..8634f29e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t251-pushoffsetclosurem2.ml b/testsuite/tests/tool-ocaml/t251-pushoffsetclosurem2.ml
new file mode 100644
index 00000000..65267e5b
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t252-pushoffsetclosure.ml b/testsuite/tests/tool-ocaml/t252-pushoffsetclosure.ml
new file mode 100644
index 00000000..dccce95a
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t253-offsetclosure0.ml b/testsuite/tests/tool-ocaml/t253-offsetclosure0.ml
new file mode 100644
index 00000000..35d66ba3
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t253-offsetclosure2.ml b/testsuite/tests/tool-ocaml/t253-offsetclosure2.ml
new file mode 100644
index 00000000..55adf632
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t253-offsetclosurem2.ml b/testsuite/tests/tool-ocaml/t253-offsetclosurem2.ml
new file mode 100644
index 00000000..e61e0c22
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t254-offsetclosure.ml b/testsuite/tests/tool-ocaml/t254-offsetclosure.ml
new file mode 100644
index 00000000..95eb1b0c
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t260-offsetref.ml b/testsuite/tests/tool-ocaml/t260-offsetref.ml
new file mode 100644
index 00000000..20dbf2c0
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t270-push_retaddr.ml b/testsuite/tests/tool-ocaml/t270-push_retaddr.ml
new file mode 100644
index 00000000..2c13f225
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t300-getmethod.ml b/testsuite/tests/tool-ocaml/t300-getmethod.ml
new file mode 100644
index 00000000..8108e801
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t301-object.ml b/testsuite/tests/tool-ocaml/t301-object.ml
new file mode 100644
index 00000000..6b33f827
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t301-object.ml
@@ -0,0 +1,25 @@
+(**** 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
+
+***)
+
+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;;
diff --git a/testsuite/tests/tool-ocaml/t310-alloc-1.ml b/testsuite/tests/tool-ocaml/t310-alloc-1.ml
new file mode 100644
index 00000000..9e0ff1a2
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t310-alloc-2.ml b/testsuite/tests/tool-ocaml/t310-alloc-2.ml
new file mode 100644
index 00000000..efdc399b
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t320-gc-1.ml b/testsuite/tests/tool-ocaml/t320-gc-1.ml
new file mode 100644
index 00000000..dde4e0b6
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t320-gc-2.ml b/testsuite/tests/tool-ocaml/t320-gc-2.ml
new file mode 100644
index 00000000..39ec57c4
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t320-gc-3.ml b/testsuite/tests/tool-ocaml/t320-gc-3.ml
new file mode 100644
index 00000000..69a63682
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t330-compact-1.ml b/testsuite/tests/tool-ocaml/t330-compact-1.ml
new file mode 100644
index 00000000..aaa80f0f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t330-compact-2.ml b/testsuite/tests/tool-ocaml/t330-compact-2.ml
new file mode 100644
index 00000000..fa91834e
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t330-compact-3.ml b/testsuite/tests/tool-ocaml/t330-compact-3.ml
new file mode 100644
index 00000000..44d80a7d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t330-compact-4.ml b/testsuite/tests/tool-ocaml/t330-compact-4.ml
new file mode 100644
index 00000000..60161a5f
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t340-weak.ml b/testsuite/tests/tool-ocaml/t340-weak.ml
new file mode 100644
index 00000000..7ced585d
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t340-weak.ml
@@ -0,0 +1,24 @@
+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
+;;
diff --git a/testsuite/tests/tool-ocaml/t350-heapcheck.ml b/testsuite/tests/tool-ocaml/t350-heapcheck.ml
new file mode 100644
index 00000000..45295eaa
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/t350-heapcheck.ml
@@ -0,0 +1,25 @@
+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
+;;
diff --git a/testsuite/tests/tool-ocaml/t360-stacks-1.ml b/testsuite/tests/tool-ocaml/t360-stacks-1.ml
new file mode 100644
index 00000000..2c257a79
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocaml/t360-stacks-2.ml b/testsuite/tests/tool-ocaml/t360-stacks-2.ml
new file mode 100644
index 00000000..88a884c7
--- /dev/null
+++ b/testsuite/tests/tool-ocaml/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/testsuite/tests/tool-ocamlc-open/Makefile b/testsuite/tests/tool-ocamlc-open/Makefile
new file mode 100644
index 00000000..4e2c52d3
--- /dev/null
+++ b/testsuite/tests/tool-ocamlc-open/Makefile
@@ -0,0 +1,14 @@
+BASEDIR=../..
+
+compile:
+	@printf " ... testing 'foo.ml'"
+	@$(OCAMLC) -c a.ml
+	@$(OCAMLC) -open A.M -c b.ml \
+	&& echo " => passed" || echo " => failed"
+
+promote:
+
+clean:
+	@rm -f a.cmi a.cmo b.cmi b.cmo
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamlc-open/a.ml b/testsuite/tests/tool-ocamlc-open/a.ml
new file mode 100644
index 00000000..4ae15f14
--- /dev/null
+++ b/testsuite/tests/tool-ocamlc-open/a.ml
@@ -0,0 +1,3 @@
+module M = struct
+  let f x = x +1
+end
diff --git a/testsuite/tests/tool-ocamlc-open/b.ml b/testsuite/tests/tool-ocamlc-open/b.ml
new file mode 100644
index 00000000..6c781576
--- /dev/null
+++ b/testsuite/tests/tool-ocamlc-open/b.ml
@@ -0,0 +1 @@
+let g = f
diff --git a/testsuite/tests/tool-ocamldep-modalias/A.ml b/testsuite/tests/tool-ocamldep-modalias/A.ml
new file mode 100644
index 00000000..9faa225a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/A.ml
@@ -0,0 +1 @@
+let f x = x +1
diff --git a/testsuite/tests/tool-ocamldep-modalias/B.ml b/testsuite/tests/tool-ocamldep-modalias/B.ml
new file mode 100644
index 00000000..17d27a3e
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/B.ml
@@ -0,0 +1,2 @@
+open Packed
+let g = A.f
diff --git a/testsuite/tests/tool-ocamldep-modalias/C.ml b/testsuite/tests/tool-ocamldep-modalias/C.ml
new file mode 100644
index 00000000..87cb814d
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/C.ml
@@ -0,0 +1,2 @@
+open Lib
+let h x = A.f x + B.g x
diff --git a/testsuite/tests/tool-ocamldep-modalias/D.ml b/testsuite/tests/tool-ocamldep-modalias/D.ml
new file mode 100644
index 00000000..9f192def
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/D.ml
@@ -0,0 +1 @@
+let z x = imp (x*2)
diff --git a/testsuite/tests/tool-ocamldep-modalias/Makefile b/testsuite/tests/tool-ocamldep-modalias/Makefile
new file mode 100644
index 00000000..476a8ace
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/Makefile
@@ -0,0 +1,73 @@
+# Test for ocamldep and -no-alias-deps
+# There are two versions:
+#  Makefile.build uses -no-alias-deps only for lib.ml/mli
+#  Makefile.build2 has no lib.ml, and uses -no-alias-deps for components too
+
+OCAMLDEP=$(OCAMLRUN) $(OTOPDIR)/tools/ocamldep
+SOURCES = A.ml B.ml C.ml D.ml
+LINKS = $(SOURCES:%=Lib%)
+DEPENDS = depend.mk depend.mk2 depend.mod depend.mod2 depend.mod3
+
+all:	clean
+	@$(MAKE) build > /dev/null
+	@$(MAKE) $(DEPENDS) > /dev/null
+	@$(MAKE) compare
+
+build:	depend.mk depend.mk2
+	rm -f $(LINKS)
+	if $(NATIVECODE_ONLY); then : ; else \
+	   $(MAKE) -f Makefile.build byte; \
+	   rm -f *.cm* lib.ml; \
+	   $(MAKE) -f Makefile.build2 byte; fi
+	if $(BYTECODE_ONLY); then :; else \
+	   $(MAKE) -f Makefile.build opt; \
+	   rm -f *.cm* lib.ml; \
+	   $(MAKE) -f Makefile.build2 opt; fi
+
+# Create links for prefixed versions of the components
+Lib%.ml: %.ml
+	cp $< $@
+
+# Dependencies for Makefile.build, compiling and linking lib.cmo
+depend.mk: $(LINKS)
+	cp lib_impl.ml lib.ml
+	$(OCAMLDEP) -as-map lib.ml lib.mli > $@
+	$(OCAMLDEP) -map lib.ml -open Lib $(LINKS) >> $@
+
+# Dependencies for Makefile.build2, not compiling lib.cmo
+depend.mk2: $(LINKS)
+	rm -f lib.ml
+	$(OCAMLDEP) -map lib.mli -open Lib \
+	  $(LINKS) > $@
+
+# Others tests for ocamldep
+depend.mod: $(LINKS)
+	cp lib_impl.ml lib.ml
+	$(OCAMLDEP) -as-map -modules lib.ml lib.mli > $@
+	$(OCAMLDEP) -modules -map lib.ml -open Lib $(LINKS) >> $@
+
+depend.mod2: $(LINKS)
+	rm -f lib.ml
+	$(OCAMLDEP) -modules -map lib.mli $(LINKS) > $@
+
+depend.mod3: $(LINKS)
+	rm -f lib.ml
+	$(OCAMLDEP) -modules -as-map -map lib.mli -open Lib \
+	  $(LINKS) > $@
+
+promote:
+	for i in $(DEPENDS); do cp $$i $$i.reference; done
+
+compare: $(DEPENDS)
+	@rm -f $(LINKS) lib.ml
+	@for i in $(DEPENDS); do \
+	  printf " ... testing '$$i':"; \
+	  $(DIFF) $$i.reference $$i > /dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+clean:
+	@rm -f *.cm* *.$(O) *.$(A) $(DEPENDS) $(LINKS) lib.ml *~ *.byt* *.opt*
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldep-modalias/Makefile.build b/testsuite/tests/tool-ocamldep-modalias/Makefile.build
new file mode 100644
index 00000000..17c61dfb
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/Makefile.build
@@ -0,0 +1,43 @@
+# Makefile using -no-alias-deps only for lib.ml/mli
+
+SOURCES = A.ml B.ml C.ml D.ml
+OBJECTS = lib.cmo $(SOURCES:%.ml=Lib%.cmo)
+NOBJECTS = $(OBJECTS:%.cmo=%.cmx)
+
+byte: main.byt
+opt: main.opt
+
+main.byt: lib.cma main.cmo
+	$(OCAMLC) lib.cma main.cmo -o $@
+
+lib.ml: lib_impl.ml
+	cp $< $@
+
+lib.cma: $(OBJECTS)
+	$(OCAMLC) -a -o $@ $(OBJECTS)
+
+lib.cmi: lib.mli
+	$(OCAMLC) -c -no-alias-deps -w -49 $<
+
+lib.cmo: lib.ml
+	$(OCAMLC) -c -no-alias-deps -w -49 $<
+
+Lib%.cmo: %.ml
+	$(OCAMLC) -c -open Lib -o $@ $<
+
+main.opt: lib.cmxa main.cmx
+	$(OCAMLOPT) lib.cmxa main.cmx -o $@
+
+lib.cmxa: $(NOBJECTS)
+	$(OCAMLOPT) -a -o $@ $(NOBJECTS)
+
+lib.cmx: lib.ml
+	$(OCAMLOPT) -c -no-alias-deps -w -49 $<
+
+Lib%.cmx: %.ml
+	$(OCAMLOPT) -c -open Lib -o $@ $<
+
+include depend.mk
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldep-modalias/Makefile.build2 b/testsuite/tests/tool-ocamldep-modalias/Makefile.build2
new file mode 100644
index 00000000..a75477b9
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/Makefile.build2
@@ -0,0 +1,38 @@
+# Makefile using -no-alias-deps for all files, no need to link lib.cmo
+
+SOURCES = A.ml B.ml C.ml
+OBJECTS = $(SOURCES:%.ml=Lib%.cmo)
+NOBJECTS = $(OBJECTS:%.cmo=%.cmx)
+
+byte: main.byt2
+opt:  main.opt2
+
+main.byt2: lib2.cma main.cmo
+	$(OCAMLC) lib2.cma main.cmo -o $@
+
+lib2.cma: $(OBJECTS)
+	$(OCAMLC) -a -o $@ $(OBJECTS)
+
+lib.cmi: lib.mli
+	$(OCAMLC) -c -w -49 $<
+
+Lib%.cmo: %.ml
+	$(OCAMLC) -c -open Lib -o $@ $<
+
+main.opt2: lib.cmxa main.cmx
+	$(OCAMLOPT) lib.cmxa main.cmx -o $@
+
+lib.cmxa: $(NOBJECTS)
+	$(OCAMLOPT) -a -o $@ $(NOBJECTS)
+
+lib.cmx: lib.ml
+	$(OCAMLOPT) -c -no-alias-deps -w -49 $<
+
+Lib%.cmx: %.ml
+	$(OCAMLOPT) -c -open Lib -o $@ $<
+
+include depend.mk2
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
+COMPFLAGS = -no-alias-deps   # Used by $(OCAMLC)
diff --git a/testsuite/tests/tool-ocamldep-modalias/depend.mk.reference b/testsuite/tests/tool-ocamldep-modalias/depend.mk.reference
new file mode 100644
index 00000000..951b5d26
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/depend.mk.reference
@@ -0,0 +1,11 @@
+lib.cmo : lib.cmi
+lib.cmx : lib.cmi
+lib.cmi :
+LibA.cmo : lib.cmi
+LibA.cmx : lib.cmx
+LibB.cmo : LibA.cmo lib.cmi
+LibB.cmx : LibA.cmx lib.cmx
+LibC.cmo : LibB.cmo LibA.cmo lib.cmi
+LibC.cmx : LibB.cmx LibA.cmx lib.cmx
+LibD.cmo : lib.cmi
+LibD.cmx : lib.cmx
diff --git a/testsuite/tests/tool-ocamldep-modalias/depend.mk2.reference b/testsuite/tests/tool-ocamldep-modalias/depend.mk2.reference
new file mode 100644
index 00000000..a3f73b5e
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/depend.mk2.reference
@@ -0,0 +1,8 @@
+LibA.cmo : lib.cmi
+LibA.cmx : lib.cmi
+LibB.cmo : LibA.cmo lib.cmi
+LibB.cmx : LibA.cmx lib.cmi
+LibC.cmo : LibB.cmo LibA.cmo lib.cmi
+LibC.cmx : LibB.cmx LibA.cmx lib.cmi
+LibD.cmo : lib.cmi
+LibD.cmx : lib.cmi
diff --git a/testsuite/tests/tool-ocamldep-modalias/depend.mod.reference b/testsuite/tests/tool-ocamldep-modalias/depend.mod.reference
new file mode 100644
index 00000000..37a3cea2
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/depend.mod.reference
@@ -0,0 +1,6 @@
+lib.ml:
+lib.mli:
+LibA.ml: Lib
+LibB.ml: Lib LibA
+LibC.ml: Lib LibA LibB
+LibD.ml: Lib
diff --git a/testsuite/tests/tool-ocamldep-modalias/depend.mod2.reference b/testsuite/tests/tool-ocamldep-modalias/depend.mod2.reference
new file mode 100644
index 00000000..7ec54741
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/depend.mod2.reference
@@ -0,0 +1,4 @@
+LibA.ml:
+LibB.ml: A Packed
+LibC.ml: Lib LibA LibB
+LibD.ml:
diff --git a/testsuite/tests/tool-ocamldep-modalias/depend.mod3.reference b/testsuite/tests/tool-ocamldep-modalias/depend.mod3.reference
new file mode 100644
index 00000000..8ab7ed95
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/depend.mod3.reference
@@ -0,0 +1,4 @@
+LibA.ml: Lib
+LibB.ml: Lib LibA
+LibC.ml: Lib LibA LibB
+LibD.ml: Lib
diff --git a/testsuite/tests/tool-ocamldep-modalias/lib.mli b/testsuite/tests/tool-ocamldep-modalias/lib.mli
new file mode 100644
index 00000000..2334c2b6
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/lib.mli
@@ -0,0 +1,8 @@
+module Packed : sig
+  module A = LibA
+  module B = LibB
+  module C = LibC
+end
+include (module type of struct include Packed end)
+
+val imp : int -> int
diff --git a/testsuite/tests/tool-ocamldep-modalias/lib_impl.ml b/testsuite/tests/tool-ocamldep-modalias/lib_impl.ml
new file mode 100644
index 00000000..fc8581ad
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/lib_impl.ml
@@ -0,0 +1,8 @@
+module Packed = struct
+  module A = LibA
+  module B = LibB
+  module C = LibC
+end
+include Packed
+
+let imp x = x+1
diff --git a/testsuite/tests/tool-ocamldep-modalias/main.ml b/testsuite/tests/tool-ocamldep-modalias/main.ml
new file mode 100644
index 00000000..94668912
--- /dev/null
+++ b/testsuite/tests/tool-ocamldep-modalias/main.ml
@@ -0,0 +1,3 @@
+open Lib
+
+let () = Printf.printf "B.g 3 = %d\n%!" (B.g 3)
diff --git a/testsuite/tests/tool-ocamldoc-2/Makefile b/testsuite/tests/tool-ocamldoc-2/Makefile
new file mode 100644
index 00000000..863c72c5
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/Makefile
@@ -0,0 +1,55 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+	-latextitle "6,subsection*" \
+	-latextitle "7,subsubsection*" \
+	-latex-type-prefix "TYP" \
+	-latex-module-prefix "" \
+	-latex-module-type-prefix "" \
+	-latex-value-prefix ""
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) run; \
+	fi
+
+.PHONY: run
+run: *.ml *.mli *.txt
+	@for file in *.mli *.ml *.txt; do \
+	  printf " ... testing '$$file'"; \
+	  F="`basename $$file .mli`"; \
+	  F="`basename $$F .ml`"; \
+	  F="`basename $$F .txt`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex $ \
+	              -o $$F.result $$file; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
new file mode 100644
index 00000000..01c67af4
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
@@ -0,0 +1,20 @@
+(** Testing display of extensible variant types.
+
+   @test_types_display
+ *)
+
+type e = ..
+
+module M = struct
+  type e +=
+  | A (** A doc *)
+  | B (** B doc *)
+  | C (** C doc *)
+end
+
+module type MT = sig
+  type e +=
+  | A (** A doc *)
+  | B (** B doc *)
+  | C (** C doc *)
+end
diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
new file mode 100644
index 00000000..85962002
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
@@ -0,0 +1,108 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types.}
+\label{Extensible-underscorevariant}\index{Extensible-underscorevariant@\verb`Extensible_variant`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{TYPExtensible-underscorevariant.e}\begin{ocamldoccode}
+type e = ..
+\end{ocamldoccode}
+\index{e@\verb`e`}
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{M}}{\tt{ : }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.M}\index{M@\verb`M`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.M.A}\begin{ocamldoccode}
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.B}\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.C}\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module type }}{\tt{MT}}{\tt{ = }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.MT}\index{MT@\verb`MT`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.MT.A}\begin{ocamldoccode}
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.B}\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.C}\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.mli b/testsuite/tests/tool-ocamldoc-2/inline_records.mli
new file mode 100644
index 00000000..ee5f14d7
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.mli
@@ -0,0 +1,48 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.reference b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
new file mode 100644
index 00000000..ff444001
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
@@ -0,0 +1,287 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records}} : This test focuses on the printing of documentation for inline record
+  within the latex generator.}
+\label{Inline-underscorerecords}\index{Inline-underscorerecords@\verb`Inline_records`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Less of int
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.r}\begin{ocamldoccode}
+type r = 
+{\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.t}\begin{ocamldoccode}
+type t =
+  | A of {\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.s}\begin{ocamldoccode}
+type s =
+  | B of {\char123}  a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C of {\char123}  c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.any}\begin{ocamldoccode}
+type any =
+  | D : {\char123}  any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Error of {\char123}  name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords.E}\begin{ocamldoccode}
+  | E of {\char123}  yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.F}\begin{ocamldoccode}
+  | F of {\char123}  even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.G}\begin{ocamldoccode}
+  | G of {\char123}  last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldocdescription}
+Two new constructors for ext
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml
new file mode 100644
index 00000000..ee5f14d7
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml
@@ -0,0 +1,48 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
new file mode 100644
index 00000000..091b0f0e
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
@@ -0,0 +1,286 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records\_bis}} : This test focuses on the printing of documentation for inline record
+  within the latex generator.}
+\label{Inline-underscorerecords-underscorebis}\index{Inline-underscorerecords-underscorebis@\verb`Inline_records_bis`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Less of int
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.r}\begin{ocamldoccode}
+type r = 
+{\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.t}\begin{ocamldoccode}
+type t =
+  | A of {\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.s}\begin{ocamldoccode}
+type s =
+  | B of {\char123}  a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C of {\char123}  c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.any}\begin{ocamldoccode}
+type any =
+  | D : {\char123}  any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Error of {\char123}  name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords-underscorebis.E}\begin{ocamldoccode}
+  | E of {\char123}  yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.F}\begin{ocamldoccode}
+  | F of {\char123}  even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.G}\begin{ocamldoccode}
+  | G of {\char123}  last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+
+
+
+
+Two new constructors for ext
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/loop.ml b/testsuite/tests/tool-ocamldoc-2/loop.ml
new file mode 100644
index 00000000..b0306b76
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/loop.ml
@@ -0,0 +1,3 @@
+
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+
diff --git a/testsuite/tests/tool-ocamldoc-2/loop.reference b/testsuite/tests/tool-ocamldoc-2/loop.reference
new file mode 100644
index 00000000..f9d6b437
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/loop.reference
@@ -0,0 +1,36 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Loop}}}
+\label{Loop}\index{Loop@\verb`Loop`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{A}}{\tt{ : }}\end{ocamldoccode}
+\label{Loop.A}\index{A@\verb`A`}
+
+{\tt{B}}
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{B}}{\tt{ : }}\end{ocamldoccode}
+\label{Loop.B}\index{B@\verb`B`}
+
+{\tt{A}}
+
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/short_description.reference b/testsuite/tests/tool-ocamldoc-2/short_description.reference
new file mode 100644
index 00000000..5ffb6075
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/short_description.reference
@@ -0,0 +1,21 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Short\_description : Short global description in text mode}
+\label{Short-underscoredescription}\index{Short-underscoredescription@\verb`Short_description`}
+
+
+
+This file tests that documentation in text mode are given
+a short description in the global description of modules.
+
+
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/short_description.txt b/testsuite/tests/tool-ocamldoc-2/short_description.txt
new file mode 100644
index 00000000..7241f875
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/short_description.txt
@@ -0,0 +1,4 @@
+Short global description in text mode
+
+This file tests that documentation in text mode are given
+a short description in the global description of modules.
diff --git a/testsuite/tests/tool-ocamldoc-2/test.mli b/testsuite/tests/tool-ocamldoc-2/test.mli
new file mode 100644
index 00000000..3c4ec154
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/test.mli
@@ -0,0 +1,30 @@
+
+(** Ten comments for tests *)
+
+(** {6 A first comments for title } *)
+
+(** {7 A subsection for ocamldoc *} *)
+
+(** {7 Bis } *)
+
+(** {7 Ter } *)
+
+(** {6 A new section } *)
+
+(** {7 And its subsection } *)
+
+(** {7 Encore } *)
+
+(** Encore! Encore! *)
+
+
+(**/**)
+module Silence : sig
+  (** At last *)
+end
+
+(**/**)
+
+(** {7 With strange aeons } *)
+
+module End : sig end
diff --git a/testsuite/tests/tool-ocamldoc-2/test.reference b/testsuite/tests/tool-ocamldoc-2/test.reference
new file mode 100644
index 00000000..55afe977
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/test.reference
@@ -0,0 +1,74 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Test}} : Ten comments for tests}
+\label{Test}\index{Test@\verb`Test`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\subsection*{A first comments for title }
+
+
+
+
+\subsubsection*{A subsection for ocamldoc *}
+
+
+
+
+\subsubsection*{Bis }
+
+
+
+
+\subsubsection*{Ter }
+
+
+
+
+\subsection*{A new section }
+
+
+
+
+\subsubsection*{And its subsection }
+
+
+
+
+\subsubsection*{Encore }
+
+
+
+
+Encore! Encore!
+
+
+
+\subsubsection*{With strange aeons }
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{End}}{\tt{ : }}\end{ocamldoccode}
+\label{Test.End}\index{End@\verb`End`}
+
+\begin{ocamldocsigend}
+\end{ocamldocsigend}
+
+
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/variants.mli b/testsuite/tests/tool-ocamldoc-2/variants.mli
new file mode 100644
index 00000000..7562a0b8
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/variants.mli
@@ -0,0 +1,38 @@
+(** This test is here to check the latex code generated for variants *)
+
+type s = A | B (** only B is documented here *) | C
+
+type t =
+  | A
+    (** doc for A *)
+  | B
+  (** doc for B *)
+
+(** Some documentation for u*)
+type u =
+| A (** doc for A *) | B of unit (** doc for B *)
+
+
+(** With records *)
+type w =
+| A of { x: int }
+    (** doc for A *)
+| B of { y:int }
+    (** doc for B *)
+
+(** With args *)
+type z =
+| A of int
+    (** doc for A *)
+| B of int
+    (** doc for B *)
+
+(** Gadt notation *)
+type a =
+    A: a (** doc for A*)
+
+(** Lonely constructor *)
+type b =
+  B (** doc for B *)
+
+type no_documentation = A | B | C
diff --git a/testsuite/tests/tool-ocamldoc-2/variants.reference b/testsuite/tests/tool-ocamldoc-2/variants.reference
new file mode 100644
index 00000000..bb9e7601
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/variants.reference
@@ -0,0 +1,190 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Variants}} : This test is here to check the latex code generated for variants}
+\label{Variants}\index{Variants@\verb`Variants`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{TYPVariants.s}\begin{ocamldoccode}
+type s =
+  | A
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+only B is documented here
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\index{s@\verb`s`}
+
+
+
+
+\label{TYPVariants.t}\begin{ocamldoccode}
+type t =
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+
+
+
+
+\label{TYPVariants.u}\begin{ocamldoccode}
+type u =
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | B of unit
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{u@\verb`u`}
+\begin{ocamldocdescription}
+Some documentation for u
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.w}\begin{ocamldoccode}
+type w =
+  | A of {\char123}  x : int ;
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | B of {\char123}  y : int ;
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{w@\verb`w`}
+\begin{ocamldocdescription}
+With records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.z}\begin{ocamldoccode}
+type z =
+  | A of int
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | B of int
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{z@\verb`z`}
+\begin{ocamldocdescription}
+With args
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.a}\begin{ocamldoccode}
+type a =
+  | A : a
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\index{a@\verb`a`}
+\begin{ocamldocdescription}
+Gadt notation
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.b}\begin{ocamldoccode}
+type b =
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{b@\verb`b`}
+\begin{ocamldocdescription}
+Lonely constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.no-underscoredocumentation}\begin{ocamldoccode}
+type no_documentation =
+  | A
+  | B
+  | C
+\end{ocamldoccode}
+\index{no-underscoredocumentation@\verb`no_documentation`}
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.mli b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli
new file mode 100644
index 00000000..f80cd2bd
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli
@@ -0,0 +1,45 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
new file mode 100644
index 00000000..856c902f
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
@@ -0,0 +1,289 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Inline_records" rel="Chapter" href="Inline_records.html"><title>Inline_records
+
+
+
 Up
+ 

+
Module Inline_records

+
+
module Inline_records: sig .. end

+This test focuses on the printing of documentation for inline record
+  within the latex generator.

+

+

+
+
exception Simple

+

+A nice exception

+

+
+
type ext = ..

+

+An open sum type

+

+
+
+
type r = {

+
+
+
+
+
+
+
+
+
+

+  
+lbl : int;(*

+Field documentation for non-inline, lbl : int

+

+		*)

+  
+more : int list;(*

+More documentation for r, more : int list

+

+		*)

+}
+
+

+A simple record type for reference

+

+
+
+
type t = 

+
+
+
+
+

+|
+A of {
+
+
+
+
+
+
+
+
+
+

+  
+lbl : int;(*

+A field documentation

+

+		*)

+  
+more : int list;(*

+More A field documentation

+

+		*)

+}
+		(*

+Constructor documentation

+

+		*)

+
+

+A sum type with one inline record

+

+
+
+
type s = 

+
+
+
+
+
+
+
+
+
+

+|
+B of {
+
+
+
+
+
+
+
+
+
+

+  
+a_label_for_B : int;(*

+B field documentation

+

+		*)

+  
+more_label_for_B : int list;(*

+More B field documentation

+

+		*)

+}
+		(*

+Constructor B documentation

+

+		*)

+|
+C of {
+
+
+
+
+
+
+
+
+
+

+  
+c_has_label_too : float;(*

+C field documentation

+

+		*)

+  
+more_than_one : unit;(*

+... documentations

+

+		*)

+}
+		(*

+Constructor C documentation

+

+		*)

+
+

+A sum type with two inline records

+

+
+
+
type any = 

+
+
+
+
+

+|
+D : {
+
+
+
+
+

+  
+any : 'a;(*

+A field any:'a for D in any.

+

+		*)

+}
+ -> any		(*

+Constructor D documentation

+

+		*)

+
+

+A gadt constructor

+

+
+
+
exception Error of {
+
+
+
+
+

+  
+name : string;(*

+Error field documentation name:string

+

+		*)

+}
+

+
type ext += 

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+|
+E of {
+
+
+
+
+

+  
+yet_another_field : unit;(*

+Field documentation for E in ext

+

+		*)

+}
+		(*

+Constructor E documentation

+

+		*)

+|
+F of {
+
+
+
+
+

+  
+even_more : int -> int;(*

+Some field documentations for F

+

+		*)

+}
+		(*

+Constructor F documentation

+

+		*)

+|
+G of {
+
+
+
+
+

+  
+last : int -> int;(*

+The last and least field documentation

+

+		*)

+}
+		(*

+Constructor G documentation

+

+		*)

+
+

+Two new constructors for ext

+

+
+
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
new file mode 100644
index 00000000..764e7f4a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
@@ -0,0 +1,69 @@
+(**
+   This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.
+
+   Two slightly different aspects are tested in this very file.
+
+   - First, inside a "pre" tags, blanks character should not be escaped.
+   For instance, the generated html code for this test fragment should not
+   contain any 
 tag:
+   {[
+     let f x =
+       let g x =
+         let h x = x in
+         h x in
+       g x
+   ]}
+   See {{:http://caml.inria.fr/mantis/view.php?id=6341} MPR#6341} for more
+   details or the file Linebreaks.html generated by ocamldoc from this file.
+
+   -Second, outside of a "pre"  tags, blank characters in embedded code
+   should be escaped, in order to make them render in a "pre"-like fashion.
+   A good example should be the files type_{i Modulename}.html generated by
+   ocamldoc that should contains the signature of the module [Modulename] in
+   a "code" tags.
+   For instance with the following type definitions,
+*)
+
+type a = A
+type 'a b = {field:'a}
+type c = C: 'a -> c
+
+type s = ..
+type s += B
+
+val x : a
+
+module S: sig module I:sig end end
+module type s = sig end
+
+class type d = object end
+
+exception E of {inline:int}
+
+
+(** type_Linebreaks.html should contain
+
+{[
+sig
+  type a = A
+  type 'a b = { field : 'a; }
+  type c = C : 'a -> Linebreaks.c
+  type s = ..
+  type s += B
+  val x : Linebreaks.a
+  module S : sig module I : sig  end end
+  module type s = sig  end
+  class type d = object  end
+  exception E of { inline : int; }
+end
+]}
+
+with 
 tags used for linebreaks.
+Another example would be [ let f x =
+x] which is rendered with a 
 linebreak inside Linebreaks.html.
+
+See {{:http://caml.inria.fr/mantis/view.php?id=7272}MPR#7272} for more
+information.
+
+*)
diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
new file mode 100644
index 00000000..71a020fb
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
@@ -0,0 +1,140 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Linebreaks
+
+
+
 Up
+ 

+
Module Linebreaks

+
+
module Linebreaks: sig .. end

+This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.
+

+
+   Two slightly different aspects are tested in this very file.
+

+
    
+
  • First, inside a "pre" tags, blanks character should not be escaped.
+   For instance, the generated html code for this test fragment should not
+   contain any <br> tag:
+   
         let f x =
+       let g x =
+         let h x = x in
+         h x in
+       g x
+   
    
+   See  MPR#6341 for more
+   details or the file Linebreaks.html generated by ocamldoc from this file.
    • 
+

+
+   -Second, outside of a "pre"  tags, blank characters in embedded code
+   should be escaped, in order to make them render in a "pre"-like fashion.
+   A good example should be the files type_Modulename.html generated by
+   ocamldoc that should contains the signature of the module Modulename in
+   a "code" tags.
+   For instance with the following type definitions,

+

+

+
+
type a = 

+
+
+
+
+

+|
+A

+
+
+
+
type 'a b = {

+
+
+
+
+

+  
+field : 'a;

+}
+
+
+
+
type c = 

+
+
+
+
+

+|
+C : 'a -> c

+
+
+
+
type s = ..

+
+
type s += 

+
+
+
+
+

+|
+B

+
+
+
+
val x : a

+
module S: sig .. end

+
module type s = sig .. end

+
class type d = object .. end

+
exception E of {
+
+
+
+
+

+  
+inline : int;

+}
+

+

+type_Linebreaks.html should contain
+

+
+
sig
+  type a = A
+  type 'a b = { field : 'a; }
+  type c = C : 'a -> Linebreaks.c
+  type s = ..
+  type s += B
+  val x : Linebreaks.a
+  module S : sig module I : sig  end end
+  module type s = sig  end
+  class type d = object  end
+  exception E of { inline : int; }
+end
+

+

+
+with <br> tags used for linebreaks.
+Another example would be  let f x =

+x which is rendered with a <br> linebreak inside Linebreaks.html.
+

+
+See MPR#7272 for more
+information.

+
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Loop.ml b/testsuite/tests/tool-ocamldoc-html/Loop.ml
new file mode 100644
index 00000000..b0306b76
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Loop.ml
@@ -0,0 +1,3 @@
+
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+
diff --git a/testsuite/tests/tool-ocamldoc-html/Loop.reference b/testsuite/tests/tool-ocamldoc-html/Loop.reference
new file mode 100644
index 00000000..235b4775
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Loop.reference
@@ -0,0 +1,20 @@
+
+
+
+
+
+
+
+
+
+Loop
+
+
+
 Up
+ 

+
Module Loop

+
+
module Loop: sig .. end

+
+
module A: B

+
module B: A

\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Makefile b/testsuite/tests/tool-ocamldoc-html/Makefile
new file mode 100644
index 00000000..116b580b
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Makefile
@@ -0,0 +1,62 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+	-latextitle "6,subsection*" \
+	-latextitle "7,subsubsection*" \
+	-latex-type-prefix "TYP" \
+	-latex-module-prefix "" \
+	-latex-module-type-prefix "" \
+	-latex-value-prefix ""
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) run; \
+	fi
+
+.PHONY: run
+run: *.mli *.ml
+# Note that we strip both .ml and .mli extensions
+	@for file in *.ml *.mli; do \
+	  printf " ... testing '$$file'"; \
+	  F="`basename $$file .mli`"; \
+	  F="`basename $$F .ml`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -colorize-code -hide-warnings -html $ \
+	              -o index $$file; \
+	  cp $$F.html $$F.result; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;\
+# For linebreaks.mli, we also compare type_Linebreaks.html and not only
+# the main html file
+	@cp type_Linebreaks.html type_Linebreaks.result;\
+	printf " ... testing 'type_Linebreak.html'";\
+	$(DIFF) type_Linebreaks.reference type_Linebreaks.result\
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.ml b/testsuite/tests/tool-ocamldoc-html/Module_whitespace.ml
new file mode 100644
index 00000000..d9ddee7b
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Module_whitespace.ml
@@ -0,0 +1,4 @@
+module M = Set.Make(struct
+        type t = int
+        let compare = compare
+end)
diff --git a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference b/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference
new file mode 100644
index 00000000..4691b2d4
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference
@@ -0,0 +1,24 @@
+
+
+
+
+
+
+
+
+
+Module_whitespace
+
+
+
 Up
+ 

+
Module Module_whitespace

+
+
module Module_whitespace: sig .. end

+
+
module M: Set.Make(sig

+
type t = int 

+
+
+
val compare : 'a -> 'a -> int

+
end)

\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Variants.mli b/testsuite/tests/tool-ocamldoc-html/Variants.mli
new file mode 100644
index 00000000..7562a0b8
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Variants.mli
@@ -0,0 +1,38 @@
+(** This test is here to check the latex code generated for variants *)
+
+type s = A | B (** only B is documented here *) | C
+
+type t =
+  | A
+    (** doc for A *)
+  | B
+  (** doc for B *)
+
+(** Some documentation for u*)
+type u =
+| A (** doc for A *) | B of unit (** doc for B *)
+
+
+(** With records *)
+type w =
+| A of { x: int }
+    (** doc for A *)
+| B of { y:int }
+    (** doc for B *)
+
+(** With args *)
+type z =
+| A of int
+    (** doc for A *)
+| B of int
+    (** doc for B *)
+
+(** Gadt notation *)
+type a =
+    A: a (** doc for A*)
+
+(** Lonely constructor *)
+type b =
+  B (** doc for B *)
+
+type no_documentation = A | B | C
diff --git a/testsuite/tests/tool-ocamldoc-html/Variants.reference b/testsuite/tests/tool-ocamldoc-html/Variants.reference
new file mode 100644
index 00000000..12bd44e7
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Variants.reference
@@ -0,0 +1,232 @@
+
+
+
+
+
+
+
+
+
+
+Variants
+
+
+
 Up
+ 

+
Module Variants

+
+
module Variants: sig .. end

+This test is here to check the latex code generated for variants

+

+

+
+
type s = 

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+|
+A

+|
+B(*

+only B is documented here

+

+		*)

+|
+C

+
+
+
+
type t = 

+
+
+
+
+
+
+
+
+
+

+|
+A(*

+doc for A

+

+		*)

+|
+B(*

+doc for B

+

+		*)

+
+
+
+
type u = 

+
+
+
+
+
+
+
+
+
+

+|
+A(*

+doc for A

+

+		*)

+|
+B of unit(*

+doc for B

+

+		*)

+
+

+Some documentation for u

+

+
+
+
type w = 

+
+
+
+
+
+
+
+
+
+

+|
+A of {
+
+
+
+
+

+  
+x : int;

+}
+		(*

+doc for A

+

+		*)

+|
+B of {
+
+
+
+
+

+  
+y : int;

+}
+		(*

+doc for B

+

+		*)

+
+

+With records

+

+
+
+
type z = 

+
+
+
+
+
+
+
+
+
+

+|
+A of int(*

+doc for A

+

+		*)

+|
+B of int(*

+doc for B

+

+		*)

+
+

+With args

+

+
+
+
type a = 

+
+
+
+
+

+|
+A : a(*

+doc for A

+

+		*)

+
+

+Gadt notation

+

+
+
+
type b = 

+
+
+
+
+

+|
+B(*

+doc for B

+

+		*)

+
+

+Lonely constructor

+

+
+
+
type no_documentation = 

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+|
+A

+|
+B

+|
+C

+
+
+
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference
new file mode 100644
index 00000000..ad097f11
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference
@@ -0,0 +1,27 @@
+
+
+
+
+
+
+
+
+
+
+
+
+Linebreaks
+
+
+sig

+  type a = A

+  type 'a b = { field : 'a; }

+  type c = C : 'a -> Linebreaks.c

+  type s = ..

+  type s += B

+  val x : Linebreaks.a

+  module S : sig module I : sig  end end

+  module type s = sig  end

+  class type d = object  end

+  exception E of { inline : int; }

+end
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.mli b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli
new file mode 100644
index 00000000..f80cd2bd
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli
@@ -0,0 +1,45 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.reference b/testsuite/tests/tool-ocamldoc-man/Inline_records.reference
new file mode 100644
index 00000000..7184b971
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Inline_records.reference
@@ -0,0 +1,201 @@
+.SH NAME
+Inline_records \- This test focuses on the printing of documentation for inline record within the latex generator.
+.SH Module
+Module   Inline_records
+.SH Documentation
+.sp
+Module
+.BI "Inline_records"
+ : 
+.B sig  end
+
+.sp
+This test focuses on the printing of documentation for inline record
+within the latex generator\&.
+
+.sp
+
+.sp
+.sp
+
+.I exception Simple 
+
+.sp
+A nice exception
+
+.sp
+.I type ext 
+= ..
+
+.sp
+An open sum type
+
+.sp
+.I type r 
+= {
+ lbl : 
+.B int
+;  (* Field documentation for non\-inline, 
+.B lbl : int
+
+ *) 
+ more : 
+.B int list
+;  (* More documentation for r, 
+.B more : int list
+
+ *) 
+ }
+
+.sp
+A simple record type for reference
+
+.sp
+.I type t 
+=
+ | A
+.B of {
+ lbl : 
+.B int
+;  (* 
+.B A
+field documentation
+ *) 
+ more : 
+.B int list
+;  (* More 
+.B A
+field documentation
+ *) 
+ }
+.I "  "
+  (* Constructor documentation
+ *)
+ 
+.sp
+A sum type with one inline record
+
+.sp
+.I type s 
+=
+ | B
+.B of {
+ a_label_for_B : 
+.B int
+;  (* 
+.B B
+field documentation
+ *) 
+ more_label_for_B : 
+.B int list
+;  (* More 
+.B B
+field documentation
+ *) 
+ }
+.I "  "
+  (* Constructor B documentation
+ *)
+ | C
+.B of {
+ c_has_label_too : 
+.B float
+;  (* 
+.B C
+field documentation
+ *) 
+ more_than_one : 
+.B unit
+;  (* \&.\&.\&. documentations
+ *) 
+ }
+.I "  "
+  (* Constructor C documentation
+ *)
+ 
+.sp
+A sum type with two inline records
+
+.sp
+.I type any 
+=
+ | D
+.B of {
+ any : 
+.B 'a
+;  (* 
+.B A
+field 
+.B any:\&'a
+for 
+.B D
+in 
+.B any
+\&.
+ *) 
+ }
+.B -> 
+.B any
+.I "  "
+  (* Constructor D documentation
+ *)
+ 
+.sp
+A gadt constructor
+
+.sp
+
+.I exception Error 
+.B of {
+ name : 
+.B string
+;  (* Error field documentation 
+.B name:string
+
+ *) 
+ }
+
+.sp
+
+.sp
+.I type ext 
++=
+ | E
+.B of {
+ yet_another_field : 
+.B unit
+;  (* Field documentation for 
+.B E
+in ext
+ *) 
+ }
+.I "  "
+(* Constructor E documentation
+ *)
+ | F
+.B of {
+ even_more : 
+.B int -> int
+;  (* Some field documentations for 
+.B F
+
+ *) 
+ }
+.I "  "
+(* Constructor F documentation
+ *)
+ | G
+.B of {
+ last : 
+.B int -> int
+;  (* The last and least field documentation
+ *) 
+ }
+.I "  "
+(* Constructor G documentation
+ *)
+ 
+.sp
+Two new constructors for ext
+
+.sp
diff --git a/testsuite/tests/tool-ocamldoc-man/Makefile b/testsuite/tests/tool-ocamldoc-man/Makefile
new file mode 100644
index 00000000..a3c272a1
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Makefile
@@ -0,0 +1,54 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+	-latextitle "6,subsection*" \
+	-latextitle "7,subsubsection*" \
+	-latex-type-prefix "TYP" \
+	-latex-module-prefix "" \
+	-latex-module-type-prefix "" \
+	-latex-value-prefix ""
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) run; \
+	fi
+
+.PHONY: run
+run: *.mli
+	@for file in *.mli; do \
+	  printf " ... testing '$$file'"; \
+	  F="`basename $$file .mli`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -man $ \
+	              -o index $$file; \
+	  tail -n +2 $$F.3o > $$F.result; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux *.3o
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-open/Makefile b/testsuite/tests/tool-ocamldoc-open/Makefile
new file mode 100644
index 00000000..92f09a1d
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/Makefile
@@ -0,0 +1,47 @@
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
+
+SRC= main.ml alias.ml inner.ml
+ODOCS=$(SRC:%.ml=%.odoc)
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) doc; \
+	fi
+
+.PHONY: doc
+doc: $(ODOCS)
+	@printf " ... testing ocamldoc '-open' option";\
+	$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+         -load alias.odoc -load inner.odoc \
+         -load main.odoc -latex -o doc.result ;\
+	$(DIFF) doc.result doc.reference > /dev/null \
+	&& echo " => passed" || echo " => failed";
+
+inner.odoc: inner.ml
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -dump inner.odoc inner.ml
+
+alias.odoc: inner.cmi alias.ml
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -dump alias.odoc alias.ml
+
+main.odoc: alias.cmi main.ml
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -open Alias.Container -open Aliased_inner -dump main.odoc main.ml
+
+alias.cmi:inner.cmi
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.odoc *.toc *.sty *.aux *.log *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-open/Readme b/testsuite/tests/tool-ocamldoc-open/Readme
new file mode 100644
index 00000000..e140d57c
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/Readme
@@ -0,0 +1,12 @@
+This test focuses on ocamldoc "-open" command line option.
+It ensures that the modules passed as argument to this "-open" option
+are opened in the initial environment of ocamldoc.
+
+More precisely, it checks that
+
+* both cmi files and inner modules can be opened
+* modules are opened in the left-to-right order
+
+The test builds a latex documentation file for the three modules
+"Main", "Alias" and "Inner". Changes to ocamldoc latex output might
+trigger spurious errors in this test.
diff --git a/testsuite/tests/tool-ocamldoc-open/alias.ml b/testsuite/tests/tool-ocamldoc-open/alias.ml
new file mode 100644
index 00000000..e3e81842
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/alias.ml
@@ -0,0 +1,3 @@
+module Container = struct
+  module Aliased_inner = Inner
+end
diff --git a/testsuite/tests/tool-ocamldoc-open/doc.reference b/testsuite/tests/tool-ocamldoc-open/doc.reference
new file mode 100644
index 00000000..19419f9b
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/doc.reference
@@ -0,0 +1,70 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Alias}}}
+\label{module:Alias}\index{Alias@\verb`Alias`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Container}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Container}\index{Container@\verb`Container`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Container.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
+{\tt{Inner}}
+
+\end{ocamldocsigend}
+
+
+
+
+\section{Module {\tt{Inner}}}
+\label{module:Inner}\index{Inner@\verb`Inner`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Inner.a}\begin{ocamldoccode}
+type a = int 
+\end{ocamldoccode}
+\index{a@\verb`a`}
+
+
+\section{Module {\tt{Main}} : Documentation test}
+\label{module:Main}\index{Main@\verb`Main`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Main.t}\begin{ocamldoccode}
+type t = Alias.Container.Aliased_inner.a 
+\end{ocamldoccode}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+Alias to type Inner.a
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-open/inner.ml b/testsuite/tests/tool-ocamldoc-open/inner.ml
new file mode 100644
index 00000000..87778638
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/inner.ml
@@ -0,0 +1,2 @@
+
+type a = int
diff --git a/testsuite/tests/tool-ocamldoc-open/main.ml b/testsuite/tests/tool-ocamldoc-open/main.ml
new file mode 100644
index 00000000..abc1f818
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/main.ml
@@ -0,0 +1,5 @@
+
+(** Documentation test *)
+
+type t = a
+(** Alias to type Inner.a *)
diff --git a/testsuite/tests/tool-ocamldoc/Makefile b/testsuite/tests/tool-ocamldoc/Makefile
new file mode 100644
index 00000000..e28c62f1
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/Makefile
@@ -0,0 +1,52 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+CUSTOM_MODULE=odoc_test
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) run; \
+	fi
+
+.PHONY: run
+run: $(CUSTOM_MODULE).cmo
+	@for file in t*.ml; do \
+	  printf " ... testing '$$file'"; \
+	  F="`basename $$file .ml`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -g $(CUSTOM_MODULE).cmo \
+	              -o $$F.result $$file; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -html t*.ml 2>&1 \
+	  | grep -v test_types_display || true
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex t*.ml 2>&1 \
+	  | grep -v test_types_display || true
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml
new file mode 100644
index 00000000..068f1e09
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml
@@ -0,0 +1,116 @@
+(** 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 (Other e) -> Odoc_info.string_of_type_expr e
+               | Some (Object_type fields) ->
+                 let b = Buffer.create 256 in
+                 Buffer.add_string b "<";
+                 List.iter
+                   (fun fd ->
+                     Printf.bprintf b " %s: %s ;"
+                       fd.of_name
+                       (Odoc_info.string_of_type_expr fd.of_type)
+                   )
+                   fields;
+                 Buffer.add_string b " >";
+                 Buffer.contents b
+               );
+            );
+
+
+    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.Global.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 _ =
+  let module My_generator = struct
+    class generator =
+    let inst = new string_gen in
+    object
+      method generate = inst#generate
+    end
+  end in
+  Odoc_args.set_generator (Odoc_gen.Base (module My_generator : Odoc_gen.Base))
diff --git a/testsuite/tests/tool-ocamldoc/t01.ml b/testsuite/tests/tool-ocamldoc/t01.ml
new file mode 100644
index 00000000..ee291b90
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t01.ml
@@ -0,0 +1,22 @@
+(** 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
+
+  type obj_type =
+     < foo : int ; bar : float -> string ; gee : int -> (int * string) >
+end
diff --git a/testsuite/tests/tool-ocamldoc/t01.reference b/testsuite/tests/tool-ocamldoc/t01.reference
new file mode 100644
index 00000000..d5159bdf
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t01.reference
@@ -0,0 +1,38 @@
+#
+# module T01:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig  end]>
+#
+# module T01.M:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig val y : int end]>
+#
+# module type T01.MT:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig
+  type t =
+      string ->
+      int ->
+      string ->
+      string * string * string ->
+      string * string * string -> string * string * string -> unit
+  val y : int
+  type obj_type =
+      < bar : float -> string; foo : int; gee : int -> int * string >
+end]>
+# type T01.MT.t:
+# manifest (Odoc_info.string_of_type_expr):
+<[string ->
+  int ->
+  string ->
+  string * string * string ->
+  string * string * string -> string * string * string -> unit]>
+# type T01.MT.obj_type:
+# manifest (Odoc_info.string_of_type_expr):
+<[< bar: float -> string ; foo: int ; gee: int -> int * string ; >]>
diff --git a/testsuite/tests/tool-ocamldoc/t02.ml b/testsuite/tests/tool-ocamldoc/t02.ml
new file mode 100644
index 00000000..d7c97421
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t02.ml
@@ -0,0 +1,10 @@
+module Foo = struct type u type t = int let x = 1 end;;
+module type TFoo = module type of Foo;;
+
+module type TBar = TFoo with type u := float;;
+
+module type Gee =
+  sig
+    module M : module type of Foo
+    include module type of Foo
+  end
diff --git a/testsuite/tests/tool-ocamldoc/t02.reference b/testsuite/tests/tool-ocamldoc/t02.reference
new file mode 100644
index 00000000..f1e7de43
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t02.reference
@@ -0,0 +1,12 @@
+#
+# module T02:
+#
+# module T02.Foo:
+#
+# module type T02.TFoo:
+#
+# module type T02.TBar:
+#
+# module type T02.Gee:
+#
+# module T02.Gee.M:
diff --git a/testsuite/tests/tool-ocamldoc/t03.ml b/testsuite/tests/tool-ocamldoc/t03.ml
new file mode 100644
index 00000000..9d9e1593
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t03.ml
@@ -0,0 +1,12 @@
+module Foo = struct type t = int let x = 1 end;;
+module type MT = module type of Foo;;
+module Bar = struct type t = int let x = 2 end;;
+
+module type MT2 = sig type t val x : t end;;
+module type Gee = MT2 with type t = float ;;
+module T = (val
+    (if true
+     then (module Foo:MT2 with type t = int)
+     else (module Bar: MT2 with type t = int))
+    : MT2 with type t = int)
+;;
diff --git a/testsuite/tests/tool-ocamldoc/t03.reference b/testsuite/tests/tool-ocamldoc/t03.reference
new file mode 100644
index 00000000..174e2199
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t03.reference
@@ -0,0 +1,14 @@
+#
+# module T03:
+#
+# module T03.Foo:
+#
+# module type T03.MT:
+#
+# module T03.Bar:
+#
+# module type T03.MT2:
+#
+# module type T03.Gee:
+#
+# module T03.T:
diff --git a/testsuite/tests/tool-ocamldoc/t04.ml b/testsuite/tests/tool-ocamldoc/t04.ml
new file mode 100644
index 00000000..97782ae6
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t04.ml
@@ -0,0 +1,20 @@
+(** Testing display of inline record.
+
+   @test_types_display
+ *)
+
+
+module A = struct
+  type a = A of {lbl:int}
+
+end
+
+module type E = sig
+  exception E of {lbl:int}
+
+end
+
+
+module E_bis= struct
+  exception E of {lbl:int}
+end
diff --git a/testsuite/tests/tool-ocamldoc/t04.reference b/testsuite/tests/tool-ocamldoc/t04.reference
new file mode 100644
index 00000000..924503ea
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t04.reference
@@ -0,0 +1,27 @@
+#
+# module T04:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig  end]>
+#
+# module T04.A:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig type a = A of { lbl : int; } end]>
+# type T04.A.a:
+# manifest (Odoc_info.string_of_type_expr):
+<[None]>
+#
+# module type T04.E:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig exception E of { lbl : int; } end]>
+#
+# module T04.E_bis:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig exception E of { lbl : int; } end]>
diff --git a/testsuite/tests/tool-ocamldoc/t05.ml b/testsuite/tests/tool-ocamldoc/t05.ml
new file mode 100644
index 00000000..b0306b76
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t05.ml
@@ -0,0 +1,3 @@
+
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+
diff --git a/testsuite/tests/tool-ocamldoc/t05.reference b/testsuite/tests/tool-ocamldoc/t05.reference
new file mode 100644
index 00000000..4a043e39
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t05.reference
@@ -0,0 +1,6 @@
+#
+# module T05:
+#
+# module T05.A:
+#
+# module T05.B:
diff --git a/testsuite/tests/tool-toplevel-invocation/Makefile b/testsuite/tests/tool-toplevel-invocation/Makefile
new file mode 100644
index 00000000..31db2c3f
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/Makefile
@@ -0,0 +1,36 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                          Bernhard Schommer                             *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+
+
+default:
+	@for file in *.txt; do \
+	 TERM=dumb $(OCAML) -args $$file < test.ml 2>&1 \
+			| grep -v '^        OCaml version' > $$file.result; \
+	done
+	@for file in *.reference; do \
+	  printf " ... testing '$$file':"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
+	done
+
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt b/testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt
new file mode 100644
index 00000000..740a834a
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt
@@ -0,0 +1,3 @@
+test.ml
+-I
+../
diff --git a/testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt.reference b/testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt.reference
new file mode 100644
index 00000000..b49ea22c
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/first_arg_fail.txt.reference
@@ -0,0 +1 @@
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
diff --git a/testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt b/testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt
new file mode 100644
index 00000000..25ac50da
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt
@@ -0,0 +1,2 @@
+-args
+first_arg_fail.txt
diff --git a/testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt.reference b/testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt.reference
new file mode 100644
index 00000000..b49ea22c
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/indirect_first_arg_fail.txt.reference
@@ -0,0 +1 @@
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
diff --git a/testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt b/testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt
new file mode 100644
index 00000000..7847f963
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt
@@ -0,0 +1,2 @@
+-args
+last_arg_fail.txt
diff --git a/testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt.reference b/testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt.reference
new file mode 100644
index 00000000..b49ea22c
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/indirect_last_arg_fail.txt.reference
@@ -0,0 +1 @@
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
diff --git a/testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt b/testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt
new file mode 100644
index 00000000..764d630e
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt
@@ -0,0 +1,3 @@
+-I
+../
+test.ml
diff --git a/testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt.reference b/testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt.reference
new file mode 100644
index 00000000..b49ea22c
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/last_arg_fail.txt.reference
@@ -0,0 +1 @@
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
diff --git a/testsuite/tests/tool-toplevel-invocation/test.ml b/testsuite/tests/tool-toplevel-invocation/test.ml
new file mode 100644
index 00000000..03b03d71
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/test.ml
@@ -0,0 +1 @@
+printf "Test succeeds\n";;
diff --git a/testsuite/tests/tool-toplevel-invocation/working_arg.txt b/testsuite/tests/tool-toplevel-invocation/working_arg.txt
new file mode 100644
index 00000000..7c42c092
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/working_arg.txt
@@ -0,0 +1,2 @@
+-open
+Printf
diff --git a/testsuite/tests/tool-toplevel-invocation/working_arg.txt.reference b/testsuite/tests/tool-toplevel-invocation/working_arg.txt.reference
new file mode 100644
index 00000000..2438811a
--- /dev/null
+++ b/testsuite/tests/tool-toplevel-invocation/working_arg.txt.reference
@@ -0,0 +1,4 @@
+
+# Test succeeds
+- : unit = ()
+# 
diff --git a/testsuite/tests/tool-toplevel/Makefile b/testsuite/tests/tool-toplevel/Makefile
new file mode 100644
index 00000000..17a9c8e3
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS+=-I $(OTOPDIR)/toplevel
diff --git a/testsuite/tests/tool-toplevel/pr7060.ml b/testsuite/tests/tool-toplevel/pr7060.ml
new file mode 100644
index 00000000..67c11a47
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/pr7060.ml
@@ -0,0 +1,6 @@
+type t = A | B;;
+type u = C of t;;
+let print_t out = function A -> Format.fprintf out "A";;
+#install_printer print_t;;
+B;;
+C B;;
diff --git a/testsuite/tests/tool-toplevel/pr7060.ml.reference b/testsuite/tests/tool-toplevel/pr7060.ml.reference
new file mode 100644
index 00000000..bdfca395
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/pr7060.ml.reference
@@ -0,0 +1,16 @@
+
+# type t = A | B
+# type u = C of t
+# Characters 18-54:
+  let print_t out = function A -> Format.fprintf out "A";;
+                    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+B
+val print_t : Format.formatter -> t -> unit = 
+# # - : t =
+
+# - : u =
+C
+ 
+# 
diff --git a/testsuite/tests/tool-toplevel/tracing.ml b/testsuite/tests/tool-toplevel/tracing.ml
new file mode 100644
index 00000000..5acaff23
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/tracing.ml
@@ -0,0 +1,4 @@
+List.fold_left;;
+#trace List.fold_left;;
+0;;
+List.fold_left (+) 0 [1;2;3];;
diff --git a/testsuite/tests/tool-toplevel/tracing.ml.reference b/testsuite/tests/tool-toplevel/tracing.ml.reference
new file mode 100644
index 00000000..e6eda8d7
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/tracing.ml.reference
@@ -0,0 +1,30 @@
+
+# - : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = 
+# List.fold_left is now traced.
+# - : int = 0
+# List.fold_left <-- 
+List.fold_left --> 
+List.fold_left* <-- 
+List.fold_left* --> 
+List.fold_left** <-- [; ; ]
+List.fold_left <-- 
+List.fold_left --> 
+List.fold_left* <-- 
+List.fold_left* --> 
+List.fold_left** <-- [; ]
+List.fold_left <-- 
+List.fold_left --> 
+List.fold_left* <-- 
+List.fold_left* --> 
+List.fold_left** <-- []
+List.fold_left <-- 
+List.fold_left --> 
+List.fold_left* <-- 
+List.fold_left* --> 
+List.fold_left** <-- []
+List.fold_left** --> 
+List.fold_left** --> 
+List.fold_left** --> 
+List.fold_left** --> 
+- : int = 6
+# 
diff --git a/testsuite/tests/translprim/Makefile b/testsuite/tests/translprim/Makefile
new file mode 100644
index 00000000..c4223d45
--- /dev/null
+++ b/testsuite/tests/translprim/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+TOPFLAGS+=-dlambda
+include $(BASEDIR)/makefiles/Makefile.dlambda
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/translprim/array_spec.ml b/testsuite/tests/translprim/array_spec.ml
new file mode 100644
index 00000000..e78c9634
--- /dev/null
+++ b/testsuite/tests/translprim/array_spec.ml
@@ -0,0 +1,62 @@
+external len : 'a array -> int = "%array_length"
+external safe_get : 'a array -> int -> 'a = "%array_safe_get"
+external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+external safe_set : 'a array -> int -> 'a -> unit = "%array_safe_set"
+external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+
+(* Specialization in application *)
+
+let int_a = [|1;2;3|];;
+let float_a = [|1.;2.;3.|];;
+let addr_a = [|"a";"b";"c"|];;
+
+len int_a;;
+len float_a;;
+len addr_a;;
+(fun a -> len a);;
+
+safe_get int_a 0;;
+safe_get float_a 0;;
+safe_get addr_a 0;;
+(fun a -> safe_get a 0);;
+
+unsafe_get int_a 0;;
+unsafe_get float_a 0;;
+unsafe_get addr_a 0;;
+(fun a -> unsafe_get a 0);;
+
+safe_set int_a 0 1;;
+safe_set float_a 0 1.;;
+safe_set addr_a 0 "a";;
+(fun a x -> safe_set a 0 x);;
+
+unsafe_set int_a 0 1;;
+unsafe_set float_a 0 1.;;
+unsafe_set addr_a 0 "a";;
+(fun a x -> unsafe_set a 0 x);;
+
+(* Specialization during eta-expansion *)
+
+let eta_gen_len : 'a array -> _ = len;;
+let eta_gen_safe_get : 'a array -> int -> 'a = safe_get;;
+let eta_gen_unsafe_get : 'a array -> int -> 'a = unsafe_get;;
+let eta_gen_safe_set : 'a array -> int -> 'a -> unit = safe_set;;
+let eta_gen_unsafe_set : 'a array -> int -> 'a -> unit = unsafe_set;;
+
+let eta_int_len : int array -> _ = len;;
+let eta_int_safe_get : int array -> int -> int = safe_get;;
+let eta_int_unsafe_get : int array -> int -> int = unsafe_get;;
+let eta_int_safe_set : int array -> int -> int -> unit = safe_set;;
+let eta_int_unsafe_set : int array -> int -> int -> unit = unsafe_set;;
+
+let eta_float_len : float array -> _ = len;;
+let eta_float_safe_get : float array -> int -> float = safe_get;;
+let eta_float_unsafe_get : float array -> int -> float = unsafe_get;;
+let eta_float_safe_set : float array -> int -> float -> unit = safe_set;;
+let eta_float_unsafe_set : float array -> int -> float -> unit = unsafe_set;;
+
+let eta_addr_len : string array -> _ = len;;
+let eta_addr_safe_get : string array -> int -> string = safe_get;;
+let eta_addr_unsafe_get : string array -> int -> string = unsafe_get;;
+let eta_addr_safe_set : string array -> int -> string -> unit = safe_set;;
+let eta_addr_unsafe_set : string array -> int -> string -> unit = unsafe_set;;
diff --git a/testsuite/tests/translprim/array_spec.ml.reference b/testsuite/tests/translprim/array_spec.ml.reference
new file mode 100644
index 00000000..83fe0c4c
--- /dev/null
+++ b/testsuite/tests/translprim/array_spec.ml.reference
@@ -0,0 +1,88 @@
+(setglobal Array_spec!
+  (let
+    (int_a = (makearray[int] 1 2 3)
+     float_a = (makearray[float] 1. 2. 3.)
+     addr_a = (makearray[addr] "a" "b" "c"))
+    (seq (array.length[int] int_a) (array.length[float] float_a)
+      (array.length[addr] addr_a)
+      (function a (array.length[gen] a))
+      (array.get[int] int_a 0) (array.get[float] float_a 0)
+      (array.get[addr] addr_a 0)
+      (function a (array.get[gen] a 0))
+      (array.unsafe_get[int] int_a 0)
+      (array.unsafe_get[float] float_a 0)
+      (array.unsafe_get[addr] addr_a 0)
+      (function a (array.unsafe_get[gen] a 0))
+      (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.)
+      (array.set[addr] addr_a 0 "a")
+      (function a x (array.set[gen] a 0 x))
+      (array.unsafe_set[int] int_a 0 1)
+      (array.unsafe_set[float] float_a 0 1.)
+      (array.unsafe_set[addr] addr_a 0 "a")
+      (function a x (array.unsafe_set[gen] a 0 x))
+      (let
+        (eta_gen_len =
+           (function prim stub (array.length[gen] prim))
+         eta_gen_safe_get =
+           (function prim prim stub
+             (array.get[gen] prim prim))
+         eta_gen_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[gen] prim prim))
+         eta_gen_safe_set =
+           (function prim prim prim stub
+             (array.set[gen] prim prim prim))
+         eta_gen_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[gen] prim prim prim))
+         eta_int_len =
+           (function prim stub (array.length[int] prim))
+         eta_int_safe_get =
+           (function prim prim stub
+             (array.get[int] prim prim))
+         eta_int_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[int] prim prim))
+         eta_int_safe_set =
+           (function prim prim prim stub
+             (array.set[int] prim prim prim))
+         eta_int_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[int] prim prim prim))
+         eta_float_len =
+           (function prim stub (array.length[float] prim))
+         eta_float_safe_get =
+           (function prim prim stub
+             (array.get[float] prim prim))
+         eta_float_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[float] prim prim))
+         eta_float_safe_set =
+           (function prim prim prim stub
+             (array.set[float] prim prim prim))
+         eta_float_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[float] prim prim prim))
+         eta_addr_len =
+           (function prim stub (array.length[addr] prim))
+         eta_addr_safe_get =
+           (function prim prim stub
+             (array.get[addr] prim prim))
+         eta_addr_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[addr] prim prim))
+         eta_addr_safe_set =
+           (function prim prim prim stub
+             (array.set[addr] prim prim prim))
+         eta_addr_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[addr] prim prim prim)))
+        (makeblock 0 int_a float_a addr_a eta_gen_len
+          eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set
+          eta_gen_unsafe_set eta_int_len eta_int_safe_get
+          eta_int_unsafe_get eta_int_safe_set
+          eta_int_unsafe_set eta_float_len eta_float_safe_get
+          eta_float_unsafe_get eta_float_safe_set
+          eta_float_unsafe_set eta_addr_len eta_addr_safe_get
+          eta_addr_unsafe_get eta_addr_safe_set
+          eta_addr_unsafe_set)))))
diff --git a/testsuite/tests/translprim/comparison_table.ml b/testsuite/tests/translprim/comparison_table.ml
new file mode 100644
index 00000000..129ea5c5
--- /dev/null
+++ b/testsuite/tests/translprim/comparison_table.ml
@@ -0,0 +1,239 @@
+external cmp : 'a -> 'a -> int = "%compare";;
+external eq : 'a -> 'a -> bool = "%equal";;
+external ne : 'a -> 'a -> bool = "%notequal";;
+external lt : 'a -> 'a -> bool = "%lessthan";;
+external gt : 'a -> 'a -> bool = "%greaterthan";;
+external le : 'a -> 'a -> bool = "%lessequal";;
+external ge : 'a -> 'a -> bool = "%greaterequal";;
+
+type intlike = A | B | C | D
+
+(* Check specialization in explicit application *)
+
+let gen_cmp x y = cmp x y;;
+let int_cmp (x : int) y = cmp x y;;
+let bool_cmp (x : bool) y = cmp x y;;
+let intlike_cmp (x : intlike) y = cmp x y;;
+let float_cmp (x : float) y = cmp x y;;
+let string_cmp (x : string) y = cmp x y;;
+let int32_cmp (x : int32) y = cmp x y;;
+let int64_cmp (x : int64) y = cmp x y;;
+let nativeint_cmp (x : nativeint) y = cmp x y;;
+
+let gen_eq x y = eq x y;;
+let int_eq (x : int) y = eq x y;;
+let bool_eq (x : bool) y = eq x y;;
+let intlike_eq (x : intlike) y = eq x y;;
+let float_eq (x : float) y = eq x y;;
+let string_eq (x : string) y = eq x y;;
+let int32_eq (x : int32) y = eq x y;;
+let int64_eq (x : int64) y = eq x y;;
+let nativeint_eq (x : nativeint) y = eq x y;;
+
+let gen_ne x y = ne x y;;
+let int_ne (x : int) y = ne x y;;
+let bool_ne (x : bool) y = ne x y;;
+let intlike_ne (x : intlike) y = ne x y;;
+let float_ne (x : float) y = ne x y;;
+let string_ne (x : string) y = ne x y;;
+let int32_ne (x : int32) y = ne x y;;
+let int64_ne (x : int64) y = ne x y;;
+let nativeint_ne (x : nativeint) y = ne x y;;
+
+let gen_lt x y = lt x y;;
+let int_lt (x : int) y = lt x y;;
+let bool_lt (x : bool) y = lt x y;;
+let intlike_lt (x : intlike) y = lt x y;;
+let float_lt (x : float) y = lt x y;;
+let string_lt (x : string) y = lt x y;;
+let int32_lt (x : int32) y = lt x y;;
+let int64_lt (x : int64) y = lt x y;;
+let nativeint_lt (x : nativeint) y = lt x y;;
+
+let gen_gt x y = gt x y;;
+let int_gt (x : int) y = gt x y;;
+let bool_gt (x : bool) y = gt x y;;
+let intlike_gt (x : intlike) y = gt x y;;
+let float_gt (x : float) y = gt x y;;
+let string_gt (x : string) y = gt x y;;
+let int32_gt (x : int32) y = gt x y;;
+let int64_gt (x : int64) y = gt x y;;
+let nativeint_gt (x : nativeint) y = gt x y;;
+
+let gen_le x y = le x y;;
+let int_le (x : int) y = le x y;;
+let bool_le (x : bool) y = le x y;;
+let intlike_le (x : intlike) y = le x y;;
+let float_le (x : float) y = le x y;;
+let string_le (x : string) y = le x y;;
+let int32_le (x : int32) y = le x y;;
+let int64_le (x : int64) y = le x y;;
+let nativeint_le (x : nativeint) y = le x y;;
+
+let gen_ge x y = ge x y;;
+let int_ge (x : int) y = ge x y;;
+let bool_ge (x : bool) y = ge x y;;
+let intlike_ge (x : intlike) y = ge x y;;
+let float_ge (x : float) y = ge x y;;
+let string_ge (x : string) y = ge x y;;
+let int32_ge (x : int32) y = ge x y;;
+let int64_ge (x : int64) y = ge x y;;
+let nativeint_ge (x : nativeint) y = ge x y;;
+
+(* Check specialization in eta-expansion *)
+
+let eta_gen_cmp : 'a -> _ = cmp;;
+let eta_int_cmp : int -> _ = cmp;;
+let eta_bool_cmp : bool -> _ = cmp;;
+let eta_intlike_cmp : intlike -> _ = cmp;;
+let eta_float_cmp : float -> _ = cmp;;
+let eta_string_cmp : string -> _ = cmp;;
+let eta_int32_cmp : int32 -> _ = cmp;;
+let eta_int64_cmp : int64 -> _ = cmp;;
+let eta_nativeint_cmp : nativeint -> _ = cmp;;
+
+let eta_gen_eq : 'a -> _ = eq;;
+let eta_int_eq : int -> _ = eq;;
+let eta_bool_eq : bool -> _ = eq;;
+let eta_intlike_eq : intlike -> _ = eq;;
+let eta_float_eq : float -> _ = eq;;
+let eta_string_eq : string -> _ = eq;;
+let eta_int32_eq : int32 -> _ = eq;;
+let eta_int64_eq : int64 -> _ = eq;;
+let eta_nativeint_eq : nativeint -> _ = eq;;
+
+let eta_gen_ne : 'a -> _ = ne;;
+let eta_int_ne : int -> _ = ne;;
+let eta_bool_ne : bool -> _ = ne;;
+let eta_intlike_ne : intlike -> _ = ne;;
+let eta_float_ne : float -> _ = ne;;
+let eta_string_ne : string -> _ = ne;;
+let eta_int32_ne : int32 -> _ = ne;;
+let eta_int64_ne : int64 -> _ = ne;;
+let eta_nativeint_ne : nativeint -> _ = ne;;
+
+let eta_gen_lt : 'a -> _ = lt;;
+let eta_int_lt : int -> _ = lt;;
+let eta_bool_lt : bool -> _ = lt;;
+let eta_intlike_lt : intlike -> _ = lt;;
+let eta_float_lt : float -> _ = lt;;
+let eta_string_lt : string -> _ = lt;;
+let eta_int32_lt : int32 -> _ = lt;;
+let eta_int64_lt : int64 -> _ = lt;;
+let eta_nativeint_lt : nativeint -> _ = lt;;
+
+let eta_gen_gt : 'a -> _ = gt;;
+let eta_int_gt : int -> _ = gt;;
+let eta_bool_gt : bool -> _ = gt;;
+let eta_intlike_gt : intlike -> _ = gt;;
+let eta_float_gt : float -> _ = gt;;
+let eta_string_gt : string -> _ = gt;;
+let eta_int32_gt : int32 -> _ = gt;;
+let eta_int64_gt : int64 -> _ = gt;;
+let eta_nativeint_gt : nativeint -> _ = gt;;
+
+let eta_gen_le : 'a -> _ = le;;
+let eta_int_le : int -> _ = le;;
+let eta_bool_le : bool -> _ = le;;
+let eta_intlike_le : intlike -> _ = le;;
+let eta_float_le : float -> _ = le;;
+let eta_string_le : string -> _ = le;;
+let eta_int32_le : int32 -> _ = le;;
+let eta_int64_le : int64 -> _ = le;;
+let eta_nativeint_le : nativeint -> _ = le;;
+
+let eta_gen_ge : 'a -> _ = ge;;
+let eta_int_ge : int -> _ = ge;;
+let eta_bool_ge : bool -> _ = ge;;
+let eta_intlike_ge : intlike -> _ = ge;;
+let eta_float_ge : float -> _ = ge;;
+let eta_string_ge : string -> _ = ge;;
+let eta_int32_ge : int32 -> _ = ge;;
+let eta_int64_ge : int64 -> _ = ge;;
+let eta_nativeint_ge : nativeint -> _ = ge;;
+
+(* Check results of computations *)
+
+let int_vec = [(1,1);(1,2);(2,1)];;
+let bool_vec = [(false,false);(false,true);(true,false)];;
+let intlike_vec = [(A,A);(A,B);(B,A)];;
+let float_vec = [(1.,1.);(1.,2.);(2.,1.)];;
+let string_vec = [("1","1");("1","2");("2","1")];;
+let int32_vec = [(1l,1l);(1l,2l);(2l,1l)];;
+let int64_vec = [(1L,1L);(1L,2L);(2L,1L)];;
+let nativeint_vec = [(1n,1n);(1n,2n);(2n,1n)];;
+
+let test_vec cmp eq ne lt gt le ge vec =
+  let uncurry f (x,y) = f x y in
+  let map f l = List.map (uncurry f) l in
+  (map gen_cmp vec, map cmp vec),
+  (map (fun gen spec -> map gen vec, map spec vec)
+     [gen_eq,eq; gen_ne,ne; gen_lt,lt; gen_gt,gt; gen_le,le; gen_ge,ge])
+;;
+
+test_vec
+  int_cmp int_eq int_ne int_lt int_gt int_le int_ge
+  int_vec;;
+test_vec
+  bool_cmp bool_eq bool_ne bool_lt bool_gt bool_le bool_ge
+  bool_vec;;
+test_vec
+  intlike_cmp intlike_eq intlike_ne intlike_lt intlike_gt intlike_le intlike_ge
+  intlike_vec;;
+test_vec
+  float_cmp float_eq float_ne float_lt float_gt float_le float_ge
+  float_vec;;
+test_vec
+  string_cmp string_eq string_ne string_lt string_gt string_le string_ge
+  string_vec;;
+test_vec
+  int32_cmp int32_eq int32_ne int32_lt int32_gt int32_le int32_ge
+  int32_vec;;
+test_vec
+  int64_cmp int64_eq int64_ne int64_lt int64_gt int64_le int64_ge
+  int64_vec;;
+test_vec
+  nativeint_cmp nativeint_eq nativeint_ne
+  nativeint_lt nativeint_gt nativeint_le nativeint_ge
+  nativeint_vec;;
+
+let eta_test_vec cmp eq ne lt gt le ge vec =
+  let uncurry f (x,y) = f x y in
+  let map f l = List.map (uncurry f) l in
+  (map eta_gen_cmp vec, map cmp vec),
+  (map (fun gen spec -> map gen vec, map spec vec)
+     [eta_gen_eq,eq; eta_gen_ne,ne; eta_gen_lt,lt;
+      eta_gen_gt,gt; eta_gen_le,le; eta_gen_ge,ge])
+;;
+
+eta_test_vec
+  eta_int_cmp eta_int_eq eta_int_ne eta_int_lt eta_int_gt eta_int_le eta_int_ge
+  int_vec;;
+eta_test_vec
+  eta_bool_cmp eta_bool_eq eta_bool_ne eta_bool_lt eta_bool_gt
+  eta_bool_le eta_bool_ge
+  bool_vec;;
+eta_test_vec
+  eta_intlike_cmp eta_intlike_eq eta_intlike_ne eta_intlike_lt eta_intlike_gt
+  eta_intlike_le eta_intlike_ge
+  intlike_vec;;
+eta_test_vec
+  eta_float_cmp eta_float_eq eta_float_ne eta_float_lt eta_float_gt
+  eta_float_le eta_float_ge
+  float_vec;;
+eta_test_vec
+  eta_string_cmp eta_string_eq eta_string_ne eta_string_lt eta_string_gt
+  eta_string_le eta_string_ge
+  string_vec;;
+eta_test_vec
+  eta_int32_cmp eta_int32_eq eta_int32_ne eta_int32_lt eta_int32_gt
+  eta_int32_le eta_int32_ge
+  int32_vec;;
+eta_test_vec
+  eta_int64_cmp eta_int64_eq eta_int64_ne eta_int64_lt eta_int64_gt
+  eta_int64_le eta_int64_ge
+  int64_vec;;
+eta_test_vec
+  eta_nativeint_cmp eta_nativeint_eq eta_nativeint_ne
+  eta_nativeint_lt eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
+  nativeint_vec;;
diff --git a/testsuite/tests/translprim/comparison_table.ml.reference b/testsuite/tests/translprim/comparison_table.ml.reference
new file mode 100644
index 00000000..e0401632
--- /dev/null
+++ b/testsuite/tests/translprim/comparison_table.ml.reference
@@ -0,0 +1,375 @@
+(setglobal Comparison_table!
+  (let
+    (gen_cmp = (function x y (caml_compare x y))
+     int_cmp = (function x y (caml_int_compare x y))
+     bool_cmp =
+       (function x y (caml_int_compare x y))
+     intlike_cmp =
+       (function x y (caml_int_compare x y))
+     float_cmp =
+       (function x y (caml_float_compare x y))
+     string_cmp =
+       (function x y (caml_string_compare x y))
+     int32_cmp =
+       (function x y (caml_int32_compare x y))
+     int64_cmp =
+       (function x y (caml_int64_compare x y))
+     nativeint_cmp =
+       (function x y (caml_nativeint_compare x y))
+     gen_eq = (function x y (caml_equal x y))
+     int_eq = (function x y (== x y))
+     bool_eq = (function x y (== x y))
+     intlike_eq = (function x y (== x y))
+     float_eq = (function x y (==. x y))
+     string_eq =
+       (function x y (caml_string_equal x y))
+     int32_eq = (function x y (Int32.== x y))
+     int64_eq = (function x y (Int64.== x y))
+     nativeint_eq =
+       (function x y (Nativeint.== x y))
+     gen_ne = (function x y (caml_notequal x y))
+     int_ne = (function x y (!= x y))
+     bool_ne = (function x y (!= x y))
+     intlike_ne = (function x y (!= x y))
+     float_ne = (function x y (!=. x y))
+     string_ne =
+       (function x y (caml_string_notequal x y))
+     int32_ne = (function x y (Int32.!= x y))
+     int64_ne = (function x y (Int64.!= x y))
+     nativeint_ne =
+       (function x y (Nativeint.!= x y))
+     gen_lt = (function x y (caml_lessthan x y))
+     int_lt = (function x y (< x y))
+     bool_lt = (function x y (< x y))
+     intlike_lt = (function x y (< x y))
+     float_lt = (function x y (<. x y))
+     string_lt =
+       (function x y (caml_string_lessthan x y))
+     int32_lt = (function x y (Int32.< x y))
+     int64_lt = (function x y (Int64.< x y))
+     nativeint_lt = (function x y (Nativeint.< x y))
+     gen_gt = (function x y (caml_greaterthan x y))
+     int_gt = (function x y (> x y))
+     bool_gt = (function x y (> x y))
+     intlike_gt = (function x y (> x y))
+     float_gt = (function x y (>. x y))
+     string_gt =
+       (function x y (caml_string_greaterthan x y))
+     int32_gt = (function x y (Int32.> x y))
+     int64_gt = (function x y (Int64.> x y))
+     nativeint_gt = (function x y (Nativeint.> x y))
+     gen_le = (function x y (caml_lessequal x y))
+     int_le = (function x y (<= x y))
+     bool_le = (function x y (<= x y))
+     intlike_le = (function x y (<= x y))
+     float_le = (function x y (<=. x y))
+     string_le =
+       (function x y (caml_string_lessequal x y))
+     int32_le = (function x y (Int32.<= x y))
+     int64_le = (function x y (Int64.<= x y))
+     nativeint_le =
+       (function x y (Nativeint.<= x y))
+     gen_ge = (function x y (caml_greaterequal x y))
+     int_ge = (function x y (>= x y))
+     bool_ge = (function x y (>= x y))
+     intlike_ge = (function x y (>= x y))
+     float_ge = (function x y (>=. x y))
+     string_ge =
+       (function x y (caml_string_greaterequal x y))
+     int32_ge = (function x y (Int32.>= x y))
+     int64_ge = (function x y (Int64.>= x y))
+     nativeint_ge =
+       (function x y (Nativeint.>= x y))
+     eta_gen_cmp =
+       (function prim prim stub (caml_compare prim prim))
+     eta_int_cmp =
+       (function prim prim stub
+         (caml_int_compare prim prim))
+     eta_bool_cmp =
+       (function prim prim stub
+         (caml_int_compare prim prim))
+     eta_intlike_cmp =
+       (function prim prim stub
+         (caml_int_compare prim prim))
+     eta_float_cmp =
+       (function prim prim stub
+         (caml_float_compare prim prim))
+     eta_string_cmp =
+       (function prim prim stub
+         (caml_string_compare prim prim))
+     eta_int32_cmp =
+       (function prim prim stub
+         (caml_int32_compare prim prim))
+     eta_int64_cmp =
+       (function prim prim stub
+         (caml_int64_compare prim prim))
+     eta_nativeint_cmp =
+       (function prim prim stub
+         (caml_nativeint_compare prim prim))
+     eta_gen_eq =
+       (function prim prim stub (caml_equal prim prim))
+     eta_int_eq =
+       (function prim prim stub (== prim prim))
+     eta_bool_eq =
+       (function prim prim stub (== prim prim))
+     eta_intlike_eq =
+       (function prim prim stub (== prim prim))
+     eta_float_eq =
+       (function prim prim stub (==. prim prim))
+     eta_string_eq =
+       (function prim prim stub
+         (caml_string_equal prim prim))
+     eta_int32_eq =
+       (function prim prim stub (Int32.== prim prim))
+     eta_int64_eq =
+       (function prim prim stub (Int64.== prim prim))
+     eta_nativeint_eq =
+       (function prim prim stub (Nativeint.== prim prim))
+     eta_gen_ne =
+       (function prim prim stub
+         (caml_notequal prim prim))
+     eta_int_ne =
+       (function prim prim stub (!= prim prim))
+     eta_bool_ne =
+       (function prim prim stub (!= prim prim))
+     eta_intlike_ne =
+       (function prim prim stub (!= prim prim))
+     eta_float_ne =
+       (function prim prim stub (!=. prim prim))
+     eta_string_ne =
+       (function prim prim stub
+         (caml_string_notequal prim prim))
+     eta_int32_ne =
+       (function prim prim stub (Int32.!= prim prim))
+     eta_int64_ne =
+       (function prim prim stub (Int64.!= prim prim))
+     eta_nativeint_ne =
+       (function prim prim stub (Nativeint.!= prim prim))
+     eta_gen_lt =
+       (function prim prim stub
+         (caml_lessthan prim prim))
+     eta_int_lt =
+       (function prim prim stub (< prim prim))
+     eta_bool_lt =
+       (function prim prim stub (< prim prim))
+     eta_intlike_lt =
+       (function prim prim stub (< prim prim))
+     eta_float_lt =
+       (function prim prim stub (<. prim prim))
+     eta_string_lt =
+       (function prim prim stub
+         (caml_string_lessthan prim prim))
+     eta_int32_lt =
+       (function prim prim stub (Int32.< prim prim))
+     eta_int64_lt =
+       (function prim prim stub (Int64.< prim prim))
+     eta_nativeint_lt =
+       (function prim prim stub (Nativeint.< prim prim))
+     eta_gen_gt =
+       (function prim prim stub
+         (caml_greaterthan prim prim))
+     eta_int_gt =
+       (function prim prim stub (> prim prim))
+     eta_bool_gt =
+       (function prim prim stub (> prim prim))
+     eta_intlike_gt =
+       (function prim prim stub (> prim prim))
+     eta_float_gt =
+       (function prim prim stub (>. prim prim))
+     eta_string_gt =
+       (function prim prim stub
+         (caml_string_greaterthan prim prim))
+     eta_int32_gt =
+       (function prim prim stub (Int32.> prim prim))
+     eta_int64_gt =
+       (function prim prim stub (Int64.> prim prim))
+     eta_nativeint_gt =
+       (function prim prim stub (Nativeint.> prim prim))
+     eta_gen_le =
+       (function prim prim stub
+         (caml_lessequal prim prim))
+     eta_int_le =
+       (function prim prim stub (<= prim prim))
+     eta_bool_le =
+       (function prim prim stub (<= prim prim))
+     eta_intlike_le =
+       (function prim prim stub (<= prim prim))
+     eta_float_le =
+       (function prim prim stub (<=. prim prim))
+     eta_string_le =
+       (function prim prim stub
+         (caml_string_lessequal prim prim))
+     eta_int32_le =
+       (function prim prim stub (Int32.<= prim prim))
+     eta_int64_le =
+       (function prim prim stub (Int64.<= prim prim))
+     eta_nativeint_le =
+       (function prim prim stub (Nativeint.<= prim prim))
+     eta_gen_ge =
+       (function prim prim stub
+         (caml_greaterequal prim prim))
+     eta_int_ge =
+       (function prim prim stub (>= prim prim))
+     eta_bool_ge =
+       (function prim prim stub (>= prim prim))
+     eta_intlike_ge =
+       (function prim prim stub (>= prim prim))
+     eta_float_ge =
+       (function prim prim stub (>=. prim prim))
+     eta_string_ge =
+       (function prim prim stub
+         (caml_string_greaterequal prim prim))
+     eta_int32_ge =
+       (function prim prim stub (Int32.>= prim prim))
+     eta_int64_ge =
+       (function prim prim stub (Int64.>= prim prim))
+     eta_nativeint_ge =
+       (function prim prim stub (Nativeint.>= prim prim))
+     int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
+     bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+     intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+     float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
+     string_vec =
+       [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
+     int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
+     int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
+     nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
+     test_vec =
+       (function cmp eq ne lt gt le ge
+         vec
+         (let
+           (uncurry =
+              (function f param
+                (apply f (field 0 param) (field 1 param)))
+            map =
+              (function f l
+                (apply (field 15 (global List!)) (apply uncurry f)
+                  l)))
+           (makeblock 0
+             (makeblock 0 (apply map gen_cmp vec)
+               (apply map cmp vec))
+             (apply map
+               (function gen spec
+                 (makeblock 0 (apply map gen vec)
+                   (apply map spec vec)))
+               (makeblock 0 (makeblock 0 gen_eq eq)
+                 (makeblock 0 (makeblock 0 gen_ne ne)
+                   (makeblock 0 (makeblock 0 gen_lt lt)
+                     (makeblock 0 (makeblock 0 gen_gt gt)
+                       (makeblock 0 (makeblock 0 gen_le le)
+                         (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
+    (seq
+      (apply test_vec int_cmp int_eq int_ne int_lt
+        int_gt int_le int_ge int_vec)
+      (apply test_vec bool_cmp bool_eq bool_ne
+        bool_lt bool_gt bool_le bool_ge bool_vec)
+      (apply test_vec intlike_cmp intlike_eq intlike_ne
+        intlike_lt intlike_gt intlike_le intlike_ge
+        intlike_vec)
+      (apply test_vec float_cmp float_eq float_ne
+        float_lt float_gt float_le float_ge
+        float_vec)
+      (apply test_vec string_cmp string_eq string_ne
+        string_lt string_gt string_le string_ge
+        string_vec)
+      (apply test_vec int32_cmp int32_eq int32_ne
+        int32_lt int32_gt int32_le int32_ge
+        int32_vec)
+      (apply test_vec int64_cmp int64_eq int64_ne
+        int64_lt int64_gt int64_le int64_ge
+        int64_vec)
+      (apply test_vec nativeint_cmp nativeint_eq
+        nativeint_ne nativeint_lt nativeint_gt
+        nativeint_le nativeint_ge nativeint_vec)
+      (let
+        (eta_test_vec =
+           (function cmp eq ne lt gt le ge
+             vec
+             (let
+               (uncurry =
+                  (function f param
+                    (apply f (field 0 param) (field 1 param)))
+                map =
+                  (function f l
+                    (apply (field 15 (global List!))
+                      (apply uncurry f) l)))
+               (makeblock 0
+                 (makeblock 0 (apply map eta_gen_cmp vec)
+                   (apply map cmp vec))
+                 (apply map
+                   (function gen spec
+                     (makeblock 0 (apply map gen vec)
+                       (apply map spec vec)))
+                   (makeblock 0 (makeblock 0 eta_gen_eq eq)
+                     (makeblock 0 (makeblock 0 eta_gen_ne ne)
+                       (makeblock 0 (makeblock 0 eta_gen_lt lt)
+                         (makeblock 0 (makeblock 0 eta_gen_gt gt)
+                           (makeblock 0 (makeblock 0 eta_gen_le le)
+                             (makeblock 0
+                               (makeblock 0 eta_gen_ge ge) 0a)))))))))))
+        (seq
+          (apply eta_test_vec eta_int_cmp eta_int_eq
+            eta_int_ne eta_int_lt eta_int_gt eta_int_le
+            eta_int_ge int_vec)
+          (apply eta_test_vec eta_bool_cmp eta_bool_eq
+            eta_bool_ne eta_bool_lt eta_bool_gt
+            eta_bool_le eta_bool_ge bool_vec)
+          (apply eta_test_vec eta_intlike_cmp eta_intlike_eq
+            eta_intlike_ne eta_intlike_lt eta_intlike_gt
+            eta_intlike_le eta_intlike_ge intlike_vec)
+          (apply eta_test_vec eta_float_cmp eta_float_eq
+            eta_float_ne eta_float_lt eta_float_gt
+            eta_float_le eta_float_ge float_vec)
+          (apply eta_test_vec eta_string_cmp eta_string_eq
+            eta_string_ne eta_string_lt eta_string_gt
+            eta_string_le eta_string_ge string_vec)
+          (apply eta_test_vec eta_int32_cmp eta_int32_eq
+            eta_int32_ne eta_int32_lt eta_int32_gt
+            eta_int32_le eta_int32_ge int32_vec)
+          (apply eta_test_vec eta_int64_cmp eta_int64_eq
+            eta_int64_ne eta_int64_lt eta_int64_gt
+            eta_int64_le eta_int64_ge int64_vec)
+          (apply eta_test_vec eta_nativeint_cmp
+            eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt
+            eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
+            nativeint_vec)
+          (makeblock 0 gen_cmp int_cmp bool_cmp
+            intlike_cmp float_cmp string_cmp int32_cmp
+            int64_cmp nativeint_cmp gen_eq int_eq
+            bool_eq intlike_eq float_eq string_eq
+            int32_eq int64_eq nativeint_eq gen_ne
+            int_ne bool_ne intlike_ne float_ne
+            string_ne int32_ne int64_ne nativeint_ne
+            gen_lt int_lt bool_lt intlike_lt
+            float_lt string_lt int32_lt int64_lt
+            nativeint_lt gen_gt int_gt bool_gt
+            intlike_gt float_gt string_gt int32_gt
+            int64_gt nativeint_gt gen_le int_le
+            bool_le intlike_le float_le string_le
+            int32_le int64_le nativeint_le gen_ge
+            int_ge bool_ge intlike_ge float_ge
+            string_ge int32_ge int64_ge nativeint_ge
+            eta_gen_cmp eta_int_cmp eta_bool_cmp
+            eta_intlike_cmp eta_float_cmp eta_string_cmp
+            eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
+            eta_gen_eq eta_int_eq eta_bool_eq
+            eta_intlike_eq eta_float_eq eta_string_eq
+            eta_int32_eq eta_int64_eq eta_nativeint_eq
+            eta_gen_ne eta_int_ne eta_bool_ne
+            eta_intlike_ne eta_float_ne eta_string_ne
+            eta_int32_ne eta_int64_ne eta_nativeint_ne
+            eta_gen_lt eta_int_lt eta_bool_lt
+            eta_intlike_lt eta_float_lt eta_string_lt
+            eta_int32_lt eta_int64_lt eta_nativeint_lt
+            eta_gen_gt eta_int_gt eta_bool_gt
+            eta_intlike_gt eta_float_gt eta_string_gt
+            eta_int32_gt eta_int64_gt eta_nativeint_gt
+            eta_gen_le eta_int_le eta_bool_le
+            eta_intlike_le eta_float_le eta_string_le
+            eta_int32_le eta_int64_le eta_nativeint_le
+            eta_gen_ge eta_int_ge eta_bool_ge
+            eta_intlike_ge eta_float_ge eta_string_ge
+            eta_int32_ge eta_int64_ge eta_nativeint_ge
+            int_vec bool_vec intlike_vec float_vec
+            string_vec int32_vec int64_vec nativeint_vec
+            test_vec eta_test_vec))))))
diff --git a/testsuite/tests/translprim/module_coercion.ml b/testsuite/tests/translprim/module_coercion.ml
new file mode 100644
index 00000000..041b3034
--- /dev/null
+++ b/testsuite/tests/translprim/module_coercion.ml
@@ -0,0 +1,37 @@
+module M = struct
+  external len : 'a array -> int = "%array_length"
+  external safe_get : 'a array -> int -> 'a = "%array_safe_get"
+  external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+  external safe_set : 'a array -> int -> 'a -> unit = "%array_safe_set"
+  external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+  external cmp : 'a -> 'a -> int = "%compare";;
+  external eq : 'a -> 'a -> bool = "%equal";;
+  external ne : 'a -> 'a -> bool = "%notequal";;
+  external lt : 'a -> 'a -> bool = "%lessthan";;
+  external gt : 'a -> 'a -> bool = "%greaterthan";;
+  external le : 'a -> 'a -> bool = "%lessequal";;
+  external ge : 'a -> 'a -> bool = "%greaterequal";;
+end;;
+
+module type T = sig
+  type t
+  val len : t array -> int
+  val safe_get : t array -> int -> t
+  val unsafe_get : t array -> int -> t
+  val safe_set : t array -> int -> t -> unit
+  val unsafe_set : t array -> int -> t -> unit
+  val cmp : t -> t -> int
+  val eq : t -> t -> bool
+  val ne : t -> t -> bool
+  val lt : t -> t -> bool
+  val gt : t -> t -> bool
+  val le : t -> t -> bool
+  val ge : t -> t -> bool
+end;;
+
+module M_int : T with type t := int = M;;
+module M_float : T with type t := float = M;;
+module M_string : T with type t := string = M;;
+module M_int32 : T with type t := int32 = M;;
+module M_int64 : T with type t := int64 = M;;
+module M_nativeint : T with type t := nativeint = M;;
diff --git a/testsuite/tests/translprim/module_coercion.ml.reference b/testsuite/tests/translprim/module_coercion.ml.reference
new file mode 100644
index 00000000..ca771020
--- /dev/null
+++ b/testsuite/tests/translprim/module_coercion.ml.reference
@@ -0,0 +1,115 @@
+(setglobal Module_coercion!
+  (let (M = (makeblock 0))
+    (makeblock 0 M
+      (makeblock 0 (function prim stub (array.length[int] prim))
+        (function prim prim stub
+          (array.get[int] prim prim))
+        (function prim prim stub
+          (array.unsafe_get[int] prim prim))
+        (function prim prim prim stub
+          (array.set[int] prim prim prim))
+        (function prim prim prim stub
+          (array.unsafe_set[int] prim prim prim))
+        (function prim prim stub
+          (caml_int_compare prim prim))
+        (function prim prim stub (== prim prim))
+        (function prim prim stub (!= prim prim))
+        (function prim prim stub (< prim prim))
+        (function prim prim stub (> prim prim))
+        (function prim prim stub (<= prim prim))
+        (function prim prim stub (>= prim prim)))
+      (makeblock 0 (function prim stub (array.length[float] prim))
+        (function prim prim stub
+          (array.get[float] prim prim))
+        (function prim prim stub
+          (array.unsafe_get[float] prim prim))
+        (function prim prim prim stub
+          (array.set[float] prim prim prim))
+        (function prim prim prim stub
+          (array.unsafe_set[float] prim prim prim))
+        (function prim prim stub
+          (caml_float_compare prim prim))
+        (function prim prim stub (==. prim prim))
+        (function prim prim stub (!=. prim prim))
+        (function prim prim stub (<. prim prim))
+        (function prim prim stub (>. prim prim))
+        (function prim prim stub (<=. prim prim))
+        (function prim prim stub (>=. prim prim)))
+      (makeblock 0 (function prim stub (array.length[addr] prim))
+        (function prim prim stub
+          (array.get[addr] prim prim))
+        (function prim prim stub
+          (array.unsafe_get[addr] prim prim))
+        (function prim prim prim stub
+          (array.set[addr] prim prim prim))
+        (function prim prim prim stub
+          (array.unsafe_set[addr] prim prim prim))
+        (function prim prim stub
+          (caml_string_compare prim prim))
+        (function prim prim stub
+          (caml_string_equal prim prim))
+        (function prim prim stub
+          (caml_string_notequal prim prim))
+        (function prim prim stub
+          (caml_string_lessthan prim prim))
+        (function prim prim stub
+          (caml_string_greaterthan prim prim))
+        (function prim prim stub
+          (caml_string_lessequal prim prim))
+        (function prim prim stub
+          (caml_string_greaterequal prim prim)))
+      (makeblock 0 (function prim stub (array.length[addr] prim))
+        (function prim prim stub
+          (array.get[addr] prim prim))
+        (function prim prim stub
+          (array.unsafe_get[addr] prim prim))
+        (function prim prim prim stub
+          (array.set[addr] prim prim prim))
+        (function prim prim prim stub
+          (array.unsafe_set[addr] prim prim prim))
+        (function prim prim stub
+          (caml_int32_compare prim prim))
+        (function prim prim stub (Int32.== prim prim))
+        (function prim prim stub (Int32.!= prim prim))
+        (function prim prim stub (Int32.< prim prim))
+        (function prim prim stub (Int32.> prim prim))
+        (function prim prim stub (Int32.<= prim prim))
+        (function prim prim stub (Int32.>= prim prim)))
+      (makeblock 0 (function prim stub (array.length[addr] prim))
+        (function prim prim stub
+          (array.get[addr] prim prim))
+        (function prim prim stub
+          (array.unsafe_get[addr] prim prim))
+        (function prim prim prim stub
+          (array.set[addr] prim prim prim))
+        (function prim prim prim stub
+          (array.unsafe_set[addr] prim prim prim))
+        (function prim prim stub
+          (caml_int64_compare prim prim))
+        (function prim prim stub (Int64.== prim prim))
+        (function prim prim stub (Int64.!= prim prim))
+        (function prim prim stub (Int64.< prim prim))
+        (function prim prim stub (Int64.> prim prim))
+        (function prim prim stub (Int64.<= prim prim))
+        (function prim prim stub (Int64.>= prim prim)))
+      (makeblock 0 (function prim stub (array.length[addr] prim))
+        (function prim prim stub
+          (array.get[addr] prim prim))
+        (function prim prim stub
+          (array.unsafe_get[addr] prim prim))
+        (function prim prim prim stub
+          (array.set[addr] prim prim prim))
+        (function prim prim prim stub
+          (array.unsafe_set[addr] prim prim prim))
+        (function prim prim stub
+          (caml_nativeint_compare prim prim))
+        (function prim prim stub
+          (Nativeint.== prim prim))
+        (function prim prim stub
+          (Nativeint.!= prim prim))
+        (function prim prim stub (Nativeint.< prim prim))
+        (function prim prim stub (Nativeint.> prim prim))
+        (function prim prim stub
+          (Nativeint.<= prim prim))
+        (function prim prim stub
+          (Nativeint.>= prim prim))))))
diff --git a/testsuite/tests/translprim/ref_spec.ml b/testsuite/tests/translprim/ref_spec.ml
new file mode 100644
index 00000000..068fa884
--- /dev/null
+++ b/testsuite/tests/translprim/ref_spec.ml
@@ -0,0 +1,54 @@
+type 'a custom_rec = { x : unit; mutable y : 'a }
+type float_rec = { w : float; mutable z : float }
+
+type cst = A | B
+type gen = C | D of string
+
+type var = [ `A | `B ]
+type vargen = [ `A | `B of int | `C ]
+
+let int_ref = ref 1;;
+let var_ref : var ref = ref `A;;
+let vargen_ref : vargen ref = ref `A;;
+let cst_ref = ref A;;
+let gen_ref = ref C;;
+let flt_ref = ref 0.;;
+
+int_ref := 2;;
+var_ref := `B;;
+vargen_ref := `B 0;;
+vargen_ref := `C;;
+cst_ref := B;;
+gen_ref := D "foo";;
+gen_ref := C;;
+flt_ref := 1.;;
+
+let int_rec = { x = (); y = 1 };;
+let var_rec : var custom_rec = { x = (); y = `A };;
+let vargen_rec : vargen custom_rec = { x = (); y = `A };;
+let cst_rec = { x = (); y = A };;
+let gen_rec = { x = (); y = C };;
+let flt_rec = { x = (); y = 0. };;
+let flt_rec' = { w = 0.; z = 0. };;
+
+int_rec.y <- 2;;
+var_rec.y <- `B;;
+vargen_rec.y <- `B 0;;
+vargen_rec.y <- `C;;
+cst_rec.y <- B;;
+gen_rec.y <- D "foo";;
+gen_rec.y <- C;;
+flt_rec.y <- 1.;;
+flt_rec'.z <- 1.;;
+
+(* must use a write barrier, type is open *)
+let set_open_poly (r:[>`Foo] ref) y = r := y ;;
+let set_open_poly (r:[<`Foo] ref) y = r := y ;;
+let set_open_poly (r:[`Foo] ref) y = r := y ;;
+let set_open_poly (r:[< `Bar | `Foo | `Baz > `Foo `Bar] ref) y = r := y ;;
+let set_open_poly (r:[>`Foo of int] ref) y = r := y ;;
+let set_open_poly (r:[<`Foo of int] ref) y = r := y ;;
+let set_open_poly (r:[`Foo of int] ref) y = r := y ;;
+let set_open_poly (r:[< `Bar | `Foo of float | `Baz > `Foo `Bar] ref) y =
+  r := y
+;;
diff --git a/testsuite/tests/translprim/ref_spec.ml.reference b/testsuite/tests/translprim/ref_spec.ml.reference
new file mode 100644
index 00000000..c21b100b
--- /dev/null
+++ b/testsuite/tests/translprim/ref_spec.ml.reference
@@ -0,0 +1,50 @@
+(setglobal Ref_spec!
+  (let
+    (int_ref = (makemutable 0 (int) 1)
+     var_ref = (makemutable 0 65a)
+     vargen_ref = (makemutable 0 65a)
+     cst_ref = (makemutable 0 0a)
+     gen_ref = (makemutable 0 0a)
+     flt_ref = (makemutable 0 (float) 0.))
+    (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a)
+      (setfield_ptr 0 vargen_ref [0: 66 0])
+      (setfield_ptr 0 vargen_ref 67a) (setfield_imm 0 cst_ref 1a)
+      (setfield_ptr 0 gen_ref [0: "foo"])
+      (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.)
+      (let
+        (int_rec = (makemutable 0 (*,int) 0a 1)
+         var_rec = (makemutable 0 0a 65a)
+         vargen_rec = (makemutable 0 0a 65a)
+         cst_rec = (makemutable 0 0a 0a)
+         gen_rec = (makemutable 0 0a 0a)
+         flt_rec = (makemutable 0 (*,float) 0a 0.)
+         flt_rec' = (makearray[float] 0. 0.))
+        (seq (setfield_imm 1 int_rec 2)
+          (setfield_imm 1 var_rec 66a)
+          (setfield_ptr 1 vargen_rec [0: 66 0])
+          (setfield_ptr 1 vargen_rec 67a)
+          (setfield_imm 1 cst_rec 1a)
+          (setfield_ptr 1 gen_rec [0: "foo"])
+          (setfield_ptr 1 gen_rec 0a) (setfield_ptr 1 flt_rec 1.)
+          (setfloatfield 1 flt_rec' 1.)
+          (let
+            (set_open_poly =
+               (function r y (setfield_ptr 0 r y))
+             set_open_poly =
+               (function r y (setfield_imm 0 r y))
+             set_open_poly =
+               (function r y (setfield_imm 0 r y))
+             set_open_poly =
+               (function r y (setfield_imm 0 r y))
+             set_open_poly =
+               (function r y (setfield_ptr 0 r y))
+             set_open_poly =
+               (function r y (setfield_ptr 0 r y))
+             set_open_poly =
+               (function r y (setfield_ptr 0 r y))
+             set_open_poly =
+               (function r y (setfield_ptr 0 r y)))
+            (makeblock 0 int_ref var_ref vargen_ref
+              cst_ref gen_ref flt_ref int_rec
+              var_rec vargen_rec cst_rec gen_rec
+              flt_rec flt_rec' set_open_poly)))))))
diff --git a/testsuite/tests/typing-extension-constructor/Makefile b/testsuite/tests/typing-extension-constructor/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-extension-constructor/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-extension-constructor/test.ml b/testsuite/tests/typing-extension-constructor/test.ml
new file mode 100644
index 00000000..4c73807f
--- /dev/null
+++ b/testsuite/tests/typing-extension-constructor/test.ml
@@ -0,0 +1,14 @@
+
+type t = ..;;
+type t += A;;
+
+[%extension_constructor A];;
+([%extension_constructor A] : extension_constructor);;
+
+module M = struct
+  type extension_constructor = int
+end;;
+
+open M;;
+
+([%extension_constructor A] : extension_constructor);;
diff --git a/testsuite/tests/typing-extension-constructor/test.ml.reference b/testsuite/tests/typing-extension-constructor/test.ml.reference
new file mode 100644
index 00000000..5fc7ac41
--- /dev/null
+++ b/testsuite/tests/typing-extension-constructor/test.ml.reference
@@ -0,0 +1,12 @@
+
+#   type t = ..
+# type t += A
+#   - : extension_constructor = 
+# - : extension_constructor = 
+#       module M : sig type extension_constructor = int end
+#   #   Characters 2-28:
+  ([%extension_constructor A] : extension_constructor);;
+   ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type extension_constructor
+       but an expression was expected of type M.extension_constructor = int
+# 
diff --git a/testsuite/tests/typing-extensions/Makefile b/testsuite/tests/typing-extensions/Makefile
new file mode 100644
index 00000000..9625a3fb
--- /dev/null
+++ b/testsuite/tests/typing-extensions/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-extensions/cast.ml b/testsuite/tests/typing-extensions/cast.ml
new file mode 100644
index 00000000..1efcfd50
--- /dev/null
+++ b/testsuite/tests/typing-extensions/cast.ml
@@ -0,0 +1,99 @@
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+(* By using two types we can have a recursive constraint *)
+type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
+and 'a name =
+  Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name
+;;
+
+exception Bad_cast
+;;
+
+class type castable =
+object
+  method cast: 'a.'a name -> 'a
+end
+;;
+
+(* Lets create a castable class with a name*)
+
+class type foo_t =
+object
+  inherit castable
+  method foo: string
+end
+;;
+
+type 'a class_name += Foo: foo_t class_name
+;;
+
+class foo: foo_t =
+object(self)
+  method cast: type a. a name -> a =
+    function
+        Class Foo -> (self :> foo_t)
+      | _ -> ((raise Bad_cast) : a)
+  method foo = "foo"
+end
+;;
+
+(* Now we can create a subclass of foo *)
+
+class type bar_t =
+object
+  inherit foo
+  method bar: string
+end
+;;
+
+type 'a class_name += Bar: bar_t class_name
+;;
+
+class bar: bar_t =
+object(self)
+  inherit foo as super
+  method cast: type a. a name -> a =
+    function
+        Class Bar -> (self :> bar_t)
+      | other -> super#cast other
+  method bar = "bar"
+end
+;;
+
+(* Now lets create a mutable list of castable objects *)
+
+let clist :castable list ref = ref []
+;;
+
+let push_castable (c: #castable) =
+  clist := (c :> castable) :: !clist
+;;
+
+let pop_castable () =
+  match !clist with
+      c :: rest ->
+        clist := rest;
+        c
+    | [] -> raise Not_found
+;;
+
+(* We can add foos and bars to this list, and retrive them *)
+
+push_castable (new foo);;
+push_castable (new bar);;
+push_castable (new foo);;
+
+let c1: castable = pop_castable ();;
+let c2: castable = pop_castable ();;
+let c3: castable = pop_castable ();;
+
+(* We can also downcast these values to foos and bars *)
+
+let f1: foo = c1#cast (Class Foo);; (* Ok *)
+let f2: foo = c2#cast (Class Foo);; (* Ok *)
+let f3: foo = c3#cast (Class Foo);; (* Ok *)
+
+let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *)
+let b2: bar = c2#cast (Class Bar);; (* Ok *)
+let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *)
diff --git a/testsuite/tests/typing-extensions/cast.ml.reference b/testsuite/tests/typing-extensions/cast.ml.reference
new file mode 100644
index 00000000..3478d60f
--- /dev/null
+++ b/testsuite/tests/typing-extensions/cast.ml.reference
@@ -0,0 +1,34 @@
+
+#   - : unit = ()
+#           type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. >
+and 'a name =
+    Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name
+#     exception Bad_cast
+#           class type castable = object method cast : 'a name -> 'a end
+#                 class type foo_t = object method cast : 'a name -> 'a method foo : string end
+#     type 'b class_name += Foo : foo_t class_name
+#                   class foo : foo_t
+#                 class type bar_t =
+  object
+    method bar : string
+    method cast : 'a name -> 'a
+    method foo : string
+  end
+#     type 'b class_name += Bar : bar_t class_name
+#                     class bar : bar_t
+#         val clist : castable list ref = {contents = []}
+#       val push_castable : #castable -> unit = 
+#               val pop_castable : unit -> castable = 
+#       - : unit = ()
+# - : unit = ()
+# - : unit = ()
+#   val c1 : castable = 
+# val c2 : castable = 
+# val c3 : castable = 
+#       val f1 : foo = 
+# val f2 : foo = 
+# val f3 : foo = 
+#   Exception: Bad_cast.
+# val b2 : bar = 
+# Exception: Bad_cast.
+# 
diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml
new file mode 100644
index 00000000..f6d6c900
--- /dev/null
+++ b/testsuite/tests/typing-extensions/extensions.ml
@@ -0,0 +1,328 @@
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+type foo = ..
+;;
+
+type foo +=
+    A
+  | B of int
+;;
+
+let is_a x =
+  match x with
+    A -> true
+  | _ -> false
+;;
+
+(* The type must be open to create extension *)
+
+type foo
+;;
+
+type foo += A of int (* Error type is not open *)
+;;
+
+(* The type parameters must match *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+;;
+
+(* In a signature the type does not have to be open *)
+
+module type S =
+sig
+  type foo
+  type foo += A of float
+end
+;;
+
+(* But it must still be extensible *)
+
+module type S =
+sig
+  type foo = A of int
+  type foo += B of float (* Error foo does not have an extensible type *)
+end
+;;
+
+(* Signatures can change the grouping of extensions *)
+
+type foo = ..
+;;
+
+module M = struct
+  type foo +=
+      A of int
+    | B of string
+
+  type foo +=
+      C of int
+    | D of float
+end
+;;
+
+module type S = sig
+  type foo +=
+      B of string
+    | C of int
+
+  type foo += D of float
+
+  type foo += A of int
+end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Extensions can be GADTs *)
+
+type 'a foo = ..
+;;
+
+type _ foo +=
+    A : int -> int foo
+  | B : int foo
+;;
+
+let get_num : type a. a foo -> a -> a option = fun f i1 ->
+    match f with
+        A i2 -> Some (i1 + i2)
+     |  _ -> None
+;;
+
+(* Extensions must obey constraints *)
+
+type 'a foo = .. constraint 'a = [> `Var ]
+;;
+
+type 'a foo += A of 'a
+;;
+
+let a = A 9 (* ERROR: Constraints not met *)
+;;
+
+type 'a foo += B : int foo (* ERROR: Constraints not met *)
+;;
+
+(* Signatures can make an extension private *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A of int end
+;;
+
+let a1 = M.A 10
+;;
+
+module type S = sig type foo += private A of int end
+;;
+
+module M_S = (M : S)
+;;
+
+let is_s x =
+  match x with
+    M_S.A _ -> true
+  | _ -> false
+;;
+
+let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+;;
+
+(* Extensions can be rebound *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A1 of int end
+;;
+
+type foo += A2 = M.A1
+;;
+
+type bar = ..
+;;
+
+type bar += A3 = M.A1    (* Error: rebind wrong type *)
+;;
+
+module M = struct type foo += private B1 of int end
+;;
+
+type foo += private B2 = M.B1
+;;
+
+type foo += B3 = M.B1  (* Error: rebind private extension *)
+;;
+
+type foo += C = Unknown  (* Error: unbound extension *)
+;;
+
+(* Extensions can be rebound even if type is closed *)
+
+module M : sig type foo type foo += A1 of int end
+  = struct type foo = .. type foo += A1 of int end
+
+type M.foo += A2 = M.A1
+
+(* Rebinding handles abbreviations *)
+
+type 'a foo = ..
+;;
+
+type 'a foo1 = 'a foo = ..
+;;
+
+type 'a foo2 = 'a foo = ..
+;;
+
+type 'a foo1 +=
+    A of int
+  | B of 'a
+  | C : int foo1
+;;
+
+type 'a foo2 +=
+    D = A
+  | E = B
+  | F = C
+;;
+
+(* Extensions must obey variances *)
+
+type +'a foo = ..
+;;
+
+type 'a foo += A of (int -> 'a)
+;;
+
+type 'a foo += B of ('a -> int)
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type _ foo += C : ('a -> int) -> 'a foo
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type 'a bar = ..
+;;
+
+type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+;;
+
+(* Exceptions are compatible with extensions *)
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end
+;;
+
+module M : sig
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end = struct
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end
+;;
+
+exception Foo of int * float
+;;
+
+exception Bar : 'a list -> exn
+;;
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar = Bar
+  exception Foo = Foo
+end
+;;
+
+(* Test toplevel printing *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo of int * int option
+  | Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar but not Foo (which has been shadowed) *)
+;;
+
+exception Foo of int * int option
+;;
+
+exception Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar and part of Foo (which has been shadowed) *)
+;;
+
+(* Test Obj functions *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo
+  | Bar of int
+;;
+
+let extension_name e = Obj.extension_name (Obj.extension_constructor e);;
+let extension_id e = Obj.extension_id (Obj.extension_constructor e);;
+
+let n1 = extension_name Foo
+;;
+
+let n2 = extension_name (Bar 1)
+;;
+
+let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *)
+;;
+
+let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *)
+;;
+
+let is_foo x = (extension_id Foo) = (extension_id x)
+
+type foo += Foo
+;;
+
+let f = is_foo Foo
+;;
+
+let _ = Obj.extension_constructor 7 (* Invald_arg *)
+;;
+
+let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *)
+;;
diff --git a/testsuite/tests/typing-extensions/extensions.ml.reference b/testsuite/tests/typing-extensions/extensions.ml.reference
new file mode 100644
index 00000000..ea2cfb8c
--- /dev/null
+++ b/testsuite/tests/typing-extensions/extensions.ml.reference
@@ -0,0 +1,134 @@
+
+#   - : unit = ()
+#     type foo = ..
+#         type foo += A | B of int
+#           val is_a : foo -> bool = 
+#         type foo
+#     Characters 13-21:
+  type foo += A of int (* Error type is not open *)
+              ^^^^^^^^
+Error: Cannot extend type definition foo
+#         type 'a foo = ..
+#     Characters 1-30:
+  type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This extension does not match the definition of type foo
+       They have different arities.
+#                 module type S = sig type foo type foo += A of float end
+#                 Characters 84-106:
+    type foo += B of float (* Error foo does not have an extensible type *)
+    ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type foo is not extensible
+#         type foo = ..
+#                     module M :
+  sig
+    type foo += A of int | B of string
+    type foo += C of int | D of float
+    
+  end
+#                     module type S =
+  sig
+    type foo += B of string | C of int
+    type foo += D of float
+    type foo += A of int
+  end
+#     module M_S : S
+#         type 'a foo = ..
+#         type _ foo += A : int -> int foo | B : int foo
+#           val get_num : 'a foo -> 'a -> 'a option = 
+#         type 'a foo = .. constraint 'a = [> `Var ]
+#     type 'a foo += A of 'a
+#     Characters 11-12:
+  let a = A 9 (* ERROR: Constraints not met *)
+            ^
+Error: This expression has type int but an expression was expected of type
+         [> `Var ]
+#     Characters 20-23:
+  type 'a foo += B : int foo (* ERROR: Constraints not met *)
+                     ^^^
+Error: This type int should be an instance of type [> `Var ]
+#         type foo = ..
+#     module M : sig type foo += A of int end
+#     val a1 : foo = M.A 10
+#     module type S = sig type foo += private A of int end
+#     module M_S : S
+#           val is_s : foo -> bool = 
+#     Characters 10-18:
+  let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+           ^^^^^^^^
+Error: Cannot create values of the private type foo
+#         type foo = ..
+#     module M : sig type foo += A1 of int end
+#     type foo += A2 of int
+#     type bar = ..
+#     Characters 18-22:
+  type bar += A3 = M.A1    (* Error: rebind wrong type *)
+                   ^^^^
+Error: The constructor M.A1 has type foo but was expected to be of type bar
+#     module M : sig type foo += private B1 of int end
+#     type foo += private B2 of int
+#     Characters 18-22:
+  type foo += B3 = M.B1  (* Error: rebind private extension *)
+                   ^^^^
+Error: The constructor M.B1 is private
+#     Characters 17-24:
+  type foo += C = Unknown  (* Error: unbound extension *)
+                  ^^^^^^^
+Error: Unbound constructor Unknown
+#                       module M : sig type foo type foo += A1 of int end
+type M.foo += A2 of int
+type 'a foo = ..
+#     type 'a foo1 = 'a foo = ..
+#     type 'a foo2 = 'a foo = ..
+#           type 'a foo1 += A of int | B of 'a | C : int foo1
+#           type 'a foo2 += D of int | E of 'a | F : int foo2
+#         type +'a foo = ..
+#     type 'a foo += A of (int -> 'a)
+#       Characters 1-32:
+  type 'a foo += B of ('a -> int)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+       The 1st type parameter was expected to be covariant,
+       but it is injective contravariant.
+#       Characters 1-40:
+  type _ foo += C : ('a -> int) -> 'a foo
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+       The 1st type parameter was expected to be covariant,
+       but it is injective contravariant.
+#     type 'a bar = ..
+#     Characters 1-33:
+  type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This extension does not match the definition of type bar
+       Their variances do not agree.
+#                       module M : sig type exn += Foo of int * float | Bar : 'a list -> exn  end
+#                   module M :
+  sig exception Bar : 'a list -> exn exception Foo of int * float end
+#     exception Foo of int * float
+#     exception Bar : 'a list -> exn
+#                   module M : sig type exn += Foo of int * float | Bar : 'a list -> exn  end
+#         type foo = ..
+#         type foo += Foo of int * int option | Bar of int option
+#     val x : foo * foo = (Foo (3, Some 4), Bar (Some 5))
+#     type foo += Foo of string
+#     val y : foo * foo = (, Bar (Some 5))
+#     exception Foo of int * int option
+#     exception Bar of int option
+#     val x : exn * exn = (Foo (3, Some 4), Bar (Some 5))
+#     type foo += Foo of string
+#     val y : exn * exn = (Foo (3, _), Bar (Some 5))
+#         type foo = ..
+#         type foo += Foo | Bar of int
+#   val extension_name : 'a -> string = 
+# val extension_id : 'a -> int = 
+#     val n1 : string = "Foo"
+#     val n2 : string = "Bar"
+#     val t : bool = true
+#     val f : bool = false
+#         val is_foo : 'a -> bool = 
+type foo += Foo
+#     val f : bool = false
+#     Exception: Invalid_argument "Obj.extension_constructor".
+#     Exception: Invalid_argument "Obj.extension_constructor".
+# 
diff --git a/testsuite/tests/typing-extensions/msg.ml b/testsuite/tests/typing-extensions/msg.ml
new file mode 100644
index 00000000..ef1c12fb
--- /dev/null
+++ b/testsuite/tests/typing-extensions/msg.ml
@@ -0,0 +1,131 @@
+(* Typed names *)
+
+module Msg : sig
+
+  type 'a tag
+
+  type result = Result : 'a tag * 'a -> result
+
+  val write : 'a tag -> 'a -> unit
+
+  val read : unit -> result
+
+  type 'a tag += Int : int tag
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) : sig
+    type 'a tag += C : D.t tag
+  end
+
+end = struct
+
+  type 'a tag = ..
+
+  type ktag = T : 'a tag -> ktag
+
+  type 'a kind =
+  { tag : 'a tag;
+    label : string;
+    write : 'a -> string;
+    read : string -> 'a; }
+
+  type rkind = K : 'a kind -> rkind
+
+  type wkind = { f : 'a . 'a tag -> 'a kind }
+
+  let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13
+
+  let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13
+
+  let read_raw () : string * string = raise (Failure "Not implemented")
+
+  type result = Result : 'a tag * 'a -> result
+
+  let read () =
+    let label, content = read_raw () in
+      let K k = Hashtbl.find readTbl label in
+        let body = k.read content in
+          Result(k.tag, body)
+
+  let write_raw (label : string) (content : string) =
+    raise (Failure "Not implemented")
+
+  let write (tag : 'a tag) (body : 'a) =
+    let {f} = Hashtbl.find writeTbl (T tag) in
+    let k = f tag in
+    let content = k.write body in
+      write_raw k.label content
+
+  (* Add int kind *)
+
+  type 'a tag += Int : int tag
+
+  let ik =
+    { tag = Int;
+      label = "int";
+      write = string_of_int;
+      read = int_of_string }
+
+  let () = Hashtbl.add readTbl "int" (K ik)
+
+  let () =
+    let f (type t) (i : t tag) : t kind =
+      match i with
+        Int -> ik
+      | _ -> assert false
+    in
+      Hashtbl.add writeTbl (T Int) {f}
+
+  (* Support user defined kinds *)
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) = struct
+    type 'a tag += C : D.t tag
+    let k =
+      { tag = C;
+        label = D.label;
+        write = D.write;
+        read = D.read }
+    let () = Hashtbl.add readTbl D.label (K k)
+    let () =
+      let f (type t) (c : t tag) : t kind =
+        match c with
+          C -> k
+        | _ -> assert false
+      in
+        Hashtbl.add writeTbl (T C) {f}
+  end
+
+end;;
+
+let write_int i = Msg.write Msg.Int i;;
+
+module StrM = Msg.Define(struct
+  type t = string
+  let label = "string"
+  let read s = s
+  let write s = s
+end);;
+
+type 'a Msg.tag += String = StrM.C;;
+
+let write_string s = Msg.write String s;;
+
+let read_one () =
+  let Msg.Result(tag, body) = Msg.read () in
+  match tag with
+    Msg.Int -> print_int body
+  | String -> print_string body
+  | _ -> print_string "Unknown";;
diff --git a/testsuite/tests/typing-extensions/msg.ml.reference b/testsuite/tests/typing-extensions/msg.ml.reference
new file mode 100644
index 00000000..e7f1a8f2
--- /dev/null
+++ b/testsuite/tests/typing-extensions/msg.ml.reference
@@ -0,0 +1,23 @@
+
+#                                                                                                                                                                                                                             module Msg :
+  sig
+    type 'a tag
+    type result = Result : 'a tag * 'a -> result
+    val write : 'a tag -> 'a -> unit
+    val read : unit -> result
+    type 'a tag += Int : int tag
+    module type Desc =
+      sig
+        type t
+        val label : string
+        val write : t -> string
+        val read : string -> t
+      end
+    module Define : functor (D : Desc) -> sig type 'a tag += C : D.t tag end
+  end
+#   val write_int : int -> unit = 
+#             module StrM : sig type 'a Msg.tag += C : string Msg.tag end
+#   type 'a Msg.tag += String : string Msg.tag
+#   val write_string : string -> unit = 
+#             val read_one : unit -> unit = 
+# 
diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml
new file mode 100644
index 00000000..c439f38a
--- /dev/null
+++ b/testsuite/tests/typing-extensions/open_types.ml
@@ -0,0 +1,125 @@
+type foo = ..
+;;
+
+(* Check that abbreviations work *)
+
+type bar = foo = ..
+;;
+
+type baz = foo = ..
+;;
+
+type bar += Bar1 of int
+;;
+
+type baz += Bar2 of int
+;;
+
+module M = struct type bar += Foo of float end
+;;
+
+module type S = sig type baz += Foo of float end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Abbreviations need to be made open *)
+
+type foo = ..
+;;
+
+type bar = foo
+;;
+
+type bar += Bar of int (* Error: type is not open *)
+;;
+
+type baz = bar = .. (* Error: type kinds don't match *)
+;;
+
+(* Abbreviations need to match parameters *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
+;;
+
+type ('a, 'b) foo = ..
+;;
+
+type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
+;;
+
+(* Private abstract types cannot be open *)
+
+type foo = ..
+;;
+
+type bar = private foo = .. (* ERROR: Private abstract types cannot be open *)
+;;
+
+(* Check that signatures can hide open-ness *)
+
+module M = struct type foo = .. end
+;;
+
+module type S = sig type foo end
+;;
+
+module M_S = (M : S)
+;;
+
+type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
+;;
+
+(* Check that signatures cannot add open-ness *)
+
+module M = struct type foo end
+;;
+
+module type S = sig type foo = .. end
+;;
+
+module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+;;
+
+(* Check that signatures maintain variances *)
+
+module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end
+;;
+
+module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
+;;
+
+module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+;;
+
+(* Exn is an open type *)
+
+type exn2 = exn = ..
+;;
+
+(* Exhaustiveness *)
+
+type foo = ..
+type foo += Foo
+let f = function Foo -> ()
+;; (* warn *)
+
+(* More complex exhaustiveness *)
+
+let f = function
+  | [Foo] -> 1
+  | _::_::_ -> 3
+  | [] -> 2
+;; (* warn *)
+
+
+(* PR#7330: exhaustiveness with GADTs *)
+
+type t = ..
+type t += IPair : (int * int) -> t ;;
+
+let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference
new file mode 100644
index 00000000..a339ac7f
--- /dev/null
+++ b/testsuite/tests/typing-extensions/open_types.ml.reference
@@ -0,0 +1,107 @@
+
+#   type foo = ..
+#         type bar = foo = ..
+#     type baz = foo = ..
+#     type bar += Bar1 of int
+#     type baz += Bar2 of int
+#     module M : sig type bar += Foo of float end
+#     module type S = sig type baz += Foo of float end
+#     module M_S : S
+#         type foo = ..
+#     type bar = foo
+#     Characters 13-23:
+  type bar += Bar of int (* Error: type is not open *)
+              ^^^^^^^^^^
+Error: Cannot extend type definition bar
+#     Characters 1-20:
+  type baz = bar = .. (* Error: type kinds don't match *)
+  ^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type bar
+       Their kinds differ.
+#         type 'a foo = ..
+#     Characters 1-32:
+  type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type 'a foo
+       They have different arities.
+#     type ('a, 'b) foo = ..
+#     Characters 1-38:
+  type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type
+         ('a, 'a) foo
+       Their constraints differ.
+#         type foo = ..
+#     Characters 24-25:
+  type bar = private foo = .. (* ERROR: Private abstract types cannot be open *)
+                         ^
+Error: Syntax error
+#         module M : sig type foo = .. end
+#     module type S = sig type foo end
+#     module M_S : S
+#     Characters 17-20:
+  type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
+                  ^^^
+Error: Cannot extend type definition M_S.foo
+#         module M : sig type foo end
+#     module type S = sig type foo = .. end
+#     Characters 15-16:
+  module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+                ^
+Error: Signature mismatch:
+       Modules do not match: sig type foo = M.foo end is not included in S
+       Type declarations do not match:
+         type foo = M.foo
+       is not included in
+         type foo = ..
+       Their kinds differ.
+#         module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
+#     module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
+#     Characters 15-16:
+  module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+                ^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end
+       is not included in
+         S
+       Type declarations do not match:
+         type 'a foo = 'a M.foo = ..
+       is not included in
+         type 'a foo = ..
+       Their variances do not agree.
+#         type exn2 = exn = ..
+#             Characters 61-79:
+  let f = function Foo -> ()
+          ^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+type foo = ..
+type foo += Foo
+val f : foo -> unit = 
+#               Characters 44-96:
+  ........function
+    | [Foo] -> 1
+    | _::_::_ -> 3
+    | [] -> 2
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*::[]
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : foo list -> int = 
+#           type t = ..
+type t += IPair : (int * int) -> t
+#   Characters 9-63:
+  let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : t -> string = 
+# 
diff --git a/testsuite/tests/typing-fstclassmod/Makefile b/testsuite/tests/typing-fstclassmod/Makefile
new file mode 100644
index 00000000..3f32b3dc
--- /dev/null
+++ b/testsuite/tests/typing-fstclassmod/Makefile
@@ -0,0 +1,22 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=fstclassmod
+ADD_COMPFLAGS=-w A -warn-error A
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/testsuite/tests/typing-fstclassmod/fstclassmod.ml
new file mode 100644
index 00000000..a291a4c7
--- /dev/null
+++ b/testsuite/tests/typing-fstclassmod/fstclassmod.ml
@@ -0,0 +1,167 @@
+(* Example of algorithm parametrized with modules *)
+
+let sort (type s) set l =
+  let module Set = (val set : Set.S with type elt = s) in
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+let make_set (type s) cmp =
+  let module S = Set.Make(struct
+    type t = s
+    let compare = cmp
+  end) in
+  (module S : Set.S with type elt = s)
+
+let both l =
+  List.map
+    (fun set -> sort set l)
+    [ make_set compare; make_set (fun x y -> compare y x) ]
+
+let () =
+  print_endline (String.concat "  " (List.map (String.concat "/")
+                                              (both ["abc";"xyz";"def"])))
+
+
+(* Hiding the internal representation *)
+
+module type S = sig
+  type t
+  val to_string: t -> string
+  val apply: t -> t
+  val x: t
+end
+
+let create (type s) to_string apply x =
+  let module M = struct
+    type t = s
+    let to_string = to_string
+    let apply = apply
+    let x = x
+  end in
+  (module M : S with type t = s)
+
+let forget (type s) x =
+  let module M = (val x : S with type t = s) in
+  (module M : S)
+
+let print x =
+  let module M = (val x : S) in
+  print_endline (M.to_string M.x)
+
+let apply x =
+  let module M = (val x : S) in
+  let module N = struct
+    include M
+    let x = apply x
+  end in
+  (module N : S)
+
+let () =
+  let int = forget (create string_of_int succ 0) in
+  let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in
+  List.iter print (List.map apply [int; apply int; apply (apply str)])
+
+
+(* Existential types + type equality witnesses -> pseudo GADT *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = unit
+  let apply _ = Obj.magic
+  let refl = ()
+  let sym () = ()
+end
+
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = struct
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end
+
+open Typ
+
+let int = Int TypEq.refl
+
+let str = String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  let pair = (module P : PAIR with type t = s1 * s2) in
+  Pair pair
+
+module rec Print : sig
+  val to_string: 'a Typ.typ -> 'a -> string
+end = struct
+  let to_string (type s) t x =
+    match t with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair p ->
+        let module P = (val p : PAIR with type t = s) in
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1)
+                       (Print.to_string P.t2 x2)
+end
+
+let () =
+  print_endline (Print.to_string int 10);
+  print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456)))
+
+
+(* #6262: first-class modules and module type aliases *)
+
+module type S1 = sig end
+module type S2 = S1
+
+let _f (x : (module S1)) : (module S2) = x
+
+module X = struct
+  module type S
+end
+module Y = struct include X end
+
+let _f (x : (module X.S)) : (module Y.S) = x
+
+(* PR#6194, main example *)
+module type S3 = sig val x : bool end;;
+let f = function
+  | Some (module M : S3) when M.x ->1
+  | Some _ -> 2
+  | None -> 3
+;;
+print_endline (string_of_int (f (Some (module struct let x = false end))));;
diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.reference b/testsuite/tests/typing-fstclassmod/fstclassmod.reference
new file mode 100644
index 00000000..ec517d78
--- /dev/null
+++ b/testsuite/tests/typing-fstclassmod/fstclassmod.reference
@@ -0,0 +1,7 @@
+abc/def/xyz  xyz/def/abc
+1
+2
+XXXXXXXX
+10
+(123,("A",456))
+2
diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile
new file mode 100644
index 00000000..0b15e777
--- /dev/null
+++ b/testsuite/tests/typing-gadts/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml
new file mode 100644
index 00000000..cab57d2b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/didier.ml
@@ -0,0 +1,101 @@
+type 'a ty =
+  | Int : int ty
+  | Bool : bool ty
+
+let fbool (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+;;
+[%%expect{|
+type 'a ty = Int : int ty | Bool : bool ty
+Line _, characters 2-30:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Int
+val fbool : 'a -> 'a ty -> 'a = 
+|}];;
+(* val fbool : 'a -> 'a ty -> 'a =  *)
+(** OK: the return value is x of type t **)
+
+let fint (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+;;
+[%%expect{|
+Line _, characters 2-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Bool
+val fint : 'a -> 'a ty -> bool = 
+|}];;
+(* val fint : 'a -> 'a ty -> bool =  *)
+(** OK: the return value is x > 0 of type bool;
+This has used the equation t = bool, not visible in the return type **)
+
+(* not principal *)
+let f (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+  | Bool -> x
+;;
+[%%expect{|
+val f : 'a -> 'a ty -> bool = 
+|}, Principal{|
+Line _, characters 12-13:
+Error: This expression has type t but an expression was expected of type bool
+|}];;
+(* val f : 'a -> 'a ty -> bool =  *)
+
+(* fail for both *)
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+;;
+[%%expect{|
+Line _, characters 11-16:
+Error: This expression has type bool but an expression was expected of type
+         t = int
+|}, Principal{|
+Line _, characters 11-16:
+Error: This expression has type bool but an expression was expected of type t
+|}];;
+(* Error: This expression has type bool but an expression was expected of type
+t = int *)
+
+(* OK *)
+let g (type t) (x : t) (tag : t ty) : bool =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+;;
+[%%expect{|
+val g : 'a -> 'a ty -> bool = 
+|}];;
+
+let id x = x;;
+let idb1 = (fun id -> let _ = id true in id) id;;
+let idb2 : bool -> bool = id;;
+let idb3 ( _ : bool ) = false;;
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb3 x
+  | Int -> x > 0
+;;
+[%%expect{|
+val id : 'a -> 'a = 
+val idb1 : bool -> bool = 
+val idb2 : bool -> bool = 
+val idb3 : bool -> bool = 
+val g : 'a -> 'a ty -> bool = 
+|}];;
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb2 x
+  | Int -> x > 0
+;;
+[%%expect{|
+val g : 'a -> 'a ty -> bool = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml b/testsuite/tests/typing-gadts/dynamic_frisch.ml
new file mode 100644
index 00000000..112c161b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml
@@ -0,0 +1,709 @@
+(* Encoding generics using GADTs *)
+(* (c) Alain Frisch / Lexifi *)
+(* cf. http://www.lexifi.com/blog/dynamic-types *)
+
+(* Basic tag *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+;;
+
+(* Tagging data *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+;;
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = 
+|}];;
+
+exception VariantMismatch
+;;
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | _ -> raise VariantMismatch
+;;
+[%%expect{|
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = 
+|}];;
+
+(* Handling records *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: 'a record -> 'a ty
+
+and 'a record =
+    {
+     path: string;
+     fields: 'a field_ list;
+    }
+
+and 'a field_ =
+  | Field: ('a, 'b) field -> 'a field_
+
+and ('a, 'b) field =
+    {
+     label: string;
+     field_type: 'b ty;
+     get: ('a -> 'b);
+    }
+;;
+
+(* Again *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+;;
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+    | Record {fields} ->
+        VRecord
+          (List.map (fun (Field{field_type; label; get}) ->
+                       (label, variantize field_type (get x))) fields)
+;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = 
+|}];;
+
+(* Extraction *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: ('a, 'builder) record -> 'a ty
+
+and ('a, 'builder) record =
+    {
+     path: string;
+     fields: ('a, 'builder) field list;
+     create_builder: (unit -> 'builder);
+     of_builder: ('builder -> 'a);
+    }
+
+and ('a, 'builder) field =
+  | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+
+and ('a, 'builder, 'b) field_ =
+  {
+   label: string;
+   field_type: 'b ty;
+   get: ('a -> 'b);
+   set: ('builder -> 'b -> unit);
+  }
+;;
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | Record {fields; create_builder; of_builder}, VRecord fl ->
+        if List.length fields <> List.length fl then raise VariantMismatch;
+        let builder = create_builder () in
+        List.iter2
+          (fun (Field {label; field_type; set}) (lab, v) ->
+            if label <> lab then raise VariantMismatch;
+            set builder (devariantize field_type v)
+          )
+          fields fl;
+        of_builder builder
+    | _ -> raise VariantMismatch
+;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = 
+|}];;
+
+type my_record  =
+    {
+     a: int;
+     b: string list;
+    }
+;;
+
+let my_record =
+  let fields =
+    [
+     Field {label = "a"; field_type = Int;
+            get = (fun {a} -> a);
+            set = (fun (r, _) x -> r := Some x)};
+     Field {label = "b"; field_type = List String;
+            get = (fun {b} -> b);
+            set = (fun (_, r) x -> r := Some x)};
+    ]
+  in
+  let create_builder () = (ref None, ref None) in
+  let of_builder (a, b) =
+    match !a, !b with
+    | Some a, Some b -> {a; b}
+    | _ -> failwith "Some fields are missing in record of type my_record"
+  in
+  Record {path = "My_module.my_record"; fields; create_builder; of_builder}
+;;
+[%%expect{|
+type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = ; set = };
+      Field {label = "b"; field_type = List String; get = ; set = }];
+    create_builder = ; of_builder = }
+|}];;
+
+(* Extension to recursive types and polymorphic variants *)
+(* by Jacques Garrigue *)
+
+type noarg = Noarg
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  (* Support for type variables and recursive types *)
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  (* Change the representation of a type *)
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  (* Sum types (both normal sums and polymorphic variants) *)
+  | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+
+and ('a, 'e, 'b) ty_sum =
+    { sum_proj: 'a -> string * 'e ty_dyn option;
+      sum_cases: (string * ('e,'b) ty_case) list;
+      sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; }
+
+and 'e ty_dyn =              (* dynamic type *)
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =           (* selector from a list of types *)
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =          (* type a sum case *)
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+type _ ty_env =              (* type variable substitution *)
+  | Enil : unit ty_env
+  | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+;;
+
+(* Comparing selectors *)
+type (_,_) eq = Eq: ('a,'a) eq
+;;
+
+let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
+  fun s1 s2 ->
+    match s1, s2 with
+    | Thd, Thd -> Some Eq
+    | Ttl s1, Ttl s2 ->
+        (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
+    | _ -> None
+;;
+[%%expect{|
+type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = 
+|}];;
+
+(* Auxiliary function to get the type of a case from its selector *)
+let rec get_case : type a b e.
+  (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option =
+  fun sel cases ->
+  match cases with
+  | (name, TCnoarg sel') :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, None
+      end
+  | (name, TCarg (sel', ty)) :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, Some ty
+      end
+  | [] -> raise Not_found
+;;
+[%%expect{|
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = 
+|}];;
+
+(* Untyped representation of values *)
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+;;
+
+let may_map f = function Some x -> Some (f x) | None -> None ;;
+
+let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
+  fun e ty v ->
+  match ty with
+  | Int -> VInt v
+  | String -> VString v
+  | List t -> VList (List.map (variantize e t) v)
+  | Option t -> VOption (may_map (variantize e t) v)
+  | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v))
+  | Rec t -> variantize (Econs (ty, e)) t v
+  | Pop t -> (match e with Econs (_, e') -> variantize e' t v)
+  | Var -> (match e with Econs (t, e') -> variantize e' t v)
+  | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v))
+  | Sum ops ->
+      let tag, arg = ops.sum_proj v in
+      VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
+;;
+[%%expect{|
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = 
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = 
+|}];;
+
+let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
+  fun e ty v ->
+  match ty, v with
+  | Int, VInt x -> x
+  | String, VString x -> x
+  | List ty1, VList vl ->
+      List.map (devariantize e ty1) vl
+  | Pair (ty1, ty2), VPair (x1, x2) ->
+      (devariantize e ty1 x1, devariantize e ty2 x2)
+  | Rec t, _ -> devariantize (Econs (ty, e)) t v
+  | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v)
+  | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v)
+  | Conv (s, proj, inj, t), VConv (s', v) when s = s' ->
+      inj (devariantize e t v)
+  | Sum ops, VSum (tag, a) ->
+      begin try match List.assoc tag ops.sum_cases, a with
+      | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a)
+      | TCnoarg sel, None -> ops.sum_inj (sel, Noarg)
+      | _ -> raise VariantMismatch
+      with Not_found -> raise VariantMismatch
+      end
+  | _ -> raise VariantMismatch
+;;
+[%%expect{|
+val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = 
+|}];;
+
+(* First attempt: represent 1-constructor variants using Conv *)
+let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+[%%expect{|
+val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = 
+|}];;
+
+let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+[%%expect{|
+val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  
+|}];;
+let v = variantize Enil (ty Int);;
+[%%expect{|
+val v : ([ `A of (int * 'a) option ] as 'a) -> variant = 
+|}];;
+let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+[%%expect{|
+val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+|}];;
+
+(* Can also use it to decompose a tuple *)
+
+let triple t1 t2 t3 =
+  Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)));;
+[%%expect{|
+val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = 
+|}];;
+
+let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+[%%expect{|
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+|}];;
+
+(* Second attempt: introduce a real sum construct *)
+let ty_abc =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  let proj = function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None
+  (* Define inj in advance to be able to write the type annotation easily *)
+  and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c ->
+    [`A of int | `B of string | `C] = function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  in
+  (* Coherence of sum_inj and sum_cases is checked by the typing *)
+  Sum { sum_proj = proj; sum_inj = inj; sum_cases =
+        [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+          "C", TCnoarg (Ttl (Ttl Thd)) ] }
+;;
+[%%expect{|
+val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = ;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = }
+|}];;
+
+let v = variantize Enil ty_abc (`A 3);;
+[%%expect{|
+val v : variant = VSum ("A", Some (VInt 3))
+|}];;
+let a = devariantize Enil ty_abc v;;
+[%%expect{|
+val a : [ `A of int | `B of string | `C ] = `A 3
+|}];;
+
+(* And an example with recursion... *)
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+;;
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum {
+       sum_proj = (function
+           `Nil -> "Nil", None
+         | `Cons p -> "Cons", Some (Tdyn (tcons, p)));
+       sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)];
+       sum_inj = fun (type c) ->
+         (function
+         | Thd, Noarg -> `Nil
+         | Ttl Thd, v -> `Cons v
+         : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
+         (* One can also write the type annotation directly *)
+     })
+;;
+[%%expect{|
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+|}];;
+
+let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
+[%%expect{|
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+|}];;
+
+(* Simpler but weaker approach *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a)
+             -> ('a, 'e) ty
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+;;
+
+let ty_abc : ([`A of int | `B of string | `C],'e) ty =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  Sum (
+  (function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None),
+  (function
+      "A", Some (Tdyn (Int, n)) -> `A n
+    | "B", Some (Tdyn (String, s)) -> `B s
+    | "C", None -> `C
+    | _ -> invalid_arg "ty_abc"))
+;;
+[%%expect{|
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
+|}];;
+
+(* Breaks: no way to pattern-match on a full recursive type *)
+let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
+  let targ = Pair (Pop t, Var) in
+  Rec (Sum (
+  (function `Nil -> "Nil", None
+    | `Cons p -> "Cons", Some (Tdyn (targ, p))),
+  (function "Nil", None -> `Nil
+    | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+;;
+[%%expect{|
+Line _, characters 41-58:
+Error: This pattern matches values of type a * a vlist
+       but a pattern was expected which matches values of type
+         $Tdyn_'a = $0 * $1
+       Type a is not compatible with type $0
+|}];;
+
+(* Define Sum using object instead of record for first-class polymorphism *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: < proj: 'a -> string * 'e ty_dyn option;
+           cases: (string * ('e,'b) ty_case) list;
+           inj: 'c. ('b,'c) ty_sel * 'c -> 'a >
+          -> ('a, 'e) ty
+
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
+  Sum (object
+    method proj = function
+        `A n -> "A", Some (Tdyn (Int, n))
+      | `B s -> "B", Some (Tdyn (String, s))
+      | `C -> "C", None
+    method cases =
+      [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+        "C", TCnoarg (Ttl (Ttl Thd)) ];
+    method inj : type c.
+        (int -> string -> noarg -> unit, c) ty_sel * c ->
+          [`A of int | `B of string | `C] =
+      function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  end)
+;;
+[%%expect{|
+type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum 
+|}];;
+
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+;;
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum (object
+    method proj = function
+        `Nil -> "Nil", None
+      | `Cons p -> "Cons", Some (Tdyn (tcons, p))
+    method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]
+    method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist
+    = function
+      | Thd, Noarg -> `Nil
+      | Ttl Thd, v -> `Cons v
+  end))
+;;
+[%%expect{|
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+|}];;
+
+(*
+type (_,_) ty_assoc =
+  | Anil : (unit,'e) ty_assoc
+  | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc
+
+and (_,_) ty_pvar =
+  | Pnil : ('a,'e) ty_pvar
+  | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar
+  | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar
+*)
diff --git a/testsuite/tests/typing-gadts/nested_equations.ml b/testsuite/tests/typing-gadts/nested_equations.ml
new file mode 100644
index 00000000..4039e358
--- /dev/null
+++ b/testsuite/tests/typing-gadts/nested_equations.ml
@@ -0,0 +1,84 @@
+(* Tests for nested equations (bind abstract types from other modules) *)
+
+type _ t = Int : int t;;
+
+let to_int (type a) (w : a t) (x : a) : int = let Int = w in x;;
+[%%expect{|
+type _ t = Int : int t
+val to_int : 'a t -> 'a -> int = 
+|}];;
+
+let w_bool : bool t = Obj.magic 0;;
+let f_bool (x : bool) : int = let Int = w_bool in x;; (* fail *)
+[%%expect{|
+val w_bool : bool t = Int
+Line _, characters 34-37:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type bool t
+       Type int is not compatible with type bool
+|}];;
+
+let w_buffer : Buffer.t t = Obj.magic 0;;
+let f_buffer (x : Buffer.t) : int = let Int = w_buffer in x;; (* ok *)
+[%%expect{|
+val w_buffer : Buffer.t t = Int
+val f_buffer : Buffer.t -> int = 
+|}];;
+
+let w_spec : Arg.spec t = Obj.magic 0;;
+let f_spec (x : Arg.spec) : int = let Int = w_spec in x;; (* fail *)
+[%%expect{|
+val w_spec : Arg.spec t = Int
+Line _, characters 38-41:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type Arg.spec t
+       Type int is not compatible with type Arg.spec
+|}];;
+
+module M : sig type u val w : u t val x : u end =
+  struct type u = int let w = Int let x = 33 end;;
+let m_x : int = let Int = M.w in M.x;;
+[%%expect{|
+module M : sig type u val w : u t val x : u end
+val m_x : int = 33
+|}];;
+
+module F (X : sig type u = int val x : u end) = struct let x : int = X.x end;;
+let fm_x : int = let Int = M.w in let module FM = F(M) in FM.x;; (* ok *)
+[%%expect{|
+module F :
+  functor (X : sig type u = int val x : u end) -> sig val x : int end
+val fm_x : int = 33
+|}];;
+
+module M' = struct module M : sig type u val w : u t val x : u end = M end;;
+module F' (X : sig module M : sig type u = int val x : u end end) =
+  struct let x : int = X.M.x end;;
+let fm'_x : int =
+  let Int = M'.M.w in let module FM' = F'(M') in FM'.x;; (* ok *)
+[%%expect{|
+module M' : sig module M : sig type u val w : u t val x : u end end
+module F' :
+  functor (X : sig module M : sig type u = int val x : u end end) ->
+    sig val x : int end
+val fm'_x : int = 33
+|}];;
+
+(* PR#7233 *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+module type S = sig
+  type t
+  val eql : (t, int) eq
+end
+
+module F (M : S) = struct
+  let zero : M.t =
+    let Refl = M.eql in 0
+end;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+module type S = sig type t val eql : (t, int) eq end
+module F : functor (M : S) -> sig val zero : M.t end
+|}];;
diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
new file mode 100644
index 00000000..6c729abe
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -0,0 +1,1213 @@
+(*
+   An attempt at encoding omega examples from the 2nd Central European
+   Functional Programming School:
+     Generic Programming in Omega, by Tim Sheard and Nathan Linger
+          http://web.cecs.pdx.edu/~sheard/
+*)
+
+(* Basic types *)
+
+type ('a,'b) sum = Inl of 'a | Inr of 'b
+
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+;;
+
+(* 2: A simple example *)
+
+type (_,_) seq =
+  | Snil  : ('a,zero) seq
+  | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq
+;;
+
+let l1 = Scons (3, Scons (5, Snil)) ;;
+[%%expect{|
+type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+|}];;
+
+(* We do not have type level functions, so we need to use witnesses. *)
+(* We copy here the definitions from section 3.9 *)
+(* Note the addition of the ['a nat] argument to PlusZ, since we do not
+   have kinds *)
+type (_,_,_) plus =
+  | PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus
+;;
+
+let rec length : type a n. (a,n) seq -> n nat = function
+  | Snil -> NZ
+  | Scons (_, s) -> NS (length s)
+;;
+[%%expect{|
+type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+val length : ('a, 'n) seq -> 'n nat = 
+|}];;
+
+(* app returns the catenated lists with a witness proving that
+   the size is the sum of its two inputs *)
+type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app
+
+let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
+  fun xs ys ->
+  match xs with
+  | Snil -> App (ys, PlusZ (length ys))
+  | Scons (x, xs') ->
+      let App (xs'', pl) = app xs' ys in
+      App (Scons (x, xs''), PlusS pl)
+;;
+[%%expect{|
+type (_, _, _) app =
+    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
+val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = 
+|}];;
+
+(* 3.1 Feature: kinds *)
+
+(* We do not have kinds, but we can encode them as predicates *)
+
+type tp = TP
+type nd = ND
+type ('a,'b) fk = FK
+type _ shape =
+  | Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
+;;
+type tt = TT
+type ff = FF
+type _ boolean =
+  | BT : tt boolean
+  | BF : ff boolean
+;;
+
+(* 3.3 Feature : GADTs *)
+
+type (_,_) path =
+  | Pnone : 'a -> (tp,'a) path
+  | Phere : (nd,'a) path
+  | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path
+  | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path
+;;
+type (_,_) tree =
+  | Ttip  : (tp,'a) tree
+  | Tnode : 'a -> (nd,'a) tree
+  | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree
+;;
+let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+;;
+[%%expect{|
+type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
+type _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+type tt = TT
+type ff = FF
+type _ boolean = BT : tt boolean | BF : ff boolean
+type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+|}];;
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
+  = fun eq n t ->
+    match t with
+    | Ttip -> []
+    | Tnode m ->
+        if eq n m then [Phere] else []
+    | Tfork (x, y) ->
+        List.map (fun x -> Pleft x) (find eq n x) @
+        List.map (fun x -> Pright x) (find eq n y)
+;;
+[%%expect{|
+val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  
+|}];;
+let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
+  match (p, t) with
+  | Pnone x, Ttip -> x
+  | Phere, Tnode y -> y
+  | Pleft p, Tfork(l,_) -> extract p l
+  | Pright p, Tfork(_,r) -> extract p r
+;;
+[%%expect{|
+val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = 
+|}];;
+
+(* 3.4 Pattern : Witness *)
+
+type (_,_) le =
+  | LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+;;
+type _ even =
+  | EvenZ : zero even
+  | EvenSS : 'n even -> 'n succ succ even
+;;
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+;;
+let even0 : zero even = EvenZ
+let even2 : two even = EvenSS EvenZ
+let even4 : four even = EvenSS (EvenSS EvenZ)
+;;
+let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+;;
+[%%expect{|
+type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+|}];;
+let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
+  match p with
+  | PlusZ n -> LeZ n
+  | PlusS p' -> LeS (summandLessThanSum p')
+;;
+[%%expect{|
+val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = 
+|}];;
+
+(* 3.8 Pattern: Leibniz Equality *)
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+[%%expect{|
+type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = 
+|}];;
+
+let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
+  match a, b with
+  | NZ, NZ -> Some Eq
+  | NS a', NS b' ->
+      begin match sameNat a' b' with
+      | Some Eq -> Some Eq
+      | None -> None
+      end
+  | _ -> None
+;;
+[%%expect{|
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
+|}];;
+
+(* Extra: associativity of addition *)
+
+let rec plus_func : type a b m n.
+  (a,b,m) plus -> (a,b,n) plus -> (m,n) equal =
+  fun p1 p2 ->
+  match p1, p2 with
+  | PlusZ _, PlusZ _ -> Eq
+  | PlusS p1', PlusS p2' ->
+      let Eq = plus_func p1' p2' in Eq
+;;
+[%%expect{|
+val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+  
+|}];;
+
+let rec plus_assoc : type a b c ab bc m n.
+  (a,b,ab) plus -> (ab,c,m) plus ->
+  (b,c,bc) plus -> (a,bc,n) plus -> (m,n) equal = fun p1 p2 p3 p4 ->
+  match p1, p4 with
+  | PlusZ b, PlusZ bc ->
+      let Eq = plus_func p2 p3 in Eq
+  | PlusS p1', PlusS p4' ->
+      let PlusS p2' = p2 in
+      let Eq = plus_assoc p1' p2' p3 p4' in Eq
+;;
+[%%expect{|
+val plus_assoc :
+  ('a, 'b, 'ab) plus ->
+  ('ab, 'c, 'm) plus ->
+  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = 
+|}];;
+
+(* 3.9 Computing Programs and Properties Simultaneously *)
+
+(* Plus and app1 are moved to section 2 *)
+
+let smaller : type a b. (a succ, b succ) le -> (a,b) le =
+  function LeS x -> x ;;
+[%%expect{|
+val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = 
+|}];;
+
+type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
+
+(*
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b, le with
+  | NZ, m, _ -> Diff (m, PlusZ m)
+  | NS x, NZ, _ -> assert false
+  | NS x, NS y, q ->
+      match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+*)
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match le, a, b with
+  | LeZ _, _, m -> Diff (m, PlusZ m)
+  | LeS q, NS x, NS y ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+[%%expect{|
+type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
+|}];;
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b,le with (* warning *)
+  | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+  | NS x, NS y, LeS q ->
+      (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
+  | _ -> .
+;;
+[%%expect{|
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
+|}];;
+
+let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
+  fun le b ->
+  match b,le with
+  | m, LeZ _ -> Diff (m, PlusZ m)
+  | NS y, LeS q ->
+      match diff q y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+[%%expect{|
+val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = 
+|}];;
+
+type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
+
+let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
+  | LeZ n -> LeZ (NS n)
+  | LeS le -> LeS (leS' le)
+;;
+[%%expect{|
+type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = 
+|}];;
+
+let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
+  fun f s ->
+  match s with
+  | Snil -> Filter (LeZ NZ, Snil)
+  | Scons (a,l) ->
+      match filter f l with Filter (le, l') ->
+        if f a then Filter (LeS le, Scons (a, l'))
+        else Filter (leS' le, l')
+;;
+[%%expect{|
+val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = 
+|}];;
+
+(* 4.1 AVL trees *)
+
+type (_,_,_) balance =
+  | Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+
+type _ avl =
+  | Leaf : zero avl
+  | Node :
+      ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl
+
+type avl' = Avl : 'h avl -> avl'
+;;
+
+let empty = Avl Leaf;;
+[%%expect{|
+type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+val empty : avl' = Avl Leaf
+|}];;
+
+let rec elem : type h. int -> h avl -> bool = fun x t ->
+  match t with
+  | Leaf -> false
+  | Node (_, l, y, r) ->
+      x = y || if x < y then elem x l else elem x r
+;;
+[%%expect{|
+val elem : int -> 'h avl -> bool = 
+|}];;
+
+let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL y tR ->
+  match tL with
+  | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR)))
+  | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR)))
+  | Node (Less, a, x, Node (Same, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (Less, b, z, c)) ->
+      Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (More, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
+;;
+[%%expect{|
+val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = 
+|}];;
+let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL u tR ->
+  match tR with
+  | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b))
+  | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b))
+  | Node (More, Node (Same, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (Less, a, x, b), y, c) ->
+      Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (More, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
+;;
+[%%expect{|
+val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  
+|}];;
+let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
+  fun x t ->
+  match t with
+  | Leaf -> Inr (Node (Same, Leaf, x, Leaf))
+  | Node (bal, a, y, b) ->
+      if x = y then Inl t else
+      if x < y then begin
+        match ins x a with
+        | Inl a -> Inl (Node (bal, a, y, b))
+        | Inr a ->
+            match bal with
+            | Less -> Inl (Node (Same, a, y, b))
+            | Same -> Inr (Node (More, a, y, b))
+            | More -> rotr a y b
+      end else begin
+        match ins x b with
+        | Inl b -> Inl (Node (bal, a, y, b) : n avl)
+        | Inr b ->
+            match bal with
+            | More -> Inl (Node (Same, a, y, b) : n avl)
+            | Same -> Inr (Node (Less, a, y, b) : n succ avl)
+            | Less -> rotl a y b
+      end
+;;
+[%%expect{|
+val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = 
+|}];;
+
+let insert x (Avl t) =
+  match ins x t with
+  | Inl t -> Avl t
+  | Inr t -> Avl t
+;;
+[%%expect{|
+val insert : int -> avl' -> avl' = 
+|}];;
+
+let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
+  function
+  | Node (Less, Leaf, x, r) -> (x, Inl r)
+  | Node (Same, Leaf, x, r) -> (x, Inl r)
+  | Node (bal, (Node _ as l) , x, r) ->
+      match del_min l with
+      | y, Inr l -> (y, Inr (Node (bal, l, x, r)))
+      | y, Inl l ->
+          (y, match bal with
+          | Same -> Inr (Node (Less, l, x, r))
+          | More -> Inl (Node (Same, l, x, r))
+          | Less -> rotl l x r)
+;;
+[%%expect{|
+val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = 
+|}];;
+
+type _ avl_del =
+  | Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+
+let rec del : type n. int -> n avl -> n avl_del = fun y t ->
+  match t with
+  | Leaf -> Dsame Leaf
+  | Node (bal, l, x, r) ->
+      if x = y then begin
+        match r with
+        | Leaf ->
+            begin match bal with
+            | Same -> Ddecr (Eq, l)
+            | More -> Ddecr (Eq, l)
+            end
+        | Node _ ->
+            begin match bal, del_min r with
+            | _, (z, Inr r) -> Dsame (Node (bal, l, z, r))
+            | Same, (z, Inl r) -> Dsame (Node (More, l, z, r))
+            | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r))
+            | More, (z, Inl r) ->
+                match rotr l z r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else if y < x then begin
+        match del y l with
+        | Dsame l -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,l) ->
+            begin match bal with
+            | Same -> Dsame (Node (Less, l, x, r))
+            | More -> Ddecr (Eq, Node (Same, l, x, r))
+            | Less ->
+                match rotl l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else begin
+        match del y r with
+        | Dsame r -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,r) ->
+            begin match bal with
+            | Same -> Dsame (Node (More, l, x, r))
+            | Less -> Ddecr (Eq, Node (Same, l, x, r))
+            | More ->
+                match rotr l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end
+;;
+[%%expect{|
+type _ avl_del =
+    Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+val del : int -> 'n avl -> 'n avl_del = 
+|}];;
+
+let delete x (Avl t) =
+  match del x t with
+  | Dsame t -> Avl t
+  | Ddecr (_, t) -> Avl t
+;;
+[%%expect{|
+val delete : int -> avl' -> avl' = 
+|}];;
+
+
+(* Exercise 22: Red-black trees *)
+
+type red = RED
+type black = BLACK
+type (_,_) sub_tree =
+  | Bleaf : (black, zero) sub_tree
+  | Rnode :
+      (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode :
+      ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+;;
+
+type dir = LeftD | RightD
+
+type (_,_) ctxt =
+  | CNil : (black,'n) ctxt
+  | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt
+  | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt
+;;
+
+let blacken = function
+    Rnode (l, e, r) -> Bnode (l, e, r)
+;;
+[%%expect{|
+type red = RED
+type black = BLACK
+type (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = 
+|}];;
+
+type _ crep =
+  | Red : red crep
+  | Black : black crep
+
+let color : type c n. (c,n) sub_tree -> c crep = function
+  | Bleaf -> Black
+  | Rnode _ -> Red
+  | Bnode _ -> Black
+;;
+[%%expect{|
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = 
+|}];;
+
+let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
+  fun ct t ->
+  match ct with
+  | CNil -> Root t
+  | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t))
+  | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle))
+  | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
+  | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
+;;
+[%%expect{|
+val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = 
+|}];;
+let recolor d1 pE sib d2 gE uncle t =
+  match d1, d2 with
+  | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
+  | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle)
+  | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
+  | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
+;;
+[%%expect{|
+val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  
+|}];;
+let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
+  match d1, d2 with
+  | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
+  | LeftD,  RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle))
+  | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
+  | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
+;;
+[%%expect{|
+val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  
+|}];;
+let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun t ct ->
+  match ct with
+  | CNil -> Root (blacken t)
+  | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t))
+  | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib))
+  | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) ->
+      match color uncle with
+      | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
+      | Black -> fill ct (rotate dir e sib dir' e' uncle t)
+;;
+[%%expect{|
+val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+|}];;
+let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun e t ct ->
+  match t with
+  | Rnode (l, e', r) ->
+      if e < e' then ins e l (CRed (e', RightD, r, ct))
+                else ins e r (CRed (e', LeftD, l, ct))
+  | Bnode (l, e', r) ->
+      if e < e' then ins e l (CBlk (e', RightD, r, ct))
+                else ins e r (CBlk (e', LeftD, l, ct))
+  | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
+;;
+[%%expect{|
+val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+|}];;
+let insert e (Root t) = ins e t CNil
+;;
+[%%expect{|
+val insert : int -> rb_tree -> rb_tree = 
+|}];;
+
+(* 5.7 typed object languages using GADTs *)
+
+type _ term =
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let ex1 = Ap (Add, Pair (Const 3, Const 5))
+let ex2 = Pair (ex1, Const 1)
+;;
+[%%expect{|
+type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+|}];;
+
+let rec eval_term : type a. a term -> a = function
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x eval_term f (eval_term x)
+  | Pair(x,y) -> (eval_term x, eval_term y)
+;;
+[%%expect{|
+val eval_term : 'a term -> 'a = 
+|}];;
+
+type _ rep =
+  | Rint  : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun  : 'a rep * 'b rep -> ('a -> 'b) rep
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
+  fun ra rb ->
+  match ra, rb with
+  | Rint, Rint -> Some Eq
+  | Rbool, Rbool -> Some Eq
+  | Rpair (a1, a2), Rpair (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | Rfun (a1, a2), Rfun (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | _ -> None
+;;
+[%%expect{|
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = 
+|}];;
+
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+
+let rec assoc : type a. string -> a rep -> assoc list -> a =
+  fun x r -> function
+  | [] -> raise Not_found
+  | Assoc (x', r', v) :: env ->
+      if x = x' then
+        match rep_equal r r' with
+        | None -> failwith ("Wrong type for " ^ x)
+        | Some Eq -> v
+      else assoc x r env
+;;
+[%%expect{|
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = 
+|}];;
+
+type _ term =
+  | Var   : string * 'a rep -> 'a term
+  | Abs   : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let rec eval_term : type a. assoc list -> a term -> a =
+  fun env -> function
+  | Var (x, r) -> assoc x r env
+  | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x eval_term env f (eval_term env x)
+  | Pair(x,y) -> (eval_term env x, eval_term env y)
+;;
+[%%expect{|
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = 
+|}];;
+
+let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
+let ex4 = Ap (ex3, Const 3)
+
+let v4 = eval_term [] ex4
+;;
+[%%expect{|
+val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+val ex4 : int term =
+  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
+   Const 3)
+val v4 : int = 6
+|}];;
+
+(* 5.9/5.10 Language with binding *)
+
+type rnil = RNIL
+type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
+
+type _ is_row =
+  | Rnil  : rnil is_row
+  | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row
+
+type (_,_) lam =
+  | Const : int -> ('e, int) lam
+  | Var : 'a -> (('a,'t,'e) rcons, 't) lam
+  | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam
+  | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+
+type x = X
+type y = Y
+
+let ex1 = App (Var X, Shift (Var Y))
+let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
+;;
+[%%expect{|
+type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
+type _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (, Abs (, App (Shift (Var ), Var )))
+|}];;
+
+type _ env =
+  | Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+
+let rec eval_lam : type e t. e env -> (e, t) lam -> t =
+  fun env m ->
+  match env, m with
+  | _, Const n -> n
+  | Econs (_, v, r), Var _ -> v
+  | Econs (_, _, r), Shift e -> eval_lam r e
+  | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
+  | _, App (f, x)    -> eval_lam env f (eval_lam env x)
+;;
+[%%expect{|
+type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = 
+|}];;
+
+type add = Add
+type suc = Suc
+
+let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil)))
+
+let _0 : (_, int) lam = Var Zero
+let suc x = App (Shift (Var Suc : (_, int -> int) lam), x)
+let _1 = suc _0
+let _2 = suc _1
+let _3 = suc _2
+let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
+
+let double = Abs (X, App (App (Shift add, Var X), Var X))
+let ex3 = App (double, _3)
+;;
+[%%expect{|
+type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = 
+val _1 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc), Var Zero)
+val _2 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (,
+   App (App (Shift (Shift (Shift (Var Add))), Var ), Var ))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+|}];;
+
+let v3 = eval_lam env0 ex3
+;;
+[%%expect{|
+val v3 : int = 6
+|}];;
+
+(* 5.13: Constructing typing derivations at runtime *)
+
+(* Modified slightly to use the language of 5.10, since this is more fun.
+   Of course this works also with the language of 5.12. *)
+
+type _ rep =
+  | I : int rep
+  | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+
+let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
+  fun a b ->
+  match a, b with
+  | I, I -> Inr Eq
+  | Ar(x,y), Ar(s,t) ->
+      begin match compare x s with
+      | Inl _ as e -> e
+      | Inr Eq -> match compare y t with
+        | Inl _ as e -> e
+        | Inr Eq as e -> e
+      end
+  | I, Ar _ -> Inl "I <> Ar _"
+  | Ar _, I -> Inl "Ar _ <> I"
+;;
+[%%expect{|
+type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = 
+|}];;
+
+type term =
+  | C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+
+type _ ctx =
+  | Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx
+;;
+
+type _ checked =
+  | Cerror of string
+  | Cok : ('e,'t) lam * 't rep -> 'e checked
+
+let rec lookup : type e. string -> e ctx -> e checked =
+  fun name ctx ->
+  match ctx with
+  | Cnil -> Cerror ("Name not found: " ^ name)
+  | Ccons (l,s,t,rs) ->
+      if s = name then Cok (Var l,t) else
+      match lookup name rs with
+      | Cerror m -> Cerror m
+      | Cok (v, t) -> Cok (Shift v, t)
+;;
+[%%expect{|
+type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = 
+|}];;
+
+let rec tc : type n e. n nat -> e ctx -> term -> e checked =
+  fun n ctx t ->
+  match t with
+  | V s -> lookup s ctx
+  | Ap(f,x) ->
+      begin match tc n ctx f with
+      | Cerror _ as e -> e
+      | Cok (f', ft) -> match tc n ctx x with
+        | Cerror _ as e -> e
+        | Cok (x', xt) ->
+            match ft with
+            | Ar (a, b) ->
+                begin match compare a xt with
+                | Inl s -> Cerror s
+                | Inr Eq -> Cok (App (f',x'), b)
+                end
+            | _ -> Cerror "Non fun in Ap"
+      end
+  | Ab(s,t,body) ->
+      begin match tc (NS n) (Ccons (n, s, t, ctx)) body with
+      | Cerror _ as e -> e
+      | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))
+      end
+  | C m -> Cok (Const m, I)
+;;
+[%%expect{|
+val tc : 'n nat -> 'e ctx -> term -> 'e checked = 
+|}];;
+
+let ctx0 =
+  Ccons (Zero, "0", I,
+         Ccons (Suc, "S", Ar(I,I),
+                Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil)))
+
+let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
+let c1 = tc NZ ctx0 ex1;;
+let ex2 = Ap (ex1, C 3);;
+let c2 = tc NZ ctx0 ex2;;
+[%%expect{|
+val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   Ar (I, I))
+val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (,
+       App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+     Const 3),
+   I)
+|}];;
+
+let eval_checked env = function
+  | Cerror s -> failwith s
+  | Cok (e, I) -> (eval_lam env e : int)
+  | Cok _ -> failwith "Can only evaluate expressions of type I"
+;;
+[%%expect{|
+val eval_checked : 'a env -> 'a checked -> int = 
+|}];;
+
+let v2 = eval_checked env0 c2 ;;
+[%%expect{|
+val v2 : int = 6
+|}];;
+
+(* 5.12 Soundness *)
+
+type pexp = PEXP
+type pval = PVAL
+type _ mode =
+  | Pexp : pexp mode
+  | Pval : pval mode
+
+type ('a,'b) tarr = TARR
+type tint = TINT
+
+type (_,_) rel =
+  | IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+
+type (_,_,_) lam =
+  | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam
+  | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam
+  | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam
+  | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+;;
+
+let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+[%%expect{|
+type pexp = PEXP
+type pval = PVAL
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type ('a, 'b) tarr = TARR
+type tint = TINT
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (, Var ), Const (IntR, ))
+|}];;
+
+let rec mode : type m e t. (m,e,t) lam -> m mode = function
+  | Lam (v, body) -> Pval
+  | Var v -> Pval
+  | Const (r, v) -> Pval
+  | Shift e -> mode e
+  | App _ -> Pexp
+;;
+[%%expect{|
+val mode : ('m, 'e, 't) lam -> 'm mode = 
+|}];;
+
+type (_,_) sub =
+  | Id : ('r,'r) sub
+  | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub
+  | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub
+
+type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam'
+;;
+
+let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
+  fun t s ->
+  match t, s with
+  | _, Id -> Ex t
+  | Const(r,c), sub -> Ex (Const (r,c))
+  | Var v, Bind (x, e, r) -> Ex e
+  | Var v, Push sub -> Ex (Var v)
+  | Shift e, Bind (_, _, r) -> subst e r
+  | Shift e, Push sub ->
+      (match subst e sub with Ex a -> Ex (Shift a))
+  | App(f,x), sub ->
+      (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y)))
+  | Lam(v,x), sub ->
+      (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
+;;
+[%%expect{|
+type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = 
+|}];;
+
+type closed = rnil
+
+type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;;
+
+let rec rule : type a b.
+  (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam =
+  fun v1 v2 ->
+  match v1, v2 with
+  | Lam(x,body), v ->
+      begin
+        match subst body (Bind (x, v, Id)) with Ex term ->
+        match mode term with
+        | Pexp -> Inl term
+        | Pval -> Inr term
+      end
+  | Const (IntTo b, f), Const (IntR, x) ->
+      Inr (Const (b, f x))
+;;
+[%%expect{|
+type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  
+|}];;
+
+let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
+  | Lam (v, body) -> Inr (Lam (v, body))
+  | Const (r, v)  -> Inr (Const (r, v))
+  | App (e1, e2) ->
+      match mode e1, mode e2 with
+      | Pexp, _->
+          begin match onestep e1 with
+          | Inl e -> Inl(App(e,e2))
+          | Inr v -> Inl(App(v,e2))
+          end
+      | Pval, Pexp ->
+          begin match onestep e2 with
+          | Inl e -> Inl(App(e1,e))
+          | Inr v -> Inl(App(e1,v))
+          end
+      | Pval, Pval -> rule e1 e2
+;;
+[%%expect{|
+val onestep : ('m, closed, 't) lam -> 't rlam = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
new file mode 100644
index 00000000..e0c77acd
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -0,0 +1,29 @@
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+   | _ -> .   (* error *)
+;;
+[%%expect{|
+type ('env, 'a) var =
+    Zero : ('a * 'env, 'a) var
+  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+type ('env, 'a) typ =
+    Tint : ('env, int) typ
+  | Tbool : ('env, bool) typ
+  | Tvar : ('env, 'a) var -> ('env, 'a) typ
+Line _, characters 5-6:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: (Tint, Tvar Zero)
+|}];;
+(* let x = f Tint (Tvar Zero) ;; *)
diff --git a/testsuite/tests/typing-gadts/pr5689.ml b/testsuite/tests/typing-gadts/pr5689.ml
new file mode 100644
index 00000000..748212d4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5689.ml
@@ -0,0 +1,105 @@
+type inkind = [ `Link | `Nonlink ]
+
+type _ inline_t =
+   | Text: string -> [< inkind > `Nonlink ] inline_t
+   | Bold: 'a inline_t list -> 'a inline_t
+   | Link: string -> [< inkind > `Link ] inline_t
+   | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+;;
+
+let uppercase seq =
+   let rec process: type a. a inline_t -> a inline_t = function
+       | Text txt       -> Text (String.uppercase_ascii txt)
+       | Bold xs        -> Bold (List.map process xs)
+       | Link lnk       -> Link lnk
+       | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
+   in List.map process seq
+;;
+[%%expect{|
+type inkind = [ `Link | `Nonlink ]
+type _ inline_t =
+    Text : string -> [< inkind > `Nonlink ] inline_t
+  | Bold : 'a inline_t list -> 'a inline_t
+  | Link : string -> [< inkind > `Link ] inline_t
+  | Mref : string *
+      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+val uppercase : 'a inline_t list -> 'a inline_t list = 
+|}];;
+
+type ast_t =
+   | Ast_Text of string
+   | Ast_Bold of ast_t list
+   | Ast_Link of string
+   | Ast_Mref of string * ast_t list
+;;
+
+let inlineseq_from_astseq seq =
+   let rec process_nonlink = function
+       | Ast_Text txt  -> Text txt
+       | Ast_Bold xs   -> Bold (List.map process_nonlink xs)
+       | _             -> assert false in
+   let rec process_any = function
+       | Ast_Text txt       -> Text txt
+       | Ast_Bold xs        -> Bold (List.map process_any xs)
+       | Ast_Link lnk       -> Link lnk
+       | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
+   in List.map process_any seq
+;;
+[%%expect{|
+type ast_t =
+    Ast_Text of string
+  | Ast_Bold of ast_t list
+  | Ast_Link of string
+  | Ast_Mref of string * ast_t list
+val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
+|}];;
+
+(* OK *)
+type _ linkp =
+ | Nonlink : [ `Nonlink ] linkp
+ | Maylink : inkind linkp
+;;
+let inlineseq_from_astseq seq =
+ let rec process : type a. a linkp -> ast_t -> a inline_t =
+   fun allow_link ast ->
+     match (allow_link, ast) with
+     | (Maylink, Ast_Text txt)    -> Text txt
+     | (Nonlink, Ast_Text txt)    -> Text txt
+     | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+     | (Maylink, Ast_Link lnk)    -> Link lnk
+     | (Nonlink, Ast_Link _)      -> assert false
+     | (Maylink, Ast_Mref (lnk, xs)) ->
+         Mref (lnk, List.map (process Nonlink) xs)
+     | (Nonlink, Ast_Mref _)      -> assert false
+   in List.map (process Maylink) seq
+;;
+[%%expect{|
+type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
+|}];;
+
+(* Bad *)
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+;;
+let inlineseq_from_astseq seq =
+let rec process : type a. a linkp2 -> ast_t -> a inline_t =
+  fun allow_link ast ->
+    match (allow_link, ast) with
+    | (Kind _, Ast_Text txt)    -> Text txt
+    | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+    | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+    | (Kind Nonlink, Ast_Link _)      -> assert false
+    | (Kind Maylink, Ast_Mref (lnk, xs)) ->
+        Mref (lnk, List.map (process (Kind Nonlink)) xs)
+    | (Kind Nonlink, Ast_Mref _)      -> assert false
+  in List.map (process (Kind Maylink)) seq
+;;
+[%%expect{|
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+Line _, characters 35-43:
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+       but an expression was expected of type a inline_t
+       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+         a = [< `Link | `Nonlink ]
+       Types for tag `Nonlink are incompatible
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5785.ml b/testsuite/tests/typing-gadts/pr5785.ml
new file mode 100644
index 00000000..9624adcd
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5785.ml
@@ -0,0 +1,22 @@
+module Add (T : sig type two end) =
+struct
+  type _ t =
+  | One : [`One] t
+  | Two : T.two t
+
+  let add (type a) : a t * a t -> string = function
+    | One, One -> "two"
+    | Two, Two -> "four"
+end;;
+[%%expect{|
+Line _, characters 43-100:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Two, One)
+module Add :
+  functor (T : sig type two end) ->
+    sig
+      type _ t = One : [ `One ] t | Two : T.two t
+      val add : 'a t * 'a t -> string
+    end
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5848.ml b/testsuite/tests/typing-gadts/pr5848.ml
new file mode 100644
index 00000000..d1ebbdf5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5848.ml
@@ -0,0 +1,20 @@
+module B : sig
+ type (_, _) t = Eq: ('a, 'a) t
+ val f: 'a -> 'b -> ('a, 'b) t
+end
+=
+struct
+ type (_, _) t = Eq: ('a, 'a) t
+ let f t1 t2 = Obj.magic Eq
+end;;
+
+let of_type: type a. a -> a = fun x ->
+  match B.f x 4 with
+  | Eq -> 5
+;;
+[%%expect{|
+module B :
+  sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
+Line _, characters 4-6:
+Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5906.ml b/testsuite/tests/typing-gadts/pr5906.ml
new file mode 100644
index 00000000..a9541265
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5906.ml
@@ -0,0 +1,33 @@
+type _ constant =
+  | Int: int -> int constant
+  | Bool: bool -> bool constant
+
+type (_, _, _) binop =
+  | Eq: ('a, 'a, bool) binop
+  | Leq: ('a, 'a, bool) binop
+  | Add: (int, int, int) binop
+
+let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant)
+         (y:b constant) : c constant =
+  match bop, x, y with
+  | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+  | Leq, Int x, Int y -> Bool (x <= y)
+  | Leq, Bool x, Bool y -> Bool (x <= y)
+  | Add, Int x, Int y -> Int (x + y)
+
+let _ = eval Eq (Int 2) (Int 3)
+
+[%%expect{|
+type _ constant = Int : int -> int constant | Bool : bool -> bool constant
+type (_, _, _) binop =
+    Eq : ('a, 'a, bool) binop
+  | Leq : ('a, 'a, bool) binop
+  | Add : (int, int, int) binop
+Line _, characters 2-195:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Eq, Int _, _)
+val eval : ('a, 'b, 'c) binop -> 'a constant -> 'b constant -> 'c constant =
+  
+Exception: Match_failure ("", 12, 2).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml
new file mode 100644
index 00000000..52477628
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5948.ml
@@ -0,0 +1,51 @@
+type tag = [`TagA | `TagB | `TagC];;
+
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int] poly
+(* constraint 'a = [< `TagA of int | `TagB] *)
+;;
+
+let intA = function `TagA i -> i
+let intB = function `TagB -> 4
+;;
+
+let intAorB = function
+    `TagA i -> i
+  | `TagB -> 4
+;;
+
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly
+;;
+
+let example6 : type a. a wrapPoly -> (a -> int) =
+  fun w  ->
+    match w with
+    | WrapPoly ATag -> intA
+    | WrapPoly _ -> intA (* This should not be allowed *)
+;;
+[%%expect{|
+type tag = [ `TagA | `TagB | `TagC ]
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int ] poly
+val intA : [< `TagA of 'a ] -> 'a = 
+val intB : [< `TagB ] -> int = 
+val intAorB : [< `TagA of int | `TagB ] -> int = 
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
+Line _, characters 23-27:
+Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
+       but an expression was expected of type a -> int
+       Type [< `TagA of 'b ] as 'a is not compatible with type
+         a = [< `TagA of int | `TagB ]
+       The first variant type does not allow tag(s) `TagB
+|}];;
+
+let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+;;
+[%%expect{|
+Line _, characters 9-17:
+Error: Unbound value example6
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5981.ml b/testsuite/tests/typing-gadts/pr5981.ml
new file mode 100644
index 00000000..bda9a883
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5981.ml
@@ -0,0 +1,48 @@
+module F(S : sig type 'a t end) = struct
+  type _ ab =
+      A : int S.t ab
+    | B : float S.t ab
+
+  let f : int S.t ab -> float S.t ab -> string =
+    fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
+    | A, B -> "f A B"
+end;;
+[%%expect{|
+Line _, characters 47-84:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type _ ab = A : int S.t ab | B : float S.t ab
+      val f : int S.t ab -> float S.t ab -> string
+    end
+|}];;
+
+module F(S : sig type 'a t end) = struct
+  type a = int * int
+  type b = int -> int
+
+  type _ ab =
+      A : a S.t ab
+    | B : b S.t ab
+
+  let f : a S.t ab -> b S.t ab -> string =
+    fun l r -> match l, r with
+    | A, B -> "f A B"
+end;;
+[%%expect{|
+Line _, characters 15-52:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type a = int * int
+      type b = int -> int
+      type _ ab = A : a S.t ab | B : b S.t ab
+      val f : a S.t ab -> b S.t ab -> string
+    end
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml
new file mode 100644
index 00000000..0243887f
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5985.ml
@@ -0,0 +1,177 @@
+(* Report from Jeremy Yallop *)
+module F (S : sig type 'a s end) = struct
+  include S
+  type _ t = T : 'a -> 'a s t
+end;; (* fail *)
+[%%expect{|
+Line _, characters 2-29:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+(*
+module M = F (struct type 'a s = int end) ;;
+let M.T x = M.T 3 in x = true;;
+*)
+
+(* Fix it using #-annotations *)
+(*
+module F (S : sig type #'a s end) = struct
+  include S
+  type _ t = T : 'a -> 'a s t
+end;; (* syntax error *)
+module M = F (struct type 'a s = int end) ;; (* fail *)
+module M = F (struct type 'a s = new int end) ;; (* ok *)
+let M.T x = M.T 3 in x = true;; (* fail *)
+let M.T x = M.T 3 in x = 3;; (* ok *)
+*)
+
+(* Another version using OCaml 2.00 objects *)
+module F(T:sig type 'a t end) = struct
+  class ['a] c x =
+    object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
+end;; (* fail *)
+[%%expect{|
+Line _, characters 2-86:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+
+(* Another (more direct) instance using polymorphic variants *)
+(* PR#6275 *)
+type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *)
+let magic (x : int) : bool  =
+  let A x = A x in
+  x;; (* fail *)
+[%%expect{|
+Line _, characters 0-49:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+
+type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
+[%%expect{|
+Line _, characters 0-37:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+
+(* It is not OK to allow modules exported by other compilation units *)
+type (_,_) eq = Eq : ('a,'a) eq;;
+let eq = Obj.magic Eq;;
+(* pretend that Queue.t is not injective *)
+let eq : ('a Queue.t, 'b Queue.t) eq = eq;;
+type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+val eq : 'a = 
+val eq : ('a Queue.t, 'b Queue.t) eq = Eq
+Line _, characters 0-33:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+(*
+let castT (type a) (type b) (x : a t) (e: (a, b) eq) : b t =
+  let Eq = e in (x : b t);;
+let T (x : bool) = castT (T 3) eq;; (* we found a contradiction *)
+*)
+
+(* The following signature should not be accepted *)
+module type S = sig
+  type 'a s
+  type _ t = T : 'a -> 'a s t
+end;; (* fail *)
+[%%expect{|
+Line _, characters 2-29:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+(* Otherwise we can write the following *)
+module rec M : (S with type 'a s = unit) = M;;
+[%%expect{|
+Line _, characters 16-17:
+Error: Unbound module type S
+|}];;
+(* For the above reason, we cannot allow the abstract declaration
+   of s and the definition of t to be in the same module, as
+   we could create the signature using [module type of ...] *)
+
+
+(* Another problem with variance *)
+(*
+module M = struct type 'a t = 'a -> unit end;;
+module F(X:sig type #'a t end) =
+  struct type +'a s = S of 'b constraint 'a = 'b X.t end;; (* fail *)
+module N = F(M);;
+let o = N.S (object end);;
+let N.S o' = (o :>  M.t N.s);; (* unsound! *)
+*)
+
+(* And yet another *)
+type 'a q = Q;;
+type +'a t = 'b constraint 'a = 'b q;;
+[%%expect{|
+type 'a q = Q
+Line _, characters 0-36:
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+|}];;
+(* shoud fail: we do not know for sure the variance of Queue.t *)
+
+type +'a t = T of 'a;;
+type +'a s = 'b constraint 'a = 'b t;; (* ok *)
+[%%expect{|
+type 'a t = T of 'a
+type +'a s = 'b constraint 'a = 'b t
+|}];;
+type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+[%%expect{|
+Line _, characters 0-36:
+Error: In this definition, a type variable has a variance that
+       is not reflected by its occurrence in type parameters.
+       It was expected to be contravariant, but it is covariant.
+|}];;
+type +'a u = 'a t;;
+type 'a t = T of ('a -> 'a);;
+type -'a s = 'b constraint 'a = 'b t;; (* ok *)
+[%%expect{|
+type 'a u = 'a t
+type 'a t = T of ('a -> 'a)
+type -'a s = 'b constraint 'a = 'b t
+|}];;
+type +'a s = 'b constraint 'a = 'b q t;; (* ok *)
+[%%expect{|
+type +'a s = 'b constraint 'a = 'b q t
+|}];;
+type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+[%%expect{|
+Line _, characters 0-38:
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+|}];;
+
+
+(* the problem from lablgtk2 *)
+(*
+module Gobject = struct
+  type -'a obj
+end
+open Gobject;;
+
+class virtual ['a] item_container =
+ object
+   constraint 'a = < as_item : [>`widget] obj; .. >
+   method virtual add : 'a -> unit
+ end;;
+*)
+
+(* Another variance anomaly, should not expand t in g before checking *)
+type +'a t = unit constraint 'a = 'b list;;
+type _ g = G : 'a -> 'a t g;; (* fail *)
+[%%expect{|
+type +'a t = unit constraint 'a = 'b list
+Line _, characters 0-27:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5989.ml b/testsuite/tests/typing-gadts/pr5989.ml
new file mode 100644
index 00000000..0abf7cb3
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5989.ml
@@ -0,0 +1,57 @@
+type (_, _) t =
+    Any : ('a, 'b) t
+  | Eq : ('a, 'a) t
+;;
+
+module M :
+sig
+  type s = private [> `A]
+  val eq : (s, [`A | `B]) t
+end =
+struct
+  type s = [`A | `B]
+  let eq = Eq
+end;;
+
+let f : (M.s, [`A | `B]) t -> string = function
+  | Any -> "Any"
+;;
+
+let () = print_endline (f M.eq) ;;
+[%%expect{|
+type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
+module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
+Line _, characters 39-64:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (M.s, [ `A | `B ]) t -> string = 
+Exception: Match_failure ("", 16, 39).
+|}];;
+
+module N :
+sig
+  type s = private < a : int; .. >
+  val eq : (s, ) t
+end =
+struct
+  type s = 
+  let eq = Eq
+end
+;;
+
+let f : (N.s, ) t -> string = function
+  | Any -> "Any"
+;;
+[%%expect{|
+module N :
+  sig
+    type s = private < a : int; .. >
+    val eq : (s, < a : int; b : bool >) t
+  end
+Line _, characters 49-74:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (N.s, < a : int; b : bool >) t -> string = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5997.ml b/testsuite/tests/typing-gadts/pr5997.ml
new file mode 100644
index 00000000..1e293ef0
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5997.ml
@@ -0,0 +1,47 @@
+type (_, _) comp =
+  | Eq : ('a, 'a) comp
+  | Diff : ('a, 'b) comp
+;;
+
+module U = struct type t = T end;;
+
+module M : sig
+  type t = T
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+[%%expect{|
+type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
+module U : sig type t = T end
+module M : sig type t = T val comp : (U.t, t) comp end
+Line _, characters 0-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+Exception: Match_failure ("", 16, 0).
+|}];;
+
+module U = struct type t = {x : int} end;;
+
+module M : sig
+  type t = {x : int}
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+[%%expect{|
+module U : sig type t = { x : int; } end
+module M : sig type t = { x : int; } val comp : (U.t, t) comp end
+Line _, characters 0-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+Exception: Match_failure ("", 11, 0).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6158.ml b/testsuite/tests/typing-gadts/pr6158.ml
new file mode 100644
index 00000000..5a115b7b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6158.ml
@@ -0,0 +1,19 @@
+type 'a t = T of 'a
+type 'a s = S of 'a
+
+type (_, _) eq = Refl : ('a, 'a) eq;;
+
+let f : (int s, int t) eq -> unit = function Refl -> ();;
+
+module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
+struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+[%%expect{|
+type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 45-49:
+Error: This pattern matches values of type (int s, int s) eq
+       but a pattern was expected which matches values of type
+         (int s, int t) eq
+       Type int s is not compatible with type int t
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml
new file mode 100644
index 00000000..bfb644ad
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6163.ml
@@ -0,0 +1,27 @@
+type _ nat =
+    Zero : [`Zero] nat
+  | Succ : 'a nat -> [`Succ of 'a] nat;;
+type 'a pre_nat = [`Zero | `Succ of 'a];;
+type aux =
+  | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;;
+
+let f (Aux x) =
+  match x with
+  | Succ Zero -> "1"
+  | Succ (Succ Zero) -> "2"
+  | Succ (Succ (Succ Zero)) -> "3"
+  | Succ (Succ (Succ (Succ Zero))) -> "4"
+  | _ -> .  (* error *)
+;;
+[%%expect{|
+type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+type 'a pre_nat = [ `Succ of 'a | `Zero ]
+type aux =
+    Aux :
+      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat ->
+      aux
+Line _, characters 4-5:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it:
+       Succ (Succ (Succ (Succ (Succ Zero))))
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6174.ml b/testsuite/tests/typing-gadts/pr6174.ml
new file mode 100644
index 00000000..fcf5c633
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6174.ml
@@ -0,0 +1,9 @@
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+[%%expect{|
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+Line _, characters 24-25:
+Error: This expression has type $0 but an expression was expected of type
+         $1 = ($2 -> $1) -> $1
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6241.ml b/testsuite/tests/typing-gadts/pr6241.ml
new file mode 100644
index 00000000..ebda191c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6241.ml
@@ -0,0 +1,30 @@
+type (_, _) t =
+ A : ('a, 'a) t
+| B : string -> ('a, 'b) t
+;;
+
+module M (A : sig module type T end) (B : sig module type T end) =
+struct
+ let f : ((module A.T), (module B.T)) t -> string = function
+   | B s -> s
+end;;
+
+module A = struct module type T = sig end end;;
+
+module N = M(A)(A);;
+
+let x = N.f A;;
+
+[%%expect{|
+type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
+Line _, characters 52-74:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+A
+module M :
+  functor (A : sig module type T end) (B : sig module type T end) ->
+    sig val f : ((module A.T), (module B.T)) t -> string end
+module A : sig module type T = sig  end end
+module N : sig val f : ((module A.T), (module A.T)) t -> string end
+Exception: Match_failure ("", 8, 52).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6690.ml b/testsuite/tests/typing-gadts/pr6690.ml
new file mode 100644
index 00000000..b9466f68
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6690.ml
@@ -0,0 +1,74 @@
+type 'a visit_action
+
+type insert
+
+type 'a local_visit_action
+
+type ('a, 'result, 'visit_action) context =
+  | Local : ('a, ('a * insert) as 'result, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+;;
+
+let vexpr (type visit_action)
+    : (_, _, visit_action) context -> _ -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+[%%expect{|
+type 'a visit_action
+type insert
+type 'a local_visit_action
+type ('a, 'result, 'visit_action) context =
+    Local : ('a, 'a * insert, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+Line _, characters 4-9:
+Error: This pattern matches values of type
+         ($0, $0 * insert, $0 local_visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       The type constructor $0 would escape its scope
+|}, Principal{|
+type 'a visit_action
+type insert
+type 'a local_visit_action
+type ('a, 'result, 'visit_action) context =
+    Local : ('a, 'a * insert, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+Line _, characters 4-10:
+Error: This pattern matches values of type ($1, $1, visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       Type $1 is not compatible with type $0
+|}];;
+
+let vexpr (type visit_action)
+    : ('a, 'result, visit_action) context -> 'a -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+[%%expect{|
+Line _, characters 4-9:
+Error: This pattern matches values of type
+         ($'a, $'a * insert, $'a local_visit_action) context
+       but a pattern was expected which matches values of type
+         ($'a, $'a * insert, visit_action) context
+       The type constructor $'a would escape its scope
+|}, Principal{|
+Line _, characters 4-10:
+Error: This pattern matches values of type ($1, $1, visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       Type $1 is not compatible with type $0
+|}];;
+
+let vexpr (type result) (type visit_action)
+    : (unit, result, visit_action) context -> unit -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+[%%expect{|
+val vexpr : (unit, 'a, 'b) context -> unit -> 'b = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6817.ml b/testsuite/tests/typing-gadts/pr6817.ml
new file mode 100644
index 00000000..c31f975b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6817.ml
@@ -0,0 +1,34 @@
+module A = struct
+    type nil = Cstr
+  end
+open A
+;;
+
+type _ s =
+  | Nil : nil s
+  | Cons : 't s -> ('h -> 't) s
+
+type ('stack, 'typ) var =
+  | Head : (('typ -> _) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> ((_ -> 'tail) s, 'typ) var
+
+type _ lst =
+  | CNil : nil lst
+  | CCons : 'h * ('t lst) -> ('h -> 't) lst
+;;
+
+let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s ->
+  match n, s with
+  | Head, CCons (h, _) -> h
+  | Tail n', CCons (_, t) -> get_var n' t
+;;
+
+[%%expect{|
+module A : sig type nil = Cstr end
+type _ s = Nil : A.nil s | Cons : 't s -> ('h -> 't) s
+type ('stack, 'typ) var =
+    Head : (('typ -> 'a) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> (('b -> 'tail) s, 'typ) var
+type _ lst = CNil : A.nil lst | CCons : 'h * 't lst -> ('h -> 't) lst
+val get_var : ('stk s, 'ret) var -> 'stk lst -> 'ret = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6980.ml b/testsuite/tests/typing-gadts/pr6980.ml
new file mode 100644
index 00000000..85b35d8f
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6980.ml
@@ -0,0 +1,24 @@
+type 'a t = [< `Foo | `Bar] as 'a;;
+type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a;;
+
+type 'a first = First : 'a second -> ('b t as 'a) first
+and 'a second = Second : ('b s as 'a) second;;
+
+type aux = Aux : 'a t second * ('a -> int) -> aux;;
+
+let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
+
+let g (Aux(Second, f)) = f it;;
+
+[%%expect{|
+type 'a t = 'a constraint 'a = [< `Bar | `Foo ]
+type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ]
+type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first
+and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second
+type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
+val it : [< `Bar | `Foo > `Bar ] = `Bar
+Line _, characters 27-29:
+Error: This expression has type [< `Bar | `Foo > `Bar ]
+       but an expression was expected of type [< `Bar | `Foo ]
+       Types for tag `Bar are incompatible
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6993_bad.ml b/testsuite/tests/typing-gadts/pr6993_bad.ml
new file mode 100644
index 00000000..65a312ba
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6993_bad.ml
@@ -0,0 +1,24 @@
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
+
+module rec A :  sig type t = B.t list end =
+  struct type t = B.t list end
+and B : sig  type t val eq : (B.t list, t) eqp end =
+  struct
+    type t = A.t
+    let eq = Y
+  end;;
+
+f B.eq;;
+
+[%%expect{|
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+Line _, characters 36-66:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Y
+val f : ('a list, 'a) eqp -> unit = 
+module rec A : sig type t = B.t list end
+and B : sig type t val eq : (B.t list, t) eqp end
+Exception: Match_failure ("", 2, 36).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7016.ml b/testsuite/tests/typing-gadts/pr7016.ml
new file mode 100644
index 00000000..2dff639e
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7016.ml
@@ -0,0 +1,28 @@
+type (_, _) t =
+  | Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
+
+let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+[%%expect{|
+type (_, _) t =
+    Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
+Line _, characters 9-43:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Nil
+val get1 : ('b * 'a, 'a) t -> 'b = 
+|}];;
+
+let get1' = function
+  | (Cons (x, _) : (_ * 'a, 'a) t) -> x
+  | Nil -> assert false ;; (* ok *)
+[%%expect{|
+val get1' : ('b * 'a as 'a, 'a) t -> 'b = 
+|}, Principal{|
+Line _, characters 4-7:
+Error: This pattern matches values of type ('b * 'a, 'b * 'a) t
+       but a pattern was expected which matches values of type
+         ('b * 'a, 'a) t
+       The type variable 'a occurs inside 'b * 'a
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7160.ml b/testsuite/tests/typing-gadts/pr7160.ml
new file mode 100644
index 00000000..38254892
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7160.ml
@@ -0,0 +1,16 @@
+type _ t =
+  Int : int -> int t | String : string -> string t | Same : 'l t -> 'l t;;
+let rec f = function Int x -> x | Same s -> f s;;
+type 'a tt = 'a t =
+  Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt;;
+
+[%%expect{|
+type _ t =
+    Int : int -> int t
+  | String : string -> string t
+  | Same : 'l t -> 'l t
+val f : int t -> int = 
+Line _, characters 0-97:
+Error: This variant or record definition does not match that of type 'a t
+       The types for field Same are not equal.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7214.ml b/testsuite/tests/typing-gadts/pr7214.ml
new file mode 100644
index 00000000..736b353e
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7214.ml
@@ -0,0 +1,37 @@
+type _ t = I : int t;;
+
+let f (type a) (x : a t) =
+  let module M = struct
+    let (I : a t) = x     (* fail because of toplevel let *)
+    let x = (I : a t)
+  end in
+  () ;;
+[%%expect{|
+type _ t = I : int t
+Line _, characters 9-10:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type a t
+       Type int is not compatible with type a
+|}];;
+
+(* extra example by Stephen Dolan, using recursive modules *)
+(* Should not be allowed! *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+
+let bad (type a) =
+ let module N = struct
+   module rec M : sig
+     val e : (int, a) eq
+   end = struct
+     let (Refl : (int, a) eq) = M.e  (* must fail for soundness *)
+     let e : (int, a) eq = Refl
+   end
+ end in N.M.e
+;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 10-14:
+Error: This pattern matches values of type (int, int) eq
+       but a pattern was expected which matches values of type (int, a) eq
+       Type int is not compatible with type a
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7222.ml b/testsuite/tests/typing-gadts/pr7222.ml
new file mode 100644
index 00000000..d26539de
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7222.ml
@@ -0,0 +1,36 @@
+type +'a n = private int
+type nil = private Nil_type
+type (_,_) elt =
+  | Elt_fine: 'nat n -> ('l,'nat * 'l) elt
+  | Elt: 'nat n -> ('l,'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t;;
+
+let undetected: ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j ->
+  let Cons(Elt dim, _) = sh in ()
+;;
+
+[%%expect{|
+type +'a n = private int
+type nil = private Nil_type
+type (_, _) elt =
+    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
+  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
+Line _, characters 11-18:
+Error: This pattern matches values of type ($Cons_'x, 'a -> $Cons_'x) elt
+       but a pattern was expected which matches values of type
+         ($Cons_'x, 'a -> $'b -> nil) elt
+       The type constructor $'b would escape its scope
+|}, Principal{|
+type +'a n = private int
+type nil = private Nil_type
+type (_, _) elt =
+    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
+  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
+Line _, characters 6-22:
+Error: This pattern matches values of type ('a -> $0 -> nil) t
+       but a pattern was expected which matches values of type
+         ('a -> 'b -> nil) t
+       The type constructor $0 would escape its scope
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7230.ml b/testsuite/tests/typing-gadts/pr7230.ml
new file mode 100644
index 00000000..16f652ce
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7230.ml
@@ -0,0 +1,9 @@
+type _ t = T : int t;;
+
+(* Should raise Not_found *)
+let _ = match (raise Not_found : float t) with _ -> .;;
+
+[%%expect{|
+type _ t = T : int t
+Exception: Not_found.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7234.ml b/testsuite/tests/typing-gadts/pr7234.ml
new file mode 100644
index 00000000..622aef90
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7234.ml
@@ -0,0 +1,24 @@
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
+type 'a t;;
+let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
+type 'a t
+Line _, characters 15-40:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : ('a, 'a t) eq -> int = 
+|}];;
+
+module F (T : sig type _ t end) = struct
+ let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
+end;;
+[%%expect{|
+Line _, characters 16-43:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+module F :
+  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7260.ml b/testsuite/tests/typing-gadts/pr7260.ml
new file mode 100644
index 00000000..77daa1f2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7260.ml
@@ -0,0 +1,21 @@
+type bar = < bar: unit >
+
+type _ ty = Int : int ty
+
+type dyn = Dyn : 'a ty -> dyn;;
+
+class foo =
+  object (this)
+    method foo (Dyn ty) =
+      match ty with
+      | Int -> (this :> bar)
+  end;;  (* fail, but not for scope *)
+
+[%%expect{|
+type bar = < bar : unit >
+type _ ty = Int : int ty
+type dyn = Dyn : 'a ty -> dyn
+Line _, characters 0-108:
+Error: This class should be virtual.
+       The following methods are undefined : bar
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7269.ml b/testsuite/tests/typing-gadts/pr7269.ml
new file mode 100644
index 00000000..051b4dc5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7269.ml
@@ -0,0 +1,71 @@
+type s = [`A | `B] and sub = [`B];;
+type +'a t = T : [< `Conj of 'a & sub | `Other of string] -> 'a t;; (* ok *)
+
+let f (T (`Other msg) : s t) = print_string msg;;
+let _ = f (T (`Conj `B) :> s t);; (* warn *)
+[%%expect{|
+type s = [ `A | `B ]
+and sub = [ `B ]
+type +'a t = T : [< `Conj of 'a & sub | `Other of string ] -> 'a t
+Line _, characters 6-47:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+T (`Conj _)
+val f : s t -> unit = 
+Exception: Match_failure ("", 4, 6).
+|}];;
+
+module M : sig
+  type s
+  type t = T : [< `Conj of int & s | `Other of string] -> t
+  val x : t
+end = struct
+  type s = int
+  type t = T : [< `Conj of int | `Other of string] -> t
+  let x = T (`Conj 42)
+end;;
+
+let () = M.(match x with T (`Other msg) -> print_string msg);; (* warn *)
+[%%expect{|
+module M :
+  sig
+    type s
+    type t = T : [< `Conj of int & s | `Other of string ] -> t
+    val x : t
+  end
+Line _, characters 12-59:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+T (`Conj _)
+Exception: Match_failure ("", 11, 12).
+|}];;
+
+
+module M : sig
+  type s
+  type elim =
+      { ex : 'a . ([<`Conj of int & s | `Other of string] as 'a) -> unit }
+  val e : elim -> unit
+end = struct
+  type s = int
+  type elim =
+      { ex : 'a . (([<`Conj of int | `Other of string] as 'a) -> unit) }
+  let e { ex } = ex (`Conj 42 : [`Conj of int])
+end;;
+
+let () = M.(e { ex = fun (`Other msg) -> print_string msg });; (* warn *)
+[%%expect{|
+module M :
+  sig
+    type s
+    type elim = {
+      ex : 'a. ([< `Conj of int & s | `Other of string ] as 'a) -> unit;
+    }
+    val e : elim -> unit
+  end
+Line _, characters 21-57:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`Conj _
+Exception: Match_failure ("", 13, 21).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7298.ml b/testsuite/tests/typing-gadts/pr7298.ml
new file mode 100644
index 00000000..695fc3c4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7298.ml
@@ -0,0 +1,14 @@
+type t = T : t;;
+
+module M : sig
+  type free = < bar : t -> unit; foo : free -> unit >
+end = struct
+  class free = object (self : 'self)
+    method foo self = ()
+    method bar T = self#foo self
+  end
+end;;
+[%%expect{|
+type t = T : t
+module M : sig type free = < bar : t -> unit; foo : free -> unit > end
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7374.ml b/testsuite/tests/typing-gadts/pr7374.ml
new file mode 100644
index 00000000..b7243fb3
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7374.ml
@@ -0,0 +1,49 @@
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+
+module type S = sig
+  type 'a t constraint 'a = [`Rec of 'b]
+end;;
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+module type S = sig type 'a t constraint 'a = [ `Rec of 'b ] end
+|}]
+
+module Fix (X : S) : sig
+  type t
+  val uniq : ('a, [`Rec of 'a] X.t) eq -> ('a, t) eq
+end = struct
+  type t = [`Rec of 'a] X.t as 'a
+  let uniq : type a . (a, [`Rec of a] X.t) eq -> (a, t) eq =
+    fun Refl -> Refl
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 16-20:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, t) eq
+       Type a is not compatible with type t = [ `Rec of 'a ] X.t as 'a
+|}]
+
+(* trigger segfault
+module Id = struct
+  type 'a t = 'b constraint 'a = [ `Rec of 'b ]
+end
+
+module Bad = Fix(Id)
+
+let segfault () =
+  print_endline (cast (trans (Bad.uniq Refl) (Bad.uniq Refl)) 0)
+*)
+
+(* addendum: ensure that hidden paths are checked too *)
+module F (X : sig type 'a t end) = struct
+  open X
+  let f : type a b. (a, b t) eq -> (b, a t) eq -> (a, a t t) eq =
+    fun Refl Refl -> Refl;;
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 21-25:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, a X.t X.t) eq
+       Type a = b X.t is not compatible with type a X.t X.t
+       Type b is not compatible with type a X.t
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7378.ml b/testsuite/tests/typing-gadts/pr7378.ml
new file mode 100644
index 00000000..3d8a2924
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7378.ml
@@ -0,0 +1,23 @@
+module X = struct
+  type t =
+    | A : 'a * 'b * ('a -> unit) -> t
+end;;
+[%%expect{|
+module X : sig type t = A : 'a * 'b * ('a -> unit) -> t end
+|}]
+
+module Y = struct
+  type t = X.t =
+    | A : 'a * 'b * ('b -> unit) -> t
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 2-54:
+Error: This variant or record definition does not match that of type X.t
+       The types for field A are not equal.
+|}]
+
+(* would segfault
+let () =
+  match Y.A (1, "", print_string) with
+  | X.A (x, y, f) -> f x
+*)
diff --git a/testsuite/tests/typing-gadts/pr7381.ml b/testsuite/tests/typing-gadts/pr7381.ml
new file mode 100644
index 00000000..79cc245c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7381.ml
@@ -0,0 +1,15 @@
+type (_,_) eql = Refl : ('a, 'a) eql;;
+[%%expect{|
+type (_, _) eql = Refl : ('a, 'a) eql
+|}]
+
+let f : type t. (int, t) eql * (t, string) eql -> unit = function _ -> . ;;
+[%%expect{|
+val f : (int, 't) eql * ('t, string) eql -> unit = 
+|}]
+
+let f : type t. ((int, t) eql * (t, string) eql) option -> unit =
+  function None -> () ;;
+[%%expect{|
+val f : ((int, 't) eql * ('t, string) eql) option -> unit = 
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7390.ml b/testsuite/tests/typing-gadts/pr7390.ml
new file mode 100644
index 00000000..b421ec57
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7390.ml
@@ -0,0 +1,25 @@
+type empty = Empty and filled = Filled
+type ('a,'fout,'fin) opt =
+  | N : ('a, 'f, 'f) opt
+  | Y : 'a -> ('a, filled, empty) opt
+type 'fill either =
+  | Either : (string, 'fill, 'f) opt * (int, 'f, empty) opt -> 'fill either;;
+[%%expect{|
+type empty = Empty
+and filled = Filled
+type ('a, 'fout, 'fin) opt =
+    N : ('a, 'f, 'f) opt
+  | Y : 'a -> ('a, filled, empty) opt
+type 'fill either =
+    Either : (string, 'fill, 'f) opt * (int, 'f, empty) opt -> 'fill either
+|}]
+
+let f (* : filled either -> string *) =
+  fun (Either (Y a, N)) -> a;;
+[%%expect{|
+Line _, characters 2-28:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Either (N, Y _)
+val f : filled either -> string = 
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7391.ml b/testsuite/tests/typing-gadts/pr7391.ml
new file mode 100644
index 00000000..ace84b5d
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7391.ml
@@ -0,0 +1,76 @@
+class virtual child1 parent =
+  object
+    method private parent = parent
+  end
+
+class virtual child2 =
+  object(_ : 'self)
+    constraint 'parent = < previous: 'self option; .. >
+    method private virtual parent: 'parent
+  end
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+class virtual child1 : 'a -> object method private parent : 'a end
+class virtual child2 :
+  object ('a)
+    method private virtual parent : < previous : 'a option; .. >
+  end
+- : < child : child2; previous : child2 option > = 
+|}]
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child (_ : unit) =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+- : < child : unit -> child2; previous : child2 option > = 
+|}]
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child () =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+- : < child : unit -> child2; previous : child2 option > = 
+|}]
+
+(* Didn't work in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child =
+      let o =
+      object
+        inherit child1 self
+        inherit child2
+      end
+      in o
+  end;;
+[%%expect{|
+Line _, characters 16-22:
+Error: The method parent has type < child : 'a; previous : 'b option >
+       but is expected to have type < previous : < .. > option; .. >
+       Self type cannot escape its class
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7397.ml b/testsuite/tests/typing-gadts/pr7397.ml
new file mode 100644
index 00000000..3960514b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7397.ml
@@ -0,0 +1,25 @@
+type +'a t
+
+class type a = object
+ method b : b
+end
+
+and b = object
+ method a : a
+end
+
+type _ response =
+ | C : #a t response;;
+[%%expect{|
+type +'a t
+class type a = object method b : b end
+and b = object method a : a end
+type _ response = C : #a t response
+|}]
+
+let f (type a) (a : a response) =
+ match a with
+ | C -> 0;;
+[%%expect{|
+val f : 'a response -> int = 
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7421.ml b/testsuite/tests/typing-gadts/pr7421.ml
new file mode 100644
index 00000000..5bee9bc1
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7421.ml
@@ -0,0 +1,26 @@
+type (_, _) eq = Refl : ('a, 'a) eq;;
+type empty = (int, unit) eq;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+type empty = (int, unit) eq
+|}]
+let f (x : ('a, empty Lazy.t) result) =
+  match x with
+  | Ok x -> x
+  | Error (lazy _) -> .;;
+[%%expect{|
+Line _, characters 4-18:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: Error lazy _
+|}]
+let f (x : ('a, empty Lazy.t) result) =
+  match x with
+  | Ok x -> x
+  | Error (lazy Refl) -> .;;
+[%%expect{|
+Line _, characters 16-20:
+Error: This pattern matches values of type (int, int) eq
+       but a pattern was expected which matches values of type
+         empty = (int, unit) eq
+       Type int is not compatible with type unit
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7432.ml b/testsuite/tests/typing-gadts/pr7432.ml
new file mode 100644
index 00000000..6b83f48e
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7432.ml
@@ -0,0 +1,27 @@
+#labels false;;
+type (_,_) eql = Refl : ('a, 'a) eql
+type s = x:int -> y:float -> unit
+type t = y:int -> x:float -> unit
+type silly = {silly: 'a.'a};;
+let eql : (s, t) eql = Refl;;
+[%%expect{|
+type (_, _) eql = Refl : ('a, 'a) eql
+type s = x:int -> y:float -> unit
+type t = y:int -> x:float -> unit
+type silly = { silly : 'a. 'a; }
+val eql : (s, t) eql = Refl
+|}]
+
+#labels true;;
+let f : [`L of (s, t) eql | `R of silly] -> 'a =
+  function `R {silly} -> silly
+;;
+[%%expect{|
+Line _, characters 2-30:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`L Refl
+val f : [ `L of (s, t) eql | `R of silly ] -> 'a = 
+|}]
+
+(* Segfault: let () = print_endline (f (`L eql)) *)
diff --git a/testsuite/tests/typing-gadts/term-conv.ml b/testsuite/tests/typing-gadts/term-conv.ml
new file mode 100644
index 00000000..4994bdfd
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml
@@ -0,0 +1,218 @@
+(* HOAS to de Bruijn, by chak *)
+(* http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ *)
+
+module Typeable = struct
+  type 'a ty =
+    | Int: int ty
+    | String: string ty
+    | List: 'a ty -> 'a list ty
+    | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+    | Fun: ('a ty * 'b ty) -> ('a -> 'b) ty
+
+  type (_,_) eq = Eq : ('a,'a) eq
+
+  exception CastFailure
+  let rec check_eq : type t t'. t ty -> t' ty -> (t,t') eq = fun t t' ->
+    match t, t' with
+    | Int, Int -> Eq
+    | String, String -> Eq
+    | List t, List t' -> (match check_eq t t' with Eq -> Eq)
+    | Pair (t1,t2), Pair (t1',t2') ->
+        (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq)
+    | Fun (t1,t2), Fun (t1',t2') ->
+        (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq)
+    | _ -> raise CastFailure
+
+  let gcast : type t t'. t ty -> t' ty -> t -> t' = fun t t' x ->
+    match check_eq t t' with Eq -> x
+end;;
+[%%expect{|
+module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+|}];;
+
+module HOAS = struct
+  open Typeable
+
+  type _ term =
+    | Tag : 't ty * int -> 't term
+    | Con : 't -> 't term
+    | Lam : 's ty * ('s term -> 't term) -> ('s -> 't) term
+    | App : ('s -> 't) term * 's term -> 't term
+
+  let rec intp : type t. t term -> t = function
+    | Tag (_, ix) -> failwith "HOAS.intp"
+    | Con v      -> v
+    | Lam (_, f) -> fun x -> intp (f (Con x))
+    | App (f, a) -> intp f (intp a)
+end;;
+[%%expect{|
+module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+|}];;
+
+module DeBruijn = struct
+  type ('env,'t) ix =
+    | ZeroIx : ('env * 't, 't) ix
+    | SuccIx : ('env,'t) ix -> ('env * 's, 't) ix
+
+  let rec to_int : type env t. (env,t) ix -> int = function
+    | ZeroIx   -> 0
+    | SuccIx n -> to_int n + 1
+
+  type ('env,'t) term =
+    | Var : ('env,'t) ix -> ('env,'t) term
+    | Con : 't -> ('env,'t) term
+    | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+    | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+
+  type _ stack =
+    | Empty : unit stack
+    | Push : 'env stack * 't -> ('env * 't) stack
+
+  let rec prj : type env t. (env,t) ix -> env stack -> t = fun i s ->
+    match i, s with
+    | ZeroIx, Push (s,v) -> v
+    | SuccIx i, Push (s,_) -> prj i s
+
+  let rec intp : type env t. (env,t) term -> env stack -> t = fun t s ->
+    match t with
+    | Var ix -> prj ix s
+    | Con v  -> v
+    | Lam b  -> fun x -> intp b (Push (s, x))
+    | App(f,a) -> intp f s (intp a s)
+end;;
+[%%expect{|
+module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+|}];;
+
+module Convert = struct
+  type (_,_) layout =
+    | EmptyLayout : ('env, unit) layout
+    | PushLayout  :
+        't Typeable.ty * ('env,'env') layout * ('env,'t) DeBruijn.ix
+           -> ('env,'env' * 't) layout
+
+  let rec size : type env env'. (env,env') layout -> int = function
+    | EmptyLayout -> 0
+    | PushLayout (_, lyt, _) -> size lyt + 1
+
+  let rec inc : type env env'. (env,env') layout -> (env * 't, env') layout =
+    function
+      | EmptyLayout -> EmptyLayout
+      | PushLayout (t, lyt, ix) -> PushLayout (t, inc lyt, DeBruijn.SuccIx ix)
+
+  let rec prj : type env env' t.
+        t Typeable.ty -> int -> (env,env') layout -> (env,t) DeBruijn.ix
+    = fun t n -> function
+      | EmptyLayout -> failwith "Convert.prj: internal error"
+      | PushLayout (t', l, ix) ->
+          if n = 0 then
+            match Typeable.check_eq t t' with Typeable.Eq -> ix
+          else prj t (n-1) l
+
+  let rec cvt :
+    type env t. (env,env) layout -> t HOAS.term -> (env,t) DeBruijn.term =
+    fun lyt -> function
+      | HOAS.Tag (t, sz) -> DeBruijn.Var (prj t (size lyt - sz -1) lyt)
+      | HOAS.Con v -> DeBruijn.Con v
+      | HOAS.Lam (t, f) ->
+          let lyt' = PushLayout (t, inc lyt, DeBruijn.ZeroIx) in
+          DeBruijn.Lam (cvt lyt' (f (HOAS.Tag (t, size lyt))))
+      | HOAS.App (f, a) ->
+          DeBruijn.App (cvt lyt f, cvt lyt a)
+
+  let convert t = cvt EmptyLayout t
+end;;
+[%%expect{|
+module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+|}];;
+
+module Main = struct
+  open HOAS
+  let i t = Lam (t, fun x -> x)
+  let zero t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> x))
+  let one t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, x)))
+  let two t =
+    Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, App (f, x))))
+  let three t =
+    Lam (Typeable.Fun(t,t),
+         fun f -> Lam(t, fun x -> App (f, App (f, App (f, x)))))
+  let plus t =
+    let t1 = Typeable.Fun(t,t) in let t2 = Typeable.Fun(t1,t1) in
+    Lam (t2, fun m -> Lam (t2, fun n ->
+      Lam (t1, fun f -> Lam(t, fun x -> App(App(m,f), App(App(n,f),x))))))
+
+  let plus_2_3 t = App (App (plus t, two t), three t)
+
+  open Convert
+
+  let i' = convert (i Typeable.Int)
+  let plus_2_3' = convert (plus_2_3 Typeable.Int)
+  let eval_plus_2_3' = DeBruijn.intp plus_2_3' DeBruijn.Empty succ 0
+end;;
+[%%expect{|
+module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+|}];;
diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
new file mode 100644
index 00000000..3003840f
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -0,0 +1,1072 @@
+module Exp =
+  struct
+
+    type _ t =
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+
+
+    let rec eval : type s . s t -> s =
+      function
+        | IntLit x -> x
+        | BoolLit y -> y
+        | Pair (x,y) ->
+            (eval x,eval y)
+        | App (f,a) ->
+            (eval f) (eval a)
+        | Abs f -> f
+
+    let discern : type a. a t -> _ = function
+        IntLit _ -> 1
+      | BoolLit _ -> 2
+      | Pair _ -> 3
+      | App _ -> 4
+      | Abs _ -> 5
+  end
+;;
+[%%expect{|
+module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+|}];;
+
+module List =
+  struct
+    type zero
+    type _ t =
+      | Nil : zero t
+      | Cons : 'a * 'b t -> ('a * 'b) t
+    let head =
+      function
+        | Cons (a,b) -> a
+    let tail =
+      function
+        | Cons (a,b) -> b
+    let rec length : type a . a t -> int =
+      function
+        | Nil -> 0
+        | Cons (a,b) -> length b
+  end
+;;
+[%%expect{|
+module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+|}];;
+
+module Nonexhaustive =
+  struct
+    type 'a u =
+      | C1 : int -> int u
+      | C2 : bool -> bool u
+
+    type 'a v =
+      | C1 : int -> int v
+
+    let unexhaustive : type s . s u -> s =
+      function
+        | C2 x -> x
+
+
+    module M : sig type t type u end =
+      struct
+        type t = int
+        type u = bool
+      end
+    type 'a t =
+      | Foo : M.t -> M.t t
+      | Bar : M.u -> M.u t
+    let same_type : type s . s t * s t -> bool  =
+      function
+        | Foo _ , Foo _ -> true
+        | Bar _, Bar _ -> true
+  end
+;;
+[%%expect{|
+Line _, characters 6-34:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+C1 _
+Line _, characters 6-77:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+|}];;
+
+module Exhaustive =
+  struct
+    type t = int
+    type u = bool
+    type 'a v =
+      | Foo : t -> t v
+      | Bar : u -> u v
+
+    let same_type : type s . s v * s v -> bool  =
+      function
+        | Foo _ , Foo _ -> true
+        | Bar _, Bar _ -> true
+  end
+;;
+[%%expect{|
+module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+|}];;
+
+module PR6862 = struct
+  class c (Some x) = object method x : int = x end
+  type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
+  class d (Just x) = object method x : int = x end
+end;;
+[%%expect{|
+Line _, characters 10-18:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+None
+Line _, characters 10-18:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Nothing
+module PR6862 :
+  sig
+    class c : int option -> object method x : int end
+    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
+    class d : int opt -> object method x : int end
+  end
+|}];;
+
+module Exhaustive2 = struct
+  type _ t = Int : int t
+  let f (x : bool t option) = match x with None -> ()
+end;;
+[%%expect{|
+module Exhaustive2 :
+  sig type _ t = Int : int t val f : bool t option -> unit end
+|}];;
+
+module PR6220 = struct
+  type 'a t = I : int t | F : float t
+  let f : int t -> int = function I -> 1
+  let g : int t -> int = function I -> 1 | _ -> 2 (* warn *)
+end;;
+[%%expect{|
+Line _, characters 43-44:
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case ' -> .'
+module PR6220 :
+  sig
+    type 'a t = I : int t | F : float t
+    val f : int t -> int
+    val g : int t -> int
+  end
+|}];;
+
+module PR6403 = struct
+  type (_, _) eq = Refl : ('a, 'a) eq
+  type empty = { bottom : 'a . 'a }
+  type ('a, 'b) sum = Left of 'a | Right of 'b
+
+  let notequal : ((int, bool) eq, empty) sum -> empty = function
+    | Right empty -> empty
+end;;
+[%%expect{|
+module PR6403 :
+  sig
+    type (_, _) eq = Refl : ('a, 'a) eq
+    type empty = { bottom : 'a. 'a; }
+    type ('a, 'b) sum = Left of 'a | Right of 'b
+    val notequal : ((int, bool) eq, empty) sum -> empty
+  end
+|}];;
+
+module PR6437 = struct
+  type ('a, 'b) ctx =
+    | Nil : (unit, unit) ctx
+    | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
+
+  type 'a var =
+    | O : ('a * unit) var
+    | S : 'a var -> ('a * unit) var
+
+  let rec f : type g1 g2. (g1, g2) ctx * g1 var -> g2 var = function
+    | Cons g, O -> O
+    | Cons g, S n -> S (f (g, n))
+    | _ -> .
+  (*| Nil, _ -> (assert false) *)  (* warns, but shouldn't *)
+end;;
+[%%expect{|
+module PR6437 :
+  sig
+    type ('a, 'b) ctx =
+        Nil : (unit, unit) ctx
+      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
+    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
+    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
+  end
+|}];;
+
+module PR6801 = struct
+  type _ value =
+    | String : string -> string value
+    | Float : float -> float value
+    | Any
+
+  let print_string_value (x : string value) =
+    match x with
+    | String s -> print_endline s (* warn : Any *)
+end;;
+[%%expect{|
+Line _, characters 4-50:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Any
+module PR6801 :
+  sig
+    type _ value =
+        String : string -> string value
+      | Float : float -> float value
+      | Any
+    val print_string_value : string value -> unit
+  end
+|}];;
+
+module Existential_escape =
+  struct
+    type _ t = C : int -> int t
+    type u = D : 'a t -> u
+    let eval (D x) = x
+  end
+;;
+[%%expect{|
+Line _, characters 21-22:
+Error: This expression has type $D_'a t
+       but an expression was expected of type 'a
+       The type constructor $D_'a would escape its scope
+|}];;
+
+module Rectype =
+  struct
+    type (_,_) t = C : ('a,'a) t
+    let f : type s. (s, s*s) t -> unit =
+      fun C -> () (* here s = s*s! *)
+  end
+;;
+[%%expect{|
+module Rectype :
+  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
+|}];;
+
+module Or_patterns =
+  struct
+      type _ t =
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+
+    let rec eval : type s . s t -> unit =
+      function
+        | (IntLit _ | BoolLit _) -> ()
+
+end
+;;
+[%%expect{|
+Line _, characters 11-19:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+       Type int is not compatible with type s
+|}];;
+
+module Polymorphic_variants =
+  struct
+      type _ t =
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+
+    let rec eval : type s . [`A] * s t -> unit =
+      function
+        | `A, IntLit _ -> ()
+        | `A, BoolLit _ -> ()
+  end
+;;
+[%%expect{|
+module Polymorphic_variants :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val eval : [ `A ] * 's t -> unit
+  end
+|}];;
+
+module Propagation = struct
+  type _ t =
+      IntLit : int -> int t
+    | BoolLit : bool -> bool t
+
+  let check : type s. s t -> s = function
+    | IntLit n -> n
+    | BoolLit b -> b
+
+  let check : type s. s t -> s = fun x ->
+    let r = match x with
+    | IntLit n -> (n : s )
+    | BoolLit b -> b
+    in r
+end
+;;
+[%%expect{|
+module Propagation :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val check : 's t -> 's
+  end
+|}, Principal{|
+Line _, characters 19-20:
+Error: This expression has type bool but an expression was expected of type s
+|}];;
+
+module Normal_constrs = struct
+  type a = A
+  type b = B
+
+  let f = function A -> 1 | B -> 2
+end;;
+[%%expect{|
+Line _, characters 28-29:
+Error: This variant pattern is expected to have type a
+       The constructor B does not belong to type a
+|}, Principal{|
+Line _, characters 28-29:
+Error: This pattern matches values of type b
+       but a pattern was expected which matches values of type a
+|}];;
+
+module PR6849 = struct
+  type 'a t = Foo : int t
+
+  let f : int -> int = function
+      Foo -> 5
+end;;
+[%%expect{|
+Line _, characters 6-9:
+Error: This pattern matches values of type 'a t
+       but a pattern was expected which matches values of type int
+|}];;
+
+type _ t = Int : int t ;;
+
+let ky x y = ignore (x = y); x ;;
+
+let test : type a. a t -> a =
+  function Int -> ky (1 : a) 1
+;;
+[%%expect{|
+type _ t = Int : int t
+val ky : 'a -> 'a -> 'a = 
+val test : 'a t -> 'a = 
+|}];;
+
+let test : type a. a t -> _ =
+  function Int -> 1       (* ok *)
+;;
+[%%expect{|
+val test : 'a t -> int = 
+|}];;
+
+let test : type a. a t -> _ =
+  function Int -> ky (1 : a) 1  (* fails *)
+;;
+[%%expect{|
+Line _, characters 18-30:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> ky (1 : a) 1  (* fails *)
+  in r
+;;
+[%%expect{|
+Line _, characters 30-42:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+  in r
+;;
+[%%expect{|
+Line _, characters 30-42:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let test (type a) x =
+  let r = match (x : a t) with Int -> ky 1 1
+  in r
+;;
+[%%expect{|
+val test : 'a t -> int = 
+|}];;
+
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> (1 : a)       (* ok! *)
+  in r
+;;
+[%%expect{|
+val test : 'a t -> 'a = 
+|}];;
+
+let test : type a. a t -> _ = fun x ->
+  let r = match x with Int -> 1       (* ok! *)
+  in r
+;;
+[%%expect{|
+val test : 'a t -> int = 
+|}];;
+
+let test : type a. a t -> a = fun x ->
+  let r : a = match x with Int -> 1
+  in r (* ok *)
+;;
+[%%expect{|
+val test : 'a t -> 'a = 
+|}];;
+
+let test2 : type a. a t -> a option = fun x ->
+  let r = ref None in
+  begin match x with Int -> r := Some (1 : a) end;
+  !r (* ok *)
+;;
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  begin match x with Int -> r := Some 1 end;
+  !r (* ok *)
+;;
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  let u = ref None in
+  begin match x with Int -> r := Some 1; u := !r end;
+  !u
+;; (* ok (u non-ambiguous) *)
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  let u = ref None in
+  begin match x with Int -> u := Some 1; r := !u end;
+  !u
+;; (* fails because u : (int | a) option ref *)
+[%%expect{|
+Line _, characters 46-48:
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let test2 : type a. a t -> a option = fun x ->
+  let u = ref None in
+  let r : a option ref = ref None in
+  begin match x with Int -> r := Some 1; u := !r end;
+  !u
+;; (* ok *)
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
+let test2 : type a. a t -> a option = fun x ->
+  let u = ref None in
+  let a =
+    let r : a option ref = ref None in
+    begin match x with Int -> r := Some 1; u := !r end;
+    !u
+  in a
+;; (* ok *)
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
+let either = ky
+let we_y1x (type a) (x : a) (v : a t) =
+  match v with Int -> let y = either 1 x in y
+;; (* fail *)
+[%%expect{|
+val either : 'a -> 'a -> 'a = 
+Line _, characters 44-45:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+(* Effect of external consraints *)
+let f (type a) (x : a t) y =
+  ignore (y : a);
+  let r = match x with Int -> (y : a) in (* ok *)
+  r
+;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
+let f (type a) (x : a t) y =
+  let r = match x with Int -> (y : a) in
+  ignore (y : a); (* ok *)
+  r
+;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
+let f (type a) (x : a t) y =
+  ignore (y : a);
+  let r = match x with Int -> y in (* ok *)
+  r
+;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
+let f (type a) (x : a t) y =
+  let r = match x with Int -> y in
+  ignore (y : a); (* ok *)
+  r
+;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
+let f (type a) (x : a t) (y : a) =
+  match x with Int -> y (* returns 'a *)
+;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
+(* Combination with local modules *)
+
+let f (type a) (x : a t) y =
+  match x with Int ->
+    let module M = struct type b = a let z = (y : b) end
+    in M.z
+;; (* fails because of aliasing... *)
+[%%expect{|
+Line _, characters 46-47:
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f (type a) (x : a t) y =
+  match x with Int ->
+    let module M = struct type b = int let z = (y : b) end
+    in M.z
+;; (* ok *)
+[%%expect{|
+val f : 'a t -> int -> int = 
+|}];;
+
+(* Objects and variants *)
+
+type _ h =
+  | Has_m :  h
+  | Has_b :  h
+
+let f : type a. a h -> a = function
+  | Has_m -> object method m = 1 end
+  | Has_b -> object method b = true end
+;;
+[%%expect{|
+type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = 
+|}];;
+
+type _ j =
+  | Has_A : [`A of int] j
+  | Has_B : [`B of bool] j
+
+let f : type a. a j -> a = function
+  | Has_A -> `A 1
+  | Has_B -> `B true
+;;
+[%%expect{|
+type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = 
+|}];;
+
+type (_,_) eq = Eq : ('a,'a) eq ;;
+
+let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
+  fun Eq o -> o
+;; (* fail *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+Line _, characters 4-90:
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+|}];;
+
+let f : type a b. (a,b) eq ->  ->  =
+  fun Eq o -> o
+;; (* fail *)
+[%%expect{|
+Line _, characters 14-15:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f (type a) (type b) (eq : (a,b) eq) (o : ) :  =
+  match eq with Eq -> o ;; (* should fail *)
+[%%expect{|
+Line _, characters 22-23:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f : type a b. (a,b) eq ->  ->  =
+  fun Eq o -> o
+;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+|}];;
+
+let int_of_bool : (bool,int) eq = Obj.magic Eq;;
+
+let x = object method m = true end;;
+let y = (x, f int_of_bool x);;
+
+let f : type a. (a, int) eq ->  -> bool =
+  fun Eq o -> ignore (o : ); o#m = 3
+;; (* should be ok *)
+[%%expect{|
+val int_of_bool : (bool, int) eq = Eq
+val x : < m : bool > = 
+val y : < m : bool > * < m : int > = (, )
+val f : ('a, int) eq -> < m : 'a > -> bool = 
+|}];;
+
+let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
+  fun eq o ->
+    ignore (o : < m : a >);
+    let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
+    r;;
+[%%expect{|
+val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+|}, Principal{|
+Line _, characters 44-45:
+Error: This expression has type < m : a >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
+  fun eq o ->
+    let r : < m : b > = match eq with Eq -> o in (* fail *)
+    ignore (o : < m : a >);
+    r;;
+[%%expect{|
+Line _, characters 44-45:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] =
+  fun Eq o -> o ;; (* fail *)
+[%%expect{|
+Line _, characters 14-15:
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f (type a b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] =
+  match eq with Eq -> v ;; (* should fail *)
+[%%expect{|
+Line _, characters 22-23:
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+  fun Eq o -> o ;; (* fail *)
+[%%expect{|
+Line _, characters 4-84:
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+|}];;
+
+let f : type a b. (a,b) eq -> [`A of a | `B] -> [`A of b | `B] =
+  fun Eq o -> o ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+|}];;
+
+let f : type a. (a, int) eq -> [`A of a] -> bool =
+  fun Eq v -> match v with `A 1 -> true | _ -> false
+;; (* ok *)
+[%%expect{|
+val f : ('a, int) eq -> [ `A of 'a ] -> bool = 
+|}];;
+
+let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
+  fun eq o ->
+    ignore (o : [< `A of a | `B]);
+    let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
+    r;;
+[%%expect{|
+val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+|}, Principal{|
+Line _, characters 49-50:
+Error: This expression has type [ `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
+  fun eq o ->
+    let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+    ignore (o : [< `A of a | `B]);
+    r;;
+[%%expect{|
+Line _, characters 49-50:
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
+(* Pattern matching *)
+
+type 'a t =
+    A of int | B of bool | C of float | D of 'a
+
+type _ ty =
+  | TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match x, y with
+  | _, A z -> z
+  | _, B z -> if z then 1 else 2
+  | _, C z -> truncate z
+  | TE TC, D [|1.0|] -> 14
+  | TA, D 0 -> -1
+  | TA, D z -> z
+  | TD "bye", D false -> 13
+  | TD "hello", D true -> 12
+ (* | TB, D z -> if z then 1 else 2 *)
+  | TC, D z -> truncate z
+  | _, D _ -> 0
+;;
+[%%expect{|
+type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = 
+|}];;
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match x, y with
+  | _, A z -> z
+  | _, B z -> if z then 1 else 2
+  | _, C z -> truncate z
+  | TE TC, D [|1.0|] -> 14
+  | TA, D 0 -> -1
+  | TA, D z -> z
+;; (* warn *)
+[%%expect{|
+Line _, characters 2-153:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(TE TC, D [| 0. |])
+val f : 'a ty -> 'a t -> int = 
+|}];;
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match y, x with
+  | A z, _ -> z
+  | B z, _ -> if z then 1 else 2
+  | C z, _ -> truncate z
+  | D [|1.0|], TE TC -> 14
+  | D 0, TA -> -1
+  | D z, TA -> z
+;; (* fail *)
+[%%expect{|
+Line _, characters 6-13:
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+|}];;
+
+type ('a,'b) pair = {right:'a; left:'b}
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match {left=x; right=y} with
+  | {left=_; right=A z} -> z
+  | {left=_; right=B z} -> if z then 1 else 2
+  | {left=_; right=C z} -> truncate z
+  | {left=TE TC; right=D [|1.0|]} -> 14
+  | {left=TA; right=D 0} -> -1
+  | {left=TA; right=D z} -> z
+;; (* fail *)
+[%%expect{|
+type ('a, 'b) pair = { right : 'a; left : 'b; }
+Line _, characters 25-32:
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+|}];;
+
+type ('a,'b) pair = {left:'a; right:'b}
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match {left=x; right=y} with
+  | {left=_; right=A z} -> z
+  | {left=_; right=B z} -> if z then 1 else 2
+  | {left=_; right=C z} -> truncate z
+  | {left=TE TC; right=D [|1.0|]} -> 14
+  | {left=TA; right=D 0} -> -1
+  | {left=TA; right=D z} -> z
+;; (* ok *)
+[%%expect{|
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+Line _, characters 2-244:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=TE TC; right=D [| 0. |]}
+val f : 'a ty -> 'a t -> int = 
+|}];;
+
+(* Injectivity *)
+
+module M : sig type 'a t val eq : ('a t, 'b t) eq end =
+  struct type 'a t = int let eq = Eq end
+;;
+
+let f : type a b. (a M.t, b M.t) eq -> (a, b) eq =
+  function Eq -> Eq (* fail *)
+;;
+[%%expect{|
+module M : sig type 'a t val eq : ('a t, 'b t) eq end
+Line _, characters 17-19:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+       Type a is not compatible with type b
+|}];;
+
+let f : type a b. (a M.t * a, b M.t * b) eq -> (a, b) eq =
+  function Eq -> Eq (* ok *)
+;;
+[%%expect{|
+val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = 
+|}];;
+
+let f : type a b. (a * a M.t, b * b M.t) eq -> (a, b) eq =
+  function Eq -> Eq (* ok *)
+;;
+[%%expect{|
+val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = 
+|}];;
+
+(* Applications of polymorphic variants *)
+
+type _ t =
+  | V1 : [`A | `B] t
+  | V2 : [`C | `D] t
+
+let f : type a. a t -> a = function
+  | V1 -> `A
+  | V2 -> `C
+;;
+
+f V1;;
+[%%expect{|
+type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
+val f : 'a t -> 'a = 
+- : [ `A | `B ] = `A
+|}];;
+
+(* PR#5425 and PR#5427 *)
+
+type _ int_foo =
+  | IF_constr :  int_foo
+
+type _ int_bar =
+  | IB_constr :  int_bar
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+[%%expect{|
+type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+Line _, characters 3-4:
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < foo : int >
+       Type $0 = < bar : int; .. > is not compatible with type <  >
+       The second object type has no method bar
+|}];;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+[%%expect{|
+Line _, characters 3-4:
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < bar : int; foo : int >
+       Type $0 = < bar : int; .. > is not compatible with type < bar : int >
+       The first object type has an abstract row, it cannot be closed
+|}];;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+[%%expect{|
+Line _, characters 2-26:
+Error: This expression has type < bar : int; foo : int; .. >
+       but an expression was expected of type 'a
+       The type constructor $1 would escape its scope
+|}];;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+[%%expect{|
+val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = 
+|}];;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  x, x#foo, x#bar
+;;
+[%%expect{|
+val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = 
+|}];;
+
+(* PR#5554 *)
+
+type 'a ty = Int : int -> int ty;;
+
+let f : type a. a ty -> a =
+  fun x -> match x with Int y -> y;;
+
+let g : type a. a ty -> a =
+  let () = () in
+  fun x -> match x with Int y -> y;;
+[%%expect{|
+type 'a ty = Int : int -> int ty
+val f : 'a ty -> 'a = 
+val g : 'a ty -> 'a = 
+|}];;
+
+(* Printing of anonymous variables *)
+
+module M = struct type _ t = int end;;
+module M = struct type _ t = T : int t end;;
+module N = M;;
+[%%expect{|
+module M : sig type _ t = int end
+module M : sig type _ t = T : int t end
+module N = M
+|}];;
+
+(* Principality *)
+
+(* adding a useless equation should not break inference *)
+let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b ->
+  let Eq = ab in
+  let x =
+    let Eq = aint in
+    if true then a else b
+  in ignore x
+;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = 
+|}];;
+
+let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
+  let Eq = ab in
+  let x =
+    let Eq = bint in
+    if true then a else b
+  in ignore x
+;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/unify_mb.ml b/testsuite/tests/typing-gadts/unify_mb.ml
new file mode 100644
index 00000000..f11f92cc
--- /dev/null
+++ b/testsuite/tests/typing-gadts/unify_mb.ml
@@ -0,0 +1,241 @@
+(* First-Order Unification by Structural Recursion *)
+(* Conor McBride, JFP 13(6) *)
+(* http://strictlypositive.org/publications.html *)
+
+(* This is a translation of the code part to ocaml *)
+(* Of course, we do not prove other properties, not even termination *)
+
+(* 2.2 Inductive Families *)
+
+type zero = Zero
+type _ succ = Succ
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+
+type _ fin =
+  | FZ : 'a succ fin
+  | FS : 'a fin -> 'a succ fin
+
+(* We cannot define
+     val empty : zero fin -> 'a
+   because we cannot write an empty pattern matching.
+   This might be useful to have *)
+
+(* In place, prove that the parameter is 'a succ *)
+type _ is_succ = IS : 'a succ is_succ
+
+let fin_succ : type n. n fin -> n is_succ = function
+  | FZ -> IS
+  | FS _ -> IS
+;;
+[%%expect{|
+type zero = Zero
+type _ succ = Succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
+type _ is_succ = IS : 'a succ is_succ
+val fin_succ : 'n fin -> 'n is_succ = 
+|}];;
+
+(* 3 First-Order Terms, Renaming and Substitution *)
+
+type 'a term =
+  | Var of 'a fin
+  | Leaf
+  | Fork of 'a term * 'a term
+
+let var x = Var x
+
+let lift r : 'm fin -> 'n term = fun x -> Var (r x)
+
+let rec pre_subst f = function
+  | Var x -> f x
+  | Leaf -> Leaf
+  | Fork (t1, t2) -> Fork (pre_subst f t1, pre_subst f t2)
+
+let comp_subst f g (x : 'a fin) = pre_subst f (g x)
+(*  val comp_subst :
+    ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term *)
+;;
+[%%expect{|
+type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
+val var : 'a fin -> 'a term = 
+val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = 
+val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = 
+val comp_subst :
+  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = 
+|}];;
+
+(* 4 The Occur-Check, through thick and thin *)
+
+let rec thin : type n. n succ fin -> n fin -> n succ fin =
+  fun x y -> match x, y with
+  | FZ, y    -> FS y
+  | FS x, FZ -> FZ
+  | FS x, FS y -> FS (thin x y)
+[%%expect{|
+val thin : 'n succ fin -> 'n fin -> 'n succ fin = 
+|}];;
+
+let bind t f =
+  match t with
+  | None   -> None
+  | Some x -> f x
+(* val bind : 'a option -> ('a -> 'b option) -> 'b option *)
+[%%expect{|
+val bind : 'a option -> ('a -> 'b option) -> 'b option = 
+|}];;
+
+let rec thick : type n. n succ fin -> n succ fin -> n fin option =
+  fun x y -> match x, y with
+  | FZ, FZ   -> None
+  | FZ, FS y -> Some y
+  | FS x, FZ -> let IS = fin_succ x in Some FZ
+  | FS x, FS y ->
+      let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x))
+[%%expect{|
+val thick : 'n succ fin -> 'n succ fin -> 'n fin option = 
+|}];;
+
+let rec check : type n. n succ fin -> n succ term -> n term option =
+  fun x t -> match t with
+  | Var y -> bind (thick x y) (fun x -> Some (Var x))
+  | Leaf  -> Some Leaf
+  | Fork (t1, t2) ->
+      bind (check x t1) (fun t1 ->
+        bind (check x t2) (fun t2 -> Some (Fork (t1, t2))))
+[%%expect{|
+val check : 'n succ fin -> 'n succ term -> 'n term option = 
+|}];;
+
+let subst_var x t' y =
+  match thick x y with
+  | None -> t'
+  | Some y' -> Var y'
+(* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *)
+[%%expect{|
+val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = 
+|}];;
+
+let subst x t' = pre_subst (subst_var x t')
+(* val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term *)
+;;
+[%%expect{|
+val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = 
+|}];;
+
+(* 5 A Refinement of Substitution *)
+
+type (_,_) alist =
+  | Anil  : ('n,'n) alist
+  | Asnoc : ('m,'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+
+let rec sub : type m n. (m,n) alist -> m fin -> n term = function
+  | Anil -> var
+  | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t)
+[%%expect{|
+type (_, _) alist =
+    Anil : ('n, 'n) alist
+  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+val sub : ('m, 'n) alist -> 'm fin -> 'n term = 
+|}];;
+
+let rec append : type m n l. (m,n) alist -> (l,m) alist -> (l,n) alist =
+  fun r s -> match s with
+  | Anil -> r
+  | Asnoc (s, t, x) -> Asnoc (append r s, t, x)
+[%%expect{|
+val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = 
+|}];;
+
+type _ ealist = EAlist : ('a,'b) alist -> 'a ealist
+
+let asnoc a t' x = EAlist (Asnoc (a, t', x))
+[%%expect{|
+type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
+val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
+  
+|}];;
+
+(* Extra work: we need sub to work on ealist too, for examples *)
+let rec weaken_fin : type n. n fin -> n succ fin = function
+  | FZ -> FZ
+  | FS x -> FS (weaken_fin x)
+
+let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t
+
+let rec weaken_alist : type m n. (m, n) alist -> (m succ, n succ) alist =
+  function
+    | Anil -> Anil
+    | Asnoc (s, t, x) -> Asnoc (weaken_alist s, weaken_term t, weaken_fin x)
+
+let rec sub' : type m. m ealist -> m fin -> m term = function
+  | EAlist Anil -> var
+  | EAlist (Asnoc (s, t, x)) ->
+      comp_subst (sub' (EAlist (weaken_alist s)))
+        (fun t' -> weaken_term (subst_var x t t'))
+
+let subst' d = pre_subst (sub' d)
+(*  val subst' : 'a ealist -> 'a term -> 'a term *)
+;;
+[%%expect{|
+val weaken_fin : 'n fin -> 'n succ fin = 
+val weaken_term : 'a term -> 'a succ term = 
+val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = 
+val sub' : 'm ealist -> 'm fin -> 'm term = 
+val subst' : 'a ealist -> 'a term -> 'a term = 
+|}];;
+
+(* 6 First-Order Unification *)
+
+let flex_flex x y =
+  match thick x y with
+  | Some y' -> asnoc Anil (Var y') x
+  | None -> EAlist Anil
+(* val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist *)
+
+let flex_rigid x t =
+  bind (check x t) (fun t' -> Some (asnoc Anil t' x))
+(* val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option *)
+
+let rec amgu : type m. m term -> m term -> m ealist -> m ealist option =
+  fun s t acc -> match s, t, acc with
+  | Leaf, Leaf, _   -> Some acc
+  | Leaf, Fork _, _ -> None
+  | Fork _, Leaf, _ -> None
+  | Fork (s1, s2), Fork (t1, t2), _ ->
+      bind (amgu s1 t1 acc) (amgu s2 t2)
+  | Var x, Var y, EAlist Anil -> let IS = fin_succ x in Some (flex_flex x y)
+  | Var x, t,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | t, Var x,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | s, t, EAlist(Asnoc(d,r,z)) ->
+      bind (amgu (subst z r s) (subst z r t) (EAlist d))
+           (fun (EAlist d) -> Some (asnoc d r z))
+
+let mgu s t = amgu s t (EAlist Anil)
+(* val mgu : 'a term -> 'a term -> 'a ealist option *)
+;;
+[%%expect{|
+val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = 
+val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = 
+val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = 
+val mgu : 'a term -> 'a term -> 'a ealist option = 
+|}];;
+
+let s = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+let t = Fork (Var (FS FZ), Var (FS FZ))
+let d = match mgu s t with Some x -> x | None -> failwith "mgu"
+let s' = subst' d s
+let t' = subst' d t
+;;
+[%%expect{|
+val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
+val d : '_a succ succ succ ealist =
+  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
+val s' : '_a succ succ succ term =
+  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
+val t' : '_a succ succ succ term =
+  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
+|}];;
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml
new file mode 100644
index 00000000..b4e60e8c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml
@@ -0,0 +1,71 @@
+(* Injectivity *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a b) (x : a) ->
+    let module M =
+      (functor (T : sig type 'a t end) ->
+       struct
+         let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+       end)
+        (struct type 'a t = unit end)
+    in M.f Refl
+;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 44-52:
+Error: Type a is not a subtype of b
+|}];;
+
+(* Variance and subtyping *)
+
+type (_, +_) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let bad_proof (type a) =
+      (Refl : (< m : a>, ) eq :> (, < >) eq) in
+    let downcast : type a. (a, < >) eq -> < > -> a =
+      fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
+    (downcast bad_proof ((object method m = x end) :> < >)) # m
+;;
+[%%expect{|
+Line _, characters 0-36:
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+|}];;
+
+(* Record patterns *)
+
+type _ t =
+  | IntLit : int t
+  | BoolLit : bool t
+
+let check : type s . s t * s -> bool = function
+  | BoolLit, false -> false
+  | IntLit , 6 -> false
+;;
+[%%expect{|
+type _ t = IntLit : int t | BoolLit : bool t
+Line _, characters 39-99:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(IntLit, 0)
+val check : 's t * 's -> bool = 
+|}];;
+
+type ('a, 'b) pair = { fst : 'a; snd : 'b }
+
+let check : type s . (s t, s) pair -> bool = function
+  | {fst = BoolLit; snd = false} -> false
+  | {fst = IntLit ; snd =  6} -> false
+;;
+[%%expect{|
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+Line _, characters 45-134:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{fst=IntLit; snd=0}
+val check : ('s t, 's) pair -> bool = 
+|}];;
diff --git a/testsuite/tests/typing-immediate/Makefile b/testsuite/tests/typing-immediate/Makefile
new file mode 100644
index 00000000..0b15e777
--- /dev/null
+++ b/testsuite/tests/typing-immediate/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-immediate/immediate.ml b/testsuite/tests/typing-immediate/immediate.ml
new file mode 100644
index 00000000..559e2a11
--- /dev/null
+++ b/testsuite/tests/typing-immediate/immediate.ml
@@ -0,0 +1,162 @@
+module type S = sig type t [@@immediate] end;;
+module F (M : S) : S = M;;
+[%%expect{|
+module type S = sig type t [@@immediate] end
+module F : functor (M : S) -> S
+|}];;
+
+(* VALID DECLARATIONS *)
+
+module A = struct
+  (* Abstract types can be immediate *)
+  type t [@@immediate]
+
+  (* [@@immediate] tag here is unnecessary but valid since t has it *)
+  type s = t [@@immediate]
+
+  (* Again, valid alias even without tag *)
+  type r = s
+
+  (* Mutually recursive declarations work as well *)
+  type p = q [@@immediate]
+  and q = int
+end;;
+[%%expect{|
+module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+|}];;
+
+(* Valid using with constraints *)
+module type X = sig type t end;;
+module Y = struct type t = int end;;
+module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+[%%expect{|
+module type X = sig type t end
+module Y : sig type t = int end
+module Z : sig type t [@@immediate] end
+|}];;
+
+(* Valid using an explicit signature *)
+module M_valid : S = struct type t = int end;;
+module FM_valid = F (struct type t = int end);;
+[%%expect{|
+module M_valid : S
+module FM_valid : S
+|}];;
+
+(* Practical usage over modules *)
+module Foo : sig type t val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Foo : sig type t val x : t ref end
+|}];;
+
+module Bar : sig type t [@@immediate] val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Bar : sig type t [@@immediate] val x : t ref end
+|}];;
+
+let test f =
+  let start = Sys.time() in f ();
+  (Sys.time() -. start);;
+[%%expect{|
+val test : (unit -> 'a) -> float = 
+|}];;
+
+let test_foo () =
+  for i = 0 to 100_000_000 do
+    Foo.x := !Foo.x
+  done;;
+[%%expect{|
+val test_foo : unit -> unit = 
+|}];;
+
+let test_bar () =
+  for i = 0 to 100_000_000 do
+    Bar.x := !Bar.x
+  done;;
+[%%expect{|
+val test_bar : unit -> unit = 
+|}];;
+
+(* Uncomment these to test. Should see substantial speedup!
+let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
+let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
+
+
+(* INVALID DECLARATIONS *)
+
+(* Cannot directly declare a non-immediate type as immediate *)
+module B = struct
+  type t = string [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-31:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Not guaranteed that t is immediate, so this is an invalid declaration *)
+module C = struct
+  type t
+  type s = t [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Can't ascribe to an immediate type signature with a non-immediate type *)
+module D : sig type t [@@immediate] end = struct
+  type t = string
+end;;
+[%%expect{|
+Line _, characters 42-70:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Same as above but with explicit signature *)
+module M_invalid : S = struct type t = string end;;
+module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line _, characters 23-49:
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Can't use a non-immediate type even if mutually recursive *)
+module E = struct
+  type t = s [@@immediate]
+  and s = string
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
diff --git a/testsuite/tests/typing-implicit_unpack/Makefile b/testsuite/tests/typing-implicit_unpack/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
new file mode 100644
index 00000000..82fca3a5
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
@@ -0,0 +1,165 @@
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;
diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
new file mode 100644
index 00000000..50e54a07
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
@@ -0,0 +1,184 @@
+
+# * * * * * * * * *                               val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = 
+val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = 
+val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = 
+module type S = sig type t val x : t end
+# val f : (module S with type t = int) -> int = 
+# Characters 6-37:
+  let f (module M : S with type t = 'a) = M.x;; (* Error *)
+        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+# val f : (module S with type t = 'a) -> 'a = 
+# - : int = 1
+#   type 'a s = { s : (module S with type t = 'a); }
+# - : int s = {s = }
+# Characters 9-19:
+  let f {s=(module M)} = M.x;; (* Error *)
+           ^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+# val f : 'a s -> 'a = 
+#   type s = { s : (module S with type t = int); }
+# val f : s -> int = 
+# val f : s -> s -> int = 
+#   module type S = sig val x : int end
+# val f : (module S) -> int -> (module S) -> int = 
+# Characters 8-37:
+  let m = (module struct let x = 3 end);; (* Error *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The signature for this packaged module couldn't be inferred.
+# val m : (module S) = 
+# - : int = 7
+# - : int = 6
+#   - : int = 3
+# Characters 4-14:
+  let (module M) = m;; (* Error: only allowed in [let .. in] *)
+      ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+# Characters 14-24:
+  class c = let (module M) = m in object end;; (* Error again *)
+                ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+# module M : S
+#   module type S' = sig val f : int -> int end
+#       - : int = 6
+#                                                                                                                                                                                   module type S = sig type t type u val x : t * u end
+val f :
+  (module S with type t = int and type u = bool) list ->
+  (module S with type u = bool) list = 
+module TypEq :
+  sig
+    type ('a, 'b) t
+    val apply : ('a, 'b) t -> 'a -> 'b
+    val refl : ('a, 'a) t
+    val sym : ('a, 'b) t -> ('b, 'a) t
+  end
+module rec Typ :
+  sig
+    module type PAIR =
+      sig
+        type t
+        and t1
+        and t2
+        val eq : (t, t1 * t2) TypEq.t
+        val t1 : t1 Typ.typ
+        val t2 : t2 Typ.typ
+      end
+    type 'a typ =
+        Int of ('a, int) TypEq.t
+      | String of ('a, string) TypEq.t
+      | Pair of (module PAIR with type t = 'a)
+  end
+val int : int Typ.typ = Int 
+val str : string Typ.typ = String 
+val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = 
+val to_string : 'a Typ.typ -> 'a -> string = 
+module type MapT =
+  sig
+    type key
+    type +'a t
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val mem : key -> 'a t -> bool
+    val add : key -> 'a -> 'a t -> 'a t
+    val singleton : key -> 'a -> 'a t
+    val remove : key -> 'a t -> 'a t
+    val merge :
+      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all : (key -> 'a -> bool) -> 'a t -> bool
+    val exists : (key -> 'a -> bool) -> 'a t -> bool
+    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal : 'a t -> int
+    val bindings : 'a t -> (key * 'a) list
+    val min_binding : 'a t -> key * 'a
+    val min_binding_opt : 'a t -> (key * 'a) option
+    val max_binding : 'a t -> key * 'a
+    val max_binding_opt : 'a t -> (key * 'a) option
+    val choose : 'a t -> key * 'a
+    val choose_opt : 'a t -> (key * 'a) option
+    val split : key -> 'a t -> 'a t * 'a option * 'a t
+    val find : key -> 'a t -> 'a
+    val find_opt : key -> 'a t -> 'a option
+    val find_first : (key -> bool) -> 'a t -> key * 'a
+    val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+    val find_last : (key -> bool) -> 'a t -> key * 'a
+    val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    type data
+    type map
+    val of_t : data t -> map
+    val to_t : map -> data t
+  end
+type ('k, 'd, 'm) map =
+    (module MapT with type data = 'd and type key = 'k and type map = 'm)
+val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = 
+module SSMap :
+  sig
+    type key = String.t
+    type 'a t = 'a Map.Make(String).t
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val mem : key -> 'a t -> bool
+    val add : key -> 'a -> 'a t -> 'a t
+    val singleton : key -> 'a -> 'a t
+    val remove : key -> 'a t -> 'a t
+    val merge :
+      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all : (key -> 'a -> bool) -> 'a t -> bool
+    val exists : (key -> 'a -> bool) -> 'a t -> bool
+    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal : 'a t -> int
+    val bindings : 'a t -> (key * 'a) list
+    val min_binding : 'a t -> key * 'a
+    val min_binding_opt : 'a t -> (key * 'a) option
+    val max_binding : 'a t -> key * 'a
+    val max_binding_opt : 'a t -> (key * 'a) option
+    val choose : 'a t -> key * 'a
+    val choose_opt : 'a t -> (key * 'a) option
+    val split : key -> 'a t -> 'a t * 'a option * 'a t
+    val find : key -> 'a t -> 'a
+    val find_opt : key -> 'a t -> 'a option
+    val find_first : (key -> bool) -> 'a t -> key * 'a
+    val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+    val find_last : (key -> bool) -> 'a t -> key * 'a
+    val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    type data = string
+    type map = data t
+    val of_t : 'a -> 'a
+    val to_t : 'a -> 'a
+  end
+val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  
+#         val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  
+#           val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  
+#       val ssmap :
+  (module MapT with type data = SSMap.data and type key = SSMap.key and type map = 
+   SSMap.map) =
+  
+#   val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = 
+#   - : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = 
+# 
diff --git a/testsuite/tests/typing-labels/Makefile b/testsuite/tests/typing-labels/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/typing-labels/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-labels/mixin.ml b/testsuite/tests/typing-labels/mixin.ml
new file mode 100644
index 00000000..5ca686a1
--- /dev/null
+++ b/testsuite/tests/typing-labels/mixin.ml
@@ -0,0 +1,155 @@
+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
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = eval1 (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 = eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
diff --git a/testsuite/tests/typing-labels/mixin.reference b/testsuite/tests/typing-labels/mixin.reference
new file mode 100644
index 00000000..27087bd9
--- /dev/null
+++ b/testsuite/tests/typing-labels/mixin.reference
@@ -0,0 +1,3 @@
+y
+-6 + x
+9
diff --git a/testsuite/tests/typing-labels/mixin2.ml b/testsuite/tests/typing-labels/mixin2.ml
new file mode 100644
index 00000000..fd2b2897
--- /dev/null
+++ b/testsuite/tests/typing-labels/mixin2.ml
@@ -0,0 +1,190 @@
+(* 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)
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
diff --git a/testsuite/tests/typing-labels/mixin2.reference b/testsuite/tests/typing-labels/mixin2.reference
new file mode 100644
index 00000000..27087bd9
--- /dev/null
+++ b/testsuite/tests/typing-labels/mixin2.reference
@@ -0,0 +1,3 @@
+y
+-6 + x
+9
diff --git a/testsuite/tests/typing-labels/mixin3.ml b/testsuite/tests/typing-labels/mixin3.ml
new file mode 100644
index 00000000..5b987e81
--- /dev/null
+++ b/testsuite/tests/typing-labels/mixin3.ml
@@ -0,0 +1,184 @@
+(* 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
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
diff --git a/testsuite/tests/typing-labels/mixin3.reference b/testsuite/tests/typing-labels/mixin3.reference
new file mode 100644
index 00000000..27087bd9
--- /dev/null
+++ b/testsuite/tests/typing-labels/mixin3.reference
@@ -0,0 +1,3 @@
+y
+-6 + x
+9
diff --git a/testsuite/tests/typing-misc-bugs/Makefile b/testsuite/tests/typing-misc-bugs/Makefile
new file mode 100644
index 00000000..994943bc
--- /dev/null
+++ b/testsuite/tests/typing-misc-bugs/Makefile
@@ -0,0 +1,17 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml b/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml
new file mode 100644
index 00000000..bd55cc0a
--- /dev/null
+++ b/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml
@@ -0,0 +1,94 @@
+type sexp = A of string | L of sexp list
+type 'a t = 'a array
+let _ = fun (_ : 'a t)  -> ()
+
+let array_of_sexp _ _ = [| |]
+let sexp_of_array _ _ = A "foo"
+let sexp_of_int _ = A "42"
+let int_of_sexp _ = 42
+
+let t_of_sexp : 'a . (sexp -> 'a) -> sexp -> 'a t=
+  let _tp_loc = "core_array.ml.t" in
+  fun _of_a  -> fun t  -> (array_of_sexp _of_a) t
+let _ = t_of_sexp
+let sexp_of_t : 'a . ('a -> sexp) -> 'a t -> sexp=
+  fun _of_a  -> fun v  -> (sexp_of_array _of_a) v
+let _ = sexp_of_t
+module T =
+  struct
+    module Int =
+      struct
+        type t_ = int array
+        let _ = fun (_ : t_)  -> ()
+
+        let t__of_sexp: sexp -> t_ =
+          let _tp_loc = "core_array.ml.T.Int.t_" in
+          fun t  -> (array_of_sexp int_of_sexp) t
+        let _ = t__of_sexp
+        let sexp_of_t_: t_ -> sexp =
+          fun v  -> (sexp_of_array sexp_of_int) v
+        let _ = sexp_of_t_
+      end
+  end
+module type Permissioned  =
+  sig
+    type ('a,-'perms) t
+  end
+module Permissioned :
+  sig
+    type ('a,-'perms) t
+    include
+      sig
+        val t_of_sexp :
+          (sexp -> 'a) ->
+            (sexp -> 'perms) -> sexp -> ('a,'perms) t
+        val sexp_of_t :
+          ('a -> sexp) ->
+            ('perms -> sexp) -> ('a,'perms) t -> sexp
+      end
+    module Int :
+    sig
+      type nonrec -'perms t = (int,'perms) t
+      include
+        sig
+          val t_of_sexp :
+            (sexp -> 'perms) -> sexp -> 'perms t
+          val sexp_of_t :
+            ('perms -> sexp) -> 'perms t -> sexp
+        end
+    end
+  end =
+  struct
+    type ('a,-'perms) t = 'a array
+    let _ = fun (_ : ('a,'perms) t)  -> ()
+
+    let t_of_sexp :
+      'a 'perms .
+        (sexp -> 'a) ->
+          (sexp -> 'perms) -> sexp -> ('a,'perms) t=
+      let _tp_loc = "core_array.ml.Permissioned.t" in
+      fun _of_a  -> fun _of_perms  -> fun t  -> (array_of_sexp _of_a) t
+    let _ = t_of_sexp
+    let sexp_of_t :
+      'a 'perms .
+        ('a -> sexp) ->
+          ('perms -> sexp) -> ('a,'perms) t -> sexp=
+      fun _of_a  -> fun _of_perms  -> fun v  -> (sexp_of_array _of_a) v
+    let _ = sexp_of_t
+    module Int =
+      struct
+        include T.Int
+        type -'perms t = t_
+        let _ = fun (_ : 'perms t)  -> ()
+
+        let t_of_sexp :
+          'perms . (sexp -> 'perms) -> sexp -> 'perms t=
+          let _tp_loc = "core_array.ml.Permissioned.Int.t" in
+          fun _of_perms  -> fun t  -> t__of_sexp t
+        let _ = t_of_sexp
+        let sexp_of_t :
+          'perms . ('perms -> sexp) -> 'perms t -> sexp=
+          fun _of_perms  -> fun v  -> sexp_of_t_ v
+        let _ = sexp_of_t
+      end
+  end
diff --git a/testsuite/tests/typing-misc-bugs/pr6303_bad.ml b/testsuite/tests/typing-misc-bugs/pr6303_bad.ml
new file mode 100644
index 00000000..7d4539c5
--- /dev/null
+++ b/testsuite/tests/typing-misc-bugs/pr6303_bad.ml
@@ -0,0 +1,3 @@
+type 'a  foo = {x: 'a; y: int}
+let r = {{x = 0; y = 0} with x = 0}
+let r' : string foo = r
diff --git a/testsuite/tests/typing-misc-bugs/pr6946_bad.ml b/testsuite/tests/typing-misc-bugs/pr6946_bad.ml
new file mode 100644
index 00000000..bbaefe90
--- /dev/null
+++ b/testsuite/tests/typing-misc-bugs/pr6946_bad.ml
@@ -0,0 +1,2 @@
+external foo : int = "%ignore";;
+let _ = foo ();;
diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile
new file mode 100644
index 00000000..0b15e777
--- /dev/null
+++ b/testsuite/tests/typing-misc/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml
new file mode 100644
index 00000000..76a360df
--- /dev/null
+++ b/testsuite/tests/typing-misc/constraints.ml
@@ -0,0 +1,112 @@
+type 'a t = [`A of 'a t t] as 'a;; (* fails *)
+[%%expect{|
+Line _, characters 0-32:
+Error: The definition of t contains a cycle:
+       'a t t as 'a
+|}, Principal{|
+Line _, characters 0-32:
+Error: The definition of t contains a cycle:
+       [ `A of 'a t t ] as 'a
+|}];;
+type 'a t = [`A of 'a t t];; (* fails *)
+[%%expect{|
+Line _, characters 0-26:
+Error: In the definition of t, type 'a t t should be 'a t
+|}];;
+type 'a t = [`A of 'a t t] constraint 'a = 'a t;; (* fails since 4.04 *)
+[%%expect{|
+Line _, characters 0-47:
+Error: The type abbreviation t is cyclic
+|}];;
+type 'a t = [`A of 'a t] constraint 'a = 'a t;; (* fails since 4.04 *)
+[%%expect{|
+Line _, characters 0-45:
+Error: The type abbreviation t is cyclic
+|}];;
+type 'a t = [`A of 'a] as 'a;;
+[%%expect{|
+type 'a t = 'a constraint 'a = [ `A of 'a ]
+|}, Principal{|
+type 'a t = [ `A of 'b ] as 'b constraint 'a = [ `A of 'a ]
+|}];;
+type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+[%%expect{|
+Line _, characters 0-41:
+Error: The definition of v contains a cycle:
+       t
+|}];;
+
+type 'a t = 'a;;
+let f (x : 'a t as 'a) = ();; (* ok *)
+[%%expect{|
+type 'a t = 'a
+val f : 'a -> unit = 
+|}];;
+
+let f (x : 'a t) (y : 'a) = x = y;;
+[%%expect{|
+val f : 'a t -> 'a -> bool = 
+|}];;
+
+(* PR#6505 *)
+module type PR6505 = sig
+  type 'o is_an_object = < .. > as 'o
+  and 'o abs constraint 'o = 'o is_an_object
+  val abs : 'o is_an_object -> 'o abs
+  val unabs : 'o abs -> 'o
+end
+;; (* fails *)
+[%%expect{|
+Line _, characters 2-44:
+Error: The definition of abs contains a cycle:
+       'a is_an_object as 'a
+|}];;
+
+module PR6505a = struct
+  type 'o is_an_object = < .. > as 'o
+  and ('k,'l) abs = 'l constraint 'k = 'l is_an_object
+  let y : ('o, 'o) abs = object end
+end;;
+let _ = PR6505a.y#bang;; (* fails *)
+[%%expect{|
+module PR6505a :
+  sig
+    type 'o is_an_object = 'o constraint 'o = < .. >
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val y : (<  > is_an_object, <  > is_an_object) abs
+  end
+Line _, characters 8-17:
+Error: This expression has type
+         (<  > PR6505a.is_an_object, <  > PR6505a.is_an_object) PR6505a.abs
+       It has no method bang
+|}, Principal{|
+module PR6505a :
+  sig
+    type 'o is_an_object = 'o constraint 'o = < .. >
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val y : (<  >, <  >) abs
+  end
+Line _, characters 8-17:
+Error: This expression has type (<  >, <  >) PR6505a.abs
+       It has no method bang
+|}]
+
+module PR6505b = struct
+  type 'o is_an_object = [> ] as 'o
+  and ('k,'l) abs = 'l constraint 'k = 'l is_an_object
+  let x : ('a, 'a) abs = `Foo 6
+end;;
+let () = print_endline (match PR6505b.x with `Bar s -> s);; (* fails *)
+[%%expect{|
+module PR6505b :
+  sig
+    type 'o is_an_object = 'o constraint 'o = [>  ]
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val x : (([> `Foo of int ] as 'a) is_an_object, 'a is_an_object) abs
+  end
+Line _, characters 23-57:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`Foo _
+Exception: Match_failure ("", 6, 23).
+|}]
diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml
new file mode 100644
index 00000000..bd6c3a6f
--- /dev/null
+++ b/testsuite/tests/typing-misc/labels.ml
@@ -0,0 +1,27 @@
+(* PR#5835 *)
+let f ~x = x + 1;;
+f ?x:0;;
+[%%expect{|
+val f : x:int -> int = 
+Line _, characters 5-6:
+Warning 43: the label x is not optional.
+- : int = 1
+|}];;
+
+(* PR#6352 *)
+let foo (f : unit -> unit) = ();;
+let g ?x () = ();;
+foo ((); g);;
+[%%expect{|
+val foo : (unit -> unit) -> unit = 
+val g : ?x:'a -> unit -> unit = 
+- : unit = ()
+|}];;
+
+(* PR#5748 *)
+foo (fun ?opt () -> ()) ;; (* fails *)
+[%%expect{|
+Line _, characters 4-23:
+Error: This function should have type unit -> unit
+       but its first argument is labelled ?opt
+|}];;
diff --git a/testsuite/tests/typing-misc/occur_check.ml b/testsuite/tests/typing-misc/occur_check.ml
new file mode 100644
index 00000000..c2c95f56
--- /dev/null
+++ b/testsuite/tests/typing-misc/occur_check.ml
@@ -0,0 +1,18 @@
+(* PR#5907 *)
+
+type 'a t = 'a;;
+let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+[%%expect{|
+type 'a t = 'a
+Line _, characters 42-43:
+Error: This expression has type 'a list
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a list
+|}];;
+let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+[%%expect{|
+Line _, characters 42-43:
+Error: This expression has type 'a * 'b
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a * 'b
+|}];;
diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml
new file mode 100644
index 00000000..a37eeb7b
--- /dev/null
+++ b/testsuite/tests/typing-misc/polyvars.ml
@@ -0,0 +1,59 @@
+type ab = [ `A | `B ];;
+let f (x : [`A]) = match x with #ab -> 1;;
+[%%expect{|
+type ab = [ `A | `B ]
+Line _, characters 32-35:
+Error: This pattern matches values of type [? `A | `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}];;
+let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+[%%expect{|
+Line _, characters 31-34:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}, Principal{|
+Line _, characters 31-34:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+|}];;
+let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+[%%expect{|
+Line _, characters 34-36:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}, Principal{|
+Line _, characters 34-36:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+|}];;
+
+let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+[%%expect{|
+Line _, characters 49-51:
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = 
+|}];;
+let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+[%%expect{|
+Line _, characters 47-49:
+Error: This pattern matches values of type [? `C ]
+       but a pattern was expected which matches values of type [ `A | `B ]
+       The second variant type does not allow tag(s) `C
+|}];;
+
+(* PR#6787 *)
+let revapply x f = f x;;
+
+let f x (g : [< `Foo]) =
+  let y = `Bar x, g in
+  revapply y (fun ((`Bar i), _) -> i);;
+(* f : 'a -> [< `Foo ] -> 'a *)
+[%%expect{|
+val revapply : 'a -> ('a -> 'b) -> 'b = 
+val f : 'a -> [< `Foo ] -> 'a = 
+|}];;
diff --git a/testsuite/tests/typing-misc/pr6939.ml b/testsuite/tests/typing-misc/pr6939.ml
new file mode 100755
index 00000000..2acdd12e
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr6939.ml
@@ -0,0 +1,15 @@
+let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+Warning 10: this expression should have type unit.
+Line _, characters 12-23:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 16-17:
+Warning 26: unused variable u.
+Line _, characters 12-32:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
diff --git a/testsuite/tests/typing-misc/pr7103.ml b/testsuite/tests/typing-misc/pr7103.ml
new file mode 100644
index 00000000..f7420fd2
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr7103.ml
@@ -0,0 +1,39 @@
+type 'a t
+type a
+
+let f : < .. > t -> unit = fun _ -> ();;
+
+let g : [< `b] t -> unit = fun _ -> ();;
+
+let h : [> `b] t -> unit = fun _ -> ();;
+[%%expect{|
+type 'a t
+type a
+val f : < .. > t -> unit = 
+val g : [< `b ] t -> unit = 
+val h : [> `b ] t -> unit = 
+|}];;
+
+let _ = fun (x : a t) -> f x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         (< .. > as 'a) t
+       Type a is not compatible with type < .. > as 'a
+|}];;
+
+let _ = fun (x : a t) -> g x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         ([< `b ] as 'a) t
+       Type a is not compatible with type [< `b ] as 'a
+|}];;
+
+let _ = fun (x : a t) -> h x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         ([> `b ] as 'a) t
+       Type a is not compatible with type [> `b ] as 'a
+|}];;
diff --git a/testsuite/tests/typing-misc/pr7228.ml b/testsuite/tests/typing-misc/pr7228.ml
new file mode 100755
index 00000000..a9f0cb1a
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr7228.ml
@@ -0,0 +1,15 @@
+type t = A of {mutable x: int};;
+fun (A r) -> r.x <- 42;;
+[%%expect{|
+type t = A of { mutable x : int; }
+- : t -> unit = 
+|}];;
+
+(* Check that mutability is blocked for inline records on private types *)
+type t = private A of {mutable x: int};;
+fun (A r) -> r.x <- 42;;
+[%%expect{|
+type t = private A of { mutable x : int; }
+Line _, characters 15-16:
+Error: Cannot assign field x of the private type t.A
+|}];;
diff --git a/testsuite/tests/typing-misc/printing.ml b/testsuite/tests/typing-misc/printing.ml
new file mode 100644
index 00000000..277c3864
--- /dev/null
+++ b/testsuite/tests/typing-misc/printing.ml
@@ -0,0 +1,18 @@
+(* PR#7012 *)
+
+type t = [ 'A_name | `Hi ];;
+[%%expect{|
+Line _, characters 11-18:
+Error: The type 'A_name is not a polymorphic variant type
+Hint: Did you mean `A_name?
+|}];;
+
+let f (x:'id_arg) = x;;
+[%%expect{|
+val f : 'id_arg -> 'id_arg = 
+|}];;
+
+let f (x:'Id_arg) = x;;
+[%%expect{|
+val f : 'Id_arg -> 'Id_arg = 
+|}];;
diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
new file mode 100644
index 00000000..b87361e8
--- /dev/null
+++ b/testsuite/tests/typing-misc/records.ml
@@ -0,0 +1,112 @@
+(* undefined labels *)
+type t = {x:int;y:int};;
+{x=3;z=2};;
+[%%expect{|
+type t = { x : int; y : int; }
+Line _, characters 5-6:
+Error: Unbound record field z
+|}];;
+fun {x=3;z=2} -> ();;
+[%%expect{|
+Line _, characters 9-10:
+Error: Unbound record field z
+|}];;
+
+(* mixed labels *)
+{x=3; contents=2};;
+[%%expect{|
+Line _, characters 6-14:
+Error: The record field contents belongs to the type 'a ref
+       but is mixed here with fields of type t
+|}];;
+
+(* private types *)
+type u = private {mutable u:int};;
+{u=3};;
+[%%expect{|
+type u = private { mutable u : int; }
+Line _, characters 0-5:
+Error: Cannot create values of the private type u
+|}];;
+fun x -> x.u <- 3;;
+[%%expect{|
+Line _, characters 11-12:
+Error: Cannot assign field u of the private type u
+|}];;
+
+(* Punning and abbreviations *)
+module M = struct
+  type t = {x: int; y: int}
+end;;
+[%%expect{|
+module M : sig type t = { x : int; y : int; } end
+|}];;
+
+let f {M.x; y} = x+y;;
+let r = {M.x=1; y=2};;
+let z = f r;;
+[%%expect{|
+val f : M.t -> int = 
+val r : M.t = {M.x = 1; y = 2}
+val z : int = 3
+|}];;
+
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+[%%expect{|
+type foo = { mutable y : int; }
+Line _, characters 17-18:
+Error: This expression has type int but an expression was expected of type
+         foo
+|}];;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+[%%expect{|
+type foo = { y : int; z : int; }
+type bar = { x : int; }
+Line _, characters 20-21:
+Error: This expression has type bar but an expression was expected of type
+         foo
+|}];;
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+[%%expect{|
+type foo = { x : int; }
+Line _, characters 16-21:
+Error: Unbound module ZZZ
+|}];;
+
+(ZZZ.X : int option);;
+[%%expect{|
+Line _, characters 1-6:
+Error: Unbound module ZZZ
+|}];;
+
+(* PR#5865 *)
+let f (x : Complex.t) = x.Complex.z;;
+[%%expect{|
+Line _, characters 26-35:
+Error: Unbound record field Complex.z
+|}];;
+
+(* PR#6608 *)
+{ true with contents = 0 };;
+[%%expect{|
+Line _, characters 2-6:
+Error: This expression has type bool but an expression was expected of type
+         'a ref
+|}];;
+
+type ('a, 'b) t = { fst : 'a; snd : 'b };;
+let with_fst r fst = { r with fst };;
+with_fst { fst=""; snd="" } 2;;
+[%%expect{|
+type ('a, 'b) t = { fst : 'a; snd : 'b; }
+val with_fst : ('a, 'b) t -> 'c -> ('c, 'b) t = 
+- : (int, string) t = {fst = 2; snd = ""}
+|}];;
diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml
new file mode 100644
index 00000000..de83454a
--- /dev/null
+++ b/testsuite/tests/typing-misc/variant.ml
@@ -0,0 +1,20 @@
+(* PR#6394 *)
+
+module rec X : sig
+ type t = int * bool
+end = struct
+ type t = A | B
+ let f = function A | B -> 0
+end;;
+[%%expect{|
+Line _, characters 6-61:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = X.t = A | B val f : t -> int end
+       is not included in
+         sig type t = int * bool end
+       Type declarations do not match:
+         type t = X.t = A | B
+       is not included in
+         type t = int * bool
+|}];;
diff --git a/testsuite/tests/typing-misc/wellfounded.ml b/testsuite/tests/typing-misc/wellfounded.ml
new file mode 100644
index 00000000..99dc4c97
--- /dev/null
+++ b/testsuite/tests/typing-misc/wellfounded.ml
@@ -0,0 +1,16 @@
+(* PR#6768 *)
+
+type _ prod = Prod : ('a * 'y) prod;;
+
+let f : type t. t prod -> _ = function Prod ->
+  let module M =
+    struct
+      type d = d * d
+    end
+  in ()
+;;
+[%%expect{|
+type _ prod = Prod : ('a * 'y) prod
+Line _, characters 6-20:
+Error: The type abbreviation d is cyclic
+|}];;
diff --git a/testsuite/tests/typing-missing-cmi/Makefile b/testsuite/tests/typing-missing-cmi/Makefile
new file mode 100644
index 00000000..bc0ce930
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/Makefile
@@ -0,0 +1,25 @@
+# Tests for compilation with missing cmis
+# main.ml: error message when equality is missing
+# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
+
+SOURCES = subdir/m.ml a.ml b.ml c.ml main.ml main_ok.ml
+
+.PHONY: default
+default: $(SOURCES)
+	@printf " ... testing 'main.ml'";
+	@$(OCAMLC) -c subdir/m.ml;
+	@$(OCAMLC) -c -I subdir a.ml;
+	@$(OCAMLC) -c -I subdir b.ml;
+	@$(OCAMLC) -c -I subdir c.ml;
+	@$(OCAMLC) -c main.ml > main.ml.result 2>&1 || :
+	@$(DIFF) main.ml.result main.ml.reference >/dev/null \
+	&& echo " => passed" || echo " => failed"
+	@printf " ... testing 'main_ok.ml'";
+	@$(OCAMLC) -c main_ok.ml && echo " => passed" || echo " => failed"
+
+.PHONY: clean
+clean:
+	@rm -f subdir/m.cm[io] *.cm[io] main.ml.result
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-missing-cmi/a.ml b/testsuite/tests/typing-missing-cmi/a.ml
new file mode 100644
index 00000000..0631d439
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/a.ml
@@ -0,0 +1 @@
+let (a : M.a) = 2
diff --git a/testsuite/tests/typing-missing-cmi/b.ml b/testsuite/tests/typing-missing-cmi/b.ml
new file mode 100644
index 00000000..eb1e004a
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/b.ml
@@ -0,0 +1 @@
+let (b : M.b) = 2
diff --git a/testsuite/tests/typing-missing-cmi/c.ml b/testsuite/tests/typing-missing-cmi/c.ml
new file mode 100644
index 00000000..35a6ce59
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/c.ml
@@ -0,0 +1,10 @@
+(* GPR#816 *)
+(* This PR means that Foo(Bar).t is known to be equal to Foo(Baz).t
+   when Bar is an alias for Baz, even when the definition for Foo is unknown.
+   This can happen when .cmi files depend on other .cmi files not in the path
+   -- a situation that is partially supported. *)
+
+module A = M
+
+type t1 = M.Foo(M).t
+type t2 = A.Foo(A).t
diff --git a/testsuite/tests/typing-missing-cmi/main.ml b/testsuite/tests/typing-missing-cmi/main.ml
new file mode 100644
index 00000000..1bf8c991
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/main.ml
@@ -0,0 +1 @@
+let _ = A.a = B.b
diff --git a/testsuite/tests/typing-missing-cmi/main.ml.reference b/testsuite/tests/typing-missing-cmi/main.ml.reference
new file mode 100644
index 00000000..dfcfd020
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/main.ml.reference
@@ -0,0 +1,5 @@
+File "main.ml", line 1, characters 14-17:
+Error: This expression has type M.b but an expression was expected of type
+         M.a
+M.b is abstract because no corresponding cmi file was found in path.
+M.a is abstract because no corresponding cmi file was found in path.
diff --git a/testsuite/tests/typing-missing-cmi/main_ok.ml b/testsuite/tests/typing-missing-cmi/main_ok.ml
new file mode 100644
index 00000000..e6907190
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/main_ok.ml
@@ -0,0 +1 @@
+let f (x : C.t1) = (x : C.t2)
diff --git a/testsuite/tests/typing-missing-cmi/subdir/m.ml b/testsuite/tests/typing-missing-cmi/subdir/m.ml
new file mode 100644
index 00000000..c939a6a6
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/subdir/m.ml
@@ -0,0 +1,4 @@
+type a = int
+type b = a
+
+module Foo(X : sig end) = struct type t = T end
diff --git a/testsuite/tests/typing-modules-bugs/Makefile b/testsuite/tests/typing-modules-bugs/Makefile
new file mode 100644
index 00000000..994943bc
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/Makefile
@@ -0,0 +1,17 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml b/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml
new file mode 100644
index 00000000..58874454
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml
@@ -0,0 +1,31 @@
+module Std = struct module Hash = Hashtbl end;;
+
+open Std;;
+module Hash1 : module type of Hash = Hash;;
+module Hash2 : sig include (module type of Hash) end = Hash;;
+let f1 (x : (_,_) Hash1.t) = (x : (_,_) Hashtbl.t);;
+let f2 (x : (_,_) Hash2.t) = (x : (_,_) Hashtbl.t);;
+
+(* Another case, not using include *)
+
+module Std2 = struct module M = struct type t end end;;
+module Std' = Std2;;
+module M' : module type of Std'.M = Std2.M;;
+let f3 (x : M'.t) = (x : Std2.M.t);;
+
+(* original report required Core_kernel:
+module type S = sig
+open Core_kernel.Std
+
+module Hashtbl1 : module type of Hashtbl
+module Hashtbl2 : sig
+  include (module type of Hashtbl)
+end
+
+module Coverage : Core_kernel.Std.Hashable
+
+type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t
+type doesnt_type = unit
+  constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t
+end
+*)
diff --git a/testsuite/tests/typing-modules-bugs/pr5164_ok.ml b/testsuite/tests/typing-modules-bugs/pr5164_ok.ml
new file mode 100644
index 00000000..5a59808e
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr5164_ok.ml
@@ -0,0 +1,9 @@
+module type INCLUDING = sig
+  include module type of List
+  include module type of ListLabels
+end
+
+module Including_typed: INCLUDING = struct
+  include List
+  include ListLabels
+end
diff --git a/testsuite/tests/typing-modules-bugs/pr51_ok.ml b/testsuite/tests/typing-modules-bugs/pr51_ok.ml
new file mode 100644
index 00000000..0826fa31
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr51_ok.ml
@@ -0,0 +1,18 @@
+module X=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG) : SIG = struct type t=Y.t let x=Y.x end
+end;;
+module DUMMY=struct type t=int let x=2 end;;
+let x = (3 : X.F(DUMMY).t);;
+
+module X2=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG)(Z:SIG) = struct
+    type t=Y.t
+    let x=Y.x
+    type t'=Z.t
+    let x'=Z.x
+  end
+end;;
+let x = (3 : X2.F(DUMMY)(DUMMY).t);;
+let x = (3 : X2.F(DUMMY)(DUMMY).t');;
diff --git a/testsuite/tests/typing-modules-bugs/pr5663_ok.ml b/testsuite/tests/typing-modules-bugs/pr5663_ok.ml
new file mode 100644
index 00000000..ce791f90
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr5663_ok.ml
@@ -0,0 +1,7 @@
+module F (M : sig
+    type 'a t
+    type 'a u = string
+    val f : unit -> _ u t
+  end) = struct
+    let t = M.f ()
+  end
diff --git a/testsuite/tests/typing-modules-bugs/pr5914_ok.ml b/testsuite/tests/typing-modules-bugs/pr5914_ok.ml
new file mode 100644
index 00000000..fb21cd4b
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr5914_ok.ml
@@ -0,0 +1,18 @@
+type 't a = [ `A ]
+type 't wrap = 't constraint 't = [> 't wrap a ]
+type t = t a wrap
+
+module T = struct
+  let foo : 't wrap -> 't wrap -> unit = fun _ _ -> ()
+  let bar : ('a a wrap as 'a) = `A
+end
+
+module Good : sig
+  val bar: t
+  val foo: t -> t -> unit
+end = T
+
+module Bad : sig
+  val foo: t -> t -> unit
+  val bar: t
+end = T
diff --git a/testsuite/tests/typing-modules-bugs/pr6240_ok.ml b/testsuite/tests/typing-modules-bugs/pr6240_ok.ml
new file mode 100644
index 00000000..de1754aa
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6240_ok.ml
@@ -0,0 +1,11 @@
+module M : sig
+  module type T
+  module F (X : T) : sig end
+end = struct
+  module type T = sig end
+  module F (X : T) = struct end
+end
+
+module type T = M.T
+
+module F : functor (X : T) -> sig end = M.F
diff --git a/testsuite/tests/typing-modules-bugs/pr6293_bad.ml b/testsuite/tests/typing-modules-bugs/pr6293_bad.ml
new file mode 100644
index 00000000..fe16fe4d
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6293_bad.ml
@@ -0,0 +1,2 @@
+module type S = sig type t = { a : int; b : int; } end;;
+let f (module M : S with type t = int) = { M.a = 0 };;
diff --git a/testsuite/tests/typing-modules-bugs/pr6427_bad.ml b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml
new file mode 100644
index 00000000..286dafb8
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml
@@ -0,0 +1,20 @@
+let flag = ref false
+module F(S : sig module type T end) (A : S.T) (B : S.T) =
+struct
+  module X = (val if !flag then (module A) else (module B) : S.T)
+end
+
+(* If the above were accepted, one could break soundness *)
+module type S = sig type t val x : t end
+module Float = struct type t = float let x = 0.0 end
+module Int = struct type t = int let x = 0 end
+
+module M = F(struct module type T = S end)
+
+let () = flag := false
+module M1 = M(Float)(Int)
+
+let () = flag := true
+module M2 = M(Float)(Int)
+
+let _ = [| M2.X.x; M1.X.x |]
diff --git a/testsuite/tests/typing-modules-bugs/pr6513_ok.ml b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml
new file mode 100644
index 00000000..7474ba93
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml
@@ -0,0 +1,28 @@
+module type PR6513 = sig
+module type S = sig type u end
+
+module type T = sig
+  type 'a wrap
+  type uri
+end
+
+module Make: functor (Html5 : T with type 'a wrap = 'a) ->
+  S with type u = < foo : Html5.uri >
+end
+
+(* Requires -package tyxml
+module type PR6513_orig = sig
+module type S =
+sig
+        type t
+        type u
+end
+
+module Make: functor (Html5: Html5_sigs.T
+                             with type 'a Xml.wrap = 'a and
+                             type 'a wrap = 'a and
+                             type 'a list_wrap = 'a list)
+                     -> S with type t = Html5_types.div Html5.elt and
+                               type u = < foo: Html5.uri >
+end
+*)
diff --git a/testsuite/tests/typing-modules-bugs/pr6572_ok.ml b/testsuite/tests/typing-modules-bugs/pr6572_ok.ml
new file mode 100644
index 00000000..00c2f091
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6572_ok.ml
@@ -0,0 +1,19 @@
+module type S = sig
+  include Set.S
+  module E : sig val x : int end
+end
+
+module Make(O : Set.OrderedType) : S with type elt = O.t =
+  struct
+    include Set.Make(O)
+    module E = struct let x = 1 end
+  end
+
+module rec A : Set.OrderedType = struct
+ type t = int
+  let compare = Pervasives.compare
+end
+and B : S = struct
+ module C = Make(A)
+ include C
+end
diff --git a/testsuite/tests/typing-modules-bugs/pr6651_ok.ml b/testsuite/tests/typing-modules-bugs/pr6651_ok.ml
new file mode 100644
index 00000000..9c430051
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6651_ok.ml
@@ -0,0 +1,13 @@
+module type S = sig
+  module type T
+  module X : T
+end
+
+module F (X : S) = X.X
+
+module M = struct
+  module type T = sig type t end
+  module X = struct type t = int end
+end
+
+type t = F(M).t
diff --git a/testsuite/tests/typing-modules-bugs/pr6752_bad.ml b/testsuite/tests/typing-modules-bugs/pr6752_bad.ml
new file mode 100644
index 00000000..6f0f5f47
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6752_bad.ml
@@ -0,0 +1,46 @@
+(* Sorry, we have to disable this as this requires accepting
+   potentially badly formed programs (after expliciting) *)
+
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end
diff --git a/testsuite/tests/typing-modules-bugs/pr6752_ok.ml b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
new file mode 100644
index 00000000..cc342ec6
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
@@ -0,0 +1,45 @@
+(* Adding a type annotation is sufficient to make typing go through *)
+
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : msg Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : msg Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end
diff --git a/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml b/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml
new file mode 100644
index 00000000..07435e11
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml
@@ -0,0 +1,3 @@
+let should_reject =
+  let table = Hashtbl.create 1 in
+  fun x y -> Hashtbl.add table x y
diff --git a/testsuite/tests/typing-modules-bugs/pr6899_ok.ml b/testsuite/tests/typing-modules-bugs/pr6899_ok.ml
new file mode 100644
index 00000000..e049534d
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6899_ok.ml
@@ -0,0 +1,6 @@
+type 'a t = 'a option
+let is_some = function
+  | None -> false
+  | Some _ -> true
+
+let should_accept ?x () = is_some x
diff --git a/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml b/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml
new file mode 100644
index 00000000..4d49fe1e
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml
@@ -0,0 +1,5 @@
+include struct
+  let foo `Test = ()
+  let wrap f `Test = f
+  let bar = wrap ()
+end
diff --git a/testsuite/tests/typing-modules-bugs/pr6944_ok.ml b/testsuite/tests/typing-modules-bugs/pr6944_ok.ml
new file mode 100644
index 00000000..dffba4e9
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6944_ok.ml
@@ -0,0 +1,4 @@
+let f () =
+   let module S = String in
+   let module N = Map.Make(S) in
+   N.add "sum" 41 N.empty;;
diff --git a/testsuite/tests/typing-modules-bugs/pr6954_ok.ml b/testsuite/tests/typing-modules-bugs/pr6954_ok.ml
new file mode 100644
index 00000000..0e13489b
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6954_ok.ml
@@ -0,0 +1,11 @@
+module X = struct module Y = struct module type S = sig type t end end end
+
+(* open X  (* works! *) *)
+module Y = X.Y
+
+type 'a arg_t = 'at constraint 'a = (module Y.S with type t = 'at)
+type t = (module X.Y.S with type t = unit)
+
+let f (x : t arg_t) = ()
+
+let () = f ()
diff --git a/testsuite/tests/typing-modules-bugs/pr6981_ok.ml b/testsuite/tests/typing-modules-bugs/pr6981_ok.ml
new file mode 100644
index 00000000..e2b285b9
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6981_ok.ml
@@ -0,0 +1,10 @@
+module type S =
+sig
+  type a
+  type b
+end
+module Foo
+    (Bar : S with type a = private [> `A])
+    (Baz : S with type b = private < b : Bar.b ; .. >) =
+struct
+end
diff --git a/testsuite/tests/typing-modules-bugs/pr6982_ok.ml b/testsuite/tests/typing-modules-bugs/pr6982_ok.ml
new file mode 100644
index 00000000..7e24940a
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6982_ok.ml
@@ -0,0 +1,26 @@
+module A = struct
+ module type A_S = sig
+ end
+
+ type t = (module A_S)
+end
+
+module type S = sig type t end
+
+let f (type a) (module X : S with type t = a) = ()
+
+let _ = f (module A) (* ok *)
+
+module A_annotated_alias : S with type t = (module A.A_S) = A
+
+let _ = f (module A_annotated_alias) (* ok *)
+let _ = f (module A_annotated_alias : S with type t = (module A.A_S)) (* ok *)
+
+module A_alias = A
+module A_alias_expanded = struct include A_alias end
+
+let _ = f (module A_alias_expanded : S with type t = (module A.A_S)) (* ok *)
+let _ = f (module A_alias_expanded) (* ok *)
+
+let _ = f (module A_alias : S with type t = (module A.A_S)) (* doesn't type *)
+let _ = f (module A_alias) (* doesn't type either *)
diff --git a/testsuite/tests/typing-modules-bugs/pr6985_ok.ml b/testsuite/tests/typing-modules-bugs/pr6985_ok.ml
new file mode 100644
index 00000000..f6078c97
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6985_ok.ml
@@ -0,0 +1,7 @@
+module Foo
+ (Bar : sig type a = private [> `A ] end)
+ (Baz : module type of struct include Bar end) =
+struct
+end
+module Bazoinks = struct type a = [ `A ] end
+module Bug = Foo(Bazoinks)(Bazoinks)
diff --git a/testsuite/tests/typing-modules-bugs/pr6992_bad.ml b/testsuite/tests/typing-modules-bugs/pr6992_bad.ml
new file mode 100644
index 00000000..c2814d44
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6992_bad.ml
@@ -0,0 +1,15 @@
+(* PR#6992, reported by Stephen Dolan *)
+
+type (_, _) eq = Eq : ('a, 'a) eq
+let cast : type a b . (a, b) eq -> a -> b = fun Eq x -> x
+
+module Fix (F : sig type 'a f end) = struct
+  type 'a fix = ('a, 'a F.f) eq
+  let uniq (type a) (type b) (Eq : a fix) (Eq : b fix) : (a, b) eq = Eq
+end
+
+(* This would allow:
+module FixId = Fix (struct type 'a f = 'a end)
+ let bad : (int, string) eq = FixId.uniq Eq Eq
+ let _ = Printf.printf "Oh dear: %s" (cast bad 42)
+*)
diff --git a/testsuite/tests/typing-modules-bugs/pr7036_ok.ml b/testsuite/tests/typing-modules-bugs/pr7036_ok.ml
new file mode 100644
index 00000000..8a646035
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7036_ok.ml
@@ -0,0 +1,21 @@
+module M = struct
+ module type S = sig type a val v : a end
+ type 'a s = (module S with type a = 'a)
+end
+
+module B = struct
+ class type a = object method a : 'a. 'a M.s -> 'a end
+end
+
+module M' = M
+module B' = B
+
+class b : B.a = object
+ method a : 'a. 'a M.s -> 'a = fun (type a) ((module X) : (module M.S with type
+a = a)) -> X.v
+end
+
+class b' : B.a = object
+ method a : 'a. 'a M'.s -> 'a = fun (type a) ((module X) : (module M'.S with
+type a = a)) -> X.v
+end
diff --git a/testsuite/tests/typing-modules-bugs/pr7082_ok.ml b/testsuite/tests/typing-modules-bugs/pr7082_ok.ml
new file mode 100644
index 00000000..c3132dae
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7082_ok.ml
@@ -0,0 +1,7 @@
+module type FOO = sig type t end
+module type BAR =
+sig
+  (* Works: module rec A : (sig include FOO with type t = < b:B.t > end) *)
+  module rec A : (FOO with type t = < b:B.t >)
+         and B : FOO
+end
diff --git a/testsuite/tests/typing-modules-bugs/pr7112_bad.ml b/testsuite/tests/typing-modules-bugs/pr7112_bad.ml
new file mode 100644
index 00000000..9f4a12d2
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7112_bad.ml
@@ -0,0 +1,5 @@
+module A = struct module type S module S = struct end end
+module F (_ : sig end) = struct module type S module S = A.S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : A.S = X
diff --git a/testsuite/tests/typing-modules-bugs/pr7112_ok.ml b/testsuite/tests/typing-modules-bugs/pr7112_ok.ml
new file mode 100644
index 00000000..9da56069
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7112_ok.ml
@@ -0,0 +1,4 @@
+module F (_ : sig end) = struct module type S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : F(M).S = X
diff --git a/testsuite/tests/typing-modules-bugs/pr7152_ok.ml b/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
new file mode 100644
index 00000000..662d8c26
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
@@ -0,0 +1,115 @@
+module M :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    module Data = struct
+      type t = make_dec
+    end
+    let key = Fast.create ()
+  end
+
+  let _ = Dem.key (* force to evaluation the lazy substitution *)
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* variant without using a Data module *)
+
+module M' :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      type data
+      val key: data t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      type data
+      val key: data t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    type data = make_dec
+    let key = Fast.create ()
+  end
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* simpler version *)
+
+module Simple = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module Register (D:S) = struct let key = D.key end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+end;;
+module EM = Simple.Register(Simple.M);;
+Simple.M.key;;
+
+module Simple2 = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+  module Register (D:S) = struct let key = D.key end
+  module EM = Simple.Register(Simple.M)
+  let k : M.Data.t t = M.key
+end;;
diff --git a/testsuite/tests/typing-modules-bugs/pr7182_ok.ml b/testsuite/tests/typing-modules-bugs/pr7182_ok.ml
new file mode 100644
index 00000000..e7d01956
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7182_ok.ml
@@ -0,0 +1,3 @@
+module rec M
+    : sig external f : int -> int = "%identity" end
+    = struct external f : int -> int = "%identity" end
diff --git a/testsuite/tests/typing-modules-bugs/pr7305_principal.ml b/testsuite/tests/typing-modules-bugs/pr7305_principal.ml
new file mode 100644
index 00000000..fd20e998
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7305_principal.ml
@@ -0,0 +1,29 @@
+type c1 = < c1: c1 >
+type c2 = < c1: c1; c2: c1; c3: c1; c4: c1; c5: c1; c6: c1 >
+type c3 = < c1: c2; c2: c2; c3: c2; c4: c2; c5: c2; c6: c2 >
+type c4 = < c1: c3; c2: c3; c3: c3; c4: c3; c5: c3; c6: c3 >
+type c5 = < c1: c4; c2: c4; c3: c4; c4: c4; c5: c4; c6: c4 >
+type c6 = < c1: c5; c2: c5; c3: c5; c4: c5; c5: c5; c6: c5 >
+type c7 = < c1: c6; c2: c6; c3: c6; c4: c6; c5: c6; c6: c6 >
+
+(* If you use this example, then checking the types themselves
+   takes a long time.
+type c1 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c2 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c3 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c4 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c5 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c6 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+*)
+
+(* Same for this example
+type 'a c1 = 
+type 'a c2 = 
+type 'a c3 = 
+type 'a c4 = 
+type 'a c5 = 
+type 'a c6 = 
+type 'a c7 = 
+*)
+
+let x = ref ([] : c7 list)
diff --git a/testsuite/tests/typing-modules-bugs/pr7414_bad.ml b/testsuite/tests/typing-modules-bugs/pr7414_bad.ml
new file mode 100644
index 00000000..38ecfa13
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7414_bad.ml
@@ -0,0 +1,55 @@
+module type T = sig
+  type t
+  val x : t
+  val show : t -> string
+end
+
+module Int = struct
+  type t = int
+  let x = 0
+  let show x = string_of_int x
+end
+
+module String = struct
+  type t = string
+  let x = "Hello"
+  let show x = x
+end
+
+let switch = ref true
+
+module Choose () = struct
+  module Choice =
+    (val if !switch then (module Int : T)
+    else (module String : T))
+  let r = ref (ref [])
+end
+
+module type S = sig
+  module Choice : T
+  val r : Choice.t list ref ref
+end
+
+module Force (X : functor () -> S) = struct end
+
+module M = Choose ()
+
+let () = switch := false
+
+module N = Choose ()
+
+let () = N.r := !M.r
+;;
+
+module Ignore = Force(Choose)
+;; (* fail *)
+
+(* would cause segfault
+module M' = (M : S)
+
+let () = (!M'.r) := [M'.Choice.x]
+
+module N' = (N : S)
+
+let () = List.iter (fun x -> print_string (N'.Choice.show x)) !(!N'.r)
+*)
diff --git a/testsuite/tests/typing-modules/Makefile b/testsuite/tests/typing-modules/Makefile
new file mode 100644
index 00000000..0b15e777
--- /dev/null
+++ b/testsuite/tests/typing-modules/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml
new file mode 100644
index 00000000..149ba154
--- /dev/null
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -0,0 +1,111 @@
+(* with module *)
+
+module type S = sig type t and s = t end;;
+module type S' = S with type t := int;;
+[%%expect{|
+module type S = sig type t and s = t end
+module type S' = sig type s = int end
+|}];;
+
+module type S = sig module rec M : sig end and N : sig end end;;
+module type S' = S with module M := String;;
+[%%expect{|
+module type S = sig module rec M : sig  end and N : sig  end end
+module type S' = sig module rec N : sig  end end
+|}];;
+
+(* with module type *)
+(*
+module type S = sig module type T module F(X:T) : T end;;
+module type T0 = sig type t end;;
+module type S1 = S with module type T = T0;;
+module type S2 = S with module type T := T0;;
+module type S3 = S with module type T := sig type t = int end;;
+module H = struct
+  include (Hashtbl : module type of Hashtbl with
+           type statistics := Hashtbl.statistics
+           and module type S := Hashtbl.S
+           and module Make := Hashtbl.Make
+           and module MakeSeeded := Hashtbl.MakeSeeded
+           and module type SeededS := Hashtbl.SeededS
+           and module type HashedType := Hashtbl.HashedType
+           and module type SeededHashedType := Hashtbl.SeededHashedType)
+end;;
+*)
+
+(* A subtle problem appearing with -principal *)
+type -'a t
+class type c = object method m : [ `A ] t end;;
+module M : sig val v : (#c as 'a) -> 'a end =
+  struct let v x = ignore (x :> c); x end;;
+[%%expect{|
+type -'a t
+class type c = object method m : [ `A ] t end
+module M : sig val v : (#c as 'a) -> 'a end
+|}];;
+
+(* PR#4838 *)
+
+let id = let module M = struct end in fun x -> x;;
+[%%expect{|
+val id : 'a -> 'a = 
+|}];;
+
+(* PR#4511 *)
+
+let ko = let module M = struct end in fun _ -> ();;
+[%%expect{|
+val ko : 'a -> unit = 
+|}];;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+  struct type +'a t = private int end
+;;
+[%%expect{|
+Line _, characters 2-37:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
+|}];;
+
+(* PR#6005 *)
+
+module type A = sig type t = X of int end;;
+type u = X of bool;;
+module type B = A with type t = u;; (* fail *)
+[%%expect{|
+module type A = sig type t = X of int end
+type u = X of bool
+Line _, characters 23-33:
+Error: This variant or record definition does not match that of type u
+       The types for field X are not equal.
+|}];;
+
+(* PR#5815 *)
+(* ---> duplicated exception name is now an error *)
+
+module type S = sig exception Foo of int  exception Foo of bool end;;
+[%%expect{|
+Line _, characters 52-55:
+Error: Multiple definition of the extension constructor name Foo.
+       Names must be unique in a given structure or signature.
+|}];;
+
+(* PR#6410 *)
+
+module F(X : sig end) = struct let x = 3 end;;
+F.x;; (* fail *)
+[%%expect{|
+module F : functor (X : sig  end) -> sig val x : int end
+Line _, characters 0-3:
+Error: The module F is a functor, not a structure
+|}];;
diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml
new file mode 100644
index 00000000..f20a3eff
--- /dev/null
+++ b/testsuite/tests/typing-modules/aliases.ml
@@ -0,0 +1,754 @@
+module C = Char;;
+C.chr 66;;
+
+module C' : module type of Char = C;;
+C'.chr 66;;
+
+module C3 = struct include Char end;;
+C3.chr 66;;
+[%%expect{|
+module C = Char
+- : char = 'B'
+module C' :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+module C3 :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+|}];;
+
+let f x = let module M = struct module L = List end in M.L.length x;;
+let g x = let module L = List in L.length (L.map succ x);;
+[%%expect{|
+val f : 'a list -> int = 
+val g : int list -> int = 
+|}];;
+
+module F(X:sig end) = Char;;
+module C4 = F(struct end);;
+C4.chr 66;;
+[%%expect{|
+module F :
+  functor (X : sig  end) ->
+    sig
+      external code : char -> int = "%identity"
+      val chr : int -> char
+      val escaped : char -> string
+      val lowercase : char -> char
+      val uppercase : char -> char
+      val lowercase_ascii : char -> char
+      val uppercase_ascii : char -> char
+      type t = char
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      external unsafe_chr : int -> char = "%identity"
+    end
+module C4 :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+|}];;
+
+module G(X:sig end) = struct module M = X end;; (* does not alias X *)
+module M = G(struct end);;
+[%%expect{|
+module G : functor (X : sig  end) -> sig module M : sig  end end
+module M : sig module M : sig  end end
+|}];;
+
+module M' = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M'.N'.x;;
+[%%expect{|
+module M' : sig module N : sig val x : int end module N' = N end
+- : int = 1
+|}];;
+
+module M'' : sig module N' : sig val x : int end end = M';;
+M''.N'.x;;
+module M2 = struct include M' end;;
+module M3 : sig module N' : sig val x : int end end = struct include M' end;;
+M3.N'.x;;
+module M3' : sig module N' : sig val x : int end end = M2;;
+M3'.N'.x;;
+[%%expect{|
+module M'' : sig module N' : sig val x : int end end
+- : int = 1
+module M2 : sig module N = M'.N module N' = N end
+module M3 : sig module N' : sig val x : int end end
+- : int = 1
+module M3' : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
+
+module M4 : sig module N' : sig val x : int end end = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M4.N'.x;;
+[%%expect{|
+module M4 : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
+
+module F(X:sig end) = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
+module M5 = G(struct end);;
+M5.N'.x;;
+[%%expect{|
+module F :
+  functor (X : sig  end) ->
+    sig module N : sig val x : int end module N' = N end
+module G : functor (X : sig  end) -> sig module N' : sig val x : int end end
+module M5 : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
+
+module M = struct
+  module D = struct let y = 3 end
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+
+module M1 : sig module N : sig val x : int end module N' = N end = M;;
+M1.N'.x;;
+module M2 : sig module N' : sig val x : int end end =
+  (M : sig module N : sig val x : int end module N' = N end);;
+M2.N'.x;;
+
+open M;;
+N'.x;;
+[%%expect{|
+module M :
+  sig
+    module D : sig val y : int end
+    module N : sig val x : int end
+    module N' = N
+  end
+module M1 : sig module N : sig val x : int end module N' = N end
+- : int = 1
+module M2 : sig module N' : sig val x : int end end
+- : int = 1
+- : int = 1
+|}];;
+
+module M = struct
+  module C = Char
+  module C' = C
+end;;
+module M1
+  : sig module C : sig val escaped : char -> string end module C' = C end
+  = M;; (* sound, but should probably fail *)
+M1.C'.escaped 'A';;
+module M2 : sig module C' : sig val chr : int -> char end end =
+  (M : sig module C : sig val chr : int -> char end module C' = C end);;
+M2.C'.chr 66;;
+[%%expect{|
+module M : sig module C = Char module C' = C end
+module M1 :
+  sig module C : sig val escaped : char -> string end module C' = C end
+- : string = "A"
+module M2 : sig module C' : sig val chr : int -> char end end
+- : char = 'B'
+|}];;
+
+StdLabels.List.map;;
+[%%expect{|
+- : f:('a -> 'b) -> 'a list -> 'b list = 
+|}];;
+
+module Q = Queue;;
+exception QE = Q.Empty;;
+try Q.pop (Q.create ()) with QE -> "Ok";;
+[%%expect{|
+module Q = Queue
+exception QE
+- : string = "Ok"
+|}];;
+
+module type Complex = module type of Complex with type t = Complex.t;;
+module M : sig module C : Complex end = struct module C = Complex end;;
+
+module C = Complex;;
+C.one.Complex.re;;
+include C;;
+[%%expect{|
+module type Complex =
+  sig
+    type t = Complex.t = { re : float; im : float; }
+    val zero : t
+    val one : t
+    val i : t
+    val neg : t -> t
+    val conj : t -> t
+    val add : t -> t -> t
+    val sub : t -> t -> t
+    val mul : t -> t -> t
+    val inv : t -> t
+    val div : t -> t -> t
+    val sqrt : t -> t
+    val norm2 : t -> float
+    val norm : t -> float
+    val arg : t -> float
+    val polar : float -> float -> t
+    val exp : t -> t
+    val log : t -> t
+    val pow : t -> t -> t
+  end
+module M : sig module C : Complex end
+module C = Complex
+- : float = 1.
+type t = Complex.t = { re : float; im : float; }
+val zero : t = {re = 0.; im = 0.}
+val one : t = {re = 1.; im = 0.}
+val i : t = {re = 0.; im = 1.}
+val neg : t -> t = 
+val conj : t -> t = 
+val add : t -> t -> t = 
+val sub : t -> t -> t = 
+val mul : t -> t -> t = 
+val inv : t -> t = 
+val div : t -> t -> t = 
+val sqrt : t -> t = 
+val norm2 : t -> float = 
+val norm : t -> float = 
+val arg : t -> float = 
+val polar : float -> float -> t = 
+val exp : t -> t = 
+val log : t -> t = 
+val pow : t -> t -> t = 
+|}];;
+
+module F(X:sig module C = Char end) = struct module C = X.C end;;
+[%%expect{|
+module F : functor (X : sig module C = Char end) -> sig module C = Char end
+|}];;
+
+(* Applicative functors *)
+module S = String
+module StringSet = Set.Make(String)
+module SSet = Set.Make(S);;
+let f (x : StringSet.t) = (x : SSet.t);;
+[%%expect{|
+module S = String
+module StringSet :
+  sig
+    type elt = String.t
+    type t = Set.Make(String).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val min_elt_opt : t -> elt option
+    val max_elt : t -> elt
+    val max_elt_opt : t -> elt option
+    val choose : t -> elt
+    val choose_opt : t -> elt option
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val find_opt : elt -> t -> elt option
+    val find_first : (elt -> bool) -> t -> elt
+    val find_first_opt : (elt -> bool) -> t -> elt option
+    val find_last : (elt -> bool) -> t -> elt
+    val find_last_opt : (elt -> bool) -> t -> elt option
+    val of_list : elt list -> t
+  end
+module SSet :
+  sig
+    type elt = S.t
+    type t = Set.Make(S).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val min_elt_opt : t -> elt option
+    val max_elt : t -> elt
+    val max_elt_opt : t -> elt option
+    val choose : t -> elt
+    val choose_opt : t -> elt option
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val find_opt : elt -> t -> elt option
+    val find_first : (elt -> bool) -> t -> elt
+    val find_first_opt : (elt -> bool) -> t -> elt option
+    val find_last : (elt -> bool) -> t -> elt
+    val find_last_opt : (elt -> bool) -> t -> elt option
+    val of_list : elt list -> t
+  end
+val f : StringSet.t -> SSet.t = 
+|}];;
+
+(* Also using include (cf. Leo's mail 2013-11-16) *)
+module F (M : sig end) : sig type t end = struct type t = int end
+module T = struct
+  module M = struct end
+  include F(M)
+end;;
+include T;;
+let f (x : t) : T.t = x ;;
+[%%expect{|
+module F : functor (M : sig  end) -> sig type t end
+module T : sig module M : sig  end type t = F(M).t end
+module M = T.M
+type t = F(M).t
+val f : t -> T.t = 
+|}];;
+
+(* PR#4049 *)
+(* This works thanks to abbreviations *)
+module A = struct
+  module B = struct type t let compare x y = 0 end
+  module S = Set.Make(B)
+  let empty = S.empty
+end
+module A1 = A;;
+A1.empty = A.empty;;
+[%%expect{|
+module A :
+  sig
+    module B : sig type t val compare : 'a -> 'b -> int end
+    module S :
+      sig
+        type elt = B.t
+        type t = Set.Make(B).t
+        val empty : t
+        val is_empty : t -> bool
+        val mem : elt -> t -> bool
+        val add : elt -> t -> t
+        val singleton : elt -> t
+        val remove : elt -> t -> t
+        val union : t -> t -> t
+        val inter : t -> t -> t
+        val diff : t -> t -> t
+        val compare : t -> t -> int
+        val equal : t -> t -> bool
+        val subset : t -> t -> bool
+        val iter : (elt -> unit) -> t -> unit
+        val map : (elt -> elt) -> t -> t
+        val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+        val for_all : (elt -> bool) -> t -> bool
+        val exists : (elt -> bool) -> t -> bool
+        val filter : (elt -> bool) -> t -> t
+        val partition : (elt -> bool) -> t -> t * t
+        val cardinal : t -> int
+        val elements : t -> elt list
+        val min_elt : t -> elt
+        val min_elt_opt : t -> elt option
+        val max_elt : t -> elt
+        val max_elt_opt : t -> elt option
+        val choose : t -> elt
+        val choose_opt : t -> elt option
+        val split : elt -> t -> t * bool * t
+        val find : elt -> t -> elt
+        val find_opt : elt -> t -> elt option
+        val find_first : (elt -> bool) -> t -> elt
+        val find_first_opt : (elt -> bool) -> t -> elt option
+        val find_last : (elt -> bool) -> t -> elt
+        val find_last_opt : (elt -> bool) -> t -> elt option
+        val of_list : elt list -> t
+      end
+    val empty : S.t
+  end
+module A1 = A
+- : bool = true
+|}];;
+
+(* PR#3476 *)
+(* Does not work yet *)
+module FF(X : sig end) = struct type t end
+module M = struct
+  module X = struct end
+  module Y = FF (X) (* XXX *)
+  type t = Y.t
+end
+module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;;
+
+module G = F (M.Y);;
+(*module N = G (M);;
+module N = F (M.Y) (M);;*)
+[%%expect{|
+module FF : functor (X : sig  end) -> sig type t end
+module M :
+  sig
+    module X : sig  end
+    module Y : sig type t = FF(X).t end
+    type t = Y.t
+  end
+module F :
+  functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig  end
+module G : functor (M : sig type t = M.Y.t end) -> sig  end
+|}];;
+
+(* PR#6307 *)
+
+module A1 = struct end
+module A2 = struct end
+module L1 = struct module X = A1 end
+module L2 = struct module X = A2 end;;
+
+module F (L : (module type of L1)) = struct end;;
+
+module F1 = F(L1);; (* ok *)
+module F2 = F(L2);; (* should succeed too *)
+[%%expect{|
+module A1 : sig  end
+module A2 : sig  end
+module L1 : sig module X = A1 end
+module L2 : sig module X = A2 end
+module F : functor (L : sig module X : sig  end end) -> sig  end
+module F1 : sig  end
+module F2 : sig  end
+|}];;
+
+(* Counter example: why we need to be careful with PR#6307 *)
+module Int = struct type t = int let compare = compare end
+module SInt = Set.Make(Int)
+type (_,_) eq = Eq : ('a,'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+
+module M = struct
+  module I = Int
+  type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+end;;
+module type S = module type of M;; (* keep alias *)
+
+module Int2 = struct type t = int let compare x y = compare y x end;;
+module type S' = sig
+  module I = Int2
+  include S with module I := I
+end;; (* fail *)
+[%%expect{|
+module Int : sig type t = int val compare : 'a -> 'a -> int end
+module SInt :
+  sig
+    type elt = Int.t
+    type t = Set.Make(Int).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val min_elt_opt : t -> elt option
+    val max_elt : t -> elt
+    val max_elt_opt : t -> elt option
+    val choose : t -> elt
+    val choose_opt : t -> elt option
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val find_opt : elt -> t -> elt option
+    val find_first : (elt -> bool) -> t -> elt
+    val find_first_opt : (elt -> bool) -> t -> elt option
+    val find_last : (elt -> bool) -> t -> elt
+    val find_last_opt : (elt -> bool) -> t -> elt option
+    val of_list : elt list -> t
+  end
+type (_, _) eq = Eq : ('a, 'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+module M :
+  sig
+    module I = Int
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+  end
+module type S =
+  sig
+    module I = Int
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+  end
+module Int2 : sig type t = int val compare : 'a -> 'a -> int end
+Line _, characters 10-30:
+Error: In this `with' constraint, the new definition of I
+       does not match its original definition in the constrained signature:
+       Modules do not match: (module Int2) is not included in (module Int)
+|}];;
+
+(* (* if the above succeeded, one could break invariants *)
+module rec M2 : S' = M2;; (* should succeed! (but this is bad) *)
+
+let M2.W eq = W Eq;;
+
+let s = List.fold_right SInt.add [1;2;3] SInt.empty;;
+module SInt2 = Set.Make(Int2);;
+let conv : type a b. (a,b) eq -> a -> b = fun Eq x -> x;;
+let s' : SInt2.t = conv eq s;;
+SInt2.elements s';;
+SInt2.mem 2 s';; (* invariants are broken *)
+*)
+
+(* Check behavior with submodules *)
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+[%%expect{|
+module M :
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
+  end
+module type S =
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
+  end
+|}];;
+
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+[%%expect{|
+module M :
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
+  end
+module type S =
+  sig
+    module N : sig module I = Int end
+    module P :
+      sig module I : sig type t = int val compare : 'a -> 'a -> int end end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
+  end
+|}];;
+
+(* PR#6365 *)
+module type S = sig module M : sig type t val x : t end end;;
+module H = struct type t = A let x = A end;;
+module H' = H;;
+module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+[%%expect{|
+module type S = sig module M : sig type t val x : t end end
+module H : sig type t = A val x : t end
+module H' = H
+module type S' = sig module M : sig type t = H.t = A val x : t end end
+|}];;
+
+(* PR#6376 *)
+module type Alias = sig module N : sig end module M = N end;;
+module F (X : sig end) = struct type t end;;
+module type A = Alias with module N := F(List);;
+module rec Bad : A = Bad;;
+[%%expect{|
+module type Alias = sig module N : sig  end module M = N end
+module F : functor (X : sig  end) -> sig type t end
+Line _:
+Error: Module type declarations do not match:
+         module type A = sig module M = F(List) end
+       does not match
+         module type A = sig module M = F(List) end
+       At position module type A = 
+       Modules do not match:
+         sig module M = F(List) end
+       is not included in
+         sig module M = F(List) end
+       At position module type A = sig module M :  end
+       Module F(List) cannot be aliased
+|}];;
+
+(* Shinwell 2014-04-23 *)
+module B = struct
+ module R = struct
+   type t = string
+ end
+
+ module O = R
+end
+
+module K = struct
+ module E = B
+ module N = E.O
+end;;
+
+let x : K.N.t = "foo";;
+[%%expect{|
+module B : sig module R : sig type t = string end module O = R end
+module K : sig module E = B module N = E.O end
+val x : K.N.t = "foo"
+|}];;
+
+(* PR#6465 *)
+
+module M = struct type t = A module B = struct type u = B end end;;
+module P : sig type t = M.t = A module B = M.B end = M;;
+module P : sig type t = M.t = A module B = M.B end = struct include M end;;
+[%%expect{|
+module M : sig type t = A module B : sig type u = B end end
+module P : sig type t = M.t = A module B = M.B end
+module P : sig type t = M.t = A module B = M.B end
+|}];;
+
+module type S = sig
+  module M : sig module P : sig end end
+  module Q = M
+end;;
+[%%expect{|
+module type S = sig module M : sig module P : sig  end end module Q = M end
+|}];;
+module type S = sig
+  module M : sig module N : sig end module P : sig end end
+  module Q : sig module N = M.N module P = M.P end
+end;;
+module R = struct
+  module M = struct module N = struct end module P = struct end end
+  module Q = M
+end;;
+module R' : S = R;;
+[%%expect{|
+module type S =
+  sig
+    module M : sig module N : sig  end module P : sig  end end
+    module Q : sig module N = M.N module P = M.P end
+  end
+module R :
+  sig
+    module M : sig module N : sig  end module P : sig  end end
+    module Q = M
+  end
+module R' : S
+|}];;
+
+module F (X : sig end) = struct type t end;;
+module M : sig
+  type a
+  module Foo : sig
+    module Bar : sig end
+    type b = a
+  end
+end = struct
+  module Foo = struct
+    module Bar = struct end
+    type b = F(Bar).t
+  end
+  type a = Foo.b
+end;;
+[%%expect{|
+module F : functor (X : sig  end) -> sig type t end
+module M :
+  sig type a module Foo : sig module Bar : sig  end type b = a end end
+|}];;
+
+(* PR#6578 *)
+
+module M = struct let f x = x end
+module rec R : sig module M : sig val f : 'a -> 'a end end =
+  struct module M = M end;;
+R.M.f 3;;
+[%%expect{|
+module M : sig val f : 'a -> 'a end
+module rec R : sig module M : sig val f : 'a -> 'a end end
+- : int = 3
+|}];;
+module rec R : sig module M = M end = struct module M = M end;;
+R.M.f 3;;
+[%%expect{|
+module rec R : sig module M = M end
+- : int = 3
+|}];;
diff --git a/testsuite/tests/typing-modules/firstclass.ml b/testsuite/tests/typing-modules/firstclass.ml
new file mode 100644
index 00000000..8bf0e422
--- /dev/null
+++ b/testsuite/tests/typing-modules/firstclass.ml
@@ -0,0 +1,43 @@
+module type S = sig type u type t end;;
+module type S' = sig type t = int type u = bool end;;
+
+(* ok to convert between structurally equal signatures, and parameters
+   are inferred *)
+let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'));;
+let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'));;
+[%%expect{|
+module type S = sig type u type t end
+module type S' = sig type t = int type u = bool end
+val f : (module S with type t = int and type u = bool) -> (module S') = 
+val g : (module S with type t = int and type u = bool) -> (module S') = 
+|}];;
+
+(* with subtyping it is also ok to forget some types *)
+module type S2 = sig type u type t type w end;;
+let g2 x = (x : (module S2 with type t = 'a and type u = 'b) :> (module S'));;
+let h x = (x : (module S2 with type t = 'a) :> (module S with type t = 'a));;
+let f2 (x : (module S2 with type t = 'a and type u = 'b)) =
+  (x : (module S'));; (* fail *)
+let k (x : (module S2 with type t = 'a)) =
+  (x : (module S with type t = 'a));; (* fail *)
+[%%expect{|
+module type S2 = sig type u type t type w end
+val g2 : (module S2 with type t = int and type u = bool) -> (module S') =
+  
+val h : (module S2 with type t = 'a) -> (module S with type t = 'a) = 
+Line _, characters 3-4:
+Error: This expression has type
+         (module S2 with type t = int and type u = bool)
+       but an expression was expected of type (module S')
+|}];;
+
+(* but you cannot forget values (no physical coercions) *)
+module type S3 = sig type u type t val x : int end;;
+let g3 x =
+  (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+[%%expect{|
+module type S3 = sig type u type t val x : int end
+Line _, characters 2-67:
+Error: Type (module S3 with type t = int and type u = bool)
+       is not a subtype of (module S')
+|}];;
diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml
new file mode 100644
index 00000000..0fb23150
--- /dev/null
+++ b/testsuite/tests/typing-modules/generative.ml
@@ -0,0 +1,86 @@
+(* Using generative functors *)
+
+(* Without type *)
+module type S = sig val x : int end;;
+let v = (module struct let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* ok *)
+module H (X : sig end) = (val v);; (* ok *)
+[%%expect{|
+module type S = sig val x : int end
+val v : (module S) = 
+module F : functor () -> S
+module G : functor (X : sig  end) -> S
+module H : functor (X : sig  end) -> S
+|}];;
+
+(* With type *)
+module type S = sig type t val x : t end;;
+let v = (module struct type t = int let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+[%%expect{|
+module type S = sig type t val x : t end
+val v : (module S) = 
+module F : functor () -> S
+|}];;
+module G (X : sig end) : S = F ();; (* fail *)
+[%%expect{|
+Line _, characters 29-33:
+Error: This expression creates fresh types.
+       It is not allowed inside applicative functors.
+|}];;
+module H() = F();; (* ok *)
+[%%expect{|
+module H : functor () -> S
+|}];;
+
+(* Alias *)
+module U = struct end;;
+module M = F(struct end);; (* ok *)
+[%%expect{|
+module U : sig  end
+module M : S
+|}];;
+module M = F(U);; (* fail *)
+[%%expect{|
+Line _, characters 11-12:
+Error: This is a generative functor. It can only be applied to ()
+|}];;
+
+(* Cannot coerce between applicative and generative *)
+module F1 (X : sig end) = struct end;;
+module F2 : functor () -> sig end = F1;; (* fail *)
+[%%expect{|
+module F1 : functor (X : sig  end) -> sig  end
+Line _, characters 36-38:
+Error: Signature mismatch:
+       Modules do not match:
+         functor (X : sig  end) -> sig  end
+       is not included in
+         functor () -> sig  end
+|}];;
+module F3 () = struct end;;
+module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+[%%expect{|
+module F3 : functor () -> sig  end
+Line _, characters 47-49:
+Error: Signature mismatch:
+       Modules do not match:
+         functor () -> sig  end
+       is not included in
+         functor (X : sig  end) -> sig  end
+|}];;
+
+(* tests for shortened functor notation () *)
+module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;;
+module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) ->
+  struct end;;
+module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;;
+module GZ : functor (X: sig end) () (Z: sig end) -> sig end
+          = functor (X: sig end) () (Z: sig end) -> struct end;;
+[%%expect{|
+module X : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
+module Y : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
+module Z : sig  end -> sig  end -> sig  end -> sig  end
+module GZ : functor (X : sig  end) () (Z : sig  end) -> sig  end
+|}];;
diff --git a/testsuite/tests/typing-modules/pr5911.ml b/testsuite/tests/typing-modules/pr5911.ml
new file mode 100644
index 00000000..e6f73539
--- /dev/null
+++ b/testsuite/tests/typing-modules/pr5911.ml
@@ -0,0 +1,24 @@
+module type S = sig
+ type t
+ val x : t
+end;;
+
+module Good (X : S with type t := unit) = struct
+ let () = X.x
+end;;
+[%%expect{|
+module type S = sig type t val x : t end
+module Good : functor (X : sig val x : unit end) -> sig  end
+|}];;
+
+module type T = sig module M : S end;;
+
+module Bad (X : T with type M.t = unit) = struct
+ let () = X.M.x
+end;;
+[%%expect{|
+module type T = sig module M : S end
+module Bad :
+  functor (X : sig module M : sig type t = unit val x : t end end) ->
+    sig  end
+|}];;
diff --git a/testsuite/tests/typing-modules/pr7207.ml b/testsuite/tests/typing-modules/pr7207.ml
new file mode 100644
index 00000000..1968f87c
--- /dev/null
+++ b/testsuite/tests/typing-modules/pr7207.ml
@@ -0,0 +1,7 @@
+module F (X : sig end) = struct type t = int end;;
+type t = F(Does_not_exist).t;;
+[%%expect{|
+module F : functor (X : sig  end) -> sig type t = int end
+Line _, characters 9-28:
+Error: Unbound module Does_not_exist
+|}];;
diff --git a/testsuite/tests/typing-modules/pr7348.ml b/testsuite/tests/typing-modules/pr7348.ml
new file mode 100644
index 00000000..eac11e81
--- /dev/null
+++ b/testsuite/tests/typing-modules/pr7348.ml
@@ -0,0 +1,37 @@
+module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
+  let x : < foo: int; ..> = X.x
+end;;
+[%%expect{|
+module F :
+  functor (X : sig type t = private < foo : int; .. > val x : t end) ->
+    sig val x : X.t end
+|}]
+
+module M = struct
+  type t = < foo: int; bar: int>
+  let x = object
+    method foo = 0
+    method bar = 0
+  end
+end;;
+[%%expect{|
+module M :
+  sig type t = < bar : int; foo : int > val x : < bar : int; foo : int > end
+|}]
+
+module N = F(M);;
+[%%expect{|
+module N : sig val x : M.t end
+|}]
+
+module A : sig end = struct
+  module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
+    let x : < foo: int; ..> = X.x
+  end
+
+  module N = F(M)                
+  let _ = (N.x = M.x)
+end;;
+[%%expect{|
+module A : sig  end
+|}]
diff --git a/testsuite/tests/typing-modules/printing.ml b/testsuite/tests/typing-modules/printing.ml
new file mode 100644
index 00000000..1f107b8f
--- /dev/null
+++ b/testsuite/tests/typing-modules/printing.ml
@@ -0,0 +1,26 @@
+(* PR#6650 *)
+
+module type S = sig
+  class type c = object method m : int end
+  module M : sig
+    class type d = c
+  end
+end;;
+module F (X : S) = X.M;;
+[%%expect{|
+module type S =
+  sig
+    class type c = object method m : int end
+    module M : sig class type d = c end
+  end
+module F : functor (X : S) -> sig class type d = X.c end
+|}];;
+
+(* PR#6648 *)
+
+module M = struct module N = struct let x = 1 end end;;
+#show_module M;;
+[%%expect{|
+module M : sig module N : sig val x : int end end
+module M : sig module N : sig ... end end
+|}];;
diff --git a/testsuite/tests/typing-modules/recursive.ml b/testsuite/tests/typing-modules/recursive.ml
new file mode 100644
index 00000000..abf76e01
--- /dev/null
+++ b/testsuite/tests/typing-modules/recursive.ml
@@ -0,0 +1,7 @@
+(* PR#7324 *)
+
+module rec T : sig type t = T.t end = T;;
+[%%expect{|
+Line _, characters 15-35:
+Error: The type abbreviation T.t is cyclic
+|}]
diff --git a/testsuite/tests/typing-multifile/Makefile b/testsuite/tests/typing-multifile/Makefile
new file mode 100644
index 00000000..a9653bd9
--- /dev/null
+++ b/testsuite/tests/typing-multifile/Makefile
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+GENERATED= a.ml b.ml c.ml
+
+default: pr7325
+
+pr7325:
+	@printf " ... testing pr7325:"
+	@echo "type _ t = T" > a.ml
+	@echo "type 'a t = 'a A.t" > b.ml
+	@echo 'external f : unit -> unit B.t = "%identity"' > c.ml
+	@$(OCAMLC) -c a.ml b.ml && rm a.cmi && $(OCAMLC) -c c.ml \
+	  && echo " => passed" || echo " => failed"
+
+clean: defaultclean
+	@rm -f $(GENERATED)
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects-bugs/Makefile b/testsuite/tests/typing-objects-bugs/Makefile
new file mode 100644
index 00000000..69e2ee7b
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects-bugs/pr3968_bad.ml b/testsuite/tests/typing-objects-bugs/pr3968_bad.ml
new file mode 100644
index 00000000..01c50666
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr3968_bad.ml
@@ -0,0 +1,21 @@
+type expr =
+  [ `Abs of string * expr
+  | `App of expr * expr
+  ]
+
+class type exp =
+object
+  method eval : (string, exp) Hashtbl.t -> expr
+end;;
+
+class app e1 e2 : exp =
+object
+  val l = e1
+  val r = e2
+  method eval env =
+      match l with
+    | `Abs(var,body) ->
+        Hashtbl.add env var r;
+        body
+    | _ -> `App(l,r);
+end
diff --git a/testsuite/tests/typing-objects-bugs/pr4018_bad.ml b/testsuite/tests/typing-objects-bugs/pr4018_bad.ml
new file mode 100644
index 00000000..5195d463
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr4018_bad.ml
@@ -0,0 +1,46 @@
+
+class virtual ['subject, 'event] observer =
+   object
+     method virtual notify : 'subject ->  'event -> unit
+   end
+
+class ['event] subject =
+   object (self : 'subject)
+     val mutable observers = ([]: (('subject, 'event) observer) list)
+     method add_observer obs = observers <- (obs :: observers)
+     method notify_observers (e : 'event) =
+         List.iter (fun x -> x#notify self e) observers
+   end
+
+type id = int
+
+class entity (id : id) =
+  object
+    val ent_destroy_subject = new subject
+    method destroy_subject : (id) subject = ent_destroy_subject
+
+    method entity_id = id
+  end
+
+class ['entity] entity_container =
+  object (self)
+    inherit ['entity, id] observer as observer
+
+    method add_entity (e : 'entity) =
+      e#destroy_subject#add_observer (self)
+
+    method notify _ id = ()
+  end
+
+let f (x : entity entity_container) = ()
+
+(*
+class world =
+  object
+    val entity_container : entity entity_container = new entity_container
+
+    method add_entity (s : entity) =
+      entity_container#add_entity (s :> entity)
+
+  end
+*)
diff --git a/testsuite/tests/typing-objects-bugs/pr4435_bad.ml b/testsuite/tests/typing-objects-bugs/pr4435_bad.ml
new file mode 100644
index 00000000..c9e1d499
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr4435_bad.ml
@@ -0,0 +1,11 @@
+(* Two v's in the same class *)
+class c v = object initializer  print_endline v val v = 42 end;;
+new c "42";;
+
+(* Two hidden v's in the same class! *)
+class c (v : int) =
+  object
+    method v0 = v
+    inherit ((fun v -> object method v : string = v end) "42")
+  end;;
+(new c 42)#v0;;
diff --git a/testsuite/tests/typing-objects-bugs/pr4766_ok.ml b/testsuite/tests/typing-objects-bugs/pr4766_ok.ml
new file mode 100644
index 00000000..726cc866
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr4766_ok.ml
@@ -0,0 +1,10 @@
+class virtual ['a] c =
+object (s : 'a)
+  method virtual m : 'b
+end
+
+let o =
+    object (s :'a)
+      inherit ['a] c
+      method m = 42
+    end
diff --git a/testsuite/tests/typing-objects-bugs/pr4824_ok.ml b/testsuite/tests/typing-objects-bugs/pr4824_ok.ml
new file mode 100644
index 00000000..90695937
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr4824_ok.ml
@@ -0,0 +1,10 @@
+module M :
+   sig
+     class x : int -> object method m : int end
+  end
+=
+struct
+  class x _ = object
+    method m = 42
+  end
+end;;
diff --git a/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml b/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml
new file mode 100644
index 00000000..983455b4
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml
@@ -0,0 +1,6 @@
+module M : sig class c : 'a -> object val x : 'b end end =
+  struct class c x = object val x = x end end
+
+class c (x : int) = object inherit M.c x method x : bool = x end
+
+let r = (new c 2)#x;;
diff --git a/testsuite/tests/typing-objects-bugs/pr5156_ok.ml b/testsuite/tests/typing-objects-bugs/pr5156_ok.ml
new file mode 100644
index 00000000..ba8288da
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr5156_ok.ml
@@ -0,0 +1,10 @@
+class type t = object end;;
+class ['a] o1 = object (self : #t as 'a) end;;
+type 'a obj = ( < .. > as 'a);;
+class type ['a] o2 = object ('a obj) end;;
+class ['a] o3 = object (self : 'a obj) end;;
+class ['a] o4 = object (self) method m = (self : 'a obj) end;;
+(*
+let o = object (self : 'a obj) end;;
+let o = object (self) method m = (self : 'a obj) end;;
+*)
diff --git a/testsuite/tests/typing-objects-bugs/pr7284_bad.ml b/testsuite/tests/typing-objects-bugs/pr7284_bad.ml
new file mode 100644
index 00000000..d6ba2ea5
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr7284_bad.ml
@@ -0,0 +1,33 @@
+module type S = sig
+
+   type o1 = < bar : int; foo : int >
+   type o2 = private < foo : int; .. >
+
+   type v1 = T of o1
+   type v2 = T of o2
+
+ end
+
+ module M = struct
+
+   type o1 = < bar : int; foo : int >
+   type o2 = o1
+
+   type v1 = T of o1
+   type v2 = v1 = T of o2
+
+ end
+
+ module F(X : S) = struct
+
+   type 'a wit =
+   | V1 : string -> X.v1 wit
+   | V2 : int -> X.v2 wit
+
+   let f : X.v1 wit -> unit = function V1 s -> print_endline s
+
+ end [@@warning "+8"] [@@warnerror "+8"]
+
+ module N = F(M)
+
+ let () = N.f (N.V2 0)
diff --git a/testsuite/tests/typing-objects-bugs/pr7293_ok.ml b/testsuite/tests/typing-objects-bugs/pr7293_ok.ml
new file mode 100644
index 00000000..60528146
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr7293_ok.ml
@@ -0,0 +1,11 @@
+type t = T : t
+type s = T
+
+class c = object (self : 'self)
+
+  method foo : s -> 'self = function
+    | T -> self#bar ()
+
+  method bar : unit -> 'self = fun () -> self
+
+end
diff --git a/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml b/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml
new file mode 100644
index 00000000..627158bc
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml
@@ -0,0 +1,14 @@
+(* test.ml *)
+class alfa = object(_:'self)
+  method x: 'a. ('a, out_channel, unit) format -> 'a = Printf.printf
+end
+
+class bravo a = object
+  val y = (a :> alfa)
+  initializer y#x "bravo initialized"
+end
+
+class charlie a = object
+  inherit bravo a
+  initializer y#x "charlie initialized"
+end
diff --git a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
new file mode 100644
index 00000000..0189310e
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.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 = Bytes.get s i |> Char.code in
+  let n = (n lsl 8) lor (Bytes.get s (i + 1) |> Char.code) in
+  let n = (n lsl 8) lor (Bytes.get s (i + 2) |> Char.code) in
+  let n = (n lsl 8) lor (Bytes.get s (i + 3) |> Char.code) 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 = (Bytes.length contents) / 4
+    method get i = get_buf contents (4 * i)
+    method nth i = new cursor (self :> text_raw) i
+    method copy = {< contents = Bytes.copy contents >}
+    method sub pos len =
+      {< contents = Bytes.sub contents (pos * 4) (len * 4) >}
+    method concat (text : ustorage) =
+      let buf = Bytes.create (Bytes.length contents + 4 * text#len) in
+      Bytes.blit contents 0 buf 0 (Bytes.length contents);
+      init_buf buf (Bytes.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 = Bytes.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/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml
new file mode 100644
index 00000000..f0ab4d53
--- /dev/null
+++ b/testsuite/tests/typing-objects/Exemples.ml
@@ -0,0 +1,333 @@
+
+class point x_init = object
+  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) = object
+  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 = object
+  val mutable x = x_init
+  method get = x
+  method set y = x <- y
+end;;
+
+class ref (x_init:int) = object
+  val mutable x = x_init
+  method get = x
+  method set y = x <- y
+end;;
+
+class ['a] ref x_init = object
+  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) = object
+  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) = object
+  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 = object
+  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);;                 (* Fail *)
+fun x -> (x : color_point color_circle :> point circle);;
+
+class printable_point y = object (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 = object (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 = object
+  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 () = object (self)
+  method virtual null : bool
+  method virtual hd : 'a
+  method 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 ")"
+end and ['a] nil () = object
+  inherit ['a] lst ()
+  method null = true
+  method hd   = failwith "hd"
+  method tl   = failwith "tl"
+end and ['a] cons h t = object
+  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 () = object (self : 'a)
+  method virtual cmp : 'a -> int
+  end;;
+
+class int_comparable (x : int) = object
+  inherit comparable ()
+  val x = x
+  method x = x
+  method cmp p = compare x p#x
+end;;
+
+class int_comparable2 xi = object
+  inherit int_comparable xi
+  val mutable x' = xi
+  method set_x y = x' <- y
+end;;
+
+class ['a] sorted_list () = object
+  constraint 'a = #comparable
+  val mutable l = ([] : 'a list)
+  method add x =
+    let rec insert =
+      function
+            []     ->  [x]
+      | a::l as l' -> if a#cmp x <= 0 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);;      (* Fail : 'a comp2 is not a subtype *)
+(new sorted_list ())#add c2;;
+
+class int_comparable3 (x : int) = object
+  val mutable x = x
+  method cmp (y : int_comparable) = compare 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;;   (* Error; strange message with -principal *)
+
+let sort (l : #comparable list) = List.sort (fun x -> x#cmp) 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#cmp y <= 0 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) = object (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 = object (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 () = object (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 () = object (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 = object (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
+end and calculator_add arg acc = object
+  inherit calculator arg acc
+  method enter n = new calculator_add n acc
+  method equals = acc +. arg
+end and calculator_sub arg acc = object
+  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/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
new file mode 100644
index 00000000..67090461
--- /dev/null
+++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
@@ -0,0 +1,358 @@
+
+#           class point :
+  int ->
+  object val mutable x : int method get_x : int method move : int -> unit end
+#   val p : point = 
+#   - : int = 7
+# - : unit = ()
+# - : int = 10
+#   val q : < get_x : int; move : int -> unit > = 
+#   - : int * int = (10, 17)
+#           class color_point :
+  int ->
+  string ->
+  object
+    val c : string
+    val mutable x : int
+    method color : string
+    method get_x : int
+    method move : int -> unit
+  end
+#   val p' : color_point = 
+#   - : int * string = (5, "red")
+#   val l : point list = [; ]
+#   val get_x : < get_x : 'a; .. > -> 'a = 
+# val set_x : < set_x : 'a; .. > -> 'a = 
+# - : int list = [10; 5]
+#           Characters 1-96:
+  class ref x_init = object
+    val mutable x = x_init
+    method get = x
+    method set y = x <- y
+  end..
+Error: Some type variables are unbound in this type:
+         class ref :
+           'a ->
+           object
+             val mutable x : 'a
+             method get : 'a
+             method set : 'a -> unit
+           end
+       The method get has type 'a where 'a is unbound
+#           class ref :
+  int ->
+  object val mutable x : int method get : int method set : int -> unit end
+#           class ['a] ref :
+  'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
+#   - : int = 2
+#             class ['a] circle :
+  'a ->
+  object
+    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 ->
+  object
+    constraint 'a = #point
+    val mutable center : 'a
+    method center : 'a
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#   val c : point circle = 
+val c' : < color : string; get_x : int; move : int -> unit > circle = 
+#           class ['a] color_circle :
+  'a ->
+  object
+    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:
+  let c'' = new color_circle p;;
+                             ^
+Error: This expression has type point but an expression was expected of type
+         #color_point
+       The first object type has no method color
+# val c'' : color_point color_circle = 
+#   - : color_point circle = 
+# Characters 0-21:
+  (c'' :> point circle);;                 (* Fail *)
+  ^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       is not a subtype of
+         point circle =
+           < center : point; move : int -> unit; set_center : point -> unit > 
+       Type point is not a subtype of color_point 
+# Characters 9-55:
+  fun x -> (x : color_point color_circle :> point circle);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       is not a subtype of
+         point circle =
+           < center : point; move : int -> unit; set_center : point -> unit > 
+       Type point is not a subtype of color_point 
+#         class printable_point :
+  int ->
+  object
+    val mutable x : int
+    method get_x : int
+    method move : int -> unit
+    method print : unit
+  end
+#   val p : printable_point = 
+# 7- : unit = ()
+#                     Characters 85-102:
+    inherit printable_point y as super
+            ^^^^^^^^^^^^^^^^^
+Warning 13: the following instance variables are overridden by the class printable_point :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class printable_color_point :
+  int ->
+  string ->
+  object
+    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 = 
+# (7, red)- : unit = ()
+#           class functional_point :
+  int ->
+  object ('a) val x : int method get_x : int method move : int -> 'a end
+#   val p : functional_point = 
+#   - : int = 7
+# - : int = 10
+# - : int = 7
+#   - : #functional_point -> functional_point = 
+#                                                                       class virtual ['a] lst :
+  unit ->
+  object
+    method virtual hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method virtual null : bool
+    method print : ('a -> unit) -> unit
+    method virtual tl : 'a lst
+  end
+and ['a] nil :
+  unit ->
+  object
+    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
+and ['a] cons :
+  'a ->
+  'a lst ->
+  object
+    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 lst = 
+#   (3::10::[])- : unit = ()
+#   val l2 : int lst = 
+# (4::11::[])- : unit = ()
+#       val map_list : ('a -> 'b) -> 'a lst -> 'b lst = 
+#   val p1 : printable_color_point lst = 
+# ((3, red)::(10, red)::[])- : unit = ()
+#           class virtual comparable :
+  unit -> object ('a) method virtual cmp : 'a -> int end
+#             class int_comparable :
+  int -> object ('a) val x : int method cmp : 'a -> int method x : int end
+#           class int_comparable2 :
+  int ->
+  object ('a)
+    val x : int
+    val mutable x' : int
+    method cmp : 'a -> int
+    method set_x : int -> unit
+    method x : int
+  end
+#                         class ['a] sorted_list :
+  unit ->
+  object
+    constraint 'a = #comparable
+    val mutable l : 'a list
+    method add : 'a -> unit
+    method hd : 'a
+  end
+#   val l : _#comparable sorted_list = 
+# val c : int_comparable = 
+# - : unit = ()
+#   val c2 : int_comparable2 = 
+# Characters 6-28:
+  l#add (c2 :> int_comparable);;      (* Fail : 'a comp2 is not a subtype *)
+        ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         int_comparable2 =
+           < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
+       is not a subtype of
+         int_comparable = < cmp : int_comparable -> int; x : int > 
+       Type int_comparable = < cmp : int_comparable -> int; x : int >
+       is not a subtype of
+         int_comparable2 =
+           < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > 
+# - : unit = ()
+#             class int_comparable3 :
+  int ->
+  object
+    val mutable x : int
+    method cmp : int_comparable -> int
+    method setx : int -> unit
+    method x : int
+  end
+#   val c3 : int_comparable3 = 
+# - : unit = ()
+# Characters 25-27:
+  (new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
+                           ^^
+Error: This expression has type
+         int_comparable3 =
+           < cmp : int_comparable -> int; setx : int -> unit; x : int >
+       but an expression was expected of type
+         #comparable as 'a = < cmp : 'a -> int; .. >
+       Type int_comparable = < cmp : int_comparable -> int; x : int >
+       is not compatible with type 'a = < cmp : 'a -> int; .. > 
+       The first object type has no method setx
+#   val sort : (#comparable as 'a) list -> 'a list = 
+#     Characters 13-66:
+    List.map (fun c -> print_int c#x; print_string " ") l;
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 10: this expression should have type unit.
+val pr : < x : int; .. > list -> unit = 
+#   val l : int_comparable list = [; ; ]
+# 5 2 4 
+- : unit = ()
+# 2 4 5 
+- : unit = ()
+# val l : int_comparable2 list = [; ]
+# 2 0 
+- : unit = ()
+# 0 2 
+- : unit = ()
+#     val min : (#comparable as 'a) -> 'a -> 'a = 
+#   - : int = 7
+# - : int = 3
+#                                 class ['a] link :
+  'a ->
+  object ('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 ->
+  object ('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 = 
+#                                       class calculator :
+  unit ->
+  object ('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 ->
+  object ('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 ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_add :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_sub :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+#   val calculator : calculator = 
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+# 
diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference
new file mode 100644
index 00000000..cfd13603
--- /dev/null
+++ b/testsuite/tests/typing-objects/Exemples.ml.reference
@@ -0,0 +1,360 @@
+
+#           class point :
+  int ->
+  object val mutable x : int method get_x : int method move : int -> unit end
+#   val p : point = 
+#   - : int = 7
+# - : unit = ()
+# - : int = 10
+#   val q : point = 
+#   - : int * int = (10, 17)
+#           class color_point :
+  int ->
+  string ->
+  object
+    val c : string
+    val mutable x : int
+    method color : string
+    method get_x : int
+    method move : int -> unit
+  end
+#   val p' : color_point = 
+#   - : int * string = (5, "red")
+#   val l : point list = [; ]
+#   val get_x : < get_x : 'a; .. > -> 'a = 
+# val set_x : < set_x : 'a; .. > -> 'a = 
+# - : int list = [10; 5]
+#           Characters 1-96:
+  class ref x_init = object
+    val mutable x = x_init
+    method get = x
+    method set y = x <- y
+  end..
+Error: Some type variables are unbound in this type:
+         class ref :
+           'a ->
+           object
+             val mutable x : 'a
+             method get : 'a
+             method set : 'a -> unit
+           end
+       The method get has type 'a where 'a is unbound
+#           class ref :
+  int ->
+  object val mutable x : int method get : int method set : int -> unit end
+#           class ['a] ref :
+  'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
+#   - : int = 2
+#             class ['a] circle :
+  'a ->
+  object
+    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 ->
+  object
+    constraint 'a = #point
+    val mutable center : 'a
+    method center : 'a
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#   val c : point circle = 
+val c' : color_point circle = 
+#           class ['a] color_circle :
+  'a ->
+  object
+    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:
+  let c'' = new color_circle p;;
+                             ^
+Error: This expression has type point but an expression was expected of type
+         #color_point
+       The first object type has no method color
+# val c'' : color_point color_circle = 
+#   - : color_point circle = 
+# Characters 0-21:
+  (c'' :> point circle);;                 (* Fail *)
+  ^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       is not a subtype of
+         point circle =
+           < center : point; move : int -> unit; set_center : point -> unit > 
+       Type point is not a subtype of color_point 
+# Characters 9-55:
+  fun x -> (x : color_point color_circle :> point circle);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       is not a subtype of
+         point circle =
+           < center : point; move : int -> unit; set_center : point -> unit > 
+       Type point is not a subtype of color_point 
+#         class printable_point :
+  int ->
+  object
+    val mutable x : int
+    method get_x : int
+    method move : int -> unit
+    method print : unit
+  end
+#   val p : printable_point = 
+# 7- : unit = ()
+#                     Characters 85-102:
+    inherit printable_point y as super
+            ^^^^^^^^^^^^^^^^^
+Warning 13: the following instance variables are overridden by the class printable_point :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class printable_color_point :
+  int ->
+  string ->
+  object
+    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 = 
+# (7, red)- : unit = ()
+#           class functional_point :
+  int ->
+  object ('a) val x : int method get_x : int method move : int -> 'a end
+#   val p : functional_point = 
+#   - : int = 7
+# - : int = 10
+# - : int = 7
+#   - : #functional_point -> functional_point = 
+#                                                                       class virtual ['a] lst :
+  unit ->
+  object
+    method virtual hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method virtual null : bool
+    method print : ('a -> unit) -> unit
+    method virtual tl : 'a lst
+  end
+and ['a] nil :
+  unit ->
+  object
+    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
+and ['a] cons :
+  'a ->
+  'a lst ->
+  object
+    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 lst = 
+#   (3::10::[])- : unit = ()
+#   val l2 : int lst = 
+# (4::11::[])- : unit = ()
+#       val map_list : ('a -> 'b) -> 'a lst -> 'b lst = 
+#   val p1 : printable_color_point lst = 
+# ((3, red)::(10, red)::[])- : unit = ()
+#           class virtual comparable :
+  unit -> object ('a) method virtual cmp : 'a -> int end
+#             class int_comparable :
+  int -> object ('a) val x : int method cmp : 'a -> int method x : int end
+#           class int_comparable2 :
+  int ->
+  object ('a)
+    val x : int
+    val mutable x' : int
+    method cmp : 'a -> int
+    method set_x : int -> unit
+    method x : int
+  end
+#                         class ['a] sorted_list :
+  unit ->
+  object
+    constraint 'a = #comparable
+    val mutable l : 'a list
+    method add : 'a -> unit
+    method hd : 'a
+  end
+#   val l : _#comparable sorted_list = 
+# val c : int_comparable = 
+# - : unit = ()
+#   val c2 : int_comparable2 = 
+# Characters 6-28:
+  l#add (c2 :> int_comparable);;      (* Fail : 'a comp2 is not a subtype *)
+        ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         int_comparable2 =
+           < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
+       is not a subtype of
+         int_comparable = < cmp : int_comparable -> int; x : int > 
+       Type int_comparable = < cmp : int_comparable -> int; x : int >
+       is not a subtype of
+         int_comparable2 =
+           < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > 
+# - : unit = ()
+#             class int_comparable3 :
+  int ->
+  object
+    val mutable x : int
+    method cmp : int_comparable -> int
+    method setx : int -> unit
+    method x : int
+  end
+#   val c3 : int_comparable3 = 
+# - : unit = ()
+# Characters 25-27:
+  (new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
+                           ^^
+Error: This expression has type
+         int_comparable3 =
+           < cmp : int_comparable -> int; setx : int -> unit; x : int >
+       but an expression was expected of type
+         #comparable as 'a = < cmp : 'a -> int; .. >
+       Type int_comparable = < cmp : int_comparable -> int; x : int >
+       is not compatible with type
+         int_comparable3 =
+           < cmp : int_comparable -> int; setx : int -> unit; x : int > 
+       The first object type has no method setx
+#   val sort : (#comparable as 'a) list -> 'a list = 
+#     Characters 13-66:
+    List.map (fun c -> print_int c#x; print_string " ") l;
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 10: this expression should have type unit.
+val pr : < x : int; .. > list -> unit = 
+#   val l : int_comparable list = [; ; ]
+# 5 2 4 
+- : unit = ()
+# 2 4 5 
+- : unit = ()
+# val l : int_comparable2 list = [; ]
+# 2 0 
+- : unit = ()
+# 0 2 
+- : unit = ()
+#     val min : (#comparable as 'a) -> 'a -> 'a = 
+#   - : int = 7
+# - : int = 3
+#                                 class ['a] link :
+  'a ->
+  object ('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 ->
+  object ('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 = 
+#                                       class calculator :
+  unit ->
+  object ('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 ->
+  object ('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 ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_add :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_sub :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+#   val calculator : calculator = 
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+# 
diff --git a/testsuite/tests/typing-objects/Makefile b/testsuite/tests/typing-objects/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-objects/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
new file mode 100644
index 00000000..b646ade3
--- /dev/null
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -0,0 +1,336 @@
+(* Subtyping is "syntactic" *)
+fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
+(* - : (< x : int > as 'a) -> 'a -> 'a * 'a =  *)
+
+(* Quirks of class typing.  *)
+class ['a] c () = object
+  method f = (new c (): int c)
+end and ['a] d () = object
+  inherit ['a] c ()
+end;;
+(* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *)
+(* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *)
+
+(* 'a free in class d *)
+class ['a] c () = object
+  method f (x : 'a) = ()
+end and d () = object
+  inherit ['a] c ()
+end;;
+
+(* Create instance #c *)
+class virtual c () = object
+end and ['a] d () = object
+  constraint 'a = #c
+  method f (x : #c) = (x#x : int)
+end;;
+(* class virtual c : unit -> object  end *)
+(* and ['a] d : *)
+(*  unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end *)
+
+class ['a] c () = object
+  constraint 'a = int
+end and ['a] d () = object
+  constraint 'a = 'b #c
+end;;
+(* class ['a] c : unit -> object constraint 'a = int end
+   and ['a] d : unit -> object constraint 'a = int #c end *)
+
+(* Self as parameter *)
+class ['a] c (x : 'a) = object (self : 'b)
+  constraint 'a = 'b
+  method f = self
+end;;
+new c;;
+(* class ['a] c :
+  'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end *)
+(* - : ('a c as 'a) -> 'a =  *)
+
+class x () = object
+  method virtual f : int
+end;;
+(* The class x should be virtual:  its methods f is undefined *)
+
+(* Supplementary method g *)
+class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
+and virtual d x = object (_ : 'a)
+  inherit c x
+  method g = true
+end;;
+
+(* Constraint not respected *)
+class ['a] c () = object
+  constraint 'a = int
+  method f x = (x : bool c)
+end;;
+
+(* Different constraints *)
+class ['a, 'b] c () = object
+  constraint 'a = int -> 'c
+  constraint 'b = 'a *  * 'c * 'd
+  method f (x : 'a) (y : 'b) = ()
+end;;
+class ['a, 'b] d () = object
+  inherit ['a, 'b] c ()
+end;;
+
+(* Non-generic constraint *)
+let x = ref [];;
+class ['a] c () = object
+  method f = (x : 'a)
+end;;
+
+(* Abbreviations *)
+type 'a c = 
+and 'a d = ;;
+type 'a c = 
+and 'a d = ;;
+type 'a c = 
+and 'a d = ;;
+type 'a u = < x : 'a>
+and 'a t = 'a t u;; (* fails since 4.04 *)
+type 'a u = 'a
+and 'a t = 'a t u;;
+type 'a u = 'a;;
+type t = t u * t u;;
+
+type t =  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 =  *)
+
+(* Modules *)
+module M =
+  struct
+    class ['a, 'b] c (x: int) (y: 'b) = object
+      constraint 'a = int -> bool
+      val x : float list = []
+      val y = y
+      method f (x : 'a) = ()
+      method g = y
+    end
+  end;;
+module M' = (M :
+  sig
+     class virtual ['a, 'b] c : int -> 'b -> object
+       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 = object inherit ['a, 'b] M.c 7 y end;;
+class ['a, 'b] e () y = object inherit ['a, 'b] M'.c 1 y end;;
+(new M.c 3 "a")#g;;
+(new d () 10)#g;;
+(new e () 7.1)#g;;
+open M;;
+(new c 5 true)#g;;
+
+(* #cl when cl is closed *)
+module M = struct class ['a] c () = object method f (x : 'a) = () end end;;
+module M' =
+  (M : sig class ['a] c : unit -> object method f : 'a -> unit end end);;
+fun x -> (x :> 'a #M.c);;
+fun x -> (x :> 'a #M'.c);;
+class ['a] c (x : 'b #c) = object end;;
+class ['a] c (x : 'b #c) = object end;;
+
+(* Computation order *)
+class c () = object method f = 1 end and d () = object method f = 2 end;;
+class e () = object inherit c () inherit d () end;;
+(new e ())#f;;
+class c () = object val x = - true val y = -. () end;;
+
+class c () = object method f = 1 method g = 1 method h = 1 end;;
+class d () = object method h = 2 method i = 2 method j = 2 end;;
+class e () = object
+  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 = object val x = 1 val y = 1 val z = 1 val a = a end;;
+class d b = object val z = 2 val t = 2 val u = 2 val b = b end;;
+class e () = object
+  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) = object
+  val x = x
+  val y = y
+  method x = x
+  method y = y
+end;;
+class d x y = object 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;;
+
+(* Parameters which does not appear in the object type *)
+class ['a] c (x : 'a) = object end;;
+new c;;
+
+(* Private variables *)
+(*
+module type M = sig
+  class c : unit -> object val x : int end
+  class d : unit -> object 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;;
+*)
+
+(* Forgotten variables in interfaces *)
+module M :
+  sig
+    class c : unit -> object
+      method xc : int
+    end
+  end =
+  struct
+    class c () = object
+      val x = 1
+      method xc = x
+    end
+  end;;
+class d () = object
+  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) = object
+  val m = Array.make_matrix sz sz init
+  method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+end;;
+
+class c () = object method m = new c () end;;
+(new c ())#m;;
+module M = struct class c () = object method m = new c () end end;;
+(new M.c ())#m;;
+
+type uu = A of int | B of ( as 'a);;
+
+class virtual c () = object (_ : 'a) method 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 () = object 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 () = object
+  constraint 'a = < .. > -> unit
+  method m = (fun x -> () : 'a)
+end;;
+class ['a] c () = object
+  constraint 'a = unit -> < .. >
+  method m (f : 'a) = f ()
+end;;
+
+class c () = object (self)
+  method private m = 1
+  method n = self#m
+end;;
+
+class d () = object (self)
+  inherit c ()
+  method o = self#m
+end;;
+
+let x = new d () in x#n, x#o;;
+
+class c () = object method virtual m : int method private m = 1 end;;
+
+(* Marshaling (cf. PR#5436) *)
+
+let r = ref 0;;
+let id o = Oo.id o - !r;;
+r := Oo.id (object end);;
+id (object end);;
+id (object end);;
+let o = object end in
+  let s = Marshal.to_string o [] in
+  let o' : < > = Marshal.from_string s 0 in
+  let o'' : < > = Marshal.from_string s 0 in
+  (id o, id o', id o'');;
+
+let o = object val x = 33 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] in
+  let o' :  = Marshal.from_string s 0 in
+  let o'' :  = Marshal.from_string s 0 in
+  (id o, id o', id o'', o#m, o'#m);;
+
+let o = object val x = 33 val y = 44 method m = x end in
+  let s = Marshal.to_string (o,o) [Marshal.Closures] in
+  let (o1, o2) : ( * ) = Marshal.from_string s 0 in
+  let (o3, o4) : ( * ) = Marshal.from_string s 0 in
+  (id o, id o1, id o2, id o3, id o4, o#m, o1#m);;
+
+(* Recursion (cf. PR#5291) *)
+
+class a = let _ = new b in object end
+and b = let _ = new a in object end;;
+
+class a = let _ = new a in object end;;
diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
new file mode 100644
index 00000000..7b1164e6
--- /dev/null
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -0,0 +1,317 @@
+
+#   - : < x : int > ->
+    < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
+= 
+#               class ['a] c : unit -> object constraint 'a = int method f : int c end
+and ['a] d : unit -> object constraint 'a = int method f : int c end
+#                 Characters 230-271:
+  ....and d () = object
+    inherit ['a] c ()
+  end..
+Error: Some type variables are unbound in this type:
+         class d : unit -> object method f : 'a -> unit end
+       The method f has type 'a -> unit where 'a is unbound
+#             class virtual c : unit -> object  end
+and ['a] d :
+  unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
+#                 class ['a] c : unit -> object constraint 'a = int end
+and ['a] d : unit -> object constraint 'a = int #c end
+# *             class ['a] c :
+  'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
+# - : ('a c as 'a) -> 'a = 
+# *           Characters 128-176:
+  class x () = object
+    method virtual f : int
+  end..
+Error: This class should be virtual. The following methods are undefined : f
+#               Characters 144-152:
+  class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
+                                                   ^^^^^^^^
+Error: This pattern cannot match self: it only matches values of type
+       < f : int >
+#           Characters 32-110:
+  class ['a] c () = object
+    constraint 'a = int
+    method f x = (x : bool c)
+  end..
+Error: The abbreviation c is used with parameters bool c
+       which are incompatible with constraints int c
+#             class ['a, 'b] c :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     class ['a, 'b] d :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     val x : '_a list ref = {contents = []}
+#     Characters 0-50:
+  class ['a] c () = object
+    method f = (x : 'a)
+  end..
+Error: The type of this class,
+       class ['a] c :
+         unit -> object constraint 'a = '_b list ref method f : 'a end,
+       contains type variables that cannot be generalized
+#       Characters 21-53:
+  type 'a c = 
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of d, type int c should be 'a 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 >
+#   Characters 22-39:
+  and 'a t = 'a t u;; (* fails since 4.04 *)
+  ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+       'a t u
+#   Characters 15-32:
+  and 'a t = 'a t u;;
+  ^^^^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+# type 'a u = 'a
+# Characters 0-18:
+  type t = t u * t u;;
+  ^^^^^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+#   type t = < x : 'a > as 'a
+# type 'a u = 'a
+# - : t -> t u -> bool = 
+# - : t -> t u -> bool = 
+#                         module M :
+  sig
+    class ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        constraint 'a = int -> bool
+        val x : float list
+        val y : 'b
+        method f : 'a -> unit
+        method g : 'b
+      end
+  end
+#                   module M' :
+  sig
+    class virtual ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        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 ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# class ['a, 'b] e :
+  unit ->
+  'b ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# - : string = "a"
+# - : int = 10
+# - : float = 7.1
+# # - : bool = true
+#     module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
+#   module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
+# - : ('a #M.c as 'b) -> 'b = 
+# - : ('a #M'.c as 'b) -> 'b = 
+# class ['a] c : 'a #c -> object  end
+# class ['a] c : 'a #c -> object  end
+#     class c : unit -> object method f : int end
+and d : unit -> object method f : int end
+# class e : unit -> object method f : int end
+# - : int = 2
+# Characters 30-34:
+  class c () = object val x = - true val y = -. () end;;
+                                ^^^^
+Error: This expression has type bool but an expression was expected of type
+         int
+#   class c : unit -> object method f : int method g : int method h : int end
+# class d : unit -> object method h : int method i : int method j : int end
+#               class e :
+  unit ->
+  object
+    method f : int
+    method g : int
+    method h : int
+    method i : int
+    method j : int
+  end
+# val e : e = 
+# - : int * int * int * int * int = (1, 3, 2, 2, 3)
+#   class c : 'a -> object val a : 'a val x : int val y : int val z : int end
+# class d : 'a -> object val b : 'a val t : int val u : int val z : int end
+#                             Characters 42-45:
+    inherit c 5
+            ^^^
+Warning 13: the following instance variables are overridden by the class c :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 52-53:
+    val y = 3
+        ^
+Warning 13: the instance variable y is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 80-83:
+    inherit d 7
+            ^^^
+Warning 13: the following instance variables are overridden by the class d :
+  t z
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 90-91:
+    val u = 3
+        ^
+Warning 13: the instance variable u is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class e :
+  unit ->
+  object
+    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 = 
+# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
+#             class c :
+  int ->
+  int -> object val x : int val y : int method x : int method y : int end
+# class d :
+  int ->
+  int -> object 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 -> object  end
+# - : 'a -> 'a c = 
+#     * * * * * * * * * * * * * * * * * * * * *                             module M : sig class c : unit -> object method xc : int end end
+#         class d : unit -> object val x : int method xc : int method xd : int end
+# - : int * int = (1, 2)
+#         Characters 1-154:
+  class virtual ['a] matrix (sz, init : int * 'a) = object
+    val m = Array.make_matrix sz sz init
+    method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+  end..
+Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
+       but is used with type < m : 'a array array; .. >
+#   class c : unit -> object method m : c end
+# - : c = 
+# module M : sig class c : unit -> object method m : c end end
+# - : M.c = 
+#   type uu = A of int | B of (< leq : 'a > as 'a)
+#   class virtual c : unit -> object ('a) method virtual m : 'a end
+#         module S : sig val f : (#c as 'a) -> 'a end
+#         Characters 12-43:
+  ............struct
+    let f (x : #c) = x
+  end......
+Error: 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 38-39:
+  module M = struct type t = int class t () = object end end;;
+                                       ^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#   - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = 
+#   Characters 10-39:
+  fun x -> (x : int -> bool :> 'a -> 'a);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
+# Characters 9-40:
+  fun x -> (x : int -> bool :> int -> int);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
+# - : <  > -> <  > = 
+# - : < .. > -> <  > = 
+#   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
+# Characters 9-19:
+  fun (x : 'a t as 'a) -> ();;
+           ^^^^^^^^^^
+Error: This alias is bound to type 'a t but is used as an instance of type 'a
+       The type variable 'a occurs inside 'a t
+# Characters 19-20:
+  fun (x : 'a t) -> (x : 'a); ();;
+                     ^
+Error: This expression has type 'a t but an expression was expected of type
+         'a
+       The type variable 'a occurs inside 'a t
+# type 'a t = < x : 'a >
+# - : ('a t as 'a) -> unit = 
+# Characters 18-26:
+  fun (x : 'a t) -> (x : 'a); ();;
+                    ^^^^^^^^
+Warning 10: this expression should have type unit.
+- : ('a t as 'a) t -> unit = 
+#         class ['a] c :
+  unit ->
+  object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
+#       class ['a] c :
+  unit ->
+  object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
+#         class c : unit -> object method private m : int method n : int end
+#         class d :
+  unit -> object method private m : int method n : int method o : int end
+#   - : int * int = (1, 1)
+#   class c : unit -> object method m : int end
+#       val r : int ref = {contents = 0}
+# val id : < .. > -> int = 
+# - : unit = ()
+# - : int = 1
+# - : int = 2
+#         - : int * int * int = (3, 4, 5)
+#           - : int * int * int * int * int = (6, 7, 8, 33, 33)
+#           - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33)
+#         Characters 42-69:
+  class a = let _ = new b in object end
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+#   Characters 11-38:
+  class a = let _ = new a in object end;;
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+# 
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
new file mode 100644
index 00000000..7b1164e6
--- /dev/null
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -0,0 +1,317 @@
+
+#   - : < x : int > ->
+    < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
+= 
+#               class ['a] c : unit -> object constraint 'a = int method f : int c end
+and ['a] d : unit -> object constraint 'a = int method f : int c end
+#                 Characters 230-271:
+  ....and d () = object
+    inherit ['a] c ()
+  end..
+Error: Some type variables are unbound in this type:
+         class d : unit -> object method f : 'a -> unit end
+       The method f has type 'a -> unit where 'a is unbound
+#             class virtual c : unit -> object  end
+and ['a] d :
+  unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
+#                 class ['a] c : unit -> object constraint 'a = int end
+and ['a] d : unit -> object constraint 'a = int #c end
+# *             class ['a] c :
+  'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
+# - : ('a c as 'a) -> 'a = 
+# *           Characters 128-176:
+  class x () = object
+    method virtual f : int
+  end..
+Error: This class should be virtual. The following methods are undefined : f
+#               Characters 144-152:
+  class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
+                                                   ^^^^^^^^
+Error: This pattern cannot match self: it only matches values of type
+       < f : int >
+#           Characters 32-110:
+  class ['a] c () = object
+    constraint 'a = int
+    method f x = (x : bool c)
+  end..
+Error: The abbreviation c is used with parameters bool c
+       which are incompatible with constraints int c
+#             class ['a, 'b] c :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     class ['a, 'b] d :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     val x : '_a list ref = {contents = []}
+#     Characters 0-50:
+  class ['a] c () = object
+    method f = (x : 'a)
+  end..
+Error: The type of this class,
+       class ['a] c :
+         unit -> object constraint 'a = '_b list ref method f : 'a end,
+       contains type variables that cannot be generalized
+#       Characters 21-53:
+  type 'a c = 
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of d, type int c should be 'a 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 >
+#   Characters 22-39:
+  and 'a t = 'a t u;; (* fails since 4.04 *)
+  ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+       'a t u
+#   Characters 15-32:
+  and 'a t = 'a t u;;
+  ^^^^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+# type 'a u = 'a
+# Characters 0-18:
+  type t = t u * t u;;
+  ^^^^^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+#   type t = < x : 'a > as 'a
+# type 'a u = 'a
+# - : t -> t u -> bool = 
+# - : t -> t u -> bool = 
+#                         module M :
+  sig
+    class ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        constraint 'a = int -> bool
+        val x : float list
+        val y : 'b
+        method f : 'a -> unit
+        method g : 'b
+      end
+  end
+#                   module M' :
+  sig
+    class virtual ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        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 ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# class ['a, 'b] e :
+  unit ->
+  'b ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# - : string = "a"
+# - : int = 10
+# - : float = 7.1
+# # - : bool = true
+#     module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
+#   module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
+# - : ('a #M.c as 'b) -> 'b = 
+# - : ('a #M'.c as 'b) -> 'b = 
+# class ['a] c : 'a #c -> object  end
+# class ['a] c : 'a #c -> object  end
+#     class c : unit -> object method f : int end
+and d : unit -> object method f : int end
+# class e : unit -> object method f : int end
+# - : int = 2
+# Characters 30-34:
+  class c () = object val x = - true val y = -. () end;;
+                                ^^^^
+Error: This expression has type bool but an expression was expected of type
+         int
+#   class c : unit -> object method f : int method g : int method h : int end
+# class d : unit -> object method h : int method i : int method j : int end
+#               class e :
+  unit ->
+  object
+    method f : int
+    method g : int
+    method h : int
+    method i : int
+    method j : int
+  end
+# val e : e = 
+# - : int * int * int * int * int = (1, 3, 2, 2, 3)
+#   class c : 'a -> object val a : 'a val x : int val y : int val z : int end
+# class d : 'a -> object val b : 'a val t : int val u : int val z : int end
+#                             Characters 42-45:
+    inherit c 5
+            ^^^
+Warning 13: the following instance variables are overridden by the class c :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 52-53:
+    val y = 3
+        ^
+Warning 13: the instance variable y is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 80-83:
+    inherit d 7
+            ^^^
+Warning 13: the following instance variables are overridden by the class d :
+  t z
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 90-91:
+    val u = 3
+        ^
+Warning 13: the instance variable u is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class e :
+  unit ->
+  object
+    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 = 
+# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
+#             class c :
+  int ->
+  int -> object val x : int val y : int method x : int method y : int end
+# class d :
+  int ->
+  int -> object 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 -> object  end
+# - : 'a -> 'a c = 
+#     * * * * * * * * * * * * * * * * * * * * *                             module M : sig class c : unit -> object method xc : int end end
+#         class d : unit -> object val x : int method xc : int method xd : int end
+# - : int * int = (1, 2)
+#         Characters 1-154:
+  class virtual ['a] matrix (sz, init : int * 'a) = object
+    val m = Array.make_matrix sz sz init
+    method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+  end..
+Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
+       but is used with type < m : 'a array array; .. >
+#   class c : unit -> object method m : c end
+# - : c = 
+# module M : sig class c : unit -> object method m : c end end
+# - : M.c = 
+#   type uu = A of int | B of (< leq : 'a > as 'a)
+#   class virtual c : unit -> object ('a) method virtual m : 'a end
+#         module S : sig val f : (#c as 'a) -> 'a end
+#         Characters 12-43:
+  ............struct
+    let f (x : #c) = x
+  end......
+Error: 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 38-39:
+  module M = struct type t = int class t () = object end end;;
+                                       ^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#   - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = 
+#   Characters 10-39:
+  fun x -> (x : int -> bool :> 'a -> 'a);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
+# Characters 9-40:
+  fun x -> (x : int -> bool :> int -> int);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
+# - : <  > -> <  > = 
+# - : < .. > -> <  > = 
+#   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
+# Characters 9-19:
+  fun (x : 'a t as 'a) -> ();;
+           ^^^^^^^^^^
+Error: This alias is bound to type 'a t but is used as an instance of type 'a
+       The type variable 'a occurs inside 'a t
+# Characters 19-20:
+  fun (x : 'a t) -> (x : 'a); ();;
+                     ^
+Error: This expression has type 'a t but an expression was expected of type
+         'a
+       The type variable 'a occurs inside 'a t
+# type 'a t = < x : 'a >
+# - : ('a t as 'a) -> unit = 
+# Characters 18-26:
+  fun (x : 'a t) -> (x : 'a); ();;
+                    ^^^^^^^^
+Warning 10: this expression should have type unit.
+- : ('a t as 'a) t -> unit = 
+#         class ['a] c :
+  unit ->
+  object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
+#       class ['a] c :
+  unit ->
+  object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
+#         class c : unit -> object method private m : int method n : int end
+#         class d :
+  unit -> object method private m : int method n : int method o : int end
+#   - : int * int = (1, 1)
+#   class c : unit -> object method m : int end
+#       val r : int ref = {contents = 0}
+# val id : < .. > -> int = 
+# - : unit = ()
+# - : int = 1
+# - : int = 2
+#         - : int * int * int = (3, 4, 5)
+#           - : int * int * int * int * int = (6, 7, 8, 33, 33)
+#           - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33)
+#         Characters 42-69:
+  class a = let _ = new b in object end
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+#   Characters 11-38:
+  class a = let _ = new a in object end;;
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+# 
diff --git a/testsuite/tests/typing-objects/pr5545.ml b/testsuite/tests/typing-objects/pr5545.ml
new file mode 100644
index 00000000..1273e6f0
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5545.ml
@@ -0,0 +1,22 @@
+type foo = int;;
+
+class o =
+  object(this)
+    method x : foo = 10
+    method y : int = this # x
+  end;;
+
+
+class o =
+  object(this)
+    method x : foo = 10
+    method y = (this # x : int)
+  end;;
+
+
+
+class o =
+  object(this)
+    method x : int = (10 : int)
+    method y = (this # x : foo)
+  end;;
diff --git a/testsuite/tests/typing-objects/pr5545.ml.principal.reference b/testsuite/tests/typing-objects/pr5545.ml.principal.reference
new file mode 100644
index 00000000..4f7fda96
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5545.ml.principal.reference
@@ -0,0 +1,6 @@
+
+# type foo = int
+#           class o : object method x : foo method y : int end
+#             class o : object method x : foo method y : int end
+#               class o : object method x : int method y : foo end
+# 
diff --git a/testsuite/tests/typing-objects/pr5545.ml.reference b/testsuite/tests/typing-objects/pr5545.ml.reference
new file mode 100644
index 00000000..4f7fda96
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5545.ml.reference
@@ -0,0 +1,6 @@
+
+# type foo = int
+#           class o : object method x : foo method y : int end
+#             class o : object method x : foo method y : int end
+#               class o : object method x : int method y : foo end
+# 
diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml b/testsuite/tests/typing-objects/pr5619_bad.ml
new file mode 100644
index 00000000..8608dd02
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5619_bad.ml
@@ -0,0 +1,28 @@
+class type foo_t =
+  object
+    method foo: string
+  end
+
+type 'a name =
+    Foo: foo_t name
+  | Int: int name
+;;
+
+class foo =
+  object(self)
+    method foo = "foo"
+    method cast =
+      function
+          Foo -> (self :> )
+  end
+;;
+
+class foo: foo_t =
+  object(self)
+    method foo = "foo"
+    method cast: type a. a name -> a =
+      function
+          Foo -> (self :> foo_t)
+        | _ -> raise Exit
+  end
+;;
diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference
new file mode 100644
index 00000000..0b50417a
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference
@@ -0,0 +1,18 @@
+
+#                 class type foo_t = object method foo : string end
+type 'a name = Foo : foo_t name | Int : int name
+#                 class foo :
+  object method cast : foo_t name -> < foo : string > method foo : string end
+#                   Characters 22-176:
+  ..object(self)
+      method foo = "foo"
+      method cast: type a. a name -> a =
+        function
+            Foo -> (self :> foo_t)
+          | _ -> raise Exit
+    end
+Error: The class type
+         object method cast : 'a name -> 'a method foo : string end
+       is not matched by the class type foo_t
+       The public method cast cannot be hidden
+# 
diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml.reference b/testsuite/tests/typing-objects/pr5619_bad.ml.reference
new file mode 100644
index 00000000..0b50417a
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5619_bad.ml.reference
@@ -0,0 +1,18 @@
+
+#                 class type foo_t = object method foo : string end
+type 'a name = Foo : foo_t name | Int : int name
+#                 class foo :
+  object method cast : foo_t name -> < foo : string > method foo : string end
+#                   Characters 22-176:
+  ..object(self)
+      method foo = "foo"
+      method cast: type a. a name -> a =
+        function
+            Foo -> (self :> foo_t)
+          | _ -> raise Exit
+    end
+Error: The class type
+         object method cast : 'a name -> 'a method foo : string end
+       is not matched by the class type foo_t
+       The public method cast cannot be hidden
+# 
diff --git a/testsuite/tests/typing-objects/pr5858.ml b/testsuite/tests/typing-objects/pr5858.ml
new file mode 100644
index 00000000..3795cf31
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5858.ml
@@ -0,0 +1,2 @@
+class type c = object end;;
+module type S = sig class c: c end;;
diff --git a/testsuite/tests/typing-objects/pr5858.ml.reference b/testsuite/tests/typing-objects/pr5858.ml.reference
new file mode 100644
index 00000000..94e63484
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5858.ml.reference
@@ -0,0 +1,7 @@
+
+# class type c = object  end
+# Characters 29-30:
+  module type S = sig class c: c end;;
+                               ^
+Error: The class type c is not yet completely defined
+# 
diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml b/testsuite/tests/typing-objects/pr6123_bad.ml
new file mode 100644
index 00000000..a773f8d7
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6123_bad.ml
@@ -0,0 +1,23 @@
+class virtual name =
+object
+end
+
+and func (args_ty, ret_ty) =
+object(self)
+  inherit name
+
+  val mutable memo_args = None
+
+  method arguments =
+    match memo_args with
+    | Some xs -> xs
+    | None ->
+      let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+        memo_args <- Some args; args
+end
+
+and argument (func, ty) =
+object
+  inherit name
+end
+;;
diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference
new file mode 100644
index 00000000..eb3b05c0
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference
@@ -0,0 +1,8 @@
+
+#                                             Characters 253-257:
+        let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+                                                    ^^^^
+Error: This expression has type < arguments : 'a; .. >
+       but an expression was expected of type 'b
+       Self type cannot escape its class
+# 
diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.reference
new file mode 100644
index 00000000..eb3b05c0
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6123_bad.ml.reference
@@ -0,0 +1,8 @@
+
+#                                             Characters 253-257:
+        let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+                                                    ^^^^
+Error: This expression has type < arguments : 'a; .. >
+       but an expression was expected of type 'b
+       Self type cannot escape its class
+# 
diff --git a/testsuite/tests/typing-objects/pr6383.ml b/testsuite/tests/typing-objects/pr6383.ml
new file mode 100644
index 00000000..bd2fdb06
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6383.ml
@@ -0,0 +1 @@
+let f (x: #M.foo) = 0;;
diff --git a/testsuite/tests/typing-objects/pr6383.ml.reference b/testsuite/tests/typing-objects/pr6383.ml.reference
new file mode 100644
index 00000000..6c92acc3
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6383.ml.reference
@@ -0,0 +1,6 @@
+
+# Characters 11-16:
+  let f (x: #M.foo) = 0;;
+             ^^^^^
+Error: Unbound module M
+# 
diff --git a/testsuite/tests/typing-objects/pr6907_bad.ml b/testsuite/tests/typing-objects/pr6907_bad.ml
new file mode 100644
index 00000000..0a9a7a1d
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6907_bad.ml
@@ -0,0 +1,7 @@
+class type ['e] t = object('s)
+  method update : 'e -> 's
+end;;
+
+module type S = sig
+  class base : 'e -> ['e] t
+end;;
diff --git a/testsuite/tests/typing-objects/pr6907_bad.ml.reference b/testsuite/tests/typing-objects/pr6907_bad.ml.reference
new file mode 100644
index 00000000..3a4ef9af
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6907_bad.ml.reference
@@ -0,0 +1,10 @@
+
+#     class type ['e] t = object ('a) method update : 'e -> 'a end
+#       Characters 23-48:
+    class base : 'e -> ['e] t
+    ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Some type variables are unbound in this type:
+         class base : 'e -> ['e] t
+       The method update has type 'e -> < update : 'a; .. > as 'a where 'e
+       is unbound
+# 
diff --git a/testsuite/tests/typing-pattern_open/Makefile b/testsuite/tests/typing-pattern_open/Makefile
new file mode 100644
index 00000000..9625a3fb
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-pattern_open/pattern_open.ml b/testsuite/tests/typing-pattern_open/pattern_open.ml
new file mode 100644
index 00000000..07390ad5
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/pattern_open.ml
@@ -0,0 +1,147 @@
+let pp fmt = Printf.printf fmt
+
+type 'a box = B of 'a
+(* Basic tests *)
+module M = struct
+  type c = C
+  type t = {x : c box }
+end
+;;
+module N = struct
+  type d = D
+  let d = D
+  type t = {x: d box}
+end
+open N
+;;
+let f M.{ x=B C } y  = M.C,y
+;;
+let g M.(x) M.(w) = x * w
+;;
+let g = function
+  | M.[] -> []
+  | M.[C] -> M.[C]
+  | _ -> []
+;;
+let h = function
+  | M.[||] -> None
+  | M.[| C |] -> Some M.C
+  | _ -> None
+;;
+let f2 = function
+  | M.( B (B C) ) -> M.C
+;;
+
+;;
+(* () constructor *)
+let M.() = ()
+;;
+(* Pattern open separation*)
+module L = struct
+  type _ c = C : unit c
+  type t = { t : unit c }
+  type r = { r : unit c }
+  let x ()= pp "Wrong value L.x\n"
+end
+;;
+module K = struct
+  type _ c = C : unit c
+  type t = { t : unit c }
+  type r = { r : unit c }
+  let x ()= pp "Right value K.x\n"
+end
+;;
+let () =
+  let test =
+  let open K in
+  function
+  | L.{t}, ({r=C} : K.r)  -> x ()
+  in
+  test (L.{t=C}, K.{r=C})
+;;
+module Exterior = struct
+module Gadt = struct
+module Boolean = struct
+  type t = { b : bool }
+  type wrong = false | true
+  let print () = pp "Wrong function: Exterior.Gadt.Boolean.print\n"
+end
+
+type _ t =
+  | Bool : Boolean.t -> bool t
+  | Int : int -> int t
+  | Eq : 'a t * 'a t -> bool t
+
+let print () = pp "Wrong function: Exterior.Gadt.print\n"
+end
+let print () = pp "Wrong function: Exterior.print\n"
+end
+;;
+let rec eval: type t. t Exterior.Gadt.t -> t = function
+  | Exterior.( Gadt.( Eq (a,b) ) ) -> (eval a) = (eval b)
+  | Exterior.( Gadt.( Bool Boolean.{b} ) ) -> b
+  | Exterior.Gadt.( Int n ) -> n
+let () =
+  let print () = pp "Right function print\n" in
+  let choose (type a):a Exterior.Gadt.t * a Exterior.Gadt.t -> a -> a =
+  fun (a,b) c ->
+  match a, b, c with
+  | Exterior.( Gadt.( Bool Boolean.{b} ), Gadt.Bool _ , _ ) -> print(); true
+  | Exterior.(Gadt.Bool Gadt.Boolean.{b}), _ , true -> print(); true
+  | Exterior.(Gadt.Bool Gadt.Boolean.{b}), _ , false -> print(); b
+  | Exterior.Gadt.( Int n, Int k, 0 ) -> print(); 0
+  | Exterior.( Gadt.(Int n, Gadt.Int k, l) ) -> print(); k+n+l
+  | Exterior.Gadt.( Eq (a,b) ), _,  true -> print(); true
+  | Exterior.(Gadt.( Eq (a,b), _ ,  false )) -> print(); eval a = eval b in
+  let _ =
+    choose Exterior.Gadt.(Bool Boolean.{b=true}, Bool Boolean.{b=false}) false
+  in
+  print ()
+;;
+(* existential type *)
+module Existential = struct
+type printable = E : 'a * ('a -> unit) -> printable
+end
+
+let rec print: Existential.printable -> unit  = function
+  | Existential.( E(x, print) ) -> print x
+;;
+(* Test that constructors and variables introduced in scope inside
+M.(..) are not propagated outside of M.(..) *)
+module S = struct
+type 'a t = Sep : unit t
+type ex = Ex: 'a * 'a -> ex
+let s = Sep
+end
+;;
+let test_separation = function
+  | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+;;
+let test_separation_2 = function
+  | S.(Ex(a,b)), Ex(c,d) -> ()
+;;
+let test_separation_3 = function
+  | S.(Sep) -> s
+;;
+
+(* Testing interaction of local open in pattern and backtracking *)
+module PR6437 = struct
+  module Ctx = struct
+  type ('a, 'b) t =
+    | Nil : (unit, unit) t
+    | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+  end
+
+  module Var = struct
+  type 'a t =
+    | O : ('a * unit) t
+    | S : 'a t -> ('a * unit) t
+  end
+end
+
+let rec f : type g1 g2. (g1, g2) PR6437.Ctx.t * g1 PR6437.Var.t
+  -> g2 PR6437.Var.t = function
+    | PR6437.( Ctx.(Cons g), Var.(O) ) -> PR6437.Var.O
+    | PR6437.( Ctx.(Cons g), Var.(S n) ) -> PR6437.Var.S (f (g, n))
+    | _ -> .
+;;
diff --git a/testsuite/tests/typing-pattern_open/pattern_open.ml.reference b/testsuite/tests/typing-pattern_open/pattern_open.ml.reference
new file mode 100644
index 00000000..f97b7374
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/pattern_open.ml.reference
@@ -0,0 +1,81 @@
+
+#                 val pp : ('a, out_channel, unit) format -> 'a = 
+type 'a box = B of 'a
+module M : sig type c = C type t = { x : c box; } end
+#             module N : sig type d = D val d : d type t = { x : d box; } end
+#   val f : M.t -> 'a -> M.c * 'a = 
+#   val g : int -> int -> int = 
+#         val g : M.c list -> M.c list = 
+#         val h : M.c array -> M.c option = 
+#     val f2 : M.c box box -> M.c = 
+#   #     #               module L :
+  sig
+    type _ c = C : unit c
+    type t = { t : unit c; }
+    type r = { r : unit c; }
+    val x : unit -> unit
+  end
+#             module K :
+  sig
+    type _ c = C : unit c
+    type t = { t : unit c; }
+    type r = { r : unit c; }
+    val x : unit -> unit
+  end
+#               Right value K.x
+#                                   module Exterior :
+  sig
+    module Gadt :
+      sig
+        module Boolean :
+          sig
+            type t = { b : bool; }
+            type wrong = false | true
+            val print : unit -> unit
+          end
+        type _ t =
+            Bool : Boolean.t -> bool t
+          | Int : int -> int t
+          | Eq : 'a t * 'a t -> bool t
+        val print : unit -> unit
+      end
+    val print : unit -> unit
+  end
+#                                         Right function print
+Right function print
+val eval : 't Exterior.Gadt.t -> 't = 
+#               module Existential :
+  sig type printable = E : 'a * ('a -> unit) -> printable end
+val print : Existential.printable -> unit = 
+# *             module S :
+  sig
+    type 'a t = Sep : unit t
+    type ex = Ex : 'a * 'a -> ex
+    val s : unit t
+  end
+#     Characters 58-61:
+    | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+                             ^^^
+Error: Unbound constructor Sep
+#     Characters 50-52:
+    | S.(Ex(a,b)), Ex(c,d) -> ()
+                   ^^
+Error: Unbound constructor Ex
+#     Characters 48-49:
+    | S.(Sep) -> s
+                 ^
+Error: Unbound value s
+#                                           module PR6437 :
+  sig
+    module Ctx :
+      sig
+        type ('a, 'b) t =
+            Nil : (unit, unit) t
+          | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+      end
+    module Var :
+      sig type 'a t = O : ('a * unit) t | S : 'a t -> ('a * unit) t end
+  end
+val f : ('g1, 'g2) PR6437.Ctx.t * 'g1 PR6437.Var.t -> 'g2 PR6437.Var.t =
+  
+# 
diff --git a/testsuite/tests/typing-poly-bugs/Makefile b/testsuite/tests/typing-poly-bugs/Makefile
new file mode 100644
index 00000000..69e2ee7b
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-poly-bugs/pr5322_ok.ml b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml
new file mode 100644
index 00000000..d6cbca1a
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml
@@ -0,0 +1,6 @@
+type 'par t = 'par
+module M : sig val x :  end =
+  struct let x :  = Obj.magic () end
+
+let ident v = v
+class alias = object method alias : 'a . 'a t -> 'a = ident end
diff --git a/testsuite/tests/typing-poly-bugs/pr5673_bad.ml b/testsuite/tests/typing-poly-bugs/pr5673_bad.ml
new file mode 100644
index 00000000..99088000
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5673_bad.ml
@@ -0,0 +1,23 @@
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+type refer1 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+type refer2 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+
+(* Actually this should succeed ... *)
+let f (x : refer1) = (x : refer2)
diff --git a/testsuite/tests/typing-poly-bugs/pr5673_ok.ml b/testsuite/tests/typing-poly-bugs/pr5673_ok.ml
new file mode 100644
index 00000000..26ad1606
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5673_ok.ml
@@ -0,0 +1,23 @@
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+module M : sig
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end = struct
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end
diff --git a/testsuite/tests/typing-poly/Makefile b/testsuite/tests/typing-poly/Makefile
new file mode 100644
index 00000000..0b15e777
--- /dev/null
+++ b/testsuite/tests/typing-poly/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml
new file mode 100644
index 00000000..0073f0ec
--- /dev/null
+++ b/testsuite/tests/typing-poly/poly.ml
@@ -0,0 +1,1476 @@
+(*
+   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;;
+[%%expect {|
+type 'a t = { t : 'a; }
+type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
+val f : 'a list -> 'a fold = 
+- : int = 6
+|}];;
+
+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
+;;
+[%%expect {|
+class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
+  end
+|}];;
+
+class virtual ['a] vlist = object (_ : 'self)
+  method virtual add : 'a -> 'self
+  method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
+end
+;;
+[%%expect {|
+class virtual ['a] vlist :
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : 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
+;;
+[%%expect {|
+class ilist2 :
+  int list ->
+  object ('a)
+    val l : int list
+    method add : int -> 'a
+    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
+let ilist2 l = object
+  inherit [_] vlist
+  val l = l
+  method add x = {< l = x :: l >}
+  method fold = List.fold_left l
+end
+;;
+[%%expect {|
+val ilist2 : 'a list -> 'a vlist = 
+|}];;
+
+class ['a] ilist3 l = object
+  inherit ['a] vlist
+  val l = l
+  method add x = {< l = x :: l >}
+  method fold = List.fold_left l
+end
+;;
+[%%expect {|
+class ['a] ilist3 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  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
+;;
+[%%expect {|
+class ['a] ilist4 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  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
+;;
+[%%expect {|
+class ['a] ilist5 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  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
+;;
+[%%expect {|
+class ['a] ilist6 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
+class virtual ['a] olist = object
+  method virtual fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c
+end
+;;
+[%%expect {|
+class virtual ['a] olist :
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
+|}];;
+
+class ['a] onil = object
+  inherit ['a] olist
+  method fold ~f ~init = init
+end
+;;
+[%%expect {|
+class ['a] onil :
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c 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
+;;
+[%%expect {|
+class ['a] ocons :
+  hd:'a ->
+  tl:'a olist ->
+  object
+    val hd : 'a
+    val tl : 'a olist
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  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
+;;
+[%%expect {|
+class ['a] ostream :
+  hd:'a ->
+  tl:'a ostream ->
+  object
+    val hd : 'a
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
+    method empty : bool
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  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
+[%%expect {|
+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
+|}, Principal{|
+Line _, characters 4-16:
+Warning 18: this use of a polymorphic method is not principal.
+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 virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
+  method m = function `A -> 1 | `B|`C  -> 0
+end
+;;
+[%%expect {|
+class vari : object method m : [< `A | `B | `C ] -> int end
+|}];;
+
+class vari = object
+  method m : 'a. ([< `A|`B|`C] as 'a) -> int = function `A -> 1 | `B|`C -> 0
+end
+;;
+[%%expect {|
+class vari : object method m : [< `A | `B | `C ] -> int end
+|}];;
+
+module V =
+  struct
+    type v = [`A | `B | `C]
+    let m : [< v] -> int = function `A -> 1 | #v -> 0
+  end
+;;
+[%%expect {|
+module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
+|}];;
+
+class varj = object
+  method virtual m : 'a. ([< V.v] as 'a) -> int
+  method m = V.m
+end
+;;
+[%%expect {|
+class varj : object method m : [< V.v ] -> int end
+|}];;
+
+
+module type T = sig
+  class vari : object method m : 'a. ([< `A | `B | `C] as 'a) -> int end
+end
+;;
+[%%expect {|
+module type T =
+  sig class vari : object method m : [< `A | `B | `C ] -> 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
+;;
+[%%expect {|
+module M0 :
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+|}];;
+
+module M : T = M0
+;;
+[%%expect {|
+module M : T
+|}];;
+
+let v = new M.vari;;
+[%%expect {|
+val v : M.vari = 
+|}];;
+
+v#m `A;;
+[%%expect {|
+- : int = 1
+|}];;
+
+
+class point ~x ~y = object
+  val x : int = x
+  val y : int = y
+  method x = x
+  method y = y
+end
+;;
+[%%expect {|
+class point :
+  x:int ->
+  y:int -> object val x : int val y : int method x : int method y : int end
+|}];;
+
+class color_point ~x ~y ~color = object
+  inherit point ~x ~y
+  val color : string = color
+  method color = color
+end
+;;
+[%%expect {|
+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 (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
+;;
+[%%expect {|
+class circle :
+  #point ->
+  r:int ->
+  object val p : point val r : int method distance : #point -> float 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 = floor (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 >)
+;;
+[%%expect {|
+val p0 : point = 
+val p1 : point = 
+val cp : color_point = 
+val c : circle = 
+val d : float = 11.
+val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = 
+Line _, characters 41-42:
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
+|}];;
+
+class id = object
+  method virtual id : 'a. 'a -> 'a
+  method id x = x
+end
+;;
+[%%expect {|
+class id : object method id : 'a -> 'a end
+|}];;
+
+class type id_spec = object
+  method id : 'a -> 'a
+end
+;;
+[%%expect {|
+class type id_spec = object method id : 'a -> 'a end
+|}];;
+
+class id_impl = object (_ : #id_spec)
+  method id x = x
+end
+;;
+[%%expect {|
+class id_impl : object method id : 'a -> 'a end
+|}];;
+
+class a = object
+  method m = (new b : id_spec)#id true
+end
+and b = object (_ : #id_spec)
+  method id x = x
+end
+;;
+[%%expect {|
+class a : object method m : bool end
+and b : object method id : 'a -> 'a end
+|}];;
+
+
+class ['a] id1 = object
+  method virtual id : 'b. 'b -> 'a
+  method id x = x
+end
+;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+|}];;
+
+class id2 (x : 'a) = object
+  method virtual id : 'b. 'b -> 'a
+  method id x = x
+end
+;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+|}];;
+
+class id3 x = object
+  val x = x
+  method virtual id : 'a. 'a -> 'a
+  method id _ = x
+end
+;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
+|}];;
+
+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
+;;
+[%%expect {|
+Line _, characters 12-79:
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
+|}];;
+
+class c = object
+  method virtual m : 'a 'b. 'a -> 'b -> 'a
+  method m x y = x
+end
+;;
+[%%expect {|
+class c : object method m : 'a -> 'b -> 'a 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
+;;
+[%%expect {|
+val f1 : id -> int * bool = 
+val f2 : id -> int * bool = 
+Line _, characters 24-28:
+Error: This expression has type bool but an expression was expected of type
+         int
+|}];;
+
+class c = object
+  method virtual m : 'a. (#id as 'a) -> int * bool
+  method m (f : #id) = f#id 1, f#id true
+end
+;;
+[%%expect {|
+class c : object method m : #id -> int * bool 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
+;;
+[%%expect {|
+class id2 : object method id : 'a -> 'a method mono : int -> int end
+val app : int * bool = (1, true)
+Line _, characters 0-25:
+Error: The type abbreviation foo is cyclic
+|}];;
+
+class ['a] bar (x : 'a) = object end
+;;
+type 'a foo = 'a foo bar
+;;
+[%%expect {|
+class ['a] bar : '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;;
+fun (x :  as 'c> as 'd) -> x#m;;
+(* printer is wrong on the next (no official syntax) *)
+fun (x :  >) -> x#m;;
+[%%expect {|
+- : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = 
+- : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = 
+val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  'a * (< n : 'c; .. > as 'c) = 
+- : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : 'a; .. > as 'c)
+= 
+- : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
+= 
+- : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
+|}, Principal{|
+- : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = 
+- : (< m : 'a. 'b * 'a list > as 'b) ->
+    (< m : 'a. 'c * 'a list > as 'c) * 'd list
+= 
+val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
+  
+- : (< 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)
+= 
+- : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f *
+     < p : 'b.
+             'b * 'e *
+             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
+     as 'e)
+= 
+- : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
+|}];;
+
+type sum = T of < id: 'a. 'a -> 'a > ;;
+fun (T x) -> x#id;;
+[%%expect {|
+type sum = T of < id : 'a. 'a -> 'a >
+- : sum -> 'a -> 'a = 
+|}];;
+
+type record = { r: < id: 'a. 'a -> 'a > } ;;
+fun x -> x.r#id;;
+fun {r=x} -> x#id;;
+[%%expect {|
+type record = { r : < id : 'a. 'a -> 'a >; }
+- : record -> 'a -> 'a = 
+- : record -> 'a -> 'a = 
+|}];;
+
+class myself = object (self)
+  method self : 'a. 'a -> 'b = fun _ -> self
+end;;
+[%%expect {|
+class myself : object ('b) method self : 'a -> 'b 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
+;;
+[%%expect {|
+class number :
+  object ('b)
+    val num : int
+    method num : int
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
+  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)
+;;
+[%%expect {|
+val id : 'a -> 'a = 
+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 : 'a -> 'a
+  end
+class ['a] olist :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+  end
+val sum : int #olist -> int = 
+val count : 'a #olist -> int = 
+val append : 'a #olist -> ('a #olist as 'b) -> 'b = 
+|}];;
+
+type 'a t = unit
+;;
+class o = object method x : 'a. ([> `A] as 'a) t -> unit = fun _ -> () end
+;;
+[%%expect {|
+type 'a t = unit
+class o : object method x : [> `A ] t -> unit 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;;
+[%%expect {|
+class c : object method m : d end
+and d : ?x:int -> unit -> object  end
+class d : ?x:int -> unit -> object  end
+and c : object method m : 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
+;;
+[%%expect {|
+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 = 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;;
+[%%expect {|
+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};;
+let bad = {bad = ref None};;
+type bad2 = {mutable bad2 : 'a. 'a option ref option};;
+let bad2 = {bad2 = None};;
+bad2.bad2 <- Some (ref None);;
+[%%expect {|
+type bad = { bad : 'a. 'a option ref; }
+Line _, characters 17-25:
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
+|}];;
+
+(* Type variable scope *)
+
+let f (x:  as 'b>) (y : 'b) = ();;
+let f (x:  as 'b)>) (y : 'b) = ();;
+[%%expect {|
+val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
+val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = 
+|}, Principal{|
+val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
+val f :
+  < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
+  (< p : int * 'c > as 'c) -> unit = 
+|}];;
+
+(* 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;;
+[%%expect {|
+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
+|}];;
+
+(* use before instancing *)
+class c = object method m : 'a. 'a option -> ([> `A] as 'a) = fun x -> `A end;;
+[%%expect {|
+class c : object method m : ([> `A ] as 'a) option -> '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;;
+[%%expect {|
+Line _, characters 30-51:
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
+|}];;
+
+type ('a,'b) list_visitor = < caseNil : 'a; caseCons : 'b -> 'b list -> 'a >
+type 'b alist = < visit : 'a. ('a,'b) list_visitor -> 'a >
+[%%expect {|
+type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : '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};;
+[%%expect {|
+class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
+type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
+|}];;
+
+(* PR#1663 *)
+type t = u and u = t;;
+[%%expect {|
+Line _, characters 0-10:
+Error: The definition of t contains a cycle:
+       u
+|}];;
+
+(* PR#1731 *)
+class ['t] a = object constraint 't = [> `A of 't a] end
+type t = [ `A of t a ];;
+[%%expect {|
+class ['a] a : object constraint 'a = [> `A of 'a 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;;
+[%%expect {|
+Line _, characters 50-59:
+Error: Constraints are not satisfied in this type.
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
+|}];;
+
+(* Full polymorphism if we do not expand *)
+type 'a t = 'a and u = int t;;
+[%%expect {|
+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;;
+[%%expect {|
+type 'a t constraint 'a = int
+Line _, characters 26-32:
+Error: Constraints are not satisfied in this type.
+       Type 'a u t should be an instance of int t
+|}];;
+
+(* 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;;
+[%%expect {|
+type g = int
+type 'a t = unit constraint 'a = g
+Line _, characters 26-32:
+Error: Constraints are not satisfied in this type.
+       Type 'a u t should be an instance of g t
+|}];;
+
+(* Example of wrong expansion *)
+type 'a u = < m : 'a v > and 'a v = 'a list u;;
+[%%expect {|
+Line _, characters 0-24:
+Error: In the definition of v, type 'a list u should be 'a u
+|}];;
+
+(* PR#1744: Ctype.matches *)
+type 'a t = 'a
+type 'a u = A of 'a t;;
+[%%expect {|
+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;;
+[%%expect {|
+type 'a t = < a : 'a >
+- : ('a t as 'a) -> 'a t = 
+type u = 'a t as 'a
+|}, Principal{|
+type 'a t = < a : 'a >
+- : ('a t as 'a) -> ('b t as '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;;
+[%%expect {|
+type t = A | B
+- : [> `A ] * t -> int = 
+- : [> `A ] * t -> int = 
+- : [> `A ] option * t -> int = 
+- : [> `A ] option * t -> int = 
+- : t * [< `A | `B ] -> int = 
+- : [< `A | `B ] * t -> int = 
+Line _, characters 0-41:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(`AnyExtraTag, `AnyExtraTag)
+- : [> `A | `B ] * [> `A | `B ] -> int = 
+Line _, characters 0-29:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 0)
+Line _, characters 21-24:
+Warning 11: this match case is unused.
+- : [< `B ] * int -> int = 
+Line _, characters 0-29:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(0, _)
+Line _, characters 21-24:
+Warning 11: this match case is unused.
+- : int * [< `B ] -> int = 
+|}];;
+
+(* 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];;
+[%%expect {|
+Line _, characters 0-71:
+Error: The definition of a contains a cycle:
+       [> `B of ('a, 'b) b as 'b ] as 'a
+|}];;
+
+(* PR#1917: expanding may change original in Ctype.unify2 *)
+(* Note: since 3.11, the abbreviations are not used when printing
+   a type where they occur recursively inside. *)
+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;;
+[%%expect {|
+class type ['a, 'b] a =
+  object
+    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
+    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
+    method as_a : 'c
+    method b : 'b
+  end
+and ['a, 'b] b =
+  object
+    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
+    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
+    method a : '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;;
+[%%expect {|
+class type ['a] ca =
+  object ('b)
+    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
+    method as_a : ('b, 'a) a
+    method b : 'a
+  end
+class type ['a] cb =
+  object ('b)
+    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+|}];;
+
+type bt = 'b ca cb as 'b
+;;
+[%%expect {|
+type bt = 'a ca cb as 'a
+|}];;
+
+(* 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;;
+[%%expect {|
+class c : object method m : int end
+val f : unit -> c = 
+val f : unit -> c = 
+Line _, characters 11-60:
+Warning 15: the following private methods were made public implicitly:
+ n.
+val f : unit -> < m : int; n : int > = 
+Line _, characters 11-56:
+Error: This object is expected to have type c but actually has type
+         < m : int; n : 'a >
+       The first object type has no method n
+|}];;
+
+
+(* Unsound! *)
+fun (x :  > as 'foo) ->
+  (x :  > as 'bar) >);;
+type 'a foo = 
+type foo' =   
+type 'a bar =  >
+type bar' =   
+let f (x : foo') = (x : bar');;
+[%%expect {|
+Line _, characters 3-4:
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
+       but an expression was expected of type
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
+       Types for method m are incompatible
+|}];;
+
+fun (x :  as 'foo)>) ->
+  (x : )> as 'bar);;
+fun (x :  as 'foo)>) ->
+  (x : )> as 'bar);;
+fun (x :  as 'foo) ->
+  (x :  as 'bar)>);;
+let f x =
+    (x :  ('a *  'bar> as 'bar)>
+       :>  ('a * 'foo)> as 'foo);;
+[%%expect {|
+Line _, characters 3-4:
+Error: This expression has type
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
+       but an expression was expected of type
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
+       Types for method m are incompatible
+|}];;
+
+module M
+: sig val f : ( as 'bar)>) -> unit end
+= struct let f (x :  as 'foo) = () end;;
+module M
+: sig type t =  as 'bar)> end
+= struct type t =  as 'foo end;;
+[%%expect {|
+Line _, characters 2-64:
+Error: Signature mismatch:
+       Modules do not match:
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
+       is not included in
+         sig
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
+         end
+       Values do not match:
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
+       is not included in
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
+|}];;
+
+module M : sig type 'a t type u =  end
+= struct type 'a t = int type u =  end;;
+module M : sig type 'a t val f :  -> int end
+= struct type 'a t = int let f (x : ) = x#m end;;
+(* The following should be accepted too! *)
+module M : sig type 'a t val f :  -> int end
+= struct type 'a t = int let f x = x#m end;;
+[%%expect {|
+module M : sig type 'a t type u = < m : 'a. 'a t > end
+module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
+module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
+|}];;
+
+let f x y =
+  ignore (x :>  'c * < > > as 'c);
+  ignore (y :>  'd * < > > as 'd);
+  x = y;;
+[%%expect {|
+val f :
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = 
+|}];;
+
+
+(* Subtyping *)
+
+type t = [`A|`B];;
+type v = private [> t];;
+fun x -> (x : t :> v);;
+type u = private [< t];;
+fun x -> (x : u :> v);;
+fun x -> (x : v :> u);;
+type v = private [< t];;
+fun x -> (x : u :> v);;
+type p = ;;
+type q = private ;;
+fun x -> (x : q :> p);;
+fun x -> (x : p :> q);;
+[%%expect {|
+type t = [ `A | `B ]
+type v = private [> t ]
+- : t -> v = 
+type u = private [< t ]
+- : u -> v = 
+Line _, characters 9-21:
+Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ]
+|}];;
+
+let f1 x =
+  (x :  as 'a) -> int>
+    :>  as 'b) -> int>);;
+let f2 x =
+  (x : ;..> as 'a) -> int>
+    :> ;..> as 'b) -> int>);;
+let f3 x =
+  (x : ;..> as 'a) -> int>
+    :> ;..> as 'b) -> int>);;
+let f4 x = (x : ;..> :> ;..>);;
+let f5 x =
+  (x :  ] as 'a> :>  ] as 'a>);;
+let f6 x =
+  (x :  ] as 'a> :>  ] as 'a>);;
+[%%expect {|
+Line _, characters 2-88:
+Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
+         < m : 'b. (< p : int; q : int; .. > as 'b) -> int >
+       Type < p : int; q : int; .. > as 'c is not a subtype of
+         < p : int; .. > as 'd
+|}];;
+
+(* Keep sharing the epsilons *)
+let f x = if true then (x : < m : 'a. 'a -> 'a >) else x;;
+fun x -> (f x)#m;; (* Warning 18 *)
+let f (x, y) = if true then (x : < m : 'a. 'a -> 'a >) else x;;
+fun x -> (f (x,x))#m;; (* Warning 18 *)
+let f x = if true then [| (x : < m : 'a. 'a -> 'a >) |] else [|x|];;
+fun x -> (f x).(0)#m;; (* Warning 18 *)
+[%%expect {|
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+|}, Principal{|
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
+Line _, characters 9-16:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
+Line _, characters 9-20:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
+Line _, characters 9-20:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+|}];;
+
+(* Not really principal? *)
+class c = object method id : 'a. 'a -> 'a = fun x -> x end;;
+type u = c option;;
+let just = function None -> failwith "just" | Some x -> x;;
+let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
+let g x =
+  let none = (fun y -> ignore [y;(None:u)]; y) None in
+  let x = List.hd [Some x; none] in (just x)#id;;
+let h x =
+  let none = let y = None in ignore [y;(None:u)]; y in
+  let x = List.hd [Some x; none] in (just x)#id;;
+[%%expect {|
+class c : object method id : 'a -> 'a end
+type u = c option
+val just : 'a option -> 'a = 
+val f : c -> 'a -> 'a = 
+val g : c -> 'a -> 'a = 
+val h : < id : 'a; .. > -> 'a = 
+|}, Principal{|
+class c : object method id : 'a -> 'a end
+type u = c option
+val just : 'a option -> 'a = 
+Line _, characters 42-62:
+Warning 18: this use of a polymorphic method is not principal.
+val f : c -> 'a -> 'a = 
+Line _, characters 36-47:
+Warning 18: this use of a polymorphic method is not principal.
+val g : c -> 'a -> 'a = 
+val h : < id : 'a; .. > -> 'a = 
+|}];;
+
+(* Only solved for parameterless abbreviations *)
+type 'a u = c option;;
+let just = function None -> failwith "just" | Some x -> x;;
+let f x = let l = [Some x; (None : _ u)] in (just(List.hd l))#id;;
+[%%expect {|
+type 'a u = c option
+val just : 'a option -> 'a = 
+val f : c -> 'a -> 'a = 
+|}];;
+
+(* polymorphic recursion *)
+
+let rec f : 'a. 'a -> _ = fun x -> 1 and g x = f x;;
+type 'a t = Leaf of 'a | Node of ('a * 'a) t;;
+let rec depth : 'a. 'a t -> _ =
+  function Leaf _ -> 1 | Node x -> 1 + depth x;;
+let rec depth : 'a. 'a t -> _ =
+  function Leaf _ -> 1 | Node x -> 1 + d x
+and d x = depth x;; (* fails *)
+let rec depth : 'a. 'a t -> _ =
+  function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
+let rec depth : 'a. 'a t -> _ =
+  function Leaf x -> x | Node x -> depth x;; (* fails *)
+let rec depth : 'a 'b. 'a t -> 'b =
+  function Leaf x -> x | Node x -> depth x;; (* fails *)
+let rec r : 'a. 'a list * 'b list ref = [], ref []
+and q () = r;;
+let f : 'a. _ -> _ = fun x -> x;;
+let zero : 'a. [> `Int of int | `B of 'a] as 'a  = `Int 0;; (* ok *)
+let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
+[%%expect {|
+val f : 'a -> int = 
+val g : 'a -> int = 
+type 'a t = Leaf of 'a | Node of ('a * 'a) t
+val depth : 'a t -> int = 
+Line _, characters 2-42:
+Error: This definition has type 'a t -> int which is less general than
+         'a0. 'a0 t -> int
+|}];;
+
+(* compare with records (should be the same) *)
+type t = {f: 'a. [> `Int of int | `B of 'a] as 'a}
+let zero = {f = `Int 0} ;;
+type t = {f: 'a. [< `Int of int] as 'a}
+let zero = {f = `Int 0} ;; (* fails *)
+[%%expect {|
+type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
+val zero : t = {f = `Int 0}
+type t = { f : 'a. [< `Int of int ] as 'a; }
+Line _, characters 16-22:
+Error: This expression has type [> `Int of int ]
+       but an expression was expected of type [< `Int of int ]
+       Types for tag `Int are incompatible
+|}];;
+
+(* Yet another example *)
+let rec id : 'a. 'a -> 'a = fun x -> x
+and neg i b = (id (-i), id (not b));;
+[%%expect {|
+val id : 'a -> 'a = 
+val neg : int -> bool -> int * bool = 
+|}];;
+
+(* De Xavier *)
+
+type t = A of int | B of (int*t) list | C of (string*t) list
+[%%expect {|
+type t = A of int | B of (int * t) list | C of (string * t) list
+|}];;
+
+let rec transf f = function
+  | A x -> f x
+  | B l -> B (transf_alist f l)
+  | C l -> C (transf_alist f l)
+and transf_alist : 'a. _ -> ('a*t) list -> ('a*t) list = fun f -> function
+  | [] -> []
+  | (k,v)::tl -> (k, transf f v) :: transf_alist f tl
+;;
+[%%expect {|
+val transf : (int -> t) -> t -> t = 
+val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = 
+|}];;
+
+(* PR#4862 *)
+
+type t = {f: 'a. ('a list -> int) Lazy.t}
+let l : t = { f = lazy (raise Not_found)};;
+[%%expect {|
+type t = { f : 'a. ('a list -> int) Lazy.t; }
+val l : t = {f = }
+|}];;
+
+(* variant *)
+type t = {f: 'a. 'a -> unit};;
+let f ?x y = () in {f};;
+let f ?x y = y in {f};; (* fail *)
+[%%expect {|
+type t = { f : 'a. 'a -> unit; }
+- : t = {f = }
+Line _, characters 19-20:
+Error: This field value has type unit -> unit which is less general than
+         'a. 'a -> unit
+|}];;
+
+(* Polux Moon caml-list 2011-07-26 *)
+module Polux = struct
+  type 'par t = 'par
+  let ident v = v
+  class alias = object method alias : 'a . 'a t -> 'a = ident end
+  let f (x : ) = (x : )
+end;;
+[%%expect {|
+module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+|}];;
+
+(* PR#5560 *)
+
+let (a, b) = (raise Exit : int * int);;
+type t = { foo : int }
+let {foo} = (raise Exit : t);;
+type s = A of int
+let (A x) = (raise Exit : s);;
+[%%expect {|
+Exception: Pervasives.Exit.
+|}];;
+
+(* PR#5224 *)
+
+type 'x t = < f : 'y. 'y t >;;
+[%%expect {|
+Line _, characters 0-28:
+Error: In the definition of t, type 'y t should be 'x t
+|}];;
+
+(* PR#6056, PR#6057 *)
+let using_match b =
+  let f =
+    match b with
+    | true -> fun x -> x
+    | false -> fun x -> x
+  in
+  f 0,f
+;;
+[%%expect {|
+val using_match : bool -> int * ('a -> 'a) = 
+|}];;
+
+match (fun x -> x), fun x -> x with x, y -> x, y;;
+match fun x -> x with x -> x, x;;
+[%%expect {|
+- : ('a -> 'a) * ('b -> 'b) = (, )
+- : ('a -> 'a) * ('b -> 'b) = (, )
+|}];;
+
+(* PR#6747 *)
+(* ok *)
+let n = object
+  method m : 'x 'o. ([< `Foo of 'x] as 'o) -> 'x = fun x -> assert false
+end;;
+[%%expect {|
+val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = 
+|}];;
+(* ok, but not with -principal *)
+let n =
+  object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+val n : < m : 'x. [< `Foo of 'x ] -> 'x > = 
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
+(* fail *)
+let (n : < m : 'a. [< `Foo of int] -> 'a >) =
+  object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+Line _, characters 2-72:
+Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
+       but an expression was expected of type
+         < m : 'a. [< `Foo of int ] -> 'a >
+       The universal variable 'x would escape its scope
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
+(* fail *)
+let (n : 'b -> < m : 'a . ([< `Foo of int] as 'b) -> 'a >) = fun x ->
+  object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+Line _, characters 2-72:
+Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
+       but an expression was expected of type
+         < m : 'a. [< `Foo of int ] -> 'a >
+       The universal variable 'x would escape its scope
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
+
+(* PR#6171 *)
+let f b (x: 'x) =
+  let module M = struct type t = A end in
+  if b then x else M.A;;
+[%%expect {|
+Line _, characters 19-22:
+Error: This expression has type M.t but an expression was expected of type 'x
+       The type constructor M.t would escape its scope
+|}];;
+
+
+(* PR#6987 *)
+type 'a t = V1 of 'a
+
+type ('c,'t) pvariant = [ `V of ('c * 't t) ]
+
+class ['c] clss =
+  object
+    method mthod : 't . 'c -> 't t -> ('c, 't) pvariant = fun c x ->
+      `V (c, x)
+  end;;
+
+let f2 = fun o c x -> match x with | V1 _ -> x
+
+let rec f1 o c x =
+  match (o :> _ clss)#mthod c x with
+  | `V c -> f2 o c x;;
+[%%expect{|
+type 'a t = V1 of 'a
+type ('c, 't) pvariant = [ `V of 'c * 't t ]
+class ['c] clss : object method mthod : 'c -> 't t -> ('c, 't) pvariant end
+val f2 : 'a -> 'b -> 'c t -> 'c t = 
+val f1 :
+  < mthod : 't. 'a -> 't t -> [< ('a, 't) pvariant ]; .. > ->
+  'a -> 'b t -> 'b t = 
+|}]
+
+(* PR#7285 *)
+type (+'a,-'b) foo = private int;;
+let f (x : int) : ('a,'a) foo = Obj.magic x;;
+let x = f 3;;
+[%%expect{|
+type (+'a, -'b) foo = private int
+val f : int -> ('a, 'a) foo = 
+val x : ('_a, '_a) foo = 3
+|}]
+
+(* PR#7395 *)
+type u
+type 'a t = u;;
+let c (f : u -> u) =
+ object
+   method apply: 'a. 'a t -> 'a t = fun x -> f x
+ end;;
+[%%expect{|
+type u
+type 'a t = u
+val c : (u -> u) -> < apply : 'a. 'a t -> 'a t > = 
+|}]
diff --git a/testsuite/tests/typing-polyvariants-bugs-2/Makefile b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
new file mode 100644
index 00000000..2775418c
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
@@ -0,0 +1,26 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+default:
+	@printf " ... testing 'pr3918':"
+	@($(OCAMLC) -c pr3918a.mli \
+	&& $(OCAMLC) -c pr3918b.mli \
+	&& $(OCAMLC) -c pr3918c.ml \
+	&& echo " => passed") || echo " => failed"
+
+clean: defaultclean
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-polyvariants-bugs-2/pr3918a.mli b/testsuite/tests/typing-polyvariants-bugs-2/pr3918a.mli
new file mode 100644
index 00000000..b0afbbe5
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs-2/pr3918a.mli
@@ -0,0 +1 @@
+type 'a voption = [ `None | `Some of 'a]
diff --git a/testsuite/tests/typing-polyvariants-bugs-2/pr3918b.mli b/testsuite/tests/typing-polyvariants-bugs-2/pr3918b.mli
new file mode 100644
index 00000000..3513ff9c
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs-2/pr3918b.mli
@@ -0,0 +1 @@
+type 'a vlist = ('a * 'b) Pr3918a.voption as 'b
diff --git a/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml b/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml
new file mode 100644
index 00000000..c49ed6e0
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml
@@ -0,0 +1,10 @@
+(*
+  ocamlc -c pr3918a.mli pr3918b.mli
+  rm -f pr3918a.cmi
+  ocamlc -c pr3918c.ml
+*)
+
+open Pr3918b
+
+let f x = (x : 'a vlist :> 'b vlist)
+let f (x : 'a vlist) = (x : 'b vlist)
diff --git a/testsuite/tests/typing-polyvariants-bugs/Makefile b/testsuite/tests/typing-polyvariants-bugs/Makefile
new file mode 100644
index 00000000..69e2ee7b
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml b/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml
new file mode 100644
index 00000000..ef857149
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml
@@ -0,0 +1,11 @@
+module type Poly = sig
+  type 'a t = 'a constraint 'a = [> ]
+end
+
+module Combine (A : Poly) (B : Poly) = struct
+  type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t
+end
+
+module C = Combine
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+  (struct type 'a t = 'a constraint 'a = [> ] end)
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml b/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml
new file mode 100644
index 00000000..b486290c
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml
@@ -0,0 +1,15 @@
+module type Priv = sig
+  type t = private int
+end
+
+module Make (Unit:sig end): Priv = struct type t = int end
+
+module A = Make (struct end)
+
+module type Priv' = sig
+  type t = private [> `A]
+end
+
+module Make' (Unit:sig end): Priv' = struct type t = [`A] end
+
+module A' = Make' (struct end)
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml b/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml
new file mode 100644
index 00000000..86cb665a
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml
@@ -0,0 +1,14 @@
+(* PR5057 *)
+
+module TT = struct
+  module IntSet = Set.Make(struct type t = int let compare = compare end)
+end
+
+let () =
+  let f flag =
+    let module T = TT in
+    let _ = match flag with `A -> 0 | `B r -> r in
+    let _ = match flag with `A -> T.IntSet.mem | `B r -> r in
+    ()
+  in
+  f `A
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml b/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml
new file mode 100644
index 00000000..15bb776b
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml
@@ -0,0 +1,7 @@
+(* This one should fail *)
+
+let f flag =
+  let module T = Set.Make(struct type t = int let compare = compare end) in
+  let _ = match flag with `A -> 0 | `B r -> r in
+  let _ = match flag with `A -> T.mem | `B r -> r in
+  ()
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml b/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml
new file mode 100644
index 00000000..dd1d05c1
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml
@@ -0,0 +1,13 @@
+module type S = sig
+ type +'a t
+
+ val foo : [`A] t -> unit
+ val bar : [< `A | `B] t -> unit
+end
+
+module Make(T : S) = struct
+ let f x =
+   T.foo x;
+   T.bar x;
+   (x :> [`A | `C] T.t)
+end
diff --git a/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml b/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml
new file mode 100644
index 00000000..4e31243b
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml
@@ -0,0 +1,53 @@
+type 'a termpc =
+    [`And of 'a * 'a
+    |`Or of 'a * 'a
+    |`Not of 'a
+    |`Atom of string
+    ]
+
+type 'a termk =
+    [`Dia of 'a
+    |`Box of 'a
+    |'a termpc
+    ]
+
+module type T = sig
+  type term
+  val map : (term -> term) -> term -> term
+  val nnf : term -> term
+  val nnf_not : term -> term
+end
+
+module Fpc(X : T with type term = private [> 'a termpc] as 'a) =
+  struct
+    type term = X.term termpc
+    let nnf = function
+      |`Not(`Atom _) as x -> x
+      |`Not x     -> X.nnf_not x
+      | x         -> X.map X.nnf x
+    let map f : term -> X.term = function
+      |`Not x    -> `Not (f x)
+      |`And(x,y) -> `And (f x, f y)
+      |`Or (x,y) -> `Or  (f x, f y)
+      |`Atom _ as x -> x
+    let nnf_not : term -> _ = function
+      |`Not x    -> X.nnf x
+      |`And(x,y) -> `Or  (X.nnf_not x, X.nnf_not y)
+      |`Or (x,y) -> `And (X.nnf_not x, X.nnf_not y)
+      |`Atom _ as x -> `Not x
+  end
+
+module Fk(X : T with type term = private [> 'a termk] as 'a) =
+  struct
+    type term = X.term termk
+    module Pc = Fpc(X)
+    let map f : term -> _ = function
+      |`Dia x -> `Dia (f x)
+      |`Box x -> `Box (f x)
+      |#termpc as x -> Pc.map f x
+    let nnf = Pc.nnf
+    let nnf_not : term -> _ = function
+      |`Dia x -> `Box (X.nnf_not x)
+      |`Box x -> `Dia (X.nnf_not x)
+      |#termpc as x -> Pc.nnf_not x
+  end
diff --git a/testsuite/tests/typing-private-bugs/Makefile b/testsuite/tests/typing-private-bugs/Makefile
new file mode 100644
index 00000000..69e2ee7b
--- /dev/null
+++ b/testsuite/tests/typing-private-bugs/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-private-bugs/pr5026_bad.ml b/testsuite/tests/typing-private-bugs/pr5026_bad.ml
new file mode 100644
index 00000000..10699952
--- /dev/null
+++ b/testsuite/tests/typing-private-bugs/pr5026_bad.ml
@@ -0,0 +1,11 @@
+type untyped;;
+type -'a typed = private untyped;;
+type -'typing wrapped = private sexp
+and +'a t = 'a typed wrapped
+and sexp = private untyped wrapped;;
+class type ['a] s3 = object
+  val underlying : 'a t
+end;;
+class ['a] s3object r : ['a] s3 = object
+  val underlying = r
+end;;
diff --git a/testsuite/tests/typing-private-bugs/pr5469_ok.ml b/testsuite/tests/typing-private-bugs/pr5469_ok.ml
new file mode 100644
index 00000000..74d35549
--- /dev/null
+++ b/testsuite/tests/typing-private-bugs/pr5469_ok.ml
@@ -0,0 +1,7 @@
+module M (T:sig type t end)
+ = struct type t = private { t : T.t } end
+module P
+ = struct
+       module T = struct type t end
+       module R = M(T)
+ end
diff --git a/testsuite/tests/typing-private/Makefile b/testsuite/tests/typing-private/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-private/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-private/private.ml b/testsuite/tests/typing-private/private.ml
new file mode 100644
index 00000000..fd3b7bd7
--- /dev/null
+++ b/testsuite/tests/typing-private/private.ml
@@ -0,0 +1,118 @@
+module Foobar : sig
+  type t = private int
+end = struct
+  type t = int
+end;;
+
+module F0 : sig type t = private int end = Foobar;;
+
+let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+
+module F = Foobar;;
+
+let f (x : F.t) = (x : Foobar.t);;
+
+module M = struct type t =  end;;
+module M1 : sig type t = private  end = M;;
+module M2 :  sig type t = private  end = M1;;
+fun (x : M1.t) -> (x : M2.t);; (* fails *)
+
+module M3 : sig type t = private M1.t end = M1;;
+fun x -> (x : M3.t :> M1.t);;
+fun x -> (x : M3.t :> M.t);;
+module M4 : sig type t = private M3.t end = M2;; (* fails *)
+module M4 : sig type t = private M3.t end = M;; (* fails *)
+module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+module M5 : sig type t = private M1.t end = M3;;
+module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+
+module Bar : sig type t = private Foobar.t val f : int -> t end =
+  struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+
+module M : sig
+  type t = private T of int
+  val mk : int -> t
+end = struct
+  type t = T of int
+  let mk x = T(x)
+end;;
+
+module M1 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  type t = M.t
+  let mk = M.mk
+end;;
+
+module M2 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  include M
+end;;
+
+module M3 : sig
+  type t = M.t
+  val mk : int -> t
+end = M;;
+
+module M4 : sig
+    type t = M.t = T of int
+    val mk : int -> t
+  end = M;;
+(* Error: The variant or record definition does not match that of type M.t *)
+
+module M5 : sig
+  type t = M.t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M6 : sig
+  type t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M' : sig
+  type t_priv = private T of int
+  type t = t_priv
+  val mk : int -> t
+end = struct
+  type t_priv = T of int
+  type t = t_priv
+  let mk x = T(x)
+end;;
+
+module M3' : sig
+  type t = M'.t
+  val mk : int -> t
+end = M';;
+
+module M : sig type 'a t = private T of 'a end =
+  struct type 'a t = T of 'a end;;
+
+module M1 : sig type 'a t = 'a M.t = private T of 'a end =
+  struct type 'a t = 'a M.t = private T of 'a end;;
+
+(* PR#6090 *)
+module Test = struct type t = private A end
+module Test2 : module type of Test with type t = Test.t = Test;;
+let f (x : Test.t) = (x : Test2.t);;
+let f Test2.A = ();;
+let a = Test2.A;; (* fail *)
+(* The following should fail from a semantical point of view,
+   but allow it for backward compatibility *)
+module Test2 : module type of Test with type t = private Test.t = Test;;
+
+(* PR#6331 *)
+type t = private < x : int; .. > as 'a;;
+type t = private (< x : int; .. > as 'a) as 'a;;
+type t = private < x : int > as 'a;;
+type t = private (< x : int > as 'a) as 'b;;
+type 'a t = private < x : int; .. > as 'a;;
+type 'a t = private 'a constraint 'a = < x : int; .. >;;
+
+(* PR#7437 *)
+type t = [` Closed ];;
+type nonrec t = private [> t];;
+
diff --git a/testsuite/tests/typing-private/private.ml.principal.reference b/testsuite/tests/typing-private/private.ml.principal.reference
new file mode 100644
index 00000000..39b9440f
--- /dev/null
+++ b/testsuite/tests/typing-private/private.ml.principal.reference
@@ -0,0 +1,127 @@
+
+#         module Foobar : sig type t = private int end
+#   module F0 : sig type t = private int end
+#   Characters 21-22:
+  let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+                      ^
+Error: This expression has type F0.t but an expression was expected of type
+         Foobar.t
+#   module F = Foobar
+#   val f : F.t -> Foobar.t = 
+#   module M : sig type t = < m : int > end
+# module M1 : sig type t = private < m : int; .. > end
+# module M2 : sig type t = private < m : int; .. > end
+# Characters 19-20:
+  fun (x : M1.t) -> (x : M2.t);; (* fails *)
+                     ^
+Error: This expression has type M1.t but an expression was expected of type
+         M2.t
+#   module M3 : sig type t = private M1.t end
+# - : M3.t -> M1.t = 
+# - : M3.t -> M.t = 
+# Characters 44-46:
+  module M4 : sig type t = private M3.t end = M2;; (* fails *)
+                                              ^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = M2.t end
+       is not included in
+         sig type t = private M3.t end
+       Type declarations do not match:
+         type t = M2.t
+       is not included in
+         type t = private M3.t
+# Characters 44-45:
+  module M4 : sig type t = private M3.t end = M;; (* fails *)
+                                              ^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = < m : int > end
+       is not included in
+         sig type t = private M3.t end
+       Type declarations do not match:
+         type t = < m : int >
+       is not included in
+         type t = private M3.t
+# Characters 44-46:
+  module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+                                              ^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = M1.t end
+       is not included in
+         sig type t = private M3.t end
+       Type declarations do not match:
+         type t = M1.t
+       is not included in
+         type t = private M3.t
+# module M5 : sig type t = private M1.t end
+# Characters 53-55:
+  module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+                                                       ^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = M1.t end
+       is not included in
+         sig type t = private < n : int; .. > end
+       Type declarations do not match:
+         type t = M1.t
+       is not included in
+         type t = private < n : int; .. >
+#     Characters 69-118:
+    struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = int val f : int -> t end
+       is not included in
+         sig type t = private Foobar.t val f : int -> t end
+       Type declarations do not match:
+         type t = int
+       is not included in
+         type t = private Foobar.t
+#               module M : sig type t = private T of int val mk : int -> t end
+#               module M1 : sig type t = M.t val mk : int -> t end
+#             module M2 : sig type t = M.t val mk : int -> t end
+#         module M3 : sig type t = M.t val mk : int -> t end
+#         Characters 21-44:
+      type t = M.t = T of int
+      ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type M.t
+       A private type would be revealed.
+#           module M5 : sig type t = M.t = private T of int val mk : int -> t end
+#         module M6 : sig type t = private T of int val mk : int -> t end
+#                   module M' :
+  sig type t_priv = private T of int type t = t_priv val mk : int -> t end
+#         module M3' : sig type t = M'.t val mk : int -> t end
+#     module M : sig type 'a t = private T of 'a end
+#     module M1 : sig type 'a t = 'a M.t = private T of 'a end
+#       module Test : sig type t = private A end
+module Test2 : sig type t = Test.t = private A end
+# val f : Test.t -> Test2.t = 
+# val f : Test2.t -> unit = 
+# Characters 8-15:
+  let a = Test2.A;; (* fail *)
+          ^^^^^^^
+Error: Cannot create values of the private type Test2.t
+# *   Characters 148-171:
+  module Test2 : module type of Test with type t = private Test.t = Test;;
+                                          ^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: spurious use of private
+module Test2 : sig type t = Test.t = private A end
+#     type t = private < x : int; .. >
+# type t = private < x : int; .. >
+# type t = private < x : int >
+# type t = private < x : int >
+# Characters -1--1:
+  type 'a t = private < x : int; .. > as 'a;;
+  
+Error: Type declarations do not match:
+         type 'a t = private 'a constraint 'a = < x : int; .. >
+       is not included in
+         type 'a t
+       Their constraints differ.
+# type 'a t = private 'a constraint 'a = < x : int; .. >
+#     type t = [ `Closed ]
+# type nonrec t = private [> t ]
+#   
diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference
new file mode 100644
index 00000000..ace6cbdb
--- /dev/null
+++ b/testsuite/tests/typing-private/private.ml.reference
@@ -0,0 +1,127 @@
+
+#         module Foobar : sig type t = private int end
+#   module F0 : sig type t = private int end
+#   Characters 21-22:
+  let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+                      ^
+Error: This expression has type F0.t but an expression was expected of type
+         Foobar.t
+#   module F = Foobar
+#   val f : F.t -> Foobar.t = 
+#   module M : sig type t = < m : int > end
+# module M1 : sig type t = private < m : int; .. > end
+# module M2 : sig type t = private < m : int; .. > end
+# Characters 19-20:
+  fun (x : M1.t) -> (x : M2.t);; (* fails *)
+                     ^
+Error: This expression has type M1.t but an expression was expected of type
+         M2.t
+#   module M3 : sig type t = private M1.t end
+# - : M3.t -> M1.t = 
+# - : M3.t -> M.t = 
+# Characters 44-46:
+  module M4 : sig type t = private M3.t end = M2;; (* fails *)
+                                              ^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = M2.t end
+       is not included in
+         sig type t = private M3.t end
+       Type declarations do not match:
+         type t = M2.t
+       is not included in
+         type t = private M3.t
+# Characters 44-45:
+  module M4 : sig type t = private M3.t end = M;; (* fails *)
+                                              ^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = < m : int > end
+       is not included in
+         sig type t = private M3.t end
+       Type declarations do not match:
+         type t = < m : int >
+       is not included in
+         type t = private M3.t
+# Characters 44-46:
+  module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+                                              ^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = M1.t end
+       is not included in
+         sig type t = private M3.t end
+       Type declarations do not match:
+         type t = M1.t
+       is not included in
+         type t = private M3.t
+# module M5 : sig type t = private M1.t end
+# Characters 53-55:
+  module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+                                                       ^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = M1.t end
+       is not included in
+         sig type t = private < n : int; .. > end
+       Type declarations do not match:
+         type t = M1.t
+       is not included in
+         type t = private < n : int; .. >
+#     Characters 69-118:
+    struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = int val f : int -> t end
+       is not included in
+         sig type t = private Foobar.t val f : int -> t end
+       Type declarations do not match:
+         type t = int
+       is not included in
+         type t = private Foobar.t
+#               module M : sig type t = private T of int val mk : int -> t end
+#               module M1 : sig type t = M.t val mk : int -> t end
+#             module M2 : sig type t = M.t val mk : int -> t end
+#         module M3 : sig type t = M.t val mk : int -> t end
+#         Characters 21-44:
+      type t = M.t = T of int
+      ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type M.t
+       A private type would be revealed.
+#           module M5 : sig type t = M.t = private T of int val mk : int -> t end
+#         module M6 : sig type t = private T of int val mk : int -> t end
+#                   module M' :
+  sig type t_priv = private T of int type t = t_priv val mk : int -> t end
+#         module M3' : sig type t = M'.t val mk : int -> t end
+#     module M : sig type 'a t = private T of 'a end
+#     module M1 : sig type 'a t = 'a M.t = private T of 'a end
+#       module Test : sig type t = private A end
+module Test2 : sig type t = Test.t = private A end
+# val f : Test.t -> Test2.t = 
+# val f : Test2.t -> unit = 
+# Characters 8-15:
+  let a = Test2.A;; (* fail *)
+          ^^^^^^^
+Error: Cannot create values of the private type Test2.t
+# *   Characters 148-171:
+  module Test2 : module type of Test with type t = private Test.t = Test;;
+                                          ^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: spurious use of private
+module Test2 : sig type t = Test.t = private A end
+#     type t = private < x : int; .. >
+# type t = private < x : int; .. >
+# type t = private < x : int >
+# type t = private < x : int >
+# Characters -1--1:
+  type 'a t = private < x : int; .. > as 'a;;
+  
+Error: Type declarations do not match:
+         type 'a t = private < x : int; .. > constraint 'a = 'a t
+       is not included in
+         type 'a t
+       Their constraints differ.
+# type 'a t = private 'a constraint 'a = < x : int; .. >
+#     type t = [ `Closed ]
+# type nonrec t = private [> t ]
+#   
diff --git a/testsuite/tests/typing-recmod/Makefile b/testsuite/tests/typing-recmod/Makefile
new file mode 100644
index 00000000..69e2ee7b
--- /dev/null
+++ b/testsuite/tests/typing-recmod/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-recmod/t01bad.ml b/testsuite/tests/typing-recmod/t01bad.ml
new file mode 100644
index 00000000..8a471e07
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t01bad.ml
@@ -0,0 +1,2 @@
+(* Bad (t = t) *)
+module rec A : sig type t = A.t end = struct type t = A.t end;;
diff --git a/testsuite/tests/typing-recmod/t02bad.ml b/testsuite/tests/typing-recmod/t02bad.ml
new file mode 100644
index 00000000..b4301a41
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t02bad.ml
@@ -0,0 +1,3 @@
+(* Bad (t = t) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = A.t end = struct type t = A.t end;;
diff --git a/testsuite/tests/typing-recmod/t03ok.ml b/testsuite/tests/typing-recmod/t03ok.ml
new file mode 100644
index 00000000..577ea20a
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t03ok.ml
@@ -0,0 +1,3 @@
+(* OK (t = int) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = int end = struct type t = int end;;
diff --git a/testsuite/tests/typing-recmod/t04bad.ml b/testsuite/tests/typing-recmod/t04bad.ml
new file mode 100644
index 00000000..ad3f985a
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t04bad.ml
@@ -0,0 +1,2 @@
+(* Bad (t = int * t) *)
+module rec A : sig type t = int * A.t end = struct type t = int * A.t end;;
diff --git a/testsuite/tests/typing-recmod/t05bad.ml b/testsuite/tests/typing-recmod/t05bad.ml
new file mode 100644
index 00000000..08fe60f0
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t05bad.ml
@@ -0,0 +1,3 @@
+(* Bad (t = t -> int) *)
+module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end
+       and B : sig type t = A.t end = struct type t = A.t end;;
diff --git a/testsuite/tests/typing-recmod/t06ok.ml b/testsuite/tests/typing-recmod/t06ok.ml
new file mode 100644
index 00000000..a220a8e0
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t06ok.ml
@@ -0,0 +1,3 @@
+(* OK (t = ) *)
+module rec A : sig type t =  end = struct type t =  end
+       and B : sig type t = A.t end = struct type t = A.t end;;
diff --git a/testsuite/tests/typing-recmod/t07bad.ml b/testsuite/tests/typing-recmod/t07bad.ml
new file mode 100644
index 00000000..ec24ea4d
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t07bad.ml
@@ -0,0 +1,3 @@
+(* Bad (not regular) *)
+module rec A : sig type 'a t =  end
+             = struct type 'a t =  end;;
diff --git a/testsuite/tests/typing-recmod/t08bad.ml b/testsuite/tests/typing-recmod/t08bad.ml
new file mode 100644
index 00000000..5ebafd11
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t08bad.ml
@@ -0,0 +1,4 @@
+(* Bad (not regular) *)
+module rec A : sig type 'a t =  end
+             = struct type 'a t =  end
+       and B : sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end;;
diff --git a/testsuite/tests/typing-recmod/t09bad.ml b/testsuite/tests/typing-recmod/t09bad.ml
new file mode 100644
index 00000000..ade5bcb7
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t09bad.ml
@@ -0,0 +1,5 @@
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a B.t end
+             = struct type 'a t = 'a B.t end
+       and B : sig type 'a t =  end
+             = struct type 'a t =  end;;
diff --git a/testsuite/tests/typing-recmod/t10ok.ml b/testsuite/tests/typing-recmod/t10ok.ml
new file mode 100644
index 00000000..3094a42a
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t10ok.ml
@@ -0,0 +1,5 @@
+(* OK *)
+module rec A : sig type 'a t = 'a array B.t * 'a list B.t end
+             = struct type 'a t = 'a array B.t * 'a list B.t end
+       and B : sig type 'a t =  end
+             = struct type 'a t =  end;;
diff --git a/testsuite/tests/typing-recmod/t11bad.ml b/testsuite/tests/typing-recmod/t11bad.ml
new file mode 100644
index 00000000..e18339ac
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t11bad.ml
@@ -0,0 +1,5 @@
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a list B.t end
+             = struct type 'a t = 'a list B.t end
+       and B : sig type 'a t =  end
+             = struct type 'a t =  end;;
diff --git a/testsuite/tests/typing-recmod/t12bad.ml b/testsuite/tests/typing-recmod/t12bad.ml
new file mode 100644
index 00000000..71100e6e
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t12bad.ml
@@ -0,0 +1,13 @@
+(* Bad (not regular) *)
+module rec M :
+    sig
+      class ['a] c : 'a -> object
+        method map : ('a -> 'b) -> 'b M.c
+      end
+    end
+  = struct
+      class ['a] c (x : 'a) = object
+        method map : 'b. ('a -> 'b) -> 'b M.c
+          = fun f -> new M.c (f x)
+      end
+    end;;
diff --git a/testsuite/tests/typing-recmod/t13ok.ml b/testsuite/tests/typing-recmod/t13ok.ml
new file mode 100644
index 00000000..4fea6e1f
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t13ok.ml
@@ -0,0 +1,5 @@
+(* OK *)
+class type [ 'node ] extension = object method node : 'node end
+class type [ 'ext ] node = object constraint 'ext = 'ext node #extension end
+class x = object method node : x node = assert false end
+type t = x node;;
diff --git a/testsuite/tests/typing-recmod/t14bad.ml b/testsuite/tests/typing-recmod/t14bad.ml
new file mode 100644
index 00000000..1b92a28c
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t14bad.ml
@@ -0,0 +1,17 @@
+(* Bad - PR 4261 *)
+
+module PR_4261 = struct
+  module type S =
+  sig
+    type t
+  end
+
+  module type T =
+  sig
+    module D : S
+    type t = D.t
+  end
+
+  module rec U : T with module D = U' = U
+  and U' : S with type t = U'.t = U
+end;;
diff --git a/testsuite/tests/typing-recmod/t15bad.ml b/testsuite/tests/typing-recmod/t15bad.ml
new file mode 100644
index 00000000..b387ae53
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t15bad.ml
@@ -0,0 +1,3 @@
+(* Bad - PR 4512 *)
+module type S' = sig type t = int end
+module rec M : S' with type t = M.t = struct type t = M.t end;;
diff --git a/testsuite/tests/typing-recmod/t16ok.ml b/testsuite/tests/typing-recmod/t16ok.ml
new file mode 100644
index 00000000..583b69bb
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t16ok.ml
@@ -0,0 +1,30 @@
+(* PR#4450 *)
+
+module PR_4450_1 = struct
+  module type MyT = sig type 'a t = Succ of 'a t end
+  module MyMap(X : MyT) = X
+  module rec MyList : MyT = MyMap(MyList)
+end;;
+
+module PR_4450_2 = struct
+  module type MyT = sig
+    type 'a wrap = My of 'a t
+    and 'a t = private < map : 'b. ('a -> 'b) ->'b wrap; .. >
+    val create : 'a list -> 'a t
+  end
+  module MyMap(X : MyT) = struct
+    include X
+    class ['a] c l = object (self)
+      method map : 'b. ('a -> 'b) -> 'b wrap =
+        fun f -> My (create (List.map f l))
+    end
+  end
+  module rec MyList : sig
+    type 'a wrap = My of 'a t
+    and 'a t = < map : 'b. ('a -> 'b) ->'b wrap >
+    val create : 'a list -> 'a t
+  end = struct
+    include MyMap(MyList)
+    let create l = new c l
+  end
+end;;
diff --git a/testsuite/tests/typing-recmod/t17ok.ml b/testsuite/tests/typing-recmod/t17ok.ml
new file mode 100644
index 00000000..4521b66c
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t17ok.ml
@@ -0,0 +1,41 @@
+(* A synthetic example of bootstrapped data structure
+   (suggested by J-C Filliatre) *)
+
+module type ORD = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type SET = sig
+  type elt
+  type t
+  val iter : (elt -> unit) -> t -> unit
+end
+
+type 'a tree = E | N of 'a tree * 'a * 'a tree
+
+module Bootstrap2
+  (MakeDiet : functor (X: ORD) -> SET with type t = X.t tree and type elt = X.t)
+  : SET with type elt = int =
+struct
+
+  type elt = int
+
+  module rec Elt : sig
+    type t = I of int * int | D of int * Diet.t * int
+    val compare : t -> t -> int
+    val iter : (int -> unit) -> t -> unit
+  end =
+  struct
+    type t = I of int * int | D of int * Diet.t * int
+    let compare x1 x2 = 0
+    let rec iter f = function
+      | I (l, r) -> for i = l to r do f i done
+      | D (_, d, _) -> Diet.iter (iter f) d
+  end
+
+  and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt)
+
+  type t = Diet.t
+  let iter f = Diet.iter (Elt.iter f)
+end
diff --git a/testsuite/tests/typing-recmod/t18ok.ml b/testsuite/tests/typing-recmod/t18ok.ml
new file mode 100644
index 00000000..64fcf6ab
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t18ok.ml
@@ -0,0 +1,25 @@
+(* PR 4470: simplified from OMake's sources *)
+
+module rec DirElt
+  : sig
+      type t = DirRoot | DirSub of DirHash.t
+    end
+  = struct
+      type t = DirRoot | DirSub of DirHash.t
+    end
+
+and DirCompare
+  : sig
+      type t = DirElt.t
+    end
+  = struct
+      type t = DirElt.t
+    end
+
+and DirHash
+  : sig
+      type t = DirElt.t list
+    end
+  = struct
+      type t = DirCompare.t list
+    end
diff --git a/testsuite/tests/typing-recmod/t19ok.ml b/testsuite/tests/typing-recmod/t19ok.ml
new file mode 100644
index 00000000..e51fa5c9
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t19ok.ml
@@ -0,0 +1,15 @@
+(* PR 4758, PR 4266 *)
+
+module PR_4758 = struct
+  module type S = sig end
+  module type Mod = sig
+    module Other : S
+  end
+  module rec A : S = struct end
+  and C : sig include Mod with module Other = A end = struct
+    module Other = A
+  end
+  module C' = C  (* check that we can take an alias *)
+  module F(X:sig end) = struct type t end
+  let f (x : F(C).t) = (x : F(C').t)
+end
diff --git a/testsuite/tests/typing-recmod/t20ok.ml b/testsuite/tests/typing-recmod/t20ok.ml
new file mode 100644
index 00000000..fec78c1d
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t20ok.ml
@@ -0,0 +1,30 @@
+(* PR 4557 *)
+module PR_4557 = struct
+  module F ( X : Set.OrderedType ) = struct
+    module rec Mod : sig
+      module XSet :
+        sig
+          type elt = X.t
+          type t = Set.Make( X ).t
+        end
+      module XMap :
+        sig
+          type key = X.t
+          type 'a t = 'a Map.Make(X).t
+        end
+      type elt = X.t
+      type t = XSet.t XMap.t
+      val compare: t -> t -> int
+    end
+       =
+    struct
+      module XSet = Set.Make( X )
+      module XMap = Map.Make( X )
+
+      type elt = X.t
+      type t = XSet.t XMap.t
+      let compare = (fun x y -> 0)
+    end
+    and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+  end
+end
diff --git a/testsuite/tests/typing-recmod/t21ok.ml b/testsuite/tests/typing-recmod/t21ok.ml
new file mode 100644
index 00000000..0415fe48
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t21ok.ml
@@ -0,0 +1,27 @@
+module F ( X : Set.OrderedType ) = struct
+  module rec Mod : sig
+    module XSet :
+      sig
+        type elt = X.t
+        type t = Set.Make( X ).t
+      end
+    module XMap :
+      sig
+        type key = X.t
+        type 'a t = 'a Map.Make(X).t
+      end
+    type elt = X.t
+    type t = XSet.t XMap.t
+    val compare: t -> t -> int
+  end
+     =
+  struct
+    module XSet = Set.Make( X )
+    module XMap = Map.Make( X )
+
+    type elt = X.t
+    type t = XSet.t XMap.t
+    let compare = (fun x y -> 0)
+  end
+  and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+end
diff --git a/testsuite/tests/typing-recmod/t22ok.ml b/testsuite/tests/typing-recmod/t22ok.ml
new file mode 100644
index 00000000..de96eced
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t22ok.ml
@@ -0,0 +1,511 @@
+(* Tests for recursive modules *)
+
+let test number result expected =
+  if result = expected
+  then Printf.printf "Test %d passed.\n" number
+  else Printf.printf "Test %d FAILED.\n" number;
+  flush stdout
+
+(* Tree of sets *)
+
+module rec A
+ : sig
+     type t = Leaf of int | Node of ASet.t
+     val compare: t -> t -> int
+   end
+ = struct
+     type t = Leaf of int | Node of ASet.t
+     let compare x y =
+       match (x,y) with
+         (Leaf i, Leaf j) -> Pervasives.compare i j
+       | (Leaf i, Node t) -> -1
+       | (Node s, Leaf j) -> 1
+       | (Node s, Node t) -> ASet.compare s t
+   end
+
+and ASet : Set.S with type elt = A.t = Set.Make(A)
+;;
+
+let _ =
+  let x = A.Node (ASet.add (A.Leaf 3) (ASet.singleton (A.Leaf 2))) in
+  let y = A.Node (ASet.add (A.Leaf 1) (ASet.singleton x)) in
+  test 10 (A.compare x x) 0;
+  test 11 (A.compare x (A.Leaf 3)) 1;
+  test 12 (A.compare (A.Leaf 0) x) (-1);
+  test 13 (A.compare y y) 0;
+  test 14 (A.compare x y) 1
+;;
+
+(* Simple value recursion *)
+
+module rec Fib
+  : sig val f : int -> int end
+  = struct let f x = if x < 2 then 1 else Fib.f(x-1) + Fib.f(x-2) end
+;;
+
+let _ =
+  test 20 (Fib.f 10) 89
+;;
+
+(* Update function by infix *)
+
+module rec Fib2
+  : sig val f : int -> int end
+  = struct let rec g x = Fib2.f(x-1) + Fib2.f(x-2)
+               and f x = if x < 2 then 1 else g x
+    end
+;;
+
+let _ =
+  test 21 (Fib2.f 10) 89
+;;
+
+(* Early application *)
+
+let _ =
+  let res =
+    try
+      let module A =
+        struct
+          module rec Bad
+            : sig val f : int -> int end
+            = struct let f = let y = Bad.f 5 in fun x -> x+y end
+          end in
+      false
+    with Undefined_recursive_module _ ->
+      true in
+  test 30 res true
+;;
+
+(* Early strict evaluation *)
+
+(*
+module rec Cyclic
+  : sig val x : int end
+  = struct let x = Cyclic.x + 1 end
+;;
+*)
+
+(* Reordering of evaluation based on dependencies *)
+
+module rec After
+  : sig val x : int end
+  = struct let x = Before.x + 1 end
+and Before
+  : sig val x : int end
+  = struct let x = 3 end
+;;
+
+let _ =
+  test 40 After.x 4
+;;
+
+(* Type identity between A.t and t within A's definition *)
+
+module rec Strengthen
+  : sig type t val f : t -> t end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen.t)
+      let f x = if true then A else Strengthen.f B
+    end
+;;
+
+module rec Strengthen2
+  : sig type t
+        val f : t -> t
+        module M : sig type u end
+        module R : sig type v end
+    end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen2.t)
+      let f x = if true then A else Strengthen2.f B
+      module M =
+        struct
+          type u = C
+          let _ = (C: Strengthen2.M.u)
+        end
+      module rec R : sig type v  = Strengthen2.R.v end =
+        struct
+          type v = D
+          let _ = (D : R.v)
+          let _ = (D : Strengthen2.R.v)
+        end
+    end
+;;
+
+(* Polymorphic recursion *)
+
+module rec PolyRec
+  : sig
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      val depth: 'a t -> int
+    end
+  = struct
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      let x = (PolyRec.Leaf 1 : int t)
+      let depth = function
+        Leaf x -> 0
+      | Node(l,r) -> 1 + max (PolyRec.depth l) (PolyRec.depth r)
+    end
+;;
+
+(* Wrong LHS signatures (PR#4336) *)
+
+(*
+module type ASig = sig type a val a:a val print:a -> unit end
+module type BSig = sig type b val b:b val print:b -> unit end
+
+module A = struct type a = int let a = 0 let print = print_int end
+module B = struct type b = float let b = 0.0 let print = print_float end
+
+module MakeA (Empty:sig end) : ASig = A
+module MakeB (Empty:sig end) : BSig = B
+
+module
+   rec NewA : ASig = MakeA (struct end)
+   and NewB : BSig with type b = NewA.a = MakeB (struct end);;
+
+*)
+
+(* Expressions and bindings *)
+
+module StringSet = Set.Make(String);;
+
+module rec Expr
+  : sig
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      val make_let: string -> t -> t -> t
+      val fv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      let make_let id e1 e2 = Binding([id, e1], e2)
+      let rec fv = function
+        Var s -> StringSet.singleton s
+      | Const n -> StringSet.empty
+      | Add(t1,t2) -> StringSet.union (fv t1) (fv t2)
+      | Binding(b,t) ->
+          StringSet.union (Binding.fv b)
+            (StringSet.diff (fv t) (Binding.bv b))
+      let rec simpl = function
+        Var s -> Var s
+      | Const n -> Const n
+      | Add(Const i, Const j) -> Const (i+j)
+      | Add(Const 0, t) -> simpl t
+      | Add(t, Const 0) -> simpl t
+      | Add(t1,t2) -> Add(simpl t1, simpl t2)
+      | Binding(b, t) -> Binding(Binding.simpl b, simpl t)
+    end
+
+and Binding
+  : sig
+      type t = (string * Expr.t) list
+      val fv: t -> StringSet.t
+      val bv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t = (string * Expr.t) list
+      let fv b =
+        List.fold_left (fun v (id,e) -> StringSet.union v (Expr.fv e))
+                       StringSet.empty b
+      let bv b =
+        List.fold_left (fun v (id,e) -> StringSet.add id v)
+                       StringSet.empty b
+      let simpl b =
+        List.map (fun (id,e) -> (id, Expr.simpl e)) b
+    end
+;;
+
+let _ =
+  let e = Expr.make_let "x" (Expr.Add (Expr.Var "y", Expr.Const 0))
+                            (Expr.Var "x") in
+  let e' = Expr.make_let "x" (Expr.Var "y") (Expr.Var "x") in
+  test 50 (StringSet.elements (Expr.fv e)) ["y"];
+  test 51 (Expr.simpl e) e'
+;;
+
+(* Okasaki's bootstrapping *)
+
+module type ORDERED =
+  sig
+    type t
+    val eq: t -> t -> bool
+    val lt: t -> t -> bool
+    val leq: t -> t -> bool
+  end
+
+module type HEAP =
+  sig
+    module Elem: ORDERED
+    type heap
+    val empty: heap
+    val isEmpty: heap -> bool
+    val insert: Elem.t -> heap -> heap
+    val merge: heap -> heap -> heap
+    val findMin: heap -> Elem.t
+    val deleteMin: heap -> heap
+  end
+
+module Bootstrap (MakeH: functor (Element:ORDERED) ->
+                                    HEAP with module Elem = Element)
+                 (Element: ORDERED) : HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    module rec BE
+    : sig type t = E | H of Elem.t * PrimH.heap
+          val eq: t -> t -> bool
+          val lt: t -> t -> bool
+          val leq: t -> t -> bool
+      end
+    = struct
+        type t = E | H of Elem.t * PrimH.heap
+        let leq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.leq x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> true
+        let eq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.eq x y
+          | H _, E -> false
+          | E, H _ -> false
+          | E, E -> true
+        let lt t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.lt x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> false
+      end
+    and PrimH
+    : HEAP with type Elem.t = BE.t
+    = MakeH(BE)
+    type heap = BE.t
+    let empty = BE.E
+    let isEmpty = function BE.E -> true | _ -> false
+    let rec merge x y =
+      match (x,y) with
+        (BE.E, _) -> y
+      | (_, BE.E) -> x
+      | (BE.H(e1,p1) as h1), (BE.H(e2,p2) as h2) ->
+          if Elem.leq e1 e2
+          then BE.H(e1, PrimH.insert h2 p1)
+          else BE.H(e2, PrimH.insert h1 p2)
+    let insert x h =
+      merge (BE.H(x, PrimH.empty)) h
+    let findMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, _) -> x
+    let deleteMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, p) ->
+          if PrimH.isEmpty p then BE.E else begin
+            match PrimH.findMin p with
+            | (BE.H(y, p1)) ->
+              let p2 = PrimH.deleteMin p in
+              BE.H(y, PrimH.merge p1 p2)
+            | BE.E -> assert false
+          end
+  end
+;;
+
+module LeftistHeap(Element: ORDERED): HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    type heap = E | T of int * Elem.t * heap * heap
+    let rank = function E -> 0 | T(r,_,_,_) -> r
+    let make x a b =
+      if rank a >= rank b
+      then T(rank b + 1, x, a, b)
+      else T(rank a + 1, x, b, a)
+    let empty = E
+    let isEmpty = function E -> true | _ -> false
+    let rec merge h1 h2 =
+      match (h1, h2) with
+        (_, E) -> h1
+      | (E, _) -> h2
+      | (T(_, x1, a1, b1), T(_, x2, a2, b2)) ->
+          if Elem.leq x1 x2
+          then make x1 a1 (merge b1 h2)
+          else make x2 a2 (merge h1 b2)
+    let insert x h = merge (T(1, x, E, E)) h
+    let findMin = function
+      E -> raise Not_found
+    | T(_, x, _, _) -> x
+    let deleteMin = function
+      E -> raise Not_found
+    | T(_, x, a, b) -> merge a b
+  end
+;;
+
+module Ints =
+  struct
+    type t = int
+    let eq = (=)
+    let lt = (<)
+    let leq = (<=)
+  end
+;;
+
+module C = Bootstrap(LeftistHeap)(Ints);;
+
+let _ =
+  let h = List.fold_right C.insert [6;4;8;7;3;1] C.empty in
+  test 60 (C.findMin h) 1;
+  test 61 (C.findMin (C.deleteMin h)) 3;
+  test 62 (C.findMin (C.deleteMin (C.deleteMin h))) 4
+;;
+
+(* Classes *)
+
+module rec Class1
+  : sig
+      class c : object method m : int -> int end
+    end
+  = struct
+      class c =
+        object
+          method m x = if x <= 0 then x else (new Class2.d)#m x
+        end
+    end
+and Class2
+  : sig
+      class d : object method m : int -> int end
+    end
+  = struct
+      class d =
+        object(self)
+          inherit Class1.c as super
+          method m (x:int) = super#m 0
+        end
+    end
+;;
+
+let _ =
+  test 70 ((new Class1.c)#m 7) 0
+;;
+
+let _ =
+  try
+    let module A = struct
+       module rec BadClass1
+         : sig
+             class c : object method m : int end
+           end
+         = struct
+             class c = object method m = 123 end
+           end
+       and BadClass2
+         : sig
+             val x: int
+           end
+         = struct
+             let x = (new BadClass1.c)#m
+           end
+    end in
+      test 71 true false
+  with Undefined_recursive_module _ ->
+    test 71 true true
+;;
+
+(* Coercions *)
+
+module rec Coerce1
+  : sig
+      val g: int -> int
+      val f: int -> int
+    end
+  = struct
+      module A = (Coerce1: sig val f: int -> int end)
+      let g x = x
+      let f x = if x <= 0 then 1 else A.f (x-1) * x
+    end
+;;
+
+let _ =
+  test 80 (Coerce1.f 10) 3628800
+;;
+
+module CoerceF(S: sig end) = struct
+  let f1 () = 1
+  let f2 () = 2
+  let f3 () = 3
+  let f4 () = 4
+  let f5 () = 5
+end
+
+module rec Coerce2: sig val f1: unit -> int end = CoerceF(Coerce3)
+       and Coerce3: sig end = struct end
+;;
+
+let _ =
+  test 81 (Coerce2.f1 ()) 1
+;;
+
+module Coerce4(A : sig val f : int -> int end) = struct
+  let x = 0
+  let at a = A.f a
+end
+
+module rec Coerce5
+  : sig val blabla: int -> int val f: int -> int end
+  = struct let blabla x = 0 let f x = 5 end
+and Coerce6
+  : sig val at: int -> int end
+  = Coerce4(Coerce5)
+
+let _ =
+  test 82 (Coerce6.at 100) 5
+;;
+
+(* Miscellaneous bug reports *)
+
+module rec F
+  : sig type t = X of int | Y of int
+        val f: t -> bool
+    end
+  = struct
+      type t = X of int | Y of int
+      let f = function
+        | X _ -> false
+        | _ -> true
+    end;;
+
+let _ =
+  test 100 (F.f (F.X 1)) false;
+  test 101 (F.f (F.Y 2)) true
+
+(* PR#4316 *)
+module G(S : sig val x : int Lazy.t end) = struct include S end
+
+module M1 = struct let x = lazy 3 end
+
+let _ = Lazy.force M1.x
+
+module rec M2 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 102 (Lazy.force M2.x) 3
+
+let _ = Gc.full_major()   (* will shortcut forwarding in M1.x *)
+
+module rec M3 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 103 (Lazy.force M3.x) 3
+
+
+(** Pure type-checking tests: see recmod/*.ml  *)
diff --git a/testsuite/tests/typing-recmod/t22ok.mli b/testsuite/tests/typing-recmod/t22ok.mli
new file mode 100644
index 00000000..6c1fad36
--- /dev/null
+++ b/testsuite/tests/typing-recmod/t22ok.mli
@@ -0,0 +1,134 @@
+module rec A :
+  sig type t = Leaf of int | Node of ASet.t val compare : t -> t -> int end
+and ASet : Set.S with type elt = A.t
+module Fib : sig val f : int -> int end
+module After : sig val x : int end
+module Before : sig val x : int end
+module Strengthen : sig type t val f : t -> t end
+module Strengthen2 :
+  sig
+    type t
+    val f : t -> t
+    module M : sig type u end
+    module R : sig type v end
+  end
+module PolyRec :
+  sig
+    type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+    val depth : 'a t -> int
+  end
+module StringSet : Set.S with type elt = string
+module rec Expr :
+  sig
+    type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+    val make_let : string -> t -> t -> t
+    val fv : t -> StringSet.t
+    val simpl : t -> t
+  end
+and Binding :
+  sig
+    type t = (string * Expr.t) list
+    val fv : t -> StringSet.t
+    val bv : t -> StringSet.t
+    val simpl : t -> t
+  end
+module type ORDERED =
+  sig
+    type t
+    val eq : t -> t -> bool
+    val lt : t -> t -> bool
+    val leq : t -> t -> bool
+  end
+module type HEAP =
+  sig
+    module Elem : ORDERED
+    type heap
+    val empty : heap
+    val isEmpty : heap -> bool
+    val insert : Elem.t -> heap -> heap
+    val merge : heap -> heap -> heap
+    val findMin : heap -> Elem.t
+    val deleteMin : heap -> heap
+  end
+module Bootstrap :
+  functor
+    (MakeH : functor (Element : ORDERED) ->
+               sig
+                 module Elem :
+                   sig
+                     type t = Element.t
+                     val eq : t -> t -> bool
+                     val lt : t -> t -> bool
+                     val leq : t -> t -> bool
+                   end
+                 type heap
+                 val empty : heap
+                 val isEmpty : heap -> bool
+                 val insert : Elem.t -> heap -> heap
+                 val merge : heap -> heap -> heap
+                 val findMin : heap -> Elem.t
+                 val deleteMin : heap -> heap
+               end) ->
+    functor (Element : ORDERED) ->
+      sig
+        module Elem :
+          sig
+            type t = Element.t
+            val eq : t -> t -> bool
+            val lt : t -> t -> bool
+            val leq : t -> t -> bool
+          end
+        type heap
+        val empty : heap
+        val isEmpty : heap -> bool
+        val insert : Elem.t -> heap -> heap
+        val merge : heap -> heap -> heap
+        val findMin : heap -> Elem.t
+        val deleteMin : heap -> heap
+      end
+module LeftistHeap :
+  functor (Element : ORDERED) ->
+    sig
+      module Elem :
+        sig
+          type t = Element.t
+          val eq : t -> t -> bool
+          val lt : t -> t -> bool
+          val leq : t -> t -> bool
+        end
+      type heap
+      val empty : heap
+      val isEmpty : heap -> bool
+      val insert : Elem.t -> heap -> heap
+      val merge : heap -> heap -> heap
+      val findMin : heap -> Elem.t
+      val deleteMin : heap -> heap
+    end
+module Ints :
+  sig
+    type t = int
+    val eq : 'a -> 'a -> bool
+    val lt : 'a -> 'a -> bool
+    val leq : 'a -> 'a -> bool
+  end
+module C :
+  sig
+    module Elem :
+      sig
+        type t = Ints.t
+        val eq : t -> t -> bool
+        val lt : t -> t -> bool
+        val leq : t -> t -> bool
+      end
+    type heap = Bootstrap(LeftistHeap)(Ints).heap
+    val empty : heap
+    val isEmpty : heap -> bool
+    val insert : Elem.t -> heap -> heap
+    val merge : heap -> heap -> heap
+    val findMin : heap -> Elem.t
+    val deleteMin : heap -> heap
+  end
diff --git a/testsuite/tests/typing-recordarg/Makefile b/testsuite/tests/typing-recordarg/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-recordarg/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-recordarg/recordarg.ml b/testsuite/tests/typing-recordarg/recordarg.ml
new file mode 100644
index 00000000..ebd8d056
--- /dev/null
+++ b/testsuite/tests/typing-recordarg/recordarg.ml
@@ -0,0 +1,92 @@
+type t = A of {x:int; mutable y:int};;
+let f (A r) = r;;  (* -> escape *)
+let f (A r) = r.x;; (* ok *)
+let f x = A {x; y = x};; (* ok *)
+let f (A r) = A {r with y = r.x + 1};; (* ok *)
+let f () = A {a = 1};; (* customized error message *)
+let f () = A {x = 1; y = 3};; (* ok *)
+
+type _ t = A: {x : 'a; y : 'b} -> 'a t;;
+let f (A {x; y}) = A {x; y = ()};;  (* ok *)
+let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *)
+
+module M = struct
+  type 'a t =
+    | A of {x : 'a}
+    | B: {u : 'b} -> unit t;;
+
+  exception Foo of {x : int};;
+end;;
+
+module N : sig
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'bla} -> unit t
+
+  exception Foo of {x : int}
+end = struct
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'z} -> unit t
+
+  exception Foo = M.Foo
+end;;
+
+
+module type S = sig exception A of {x:int}  end;;
+
+module F (X : sig val x : (module S) end) = struct
+  module A = (val X.x)
+end;;  (* -> this expression creates fresh types (not really!) *)
+
+
+module type S = sig
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+module M = struct
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+
+module M1 = struct
+  exception A of {x : int}
+end;;
+
+module M = struct
+  include M1
+  include M1
+end;;
+
+
+module type S1 = sig
+  exception A of {x : int}
+end;;
+
+module type S = sig
+  include S1
+  include S1
+end;;
+
+module M = struct
+  exception A = M1.A
+end;;
+
+module X1 = struct
+  type t = ..
+end;;
+module X2 = struct
+  type t = ..
+end;;
+module Z = struct
+  type X1.t += A of {x: int}
+  type X2.t += A of {x: int}
+end;;
+
+(* PR#6716 *)
+
+type _ c = C : [`A] c
+type t = T : {x:[<`A] c} -> t;;
+let f (T { x = C }) = ();;
diff --git a/testsuite/tests/typing-recordarg/recordarg.ml.reference b/testsuite/tests/typing-recordarg/recordarg.ml.reference
new file mode 100644
index 00000000..5a671d65
--- /dev/null
+++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference
@@ -0,0 +1,67 @@
+
+# type t = A of { x : int; mutable y : int; }
+# Characters 14-15:
+  let f (A r) = r;;  (* -> escape *)
+                ^
+Error: This form is not allowed as the type of the inlined record could escape.
+# val f : t -> int = 
+# val f : int -> t = 
+# val f : t -> t = 
+# Characters 14-15:
+  let f () = A {a = 1};; (* customized error message *)
+                ^
+Error: The field a is not part of the record argument for the t.A constructor
+# val f : unit -> t = 
+#   type _ t = A : { x : 'a; y : 'b; } -> 'a t
+# val f : 'a t -> 'a t = 
+# val f : 'a t -> 'a t = 
+#               module M :
+  sig
+    type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t
+    exception Foo of { x : int; }
+  end
+#                           module N :
+  sig
+    type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t
+    exception Foo of { x : int; }
+  end
+#     module type S = sig exception A of { x : int; } end
+#       Characters 65-74:
+    module A = (val X.x)
+               ^^^^^^^^^
+Error: This expression creates fresh types.
+       It is not allowed inside applicative functors.
+#           Characters 61-62:
+    exception A of {x : string}
+              ^
+Error: Multiple definition of the extension constructor name A.
+       Names must be unique in a given structure or signature.
+#         Characters 58-59:
+    exception A of {x : string}
+              ^
+Error: Multiple definition of the extension constructor name A.
+       Names must be unique in a given structure or signature.
+#         module M1 : sig exception A of { x : int; } end
+#         Characters 34-44:
+    include M1
+    ^^^^^^^^^^
+Error: Multiple definition of the extension constructor name A.
+       Names must be unique in a given structure or signature.
+#         module type S1 = sig exception A of { x : int; } end
+#         Characters 36-46:
+    include S1
+    ^^^^^^^^^^
+Error: Multiple definition of the extension constructor name A.
+       Names must be unique in a given structure or signature.
+#       module M : sig exception A of { x : int; } end
+#       module X1 : sig type t = .. end
+#     module X2 : sig type t = .. end
+#       Characters 62-63:
+    type X2.t += A of {x: int}
+                 ^
+Error: Multiple definition of the extension constructor name A.
+       Names must be unique in a given structure or signature.
+#         type _ c = C : [ `A ] c
+type t = T : { x : [< `A ] c; } -> t
+# val f : t -> unit = 
+# 
diff --git a/testsuite/tests/typing-rectypes-bugs/Makefile b/testsuite/tests/typing-rectypes-bugs/Makefile
new file mode 100644
index 00000000..5d8e8dbd
--- /dev/null
+++ b/testsuite/tests/typing-rectypes-bugs/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
+COMPFLAGS = -rectypes
diff --git a/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml b/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml
new file mode 100644
index 00000000..0484c677
--- /dev/null
+++ b/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml
@@ -0,0 +1,13 @@
+module M : sig
+  type 'a t
+  type u = u t and v = v t
+  val f : int -> u
+  val g : v -> bool
+end = struct
+  type 'a t = 'a
+  type u = int and v = bool
+  let f x = x
+  let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;
diff --git a/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml b/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml
new file mode 100644
index 00000000..84f79ba0
--- /dev/null
+++ b/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml
@@ -0,0 +1,3 @@
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
diff --git a/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml b/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml
new file mode 100644
index 00000000..ed834605
--- /dev/null
+++ b/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml
@@ -0,0 +1,2 @@
+module type T = sig type 'a t end
+module Fix (T : T) = struct type r = ('r T.t as 'r) end
diff --git a/testsuite/tests/typing-safe-linking/Makefile b/testsuite/tests/typing-safe-linking/Makefile
new file mode 100644
index 00000000..4e3cf43a
--- /dev/null
+++ b/testsuite/tests/typing-safe-linking/Makefile
@@ -0,0 +1,20 @@
+# Check safety of linking
+
+SOURCES = a.ml b_bad.ml
+OBJECTS = $(SOURCES:%.ml=%.cmo)
+
+all: a.cmo
+	@printf " ... testing 'b_bad.ml'"
+	@$(OCAMLC) $(ADD_COMPFLAGS) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
+	 && echo " => failed" || echo " => passed"
+
+clean:
+	@rm -f *.cmo *.cmi
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
+
+# The second test (`A.y`) is unnecessary, indeed cannot be compiled, under -safe-string
+ifeq ($(SAFE_STRING),true)
+ADD_COMPFLAGS=-pp "sed -e '\$$d'"
+endif
diff --git a/testsuite/tests/typing-safe-linking/a.ml b/testsuite/tests/typing-safe-linking/a.ml
new file mode 100644
index 00000000..12e0cb12
--- /dev/null
+++ b/testsuite/tests/typing-safe-linking/a.ml
@@ -0,0 +1,6 @@
+ type _ t =
+     X of string
+   | Y : bytes t
+
+(* It is important that the line below is the last line of the file (see Makefile) *)
+let y : string t = Y
diff --git a/testsuite/tests/typing-safe-linking/b_bad.ml b/testsuite/tests/typing-safe-linking/b_bad.ml
new file mode 100644
index 00000000..6615070a
--- /dev/null
+++ b/testsuite/tests/typing-safe-linking/b_bad.ml
@@ -0,0 +1,5 @@
+let f : string A.t -> unit = function
+    A.X s -> print_endline s
+
+(* It is important that the line below is the last line of the file (see Makefile) *)
+let () = f A.y
diff --git a/testsuite/tests/typing-short-paths/Makefile b/testsuite/tests/typing-short-paths/Makefile
new file mode 100644
index 00000000..3e5a5df0
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -short-paths
diff --git a/testsuite/tests/typing-short-paths/pr5918.ml b/testsuite/tests/typing-short-paths/pr5918.ml
new file mode 100644
index 00000000..604f66d8
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr5918.ml
@@ -0,0 +1,7 @@
+module rec A : sig
+ type t
+end = struct
+ type t = { a : unit; b : unit }
+ let _ = { a = () }
+end
+;;
diff --git a/testsuite/tests/typing-short-paths/pr5918.ml.reference b/testsuite/tests/typing-short-paths/pr5918.ml.reference
new file mode 100644
index 00000000..3364e16d
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr5918.ml.reference
@@ -0,0 +1,6 @@
+
+#             Characters 82-92:
+   let _ = { a = () }
+           ^^^^^^^^^^
+Error: Some record fields are undefined: b
+# 
diff --git a/testsuite/tests/typing-short-paths/pr6836.ml b/testsuite/tests/typing-short-paths/pr6836.ml
new file mode 100644
index 00000000..121bc463
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr6836.ml
@@ -0,0 +1,6 @@
+type t = [`A | `B];;
+type 'a u = t;;
+let a : [< int u] = `A;;
+
+type 'a s = 'a;;
+let b : [< t s] = `B;;
diff --git a/testsuite/tests/typing-short-paths/pr6836.ml.reference b/testsuite/tests/typing-short-paths/pr6836.ml.reference
new file mode 100644
index 00000000..cc77356e
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr6836.ml.reference
@@ -0,0 +1,7 @@
+
+# type t = [ `A | `B ]
+# type 'a u = t
+# val a : [< t > `A ] = `A
+#   type 'a s = 'a
+# val b : [< t > `B ] = `B
+# 
diff --git a/testsuite/tests/typing-short-paths/short-paths.ml b/testsuite/tests/typing-short-paths/short-paths.ml
new file mode 100644
index 00000000..5d691aca
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/short-paths.ml
@@ -0,0 +1,57 @@
+module Core = struct
+  module Int = struct
+    module T = struct
+      type t = int
+      let compare = compare
+      let (+) x y = x + y
+    end
+    include T
+    module Map = Map.Make(T)
+  end
+
+  module Std = struct
+    module Int = Int
+  end
+end
+;;
+
+open Core.Std
+;;
+
+let x = Int.Map.empty ;;
+let y = x + x ;;
+
+(* Avoid ambiguity *)
+
+module M = struct type t = A type u = C end
+module N = struct type t = B end
+open M open N;;
+A;;
+B;;
+C;;
+
+include M open M;;
+C;;
+
+module L = struct type v = V end
+open L;;
+V;;
+module L = struct type v = V end
+open L;;
+V;;
+
+
+type t1 = A;;
+module M1 = struct type u = v and v = t1 end;;
+module N1 = struct type u = v and v = M1.v end;;
+type t1 = B;;
+module N2 = struct type u = v and v = M1.v end;;
+
+
+(* PR#6566 *)
+module type PR6566 = sig type t = string end;;
+module PR6566 = struct type t = int end;;
+module PR6566' : PR6566 = PR6566;;
+
+module A = struct module B = struct type t = T end end;;
+module M2 = struct type u = A.B.t type foo = int type v = A.B.t end;;
diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference
new file mode 100644
index 00000000..64651566
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference
@@ -0,0 +1,95 @@
+
+#                               module Core :
+  sig
+    module Int :
+      sig
+        module T :
+          sig
+            type t = int
+            val compare : 'a -> 'a -> t
+            val ( + ) : t -> t -> t
+          end
+        type t = int
+        val compare : 'a -> 'a -> t
+        val ( + ) : t -> t -> t
+        module Map :
+          sig
+            type key = t
+            type 'a t = 'a Map.Make(T).t
+            val empty : 'a t
+            val is_empty : 'a t -> bool
+            val mem : key -> 'a t -> bool
+            val add : key -> 'a -> 'a t -> 'a t
+            val singleton : key -> 'a -> 'a t
+            val remove : key -> 'a t -> 'a t
+            val merge :
+              (key -> 'a option -> 'b option -> 'c option) ->
+              'a t -> 'b t -> 'c t
+            val union :
+              (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
+            val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
+            val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+            val iter : (key -> 'a -> unit) -> 'a t -> unit
+            val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+            val for_all : (key -> 'a -> bool) -> 'a t -> bool
+            val exists : (key -> 'a -> bool) -> 'a t -> bool
+            val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+            val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+            val cardinal : 'a t -> key
+            val bindings : 'a t -> (key * 'a) list
+            val min_binding : 'a t -> key * 'a
+            val min_binding_opt : 'a t -> (key * 'a) option
+            val max_binding : 'a t -> key * 'a
+            val max_binding_opt : 'a t -> (key * 'a) option
+            val choose : 'a t -> key * 'a
+            val choose_opt : 'a t -> (key * 'a) option
+            val split : key -> 'a t -> 'a t * 'a option * 'a t
+            val find : key -> 'a t -> 'a
+            val find_opt : key -> 'a t -> 'a option
+            val find_first : (key -> bool) -> 'a t -> key * 'a
+            val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+            val find_last : (key -> bool) -> 'a t -> key * 'a
+            val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
+            val map : ('a -> 'b) -> 'a t -> 'b t
+            val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+          end
+      end
+    module Std : sig module Int = Int end
+  end
+#     #   val x : 'a Int.Map.t = 
+# Characters 8-9:
+  let y = x + x ;;
+          ^
+Error: This expression has type 'a Int.Map.t
+       but an expression was expected of type int
+#           module M : sig type t = A type u = C end
+module N : sig type t = B end
+# - : M.t = A
+# - : N.t = B
+# - : u = C
+#   type t = M.t = A
+type u = M.u = C
+# - : u = C
+#     module L : sig type v = V end
+# - : v = V
+#   module L : sig type v = V end
+# - : v = V
+#     type t1 = A
+# module M1 : sig type u = v and v = t1 end
+# module N1 : sig type u = v and v = t1 end
+# type t1 = B
+# module N2 : sig type u = v and v = N1.v end
+#       module type PR6566 = sig type t = string end
+# module PR6566 : sig type t = int end
+# Characters 26-32:
+  module PR6566' : PR6566 = PR6566;;
+                            ^^^^^^
+Error: Signature mismatch:
+       Modules do not match: sig type t = int end is not included in PR6566
+       Type declarations do not match:
+         type t = int
+       is not included in
+         type t = string
+#   module A : sig module B : sig type t = T end end
+# module M2 : sig type u = A.B.t type foo = int type v = u end
+# 
diff --git a/testsuite/tests/typing-signatures/Makefile b/testsuite/tests/typing-signatures/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-signatures/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-signatures/els.ml b/testsuite/tests/typing-signatures/els.ml
new file mode 100644
index 00000000..dfc2e074
--- /dev/null
+++ b/testsuite/tests/typing-signatures/els.ml
@@ -0,0 +1,95 @@
+(* Adapted from: An Expressive Language of Signatures
+   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+
+module type VALUE = sig
+  type value (* a Lua value *)
+  type state (* the state of a Lua interpreter *)
+  type usert (* a user-defined value *)
+end;;
+
+module type CORE0 = sig
+  module V : VALUE
+  val setglobal : V.state -> string -> V.value -> unit
+  (* five more functions common to core and evaluator *)
+end;;
+
+module type CORE = sig
+  include CORE0
+  val apply : V.value -> V.state -> V.value list -> V.value
+  (* apply function f in state s to list of args *)
+end;;
+
+module type AST = sig
+  module Value : VALUE
+  type chunk
+  type program
+  val get_value : chunk -> Value.value
+end;;
+
+module type EVALUATOR = sig
+  module Value : VALUE
+  module Ast : (AST with module Value := Value)
+  type state = Value.state
+  type value = Value.value
+  exception Error of string
+  val compile : Ast.program -> string
+  include CORE0 with module V := Value
+end;;
+
+module type PARSER = sig
+  type chunk
+  val parse : string -> chunk
+end;;
+
+module type INTERP = sig
+  include EVALUATOR
+  module Parser : PARSER with type chunk = Ast.chunk
+  val dostring : state -> string -> value list
+  val mk : unit -> state
+end;;
+
+module type USERTYPE = sig
+  type t
+  val eq : t -> t -> bool
+  val to_string : t -> string
+end;;
+
+module type TYPEVIEW = sig
+  type combined
+  type t
+  val map : (combined -> t) * (t -> combined)
+end;;
+
+module type COMBINED_COMMON = sig
+  module T : sig type t end
+  module TV1 : TYPEVIEW with type combined := T.t
+  module TV2 : TYPEVIEW with type combined := T.t
+end;;
+
+module type COMBINED_TYPE = sig
+  module T : USERTYPE
+  include COMBINED_COMMON with module T := T
+end;;
+
+module type BARECODE = sig
+  type state
+  val init : state -> unit
+end;;
+
+module USERCODE(X : TYPEVIEW) = struct
+  module type F =
+      functor (C : CORE with type V.usert = X.combined) ->
+        BARECODE with type state := C.V.state
+end;;
+
+module Weapon = struct type t end;;
+
+module type WEAPON_LIB = sig
+  type t = Weapon.t
+  module T : USERTYPE with type t = t
+  module Make :
+    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
+end;;
+
+module type X = functor (X: CORE) -> BARECODE;;
+module type X = functor (_: CORE) -> BARECODE;;
diff --git a/testsuite/tests/typing-signatures/els.ml.reference b/testsuite/tests/typing-signatures/els.ml.reference
new file mode 100644
index 00000000..460820b7
--- /dev/null
+++ b/testsuite/tests/typing-signatures/els.ml.reference
@@ -0,0 +1,95 @@
+
+# *             module type VALUE = sig type value type state type usert end
+#           module type CORE0 =
+  sig
+    module V : VALUE
+    val setglobal : V.state -> string -> V.value -> unit
+  end
+#           module type CORE =
+  sig
+    module V : VALUE
+    val setglobal : V.state -> string -> V.value -> unit
+    val apply : V.value -> V.state -> V.value list -> V.value
+  end
+#             module type AST =
+  sig
+    module Value : VALUE
+    type chunk
+    type program
+    val get_value : chunk -> Value.value
+  end
+#                   module type EVALUATOR =
+  sig
+    module Value : VALUE
+    module Ast :
+      sig type chunk type program val get_value : chunk -> Value.value end
+    type state = Value.state
+    type value = Value.value
+    exception Error of string
+    val compile : Ast.program -> string
+    val setglobal : Value.state -> string -> Value.value -> unit
+  end
+#         module type PARSER = sig type chunk val parse : string -> chunk end
+#             module type INTERP =
+  sig
+    module Value : VALUE
+    module Ast :
+      sig type chunk type program val get_value : chunk -> Value.value end
+    type state = Value.state
+    type value = Value.value
+    exception Error of string
+    val compile : Ast.program -> string
+    val setglobal : Value.state -> string -> Value.value -> unit
+    module Parser :
+      sig type chunk = Ast.chunk val parse : string -> chunk end
+    val dostring : state -> string -> value list
+    val mk : unit -> state
+  end
+#           module type USERTYPE =
+  sig type t val eq : t -> t -> bool val to_string : t -> string end
+#           module type TYPEVIEW =
+  sig type combined type t val map : (combined -> t) * (t -> combined) end
+#           module type COMBINED_COMMON =
+  sig
+    module T : sig type t end
+    module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+    module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+  end
+#         module type COMBINED_TYPE =
+  sig
+    module T : USERTYPE
+    module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+    module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+  end
+#         module type BARECODE = sig type state val init : state -> unit end
+#           module USERCODE :
+  functor (X : TYPEVIEW) ->
+    sig
+      module type F =
+        functor
+          (C : sig
+                 module V :
+                   sig type value type state type usert = X.combined end
+                 val setglobal : V.state -> string -> V.value -> unit
+                 val apply : V.value -> V.state -> V.value list -> V.value
+               end) ->
+          sig val init : C.V.state -> unit end
+    end
+#   module Weapon : sig type t end
+#             module type WEAPON_LIB =
+  sig
+    type t = Weapon.t
+    module T :
+      sig type t = t val eq : t -> t -> bool val to_string : t -> string end
+    module Make :
+      functor
+        (TV : sig
+                type combined
+                type t = t
+                val map : (combined -> t) * (t -> combined)
+              end) ->
+        USERCODE(TV).F
+  end
+#   module type X = functor (X : CORE) -> BARECODE
+# module type X = CORE -> BARECODE
+# 
diff --git a/testsuite/tests/typing-signatures/pr6371.ml b/testsuite/tests/typing-signatures/pr6371.ml
new file mode 100644
index 00000000..d717b9e6
--- /dev/null
+++ b/testsuite/tests/typing-signatures/pr6371.ml
@@ -0,0 +1,7 @@
+module M = struct
+  type t = int * (< m : 'a > as 'a)
+end;;
+
+module type S =
+    sig module M : sig type t end end with module M = M
+;;
diff --git a/testsuite/tests/typing-signatures/pr6371.ml.reference b/testsuite/tests/typing-signatures/pr6371.ml.reference
new file mode 100644
index 00000000..d6d916a7
--- /dev/null
+++ b/testsuite/tests/typing-signatures/pr6371.ml.reference
@@ -0,0 +1,4 @@
+
+#     module M : sig type t = int * (< m : 'a > as 'a) end
+#       module type S = sig module M : sig type t = int * (< m : 'a > as 'a) end end
+# 
diff --git a/testsuite/tests/typing-signatures/pr6672.ml b/testsuite/tests/typing-signatures/pr6672.ml
new file mode 100644
index 00000000..5b168f05
--- /dev/null
+++ b/testsuite/tests/typing-signatures/pr6672.ml
@@ -0,0 +1,3 @@
+module type S = sig type 'a t end;;
+module type T = S with type +'a t = 'a list;;
+module type T = S with type -'a t = 'a list;;
diff --git a/testsuite/tests/typing-signatures/pr6672.ml.reference b/testsuite/tests/typing-signatures/pr6672.ml.reference
new file mode 100644
index 00000000..959cee7e
--- /dev/null
+++ b/testsuite/tests/typing-signatures/pr6672.ml.reference
@@ -0,0 +1,10 @@
+
+# module type S = sig type 'a t end
+# module type T = sig type 'a t = 'a list end
+# Characters 23-43:
+  module type T = S with type -'a t = 'a list;;
+                         ^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+       The 1st type parameter was expected to be contravariant,
+       but it is injective covariant.
+# 
diff --git a/testsuite/tests/typing-sigsubst/Makefile b/testsuite/tests/typing-sigsubst/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml
new file mode 100644
index 00000000..6759f63a
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml
@@ -0,0 +1,40 @@
+module type Printable = sig
+  type t
+  val print : Format.formatter -> t -> unit
+end;;
+module type Comparable = sig
+  type t
+  val compare : t -> t -> int
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t = t
+end;; (* Fails *)
+module type PrintableComparable = sig
+  type t
+  include Printable with type t := t
+  include Comparable with type t := t
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t := t
+end;;
+module type ComparableInt = Comparable with type t := int;;
+module type S = sig type t val f : t -> t end;;
+module type S' = S with type t := int;;
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
+module type S1 = S with type 'a t := 'a list;;
+module type S2 = sig
+  type 'a dict = (string * 'a) list
+  include S with type 'a t := 'a dict
+end;;
+
+
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
+module M = struct type exp = string type arg = int end;;
+module type S' = S with module T := M;;
+
+
+module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
new file mode 100644
index 00000000..5a160347
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
@@ -0,0 +1,40 @@
+
+#       module type Printable =
+  sig type t val print : Format.formatter -> t -> unit end
+#       module type Comparable = sig type t val compare : t -> t -> int end
+#       Characters 60-94:
+    include Comparable with type t = t
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#         module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+#       module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+# module type ComparableInt = sig val compare : int -> int -> int end
+# module type S = sig type t val f : t -> t end
+# module type S' = sig val f : int -> int end
+#   module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
+# module type S1 = sig val map : ('a -> 'b) -> 'a list -> 'b list end
+#       module type S2 =
+  sig
+    type 'a dict = (string * 'a) list
+    val map : ('a -> 'b) -> 'a dict -> 'b dict
+  end
+#       module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
+# module M : sig type exp = string type arg = int end
+# module type S' = sig val f : M.exp -> M.arg end
+#     Characters 41-58:
+  module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
+                                         ^^^^^^^^^^^^^^^^^
+Error: Only type constructors with identical parameters can be substituted.
+# 
diff --git a/testsuite/tests/typing-typeparam/Makefile b/testsuite/tests/typing-typeparam/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-typeparam/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-typeparam/newtype.ml b/testsuite/tests/typing-typeparam/newtype.ml
new file mode 100644
index 00000000..abe58763
--- /dev/null
+++ b/testsuite/tests/typing-typeparam/newtype.ml
@@ -0,0 +1,32 @@
+let property (type t) () =
+  let module M = struct exception E of t end in
+  (fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+;;
+
+let () =
+  let (int_inj, int_proj) = property () in
+  let (string_inj, string_proj) = property () in
+
+  let i = int_inj 3 in
+  let s = string_inj "abc" in
+
+  Printf.printf "%b\n%!" (int_proj i = None);
+  Printf.printf "%b\n%!" (int_proj s = None);
+  Printf.printf "%b\n%!" (string_proj i = None);
+  Printf.printf "%b\n%!" (string_proj s = None)
+;;
+
+let sort_uniq (type s) cmp l =
+  let module S = Set.Make(struct type t = s let compare = cmp end) in
+  S.elements (List.fold_right S.add l S.empty)
+;;
+
+let () =
+  print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ]))
+;;
+
+let f x (type a) (y : a) = (x = y);; (* Fails *)
+class ['a] c = object (self)
+  method m : 'a -> 'a = fun x -> x
+  method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
+end;; (* Fails *)
diff --git a/testsuite/tests/typing-typeparam/newtype.ml.reference b/testsuite/tests/typing-typeparam/newtype.ml.reference
new file mode 100644
index 00000000..21769753
--- /dev/null
+++ b/testsuite/tests/typing-typeparam/newtype.ml.reference
@@ -0,0 +1,19 @@
+
+#       val property : unit -> ('a -> exn) * (exn -> 'a option) = 
+#                         false
+true
+true
+false
+#         val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = 
+#       abc,xyz
+#   Characters 33-34:
+  let f x (type a) (y : a) = (x = y);; (* Fails *)
+                                  ^
+Error: This expression has type a but an expression was expected of type 'a
+       The type constructor a would escape its scope
+#       Characters 117-118:
+    method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
+                                                       ^
+Error: This expression has type g but an expression was expected of type 'a
+       The type constructor g would escape its scope
+# 
diff --git a/testsuite/tests/typing-unboxed-types/Makefile b/testsuite/tests/typing-unboxed-types/Makefile
new file mode 100644
index 00000000..9625a3fb
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml
new file mode 100644
index 00000000..8e0b337b
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml
@@ -0,0 +1,156 @@
+(* Check the unboxing *)
+
+(* For concrete types *)
+type t1 = A of string [@@ocaml.unboxed];;
+
+let x = A "foo" in
+Obj.repr x == Obj.repr (match x with A s -> s)
+;;
+
+(* For records *)
+type t2 = { f : string } [@@ocaml.unboxed];;
+
+let x = { f = "foo" } in
+Obj.repr x == Obj.repr x.f
+;;
+
+(* For inline records *)
+type t3 = B of { g : string } [@@ocaml.unboxed];;
+
+let x = B { g = "foo" } in
+Obj.repr x == Obj.repr (match x with B {g} -> g)
+;;
+
+(* Check unboxable types *)
+type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+type t6 = G of int | H [@@ocaml.unboxed];;
+type t7 = I of string | J of bool [@@ocaml.unboxed];;
+
+type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+
+(* let rec must be rejected *)
+type t10 = A of t10 [@@ocaml.unboxed];;
+let rec x = A x;;
+
+(* Representation mismatch between module and signature must be rejected *)
+module M : sig
+  type t = A of string
+end = struct
+  type t = A of string [@@ocaml.unboxed]
+end;;
+
+module N : sig
+  type t = A of string [@@ocaml.unboxed]
+end = struct
+  type t = A of string
+end;;
+
+module O : sig
+  type t = { f : string }
+end = struct
+  type t = { f : string } [@@ocaml.unboxed]
+end;;
+
+module P : sig
+  type t = { f : string } [@@ocaml.unboxed]
+end = struct
+  type t = { f : string }
+end;;
+
+module Q : sig
+  type t = A of { f : string }
+end = struct
+  type t = A of { f : string } [@@ocaml.unboxed]
+end;;
+
+module R : sig
+  type t = A of { f : string } [@@ocaml.unboxed]
+end = struct
+  type t = A of { f : string }
+end;;
+
+
+(* Check interference with representation of float arrays. *)
+type t11 = L of float [@@ocaml.unboxed];;
+let x = Array.make 10 (L 3.14)   (* represented as a flat array *)
+and f (a : t11 array) = a.(0)    (* might wrongly assume an array of pointers *)
+in assert (f x = L 3.14);;
+
+
+(* Check for a potential infinite loop in the typing algorithm. *)
+type 'a t12 = M of 'a t12 [@@ocaml.unboxed];;
+let f (a : int t12 array) = a.(0);;
+
+(* Check for another possible loop *)
+type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];;
+
+
+
+(* should work *)
+type t14;;
+type t15 = A of t14 [@@ocaml.unboxed];;
+
+(* should fail *)
+type 'a abs;;
+type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+
+(* should work *)
+type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
+
+(* should fail because the compiler knows that t is actually float and
+   optimizes the record's representation *)
+module S : sig
+  type t
+  type u = { f1 : t; f2 : t }
+end = struct
+  type t = A of float [@@ocaml.unboxed]
+  type u = { f1 : t; f2 : t }
+end;;
+
+
+(* implementing [@@immediate] with [@@ocaml.unboxed]: this works because the
+   representation of [t] is [int]
+ *)
+module T : sig
+  type t [@@immediate]
+end = struct
+  type t = A of int [@@ocaml.unboxed]
+end;;
+
+(* regression test for PR#7511 (wrong determination of unboxability for GADTs)
+*)
+type 'a s = S : 'a -> 'a s [@@unboxed];;
+type t = T : _ s -> t [@@unboxed];;
+
+(* regression test for GPR#1133 (follow-up to PR#7511) *)
+type 'a s = S : 'a -> 'a option s [@@unboxed];;
+type t = T : _ s -> t [@@unboxed];;
+
+(* Another test for GPR#1133: abstract types *)
+module M : sig
+  type 'a r constraint 'a = unit -> 'b
+  val inj : 'b -> (unit -> 'b) r
+end = struct
+  type 'a r = 'b constraint 'a = unit -> 'b
+  let inj x = x
+end;;
+
+(* reject *)
+type t = T : (unit -> _) M.r -> t [@@unboxed];;
+
+type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed];;
+
+(* reject *)
+type t = T : _ s -> t [@@unboxed];;
+
+(* accept *)
+type 'a t = T : 'a s -> 'a t [@@unboxed];;
+
+
+(* Another corner case from GPR#1133 *)
+type _ s = S : 'a t -> _ s  [@@unboxed]
+ and _ t = T : 'a -> 'a s t
+;;
diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference b/testsuite/tests/typing-unboxed-types/test.ml.reference
new file mode 100644
index 00000000..10a118d8
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference
@@ -0,0 +1,203 @@
+
+#       type t1 = A of string [@@unboxed]
+#       - : bool = true
+#     type t2 = { f : string; } [@@unboxed]
+#       - : bool = true
+#     type t3 = B of { g : string; } [@@unboxed]
+#       - : bool = true
+#     Characters 29-58:
+  type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because its constructor has no argument.
+# Characters 0-45:
+  type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+# Characters 0-33:
+  type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-40:
+  type t6 = G of int | H [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-51:
+  type t7 = I of string | J of bool [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+#   Characters 1-50:
+  type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one field.
+# Characters 0-56:
+  type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+#     type t10 = A of t10 [@@unboxed]
+# Characters 12-15:
+  let rec x = A x;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 121-172:
+  ......struct
+    type t = A of string [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string [@@unboxed] end
+       is not included in
+         sig type t = A of string end
+       Type declarations do not match:
+         type t = A of string [@@unboxed]
+       is not included in
+         type t = A of string
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 63-96:
+  ......struct
+    type t = A of string
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string end
+       is not included in
+         sig type t = A of string [@@unboxed] end
+       Type declarations do not match:
+         type t = A of string
+       is not included in
+         type t = A of string [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 48-102:
+  ......struct
+    type t = { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = { f : string; } end
+       Type declarations do not match:
+         type t = { f : string; } [@@unboxed]
+       is not included in
+         type t = { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 66-102:
+  ......struct
+    type t = { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } end
+       is not included in
+         sig type t = { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = { f : string; }
+       is not included in
+         type t = { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 53-112:
+  ......struct
+    type t = A of { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = A of { f : string; } end
+       Type declarations do not match:
+         type t = A of { f : string; } [@@unboxed]
+       is not included in
+         type t = A of { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 71-112:
+  ......struct
+    type t = A of { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } end
+       is not included in
+         sig type t = A of { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = A of { f : string; }
+       is not included in
+         type t = A of { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#       type t11 = L of float [@@unboxed]
+#     - : unit = ()
+#       type 'a t12 = M of 'a t12 [@@unboxed]
+# val f : int t12 array -> int t12 = 
+#     type t13 = A : 'a t12 -> t13 [@@unboxed]
+#         type t14
+# type t15 = A of t14 [@@unboxed]
+#     type 'a abs
+# Characters 0-45:
+  type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     Characters 19-69:
+  type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#   *               Characters 176-256:
+  ......struct
+    type t = A of float [@@ocaml.unboxed]
+    type u = { f1 : t; f2 : t }
+  end..
+Error: Signature mismatch:
+       ...
+       Type declarations do not match:
+         type u = { f1 : t; f2 : t; }
+       is not included in
+         type u = { f1 : t; f2 : t; }
+       Their internal representations differ:
+       the first declaration uses unboxed float representation.
+#     * *           module T : sig type t [@@immediate] end
+#   *   type 'a s = S : 'a -> 'a s [@@unboxed]
+# Characters 0-33:
+  type t = T : _ s -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     type 'a s = S : 'a -> 'a option s [@@unboxed]
+# Characters 0-33:
+  type t = T : _ s -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#                 module M :
+  sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
+#     Characters 14-59:
+  type t = T : (unit -> _) M.r -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#   type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
+#     Characters 14-47:
+  type t = T : _ s -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     type 'a t = T : 'a s -> 'a t [@@unboxed]
+#           Characters 42-81:
+  type _ s = S : 'a t -> _ s  [@@unboxed]
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+# 
diff --git a/testsuite/tests/typing-unboxed/Makefile b/testsuite/tests/typing-unboxed/Makefile
new file mode 100644
index 00000000..7fc00661
--- /dev/null
+++ b/testsuite/tests/typing-unboxed/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-unboxed/test.ml b/testsuite/tests/typing-unboxed/test.ml
new file mode 100644
index 00000000..85265c1f
--- /dev/null
+++ b/testsuite/tests/typing-unboxed/test.ml
@@ -0,0 +1,129 @@
+
+external a : (int [@untagged]) -> unit = "a" "a_nat"
+external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
+external c : (int64 [@unboxed]) -> unit = "c" "c_nat"
+external d : (nativeint [@unboxed]) -> unit = "d" "d_nat"
+external e : (float [@unboxed]) -> unit = "e" "e_nat"
+
+type t = private int
+
+external f : (t [@untagged]) -> unit = "f" "f_nat"
+
+module M : sig
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end = struct
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end;;
+
+module Global_attributes = struct
+  [@@@ocaml.warning "-3"]
+
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  external b : float -> float = "b" "noalloc" "b_nat"
+  external c : float -> float = "c" "c_nat" "float"
+  external d : float -> float = "d" "noalloc"
+  external e : float -> float = "e"
+
+  (* Should output a warning: no native implementation provided *)
+  external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
+  external g : int32 -> int32 = "g" "g_nat" [@@unboxed] [@@noalloc]
+
+  external h : (int [@untagged]) -> (int [@untagged]) = "h" "h_nat" "noalloc"
+  external i : int -> int = "i" "i_nat" [@@untagged] [@@noalloc]
+end;;
+
+module Old_style_warning = struct
+  [@@@ocaml.warning "+3"]
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  external b : float -> float = "b" "noalloc" "b_nat"
+  external c : float -> float = "c" "c_nat" "float"
+  external d : float -> float = "d" "noalloc"
+  external e : float -> float = "c" "float"
+end
+
+(* Bad: attributes not reported in the interface *)
+
+module Bad1 : sig
+  external f : int -> int = "f" "f_nat"
+end = struct
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end;;
+
+module Bad2 : sig
+  external f : int -> int = "a" "a_nat"
+end = struct
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end;;
+
+module Bad3 : sig
+  external f : float -> float = "f" "f_nat"
+end = struct
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end;;
+
+module Bad4 : sig
+  external f : float -> float = "a" "a_nat"
+end = struct
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end;;
+
+(* Bad: attributes in the interface but not in the implementation *)
+
+module Bad5 : sig
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end = struct
+  external f : int -> int = "f" "f_nat"
+end;;
+
+module Bad6 : sig
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end = struct
+  external f : int -> int = "a" "a_nat"
+end;;
+
+module Bad7 : sig
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end = struct
+  external f : float -> float = "f" "f_nat"
+end;;
+
+module Bad8 : sig
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end = struct
+  external f : float -> float = "a" "a_nat"
+end;;
+
+(* Bad: unboxed or untagged with the wrong type *)
+
+external g : (float [@untagged]) -> float = "g" "g_nat";;
+external h : (int [@unboxed]) -> float = "h" "h_nat";;
+
+(* Bad: unboxing the function type *)
+external i : int -> float [@unboxed] = "i" "i_nat";;
+
+(* Bad: unboxing a "deep" sub-type. *)
+external j : int -> (float [@unboxed]) * float = "j" "j_nat";;
+
+(* This should be rejected, but it is quite complicated to do
+   in the current state of things *)
+
+external k : int -> (float [@unboxd]) = "k" "k_nat";;
+
+(* Bad: old style annotations + new style attributes *)
+
+external l : float -> float = "l" "l_nat" "float" [@@unboxed];;
+external m : (float [@unboxed]) -> float = "m" "m_nat" "float";;
+external n : float -> float = "n" "noalloc" [@@noalloc];;
+
+(* Warnings: unboxed / untagged without any native implementation *)
+external o : (float[@unboxed]) -> float = "o";;
+external p : float -> (float[@unboxed]) = "p";;
+external q : (int[@untagged]) -> float = "q";;
+external r : int -> (int[@untagged]) = "r";;
+external s : int -> int = "s" [@@untagged];;
+external t : float -> float = "t" [@@unboxed];;
+
+(* PR#7424 *)
+type 'a b = B of 'a b b [@@unboxed];;
diff --git a/testsuite/tests/typing-unboxed/test.ml.reference b/testsuite/tests/typing-unboxed/test.ml.reference
new file mode 100644
index 00000000..803bf571
--- /dev/null
+++ b/testsuite/tests/typing-unboxed/test.ml.reference
@@ -0,0 +1,192 @@
+
+#                                   external a : (int [@untagged]) -> unit = "a" "a_nat"
+external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
+external c : (int64 [@unboxed]) -> unit = "c" "c_nat"
+external d : (nativeint [@unboxed]) -> unit = "d" "d_nat"
+external e : (float [@unboxed]) -> unit = "e" "e_nat"
+type t = private int
+external f : (t [@untagged]) -> unit = "f" "f_nat"
+module M :
+  sig
+    external a : int -> (int [@untagged]) = "a" "a_nat"
+    external b : (int [@untagged]) -> int = "b" "b_nat"
+  end
+#                                 Characters 382-451:
+    external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+#                                 Characters 63-122:
+    external a : float -> float = "a" "noalloc" "a_nat" "float"
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float"
+Characters 125-176:
+    external b : float -> float = "b" "noalloc" "b_nat"
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc"
+Characters 179-228:
+    external c : float -> float = "c" "c_nat" "float"
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@unboxed] + [@@noalloc] should be used instead of "float"
+Characters 231-274:
+    external d : float -> float = "d" "noalloc"
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 3: deprecated: [@@noalloc] should be used instead of "noalloc"
+Characters 441-505:
+  ......struct
+    external f : int -> (int [@untagged]) = "f" "f_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : int -> (int [@untagged]) = "f" "f_nat" end
+       is not included in
+         sig external f : int -> int = "f" "f_nat" end
+       Values do not match:
+         external f : int -> (int [@untagged]) = "f" "f_nat"
+       is not included in
+         external f : int -> int = "f" "f_nat"
+#           Characters 65-129:
+  ......struct
+    external f : (int [@untagged]) -> int = "f" "f_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : (int [@untagged]) -> int = "f" "f_nat" end
+       is not included in
+         sig external f : int -> int = "a" "a_nat" end
+       Values do not match:
+         external f : (int [@untagged]) -> int = "f" "f_nat"
+       is not included in
+         external f : int -> int = "a" "a_nat"
+#           Characters 69-136:
+  ......struct
+    external f : float -> (float [@unboxed]) = "f" "f_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : float -> (float [@unboxed]) = "f" "f_nat" end
+       is not included in
+         sig external f : float -> float = "f" "f_nat" end
+       Values do not match:
+         external f : float -> (float [@unboxed]) = "f" "f_nat"
+       is not included in
+         external f : float -> float = "f" "f_nat"
+#           Characters 69-136:
+  ......struct
+    external f : (float [@unboxed]) -> float = "f" "f_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : (float [@unboxed]) -> float = "f" "f_nat" end
+       is not included in
+         sig external f : float -> float = "a" "a_nat" end
+       Values do not match:
+         external f : (float [@unboxed]) -> float = "f" "f_nat"
+       is not included in
+         external f : float -> float = "a" "a_nat"
+#               Characters 149-199:
+  ......struct
+    external f : int -> int = "f" "f_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : int -> int = "f" "f_nat" end
+       is not included in
+         sig external f : int -> (int [@untagged]) = "f" "f_nat" end
+       Values do not match:
+         external f : int -> int = "f" "f_nat"
+       is not included in
+         external f : int -> (int [@untagged]) = "f" "f_nat"
+#           Characters 79-129:
+  ......struct
+    external f : int -> int = "a" "a_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : int -> int = "a" "a_nat" end
+       is not included in
+         sig external f : (int [@untagged]) -> int = "f" "f_nat" end
+       Values do not match:
+         external f : int -> int = "a" "a_nat"
+       is not included in
+         external f : (int [@untagged]) -> int = "f" "f_nat"
+#           Characters 82-136:
+  ......struct
+    external f : float -> float = "f" "f_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : float -> float = "f" "f_nat" end
+       is not included in
+         sig external f : float -> (float [@unboxed]) = "f" "f_nat" end
+       Values do not match:
+         external f : float -> float = "f" "f_nat"
+       is not included in
+         external f : float -> (float [@unboxed]) = "f" "f_nat"
+#           Characters 82-136:
+  ......struct
+    external f : float -> float = "a" "a_nat"
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig external f : float -> float = "a" "a_nat" end
+       is not included in
+         sig external f : (float [@unboxed]) -> float = "f" "f_nat" end
+       Values do not match:
+         external f : float -> float = "a" "a_nat"
+       is not included in
+         external f : (float [@unboxed]) -> float = "f" "f_nat"
+#       Characters 67-72:
+  external g : (float [@untagged]) -> float = "g" "g_nat";;
+                ^^^^^
+Error: Don't know how to untag this type. Only int can be untagged
+# Characters 14-17:
+  external h : (int [@unboxed]) -> float = "h" "h_nat";;
+                ^^^
+Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed
+#     Characters 52-64:
+  external i : int -> float [@unboxed] = "i" "i_nat";;
+               ^^^^^^^^^^^^
+Error: Don't know how to unbox this type. Only float, int32, int64 and nativeint can be unboxed
+#     Characters 61-66:
+  external j : int -> (float [@unboxed]) * float = "j" "j_nat";;
+                       ^^^^^
+Error: The attribute '@unboxed' should be attached to a direct argument or result of the primitive, it should not occur deeply into its type
+#   *     external k : int -> float = "k" "k_nat"
+#       Characters 58-119:
+  external l : float -> float = "l" "l_nat" "float" [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged]
+# Characters 0-62:
+  external m : (float [@unboxed]) -> float = "m" "m_nat" "float";;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot use "float" in conjunction with [@unboxed]/[@untagged]
+# Characters 0-55:
+  external n : float -> float = "n" "noalloc" [@@noalloc];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Cannot use "noalloc" in conjunction with [@@noalloc]
+#     Characters 70-115:
+  external o : (float[@unboxed]) -> float = "o";;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+# Characters 0-45:
+  external p : float -> (float[@unboxed]) = "p";;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+# Characters 0-44:
+  external q : (int[@untagged]) -> float = "q";;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+# Characters 0-42:
+  external r : int -> (int[@untagged]) = "r";;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+# Characters 0-42:
+  external s : int -> int = "s" [@@untagged];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+# Characters 0-45:
+  external t : float -> float = "t" [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+#     type 'a b = B of 'a b b [@@unboxed]
+# 
diff --git a/testsuite/tests/typing-warnings/Makefile b/testsuite/tests/typing-warnings/Makefile
new file mode 100644
index 00000000..646c8d49
--- /dev/null
+++ b/testsuite/tests/typing-warnings/Makefile
@@ -0,0 +1,19 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -w A -strict-sequence
diff --git a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml
new file mode 100644
index 00000000..2b52368e
--- /dev/null
+++ b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml
@@ -0,0 +1,206 @@
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+let () = print_endline "\n\
+  <----------------------------------------------------------------------\n\
+  To check the result file for this test, it suffices to look for \"val\"\n\
+  lines corresponding to toplevel answers. If they start with\n\
+  \n\
+  \    val ambiguous_...\n\
+  \n\
+  then just above there should be the warning text for Warning 57\n\
+  (we try to avoid all other warnings). If they start with\n\
+  \n\
+  \   val not_ambiguous_...\n\
+  \n\
+  then just above there should be *no* warning text.\n\
+  ---------------------------------------------------------------------->\n\
+";;
+
+
+type expr = Val of int | Rest;;
+
+let ambiguous_typical_example = function
+  | ((Val x, _) | (_, Val x)) when x < 0 -> ()
+  | (_, Rest) -> ()
+  | (_, Val x) ->
+      (* the reader might expect *)
+      assert (x >= 0);
+      (* to hold here, but it is wrong! *)
+      ()
+;;
+
+let () = print_endline "Note that an Assert_failure is expected just below.";;
+let fails = ambiguous_typical_example (Val 2, Val (-1))
+;;
+
+let not_ambiguous__no_orpat = function
+  | Some x when x > 0 -> ()
+  | Some _ -> ()
+  | None -> ()
+;;
+
+let not_ambiguous__no_guard = function
+  | `A -> ()
+  | (`B | `C) -> ()
+;;
+
+let not_ambiguous__no_patvar_in_guard b = function
+  | (`B x | `C x) when b -> ignore x
+  | _ -> ()
+;;
+
+let not_ambiguous__disjoint_cases = function
+  | (`B x | `C x) when x -> ()
+  | _ -> ()
+;;
+
+(* the curious (..., _, Some _) | (..., Some _, _) device used in
+   those tests serves to avoid warning 12 (this sub-pattern
+   is unused), by making sure that, even if the two sides of the
+   disjunction overlap, none is fully included in the other. *)
+let not_ambiguous__prefix_variables = function
+  | (`B (x, _, Some y) | `B (x, Some y, _)) when x -> ignore y
+  | _ -> ()
+;;
+
+let ambiguous__y = function
+  | (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x
+  | _ -> ()
+;;
+
+(* it should be understood that the ambiguity warning only protects
+     (p | q) when guard -> ...
+   it will never warn on
+     (p | q) -> if guard ...
+   This is not a limitation. The point is that people have an
+   intuitive understanding of [(p | q) when guard -> ...] that differs
+   from the reality, while there is no such issue with
+   [(p | q) -> if guard ...].
+*)
+let not_ambiguous__rhs_not_protected = function
+  | (`B (x, _, Some y) | `B (x, Some y, _)) -> if y then ignore x else ()
+  | _ -> ()
+;;
+
+let ambiguous__x_y = function
+  | (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> ()
+  | _ -> ()
+;;
+
+let ambiguous__x_y_z = function
+  | (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__disjoint_in_depth = function
+  | `A (`B x | `C x) when x -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__prefix_variables_in_depth = function
+  | `A (`B (x, `C1) | `B (x, `C2)) when x -> ()
+  | _ -> ()
+;;
+
+let ambiguous__in_depth = function
+  | `A (`B (Some x, _) | `B (_, Some x)) when x -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__several_orpats = function
+  | `A ((`B (x, Some _, _) | `B (x, _, Some _)),
+        (`C (y, Some _, _) | `C (y, _, Some _)),
+        (`D1 (_, z, Some _, _) | `D2 (_, z, _, Some _))) when x < y && x < z ->
+      ()
+  | _ -> ()
+;;
+
+let ambiguous__first_orpat = function
+  | `A ((`B (Some x, _) | `B (_, Some x)),
+        (`C (Some y, Some _, _) | `C (Some y, _, Some _))) when x < y -> ()
+  | _ -> ()
+;;
+
+let ambiguous__second_orpat = function
+  | `A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)),
+        (`C (Some y, _) | `C (_, Some y))) when x < y -> ()
+  | _ -> ()
+;;
+
+(* check that common prefixes work as expected *)
+let not_ambiguous__pairs = function
+  | (x, Some _, _) | (x, _, Some _) when x -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__vars =
+  begin[@warning "-12"] function
+  | (x | x) when x -> ()
+  | _ -> ()
+  end
+;;
+
+let not_ambiguous__as p = function
+  | (([], _) as x | ((_, []) as x)) when p x -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__as_var p = function
+  | (([], _) as x | x) when p x -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__var_as p = function
+  | (x, Some _, _) | (([], _) as x, _, Some _) when p x -> ()
+  | _ -> ()
+;;
+
+let not_ambiguous__lazy = function
+  | (([], _), lazy x) | ((_, []), lazy x) when x -> ()
+  | _ -> ()
+
+;;
+
+type t = A of int * int option * int option | B;;
+
+let not_ambiguous__constructor = function
+  | A (x, Some _, _) | A (x, _, Some _) when x > 0 -> ()
+  | A _ | B -> ()
+;;
+
+
+type amoi = Z of int | Y of int * int  | X of amoi * amoi
+;;
+
+let ambiguous__amoi a = match a with
+| X (Z x,Y (y,0))
+| X (Z y,Y (x,_))
+ when x+y > 0 -> 0
+| X _|Y _|Z _ -> 1
+;;
+
+module type S = sig val b : bool end
+;;
+
+let ambiguous__module_variable x b =  match x with
+  | (module M:S),_,(1,_)
+  | _,(module M:S),(_,1) when M.b && b -> 1
+  | _ -> 2
+;;
+
+let not_ambiguous__module_variable x b =  match x with
+  | (module M:S),_,(1,_)
+  | _,(module M:S),(_,1) when b -> 1
+  | _ -> 2
+;;
+
+(* Mixed case *)
+
+type t = A of int * int | B of int * int
+;;
+
+let ambiguous_xy_but_not_ambiguous_z g = function
+  | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+  | _ -> 2
+;;
diff --git a/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference
new file mode 100644
index 00000000..ece388aa
--- /dev/null
+++ b/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference
@@ -0,0 +1,140 @@
+
+#   - : unit = ()
+#                               
+<----------------------------------------------------------------------
+To check the result file for this test, it suffices to look for "val"
+lines corresponding to toplevel answers. If they start with
+
+    val ambiguous_...
+
+then just above there should be the warning text for Warning 57
+(we try to avoid all other warnings). If they start with
+
+   val not_ambiguous_...
+
+then just above there should be *no* warning text.
+---------------------------------------------------------------------->
+
+#     type expr = Val of int | Rest
+#                   Characters 46-71:
+    | ((Val x, _) | (_, Val x)) when x < 0 -> ()
+      ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 8.5)
+val ambiguous_typical_example : expr * expr -> unit = 
+#   Note that an Assert_failure is expected just below.
+#   Exception: Assert_failure ("//toplevel//", 25, 6).
+#           val not_ambiguous__no_orpat : int option -> unit = 
+#         val not_ambiguous__no_guard : [< `A | `B | `C ] -> unit = 
+#         val not_ambiguous__no_patvar_in_guard :
+  bool -> [> `B of 'a | `C of 'a ] -> unit = 
+#         val not_ambiguous__disjoint_cases : [> `B of bool | `C of bool ] -> unit =
+  
+#   * * *         val not_ambiguous__prefix_variables :
+  [> `B of bool * 'a option * 'a option ] -> unit = 
+#         Characters 33-72:
+    | (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 8.5)
+val ambiguous__y : [> `B of 'a * bool option * bool option ] -> unit = 
+#   * * * * * * * *         val not_ambiguous__rhs_not_protected :
+  [> `B of 'a * bool option * bool option ] -> unit = 
+#         Characters 35-74:
+    | (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> ()
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 8.5)
+val ambiguous__x_y : [> `B of 'a * 'a option * 'a option ] -> unit = 
+#         Characters 37-76:
+    | (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> ()
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variables y,z may match different arguments. (See manual section 8.5)
+val ambiguous__x_y_z : [> `B of 'a * 'a option * 'a option ] -> unit = 
+#         val not_ambiguous__disjoint_in_depth :
+  [> `A of [> `B of bool | `C of bool ] ] -> unit = 
+#         val not_ambiguous__prefix_variables_in_depth :
+  [> `A of [> `B of bool * [> `C1 | `C2 ] ] ] -> unit = 
+#         Characters 40-76:
+    | `A (`B (Some x, _) | `B (_, Some x)) when x -> ()
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 8.5)
+val ambiguous__in_depth :
+  [> `A of [> `B of bool option * bool option ] ] -> unit = 
+#               val not_ambiguous__several_orpats :
+  [> `A of
+       [> `B of 'a * 'b option * 'c option ] *
+       [> `C of 'a * 'd option * 'e option ] *
+       [> `D1 of 'f * 'a * 'g option * 'h | `D2 of 'i * 'a * 'j * 'k option ] ] ->
+  unit = 
+#           Characters 43-140:
+  ....`A ((`B (Some x, _) | `B (_, Some x)),
+          (`C (Some y, Some _, _) | `C (Some y, _, Some _))).................
+Warning 57: Ambiguous or-pattern variables under guard;
+variable x may match different arguments. (See manual section 8.5)
+val ambiguous__first_orpat :
+  [> `A of
+       [> `B of 'a option * 'a option ] *
+       [> `C of 'a option * 'b option * 'c option ] ] ->
+  unit = 
+#           Characters 44-141:
+  ....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)),
+          (`C (Some y, _) | `C (_, Some y))).................
+Warning 57: Ambiguous or-pattern variables under guard;
+variable y may match different arguments. (See manual section 8.5)
+val ambiguous__second_orpat :
+  [> `A of
+       [> `B of 'a option * 'b option * 'c option ] *
+       [> `C of 'a option * 'a option ] ] ->
+  unit = 
+#           val not_ambiguous__pairs : bool * 'a option * 'b option -> unit = 
+#             val not_ambiguous__vars : bool -> unit = 
+#         val not_ambiguous__as :
+  ('a list * 'b list -> bool) -> 'a list * 'b list -> unit = 
+#         val not_ambiguous__as_var : ('a list * 'b -> bool) -> 'a list * 'b -> unit =
+  
+#         val not_ambiguous__var_as :
+  ('a list * 'b -> bool) -> ('a list * 'b) * 'c option * 'd option -> unit =
+  
+#           val not_ambiguous__lazy : ('a list * 'b list) * bool lazy_t -> unit = 
+#   type t = A of int * int option * int option | B
+#         val not_ambiguous__constructor : t -> unit = 
+#       type amoi = Z of int | Y of int * int | X of amoi * amoi
+#             Characters 40-73:
+  ..X (Z x,Y (y,0))
+  | X (Z y,Y (x,_))
+Warning 57: Ambiguous or-pattern variables under guard;
+variables x,y may match different arguments. (See manual section 8.5)
+val ambiguous__amoi : amoi -> int = 
+#     module type S = sig val b : bool end
+#           Characters 56-101:
+  ....(module M:S),_,(1,_)
+    | _,(module M:S),(_,1)...................
+Warning 57: Ambiguous or-pattern variables under guard;
+variable M may match different arguments. (See manual section 8.5)
+val ambiguous__module_variable :
+  (module S) * (module S) * (int * int) -> bool -> int = 
+#           val not_ambiguous__module_variable :
+  (module S) * (module S) * (int * int) -> bool -> int = 
+#         type t = A of int * int | B of int * int
+#         Characters 55-56:
+    | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+      ^
+Warning 41: A belongs to several types: t t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 42-138:
+  .........................................function
+    | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+    | _ -> 2
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t.
+Characters 55-107:
+    | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 57: Ambiguous or-pattern variables under guard;
+variables x,y may match different arguments. (See manual section 8.5)
+val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t -> int =
+  
+# 
diff --git a/testsuite/tests/typing-warnings/application.ml b/testsuite/tests/typing-warnings/application.ml
new file mode 100644
index 00000000..8948dc8c
--- /dev/null
+++ b/testsuite/tests/typing-warnings/application.ml
@@ -0,0 +1,5 @@
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+let _ = ignore (+);;
+let _ = raise Exit 3;;
diff --git a/testsuite/tests/typing-warnings/application.ml.reference b/testsuite/tests/typing-warnings/application.ml.reference
new file mode 100644
index 00000000..d35fd40e
--- /dev/null
+++ b/testsuite/tests/typing-warnings/application.ml.reference
@@ -0,0 +1,14 @@
+
+#   - : unit = ()
+#   Characters 16-19:
+  let _ = ignore (+);;
+                 ^^^
+Warning 5: this function application is partial,
+maybe some arguments are missing.
+- : unit = ()
+# Characters 19-20:
+  let _ = raise Exit 3;;
+                     ^
+Warning 20: this argument will not be used by the function.
+Exception: Pervasives.Exit.
+# 
diff --git a/testsuite/tests/typing-warnings/coercions.ml b/testsuite/tests/typing-warnings/coercions.ml
new file mode 100644
index 00000000..5fd77e1a
--- /dev/null
+++ b/testsuite/tests/typing-warnings/coercions.ml
@@ -0,0 +1,22 @@
+(* comment 9644 of PR#6000 *)
+
+fun b -> if b then format_of_string "x" else "y";;
+fun b -> if b then "x" else format_of_string "y";;
+fun b : (_,_,_) format -> if b then "x" else "y";;
+
+(* PR#7135 *)
+
+module PR7135 = struct
+  module M : sig type t = private int end =  struct type t = int end
+  include M
+
+  let lift2 (f : int -> int -> int) (x : t) (y : t) =
+    f (x :> int) (y :> int)
+end;;
+
+(* exemple of non-ground coercion *)
+
+module Test1 = struct
+  type t = private int
+  let f x = let y = if true then x else (x:t) in (y :> int)
+end;;
diff --git a/testsuite/tests/typing-warnings/coercions.ml.principal.reference b/testsuite/tests/typing-warnings/coercions.ml.principal.reference
new file mode 100644
index 00000000..c16dd9f8
--- /dev/null
+++ b/testsuite/tests/typing-warnings/coercions.ml.principal.reference
@@ -0,0 +1,26 @@
+
+#     Characters 76-79:
+  fun b -> if b then format_of_string "x" else "y";;
+                                               ^^^
+Warning 18: this coercion to format6 is not principal.
+- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = 
+# Characters 28-48:
+  fun b -> if b then "x" else format_of_string "y";;
+                              ^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type
+         ('a, 'b, 'c, 'd, 'd, 'a) format6 =
+           ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
+       but an expression was expected of type string
+# - : bool -> ('a, 'b, 'a) format = 
+#                   module PR7135 :
+  sig
+    module M : sig type t = private int end
+    type t = M.t
+    val lift2 : (int -> int -> int) -> t -> t -> int
+  end
+#             Characters 133-143:
+    let f x = let y = if true then x else (x:t) in (y :> int)
+                                                   ^^^^^^^^^^
+Warning 18: this ground coercion is not principal.
+module Test1 : sig type t = private int val f : t -> int end
+# 
diff --git a/testsuite/tests/typing-warnings/coercions.ml.reference b/testsuite/tests/typing-warnings/coercions.ml.reference
new file mode 100644
index 00000000..f5ff65b7
--- /dev/null
+++ b/testsuite/tests/typing-warnings/coercions.ml.reference
@@ -0,0 +1,18 @@
+
+#     - : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = 
+# Characters 28-48:
+  fun b -> if b then "x" else format_of_string "y";;
+                              ^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type
+         ('a, 'b, 'c, 'd, 'd, 'a) format6 =
+           ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
+       but an expression was expected of type string
+# - : bool -> ('a, 'b, 'a) format = 
+#                   module PR7135 :
+  sig
+    module M : sig type t = private int end
+    type t = M.t
+    val lift2 : (int -> int -> int) -> t -> t -> int
+  end
+#             module Test1 : sig type t = private int val f : t -> int end
+# 
diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml
new file mode 100644
index 00000000..c1e78a2a
--- /dev/null
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml
@@ -0,0 +1,113 @@
+(* Warn about all relevant cases when possible *)
+let f = function
+    None, None -> 1
+  | Some _, Some _ -> 2;;
+
+(* Exhaustiveness check is very slow *)
+type _ t =
+  A : int t | B : bool t | C : char t | D : float t
+type (_,_,_,_) u = U : (int, int, int, int) u
+type v = E | F | G
+;;
+
+let f : type a b c d e f g.
+      a t * b t * c t * d t * e t * f t * g t * v
+       * (a,b,c,d) u * (e,f,g,g) u -> int =
+ function A, A, A, A, A, A, A, _, U, U -> 1
+   | _, _, _, _, _, _, _, G, _, _ -> 1
+   (*| _ -> _ *)
+;;
+
+(* Unused cases *)
+let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
+let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
+let f (x : int t option) = match x with None -> 1 | _ -> 2;;
+let f (x : int t option) = match x with None -> 1;; (* warn *)
+
+(* Example with record, type, single case *)
+
+type 'a box = Box of 'a
+type 'a pair = {left: 'a; right: 'a};;
+
+let f : (int t box pair * bool) option -> unit = function None -> ();;
+let f : (string t box pair * bool) option -> unit = function None -> ();;
+let f = function {left=Box 0; _ } -> ();;
+let f = function {left=Box 0;right=Box 1} -> ();;
+
+(* Examples from ML2015 paper *)
+
+type _ t =
+  | Int : int t
+  | Bool : bool t
+;;
+
+let f : type a. a t -> a = function
+  | Int -> 1
+  | Bool -> true
+;;
+let g : int t -> int = function
+  | Int -> 1
+;;
+let h : type a. a t -> a t -> bool =
+  fun x y -> match x, y with
+  | Int, Int -> true
+  | Bool, Bool -> true
+;;
+type (_, _) cmp =
+ | Eq : ('a, 'a) cmp
+ | Any: ('a, 'b) cmp
+module A : sig type a type b val eq : (a, b) cmp end
+  = struct type a type b = a let eq = Eq end
+;;
+let f : (A.a, A.b) cmp -> unit = function Any -> ()
+;;
+let deep : char t option -> char =
+  function None -> 'c'
+;;
+type zero = Zero
+type _ succ = Succ
+;;
+type (_,_,_) plus =
+  | Plus0 : (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus ->
+       ('a succ, 'b, 'c succ) plus
+;;
+let trivial : (zero succ, zero, zero) plus option -> bool =
+  function None -> false
+;;
+let easy : (zero, zero succ, zero) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option  -> bool =
+  function None -> false | Some (PlusS _) -> .
+;;
+let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool =
+  fun p1 p2 ->
+    match p1, p2 with
+    | Plus0, Plus0 -> true
+;;
+
+
+(* Empty match *)
+
+type _ t = Int : int t;;
+let f (x : bool t) = match x with _ -> . ;; (* ok *)
+
+
+(* trefis in PR#6437 *)
+
+let f () = match None with _ -> .;; (* error *)
+let g () = match None with _ -> () | exception _ -> .;; (* error *)
+let h () = match None with _ -> .  | exception _ -> .;; (* error *)
+let f x = match x with _ -> () | None -> .;; (* do not warn *)
+
+(* #7059, all clauses guarded *)
+
+let f x y = match 1 with 1 when x = y -> 1;;
+
+(* #7504, Example with no constraints on a record *)
+let f = function {contents=_}, 0 -> 0;;
diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
new file mode 100644
index 00000000..0bb5b0b8
--- /dev/null
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
@@ -0,0 +1,143 @@
+
+#       Characters 58-110:
+  ........function
+      None, None -> 1
+    | Some _, Some _ -> 2..
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+((Some _, None)|(None, Some _))
+val f : 'a option * 'b option -> int = 
+#             type _ t = A : int t | B : bool t | C : char t | D : float t
+type (_, _, _, _) u = U : (int, int, int, int) u
+type v = E | F | G
+#               Characters 124-205:
+  .function A, A, A, A, A, A, A, _, U, U -> 1
+     | _, _, _, _, _, _, _, G, _, _ -> 1
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A, A, A, A, A, B, (E|F), _, _)
+Characters 172-200:
+     | _, _, _, _, _, _, _, G, _, _ -> 1
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case ' -> .'
+val f :
+  'a t * 'b t * 'c t * 'd t * 'e t * 'f t * 'g t * v * ('a, 'b, 'c, 'd) u *
+  ('e, 'f, 'g, 'g) u -> int = 
+#     Characters 40-68:
+  let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+                      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t.
+Characters 62-63:
+  let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+                                            ^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case ' -> .'
+val f : int t -> int = 
+# Characters 53-54:
+  let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
+                                                       ^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case ' -> .'
+val f : unit t option -> int = 
+# Characters 53-59:
+  let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
+                                                       ^^^^^^
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case ' -> .'
+val f : unit t option -> int = 
+# val f : int t option -> int = 
+# Characters 27-49:
+  let f (x : int t option) = match x with None -> 1;; (* warn *)
+                             ^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some A
+val f : int t option -> int = 
+#         type 'a box = Box of 'a
+type 'a pair = { left : 'a; right : 'a; }
+#   Characters 50-69:
+  let f : (int t box pair * bool) option -> unit = function None -> ();;
+                                                   ^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some ({left=Box A; right=Box A}, _)
+val f : (int t box pair * bool) option -> unit = 
+# val f : (string t box pair * bool) option -> unit = 
+# Characters 8-39:
+  let f = function {left=Box 0; _ } -> ();;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 1; _ }
+val f : int box pair -> unit = 
+# Characters 8-47:
+  let f = function {left=Box 0;right=Box 1} -> ();;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 0; right=Box 0}
+val f : int box pair -> unit = 
+#             type _ t = Int : int t | Bool : bool t
+#         val f : 'a t -> 'a = 
+#     val g : int t -> int = 
+#         val h : 'a t -> 'a t -> bool = 
+#           type (_, _) cmp = Eq : ('a, 'a) cmp | Any : ('a, 'b) cmp
+module A : sig type a type b val eq : (a, b) cmp end
+#   Characters 33-51:
+  let f : (A.a, A.b) cmp -> unit = function Any -> ()
+                                   ^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (A.a, A.b) cmp -> unit = 
+#     val deep : char t option -> char = 
+#     type zero = Zero
+type _ succ = Succ
+#         type (_, _, _) plus =
+    Plus0 : (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+#     val trivial : (zero succ, zero, zero) plus option -> bool = 
+#     val easy : (zero, zero succ, zero) plus option -> bool = 
+#     Characters 71-93:
+    function None -> false
+    ^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some (PlusS _)
+val harder : (zero succ, zero succ, zero succ) plus option -> bool = 
+#     val harder : (zero succ, zero succ, zero succ) plus option -> bool = 
+#         val inv_zero : ('a, 'b, 'c) plus -> ('c, 'd, zero) plus -> bool = 
+#         type _ t = Int : int t
+# val f : bool t -> 'a = 
+#         Characters 54-55:
+  let f () = match None with _ -> .;; (* error *)
+                             ^
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: _
+# Characters 47-48:
+  let g () = match None with _ -> () | exception _ -> .;; (* error *)
+                                                 ^
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: _
+# Characters 27-28:
+  let h () = match None with _ -> .  | exception _ -> .;; (* error *)
+                             ^
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: _
+# val f : 'a option -> unit = 
+#       Characters 47-77:
+  let f x y = match 1 with 1 when x = y -> 1;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+All clauses in this pattern-matching are guarded.
+val f : 'a -> 'a -> int = 
+#     Characters 62-91:
+  let f = function {contents=_}, 0 -> 0;;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 1)
+val f : 'a ref * int -> int = 
+# 
diff --git a/testsuite/tests/typing-warnings/pr5892.ml b/testsuite/tests/typing-warnings/pr5892.ml
new file mode 100644
index 00000000..bbc73b55
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr5892.ml
@@ -0,0 +1,3 @@
+open CamlinternalOO;;
+type _ choice = Left : label choice | Right : tag choice;;
+let f : label choice -> bool = function Left -> true;; (* warn *)
diff --git a/testsuite/tests/typing-warnings/pr5892.ml.reference b/testsuite/tests/typing-warnings/pr5892.ml.reference
new file mode 100644
index 00000000..e56687af
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr5892.ml.reference
@@ -0,0 +1,12 @@
+
+# # type _ choice =
+    Left : CamlinternalOO.label choice
+  | Right : CamlinternalOO.tag choice
+# Characters 31-52:
+  let f : label choice -> bool = function Left -> true;; (* warn *)
+                                 ^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Right
+val f : CamlinternalOO.label choice -> bool = 
+# 
diff --git a/testsuite/tests/typing-warnings/pr6872.ml b/testsuite/tests/typing-warnings/pr6872.ml
new file mode 100644
index 00000000..73870a02
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr6872.ml
@@ -0,0 +1,11 @@
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+exception A;;
+type a = A;;
+
+A;;
+raise A;;
+fun (A : a) -> ();;
+function Not_found -> 1 | A -> 2 | _ -> 3;;
+try raise A with A -> 2;;
diff --git a/testsuite/tests/typing-warnings/pr6872.ml.principal.reference b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
new file mode 100644
index 00000000..616b4548
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
@@ -0,0 +1,39 @@
+
+#   - : unit = ()
+#   exception A
+# type a = A
+#   Characters 1-2:
+  A;;
+  ^
+Warning 41: A belongs to several types: a exn
+The first one was selected. Please disambiguate if this is wrong.
+- : a = A
+# Characters 6-7:
+  raise A;;
+        ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Exception: A.
+# - : a -> unit = 
+# Characters 26-27:
+  function Not_found -> 1 | A -> 2 | _ -> 3;;
+                            ^
+Warning 41: A belongs to several types: a exn
+The first one was selected. Please disambiguate if this is wrong.
+Characters 26-27:
+  function Not_found -> 1 | A -> 2 | _ -> 3;;
+                            ^
+Error: This pattern matches values of type a
+       but a pattern was expected which matches values of type exn
+# Characters 10-11:
+  try raise A with A -> 2;;
+            ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 17-18:
+  try raise A with A -> 2;;
+                   ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+- : int = 2
+# 
diff --git a/testsuite/tests/typing-warnings/pr6872.ml.reference b/testsuite/tests/typing-warnings/pr6872.ml.reference
new file mode 100644
index 00000000..5cd4291f
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr6872.ml.reference
@@ -0,0 +1,35 @@
+
+#   - : unit = ()
+#   exception A
+# type a = A
+#   Characters 1-2:
+  A;;
+  ^
+Warning 41: A belongs to several types: a exn
+The first one was selected. Please disambiguate if this is wrong.
+- : a = A
+# Characters 6-7:
+  raise A;;
+        ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Exception: A.
+# - : a -> unit = 
+# Characters 26-27:
+  function Not_found -> 1 | A -> 2 | _ -> 3;;
+                            ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+- : exn -> int = 
+# Characters 10-11:
+  try raise A with A -> 2;;
+            ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 17-18:
+  try raise A with A -> 2;;
+                   ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+- : int = 2
+# 
diff --git a/testsuite/tests/typing-warnings/pr7085.ml b/testsuite/tests/typing-warnings/pr7085.ml
new file mode 100644
index 00000000..21ca0d67
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7085.ml
@@ -0,0 +1,23 @@
+module TypEq = struct
+ type (_, _) t = Eq : ('a, 'a) t
+end
+
+module type T = sig
+ type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
+ val is_t : unit -> unit is_t option
+end
+
+module Make (M : T) =
+ struct
+   let _ =
+     match M.is_t () with
+     | None -> 0
+     | Some _ -> 0
+   let f () =
+     match M.is_t () with None -> 0
+end;;
+
+module Make2 (M : T) = struct
+  type t = T of unit M.is_t
+  let g : t -> int = function _ -> .
+end;;
diff --git a/testsuite/tests/typing-warnings/pr7085.ml.reference b/testsuite/tests/typing-warnings/pr7085.ml.reference
new file mode 100644
index 00000000..3a54d4ad
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7085.ml.reference
@@ -0,0 +1,20 @@
+
+#                                   Characters 292-322:
+       match M.is_t () with None -> 0
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some (Is Eq)
+module TypEq : sig type (_, _) t = Eq : ('a, 'a) t end
+module type T =
+  sig
+    type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
+    val is_t : unit -> unit is_t option
+  end
+module Make : functor (M : T) -> sig val f : unit -> int end
+#         Characters 89-90:
+    let g : t -> int = function _ -> .
+                                ^
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: T (Is Eq)
+# 
diff --git a/testsuite/tests/typing-warnings/pr7115.ml b/testsuite/tests/typing-warnings/pr7115.ml
new file mode 100755
index 00000000..1a892061
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7115.ml
@@ -0,0 +1,20 @@
+type t = A : t;;
+
+module X1 : sig end = struct
+  let _f ~x (* x unused argument *) = function
+    | A -> let x = () in x
+end;;
+
+module X2 : sig end = struct
+  let x = 42 (* unused value *)
+  let _f = function
+    | A -> let x = () in x
+end;;
+
+module X3 : sig end = struct
+  module O = struct let x = 42 (* unused *) end
+  open O (* unused open *)
+
+  let _f = function
+    | A -> let x = () in x
+end;;
diff --git a/testsuite/tests/typing-warnings/pr7115.ml.reference b/testsuite/tests/typing-warnings/pr7115.ml.reference
new file mode 100644
index 00000000..8a4fcd6a
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7115.ml.reference
@@ -0,0 +1,22 @@
+
+# type t = A : t
+#         Characters 40-41:
+    let _f ~x (* x unused argument *) = function
+            ^
+Warning 27: unused variable x.
+module X1 : sig  end
+#           Characters 36-37:
+    let x = 42 (* unused value *)
+        ^
+Warning 32: unused value x.
+module X2 : sig  end
+#               Characters 54-55:
+    module O = struct let x = 42 (* unused *) end
+                          ^
+Warning 32: unused value x.
+Characters 80-86:
+    open O (* unused open *)
+    ^^^^^^
+Warning 33: unused open O.
+module X3 : sig  end
+# 
diff --git a/testsuite/tests/typing-warnings/pr7297.ml b/testsuite/tests/typing-warnings/pr7297.ml
new file mode 100644
index 00000000..f55c0a32
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7297.ml
@@ -0,0 +1,4 @@
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
+let () = raise Exit; () ;; (* warn *)
diff --git a/testsuite/tests/typing-warnings/pr7297.ml.reference b/testsuite/tests/typing-warnings/pr7297.ml.reference
new file mode 100644
index 00000000..bc8580fc
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7297.ml.reference
@@ -0,0 +1,8 @@
+
+#   - : unit = ()
+#   Characters 10-20:
+  let () = raise Exit; () ;; (* warn *)
+           ^^^^^^^^^^
+Warning 21: this statement never returns (or has an unsound type.)
+Exception: Pervasives.Exit.
+# 
diff --git a/testsuite/tests/typing-warnings/records.ml b/testsuite/tests/typing-warnings/records.ml
new file mode 100644
index 00000000..768bb965
--- /dev/null
+++ b/testsuite/tests/typing-warnings/records.ml
@@ -0,0 +1,180 @@
+(* Use type information *)
+module M1 = struct
+  type t = {x: int; y: int}
+  type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+  open M1
+  let f1 (r:t) = r.x (* ok *)
+  let f2 r = ignore (r:t); r.x (* non principal *)
+
+  let f3 (r: t) =
+    match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+  open M1
+  let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+  open M1
+  let f r =
+    ignore (r: t);
+    match r with
+       {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+  type t = {x:int}
+  type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+let f ({x}:M.t) = x;; (* warning *)
+
+module M = struct
+  type t = {x: int; y: int}
+end;;
+module N = struct
+  type u = {x: bool; y: bool}
+end;;
+module OK = struct
+  open M
+  open N
+  let f (r:M.t) = r.x
+end;;
+
+module M = struct
+  type t = {x:int}
+  module N = struct type s = t = {x:int} end
+  type u = {x:bool}
+end;;
+module OK = struct
+  open M.N
+  let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+  type u = {x:bool;y:int;z:char}
+  type t = {x:int;y:bool}
+end;;
+module OK = struct
+  open M
+  let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+  open M
+  let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+  type u = {x:int;y:bool}
+  type t = {x:bool;y:int;z:char}
+  let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+  type foo = {x:int; y:int}
+  type bar = {x:int}
+  let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+  type foo = { x: int; y: int }
+  type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+  open M
+  let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+  include M
+  type other = { a: int; b: int }
+end;;
+module F6 = struct
+  open M
+  let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+  open M
+  let r = {x=1; y=2}
+  let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+  type t = {x:int; yyy:int}
+  let a : t = {x=1;yyz=2}
+end;;
+
+(* PR#6004 *)
+
+type t = A
+type s = A
+
+class f (_ : t) = object end;;
+class g = f A;; (* ok *)
+
+class f (_ : 'a) (_ : 'a) = object end;;
+class g = f (A : t) A;; (* warn with -principal *)
+
+
+(* PR#5980 *)
+
+module Shadow1 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+  let y : t = {x = 0}
+end;;
+module Shadow2 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open shadows label 'x' *)
+  let y = {x = ""}
+end;;
+
+(* PR#6235 *)
+
+module P6235 = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f (u : u) = match u with `Key {loc} -> loc
+end;;
+
+(* Remove interaction between branches *)
+
+module P6235' = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f = function
+    | (_ : u) when false -> ""
+    |`Key {loc} -> loc
+end;;
diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference
new file mode 100644
index 00000000..989fce35
--- /dev/null
+++ b/testsuite/tests/typing-warnings/records.ml.principal.reference
@@ -0,0 +1,321 @@
+
+#         module M1 :
+  sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+#                 Characters 49-50:
+    let f1 (r:t) = r.x (* ok *)
+                     ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 89-90:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                               ^
+Warning 18: this type-based field disambiguation is not principal.
+Characters 89-90:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                               ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 151-152:
+      match r with {x; y} -> y + y (* ok *)
+                       ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 27: unused variable x.
+module OK :
+  sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+#         Characters 55-61:
+    let f r = match r with {x; y} -> y + y
+                           ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+    let f r = match r with {x; y} -> y + y
+                                     ^
+Error: This expression has type bool but an expression was expected of type
+         int
+#               Characters 85-91:
+         {x; y} -> y + y
+         ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 85-91:
+         {x; y} -> y + y
+         ^^^^^^
+Error: This pattern matches values of type M1.u
+       but a pattern was expected which matches values of type M1.t
+#           module M : sig type t = { x : int; } type u = { x : bool; } end
+# Characters 18-21:
+  let f (r:M.t) = r.M.x;; (* ok *)
+                    ^^^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = 
+# Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not 
+be selected if the type becomes unknown.
+Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = 
+# Characters 8-9:
+  let f ({x}:M.t) = x;; (* warning *)
+          ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 7-10:
+  let f ({x}:M.t) = x;; (* warning *)
+         ^^^
+Warning 40: this record of type M.t contains fields that are 
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = 
+#       module M : sig type t = { x : int; y : int; } end
+#     module N : sig type u = { x : bool; y : bool; } end
+#         Characters 57-58:
+    let f (r:M.t) = r.x
+                      ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 30-36:
+    open N
+    ^^^^^^
+Warning 33: unused open N.
+module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type t = { x : int; }
+    module N : sig type s = t = { x : int; } end
+    type u = { x : bool; }
+  end
+#       module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type u = { x : bool; y : int; z : char; }
+    type t = { x : int; y : bool; }
+  end
+#       Characters 37-38:
+    let f {x;z} = x,z
+           ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 36-41:
+    let f {x;z} = x,z
+          ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+module OK : sig val f : M.u -> bool * char end
+#       Characters 38-52:
+    let r = {x=true;z='z'}
+            ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+#           Characters 90-91:
+    let r = {x=3; y=true}
+             ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 95-96:
+    let r = {x=3; y=true}
+                  ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module OK :
+  sig
+    type u = { x : int; y : bool; }
+    type t = { x : bool; y : int; z : char; }
+    val r : u
+  end
+#               Characters 111-112:
+    let b : bar = {x=3; y=4}
+                        ^
+Error: This record expression is expected to have type bar
+       The field y does not belong to type bar
+#   module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+  let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+                     ^^^
+Error: The record field N.y belongs to the type N.bar
+       but is mixed here with fields of type M.foo
+#     module MN :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = N.bar = { x : int; y : int; }
+  end
+module NM :
+  sig
+    type bar = N.bar = { x : int; y : int; }
+    type foo = M.foo = { x : int; y : int; }
+  end
+# Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+                     ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+       but is mixed here with fields of type MN.bar = N.bar
+#             module M :
+  sig
+    type foo = { x : int; y : int; }
+    type bar = { x : int; y : int; z : int; }
+  end
+#       Characters 65-66:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                       ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 72-73:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                              ^
+Error: This record expression is expected to have type M.foo
+       The field z does not belong to type M.foo
+#       module M :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = M.bar = { x : int; y : int; z : int; }
+    type other = { a : int; b : int; }
+  end
+#       Characters 66-67:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                        ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 73-74:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                               ^
+Error: This record expression is expected to have type M.foo
+       The field a does not belong to type M.foo
+#         Characters 39-40:
+    let r = {x=1; y=2}
+             ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 44-45:
+    let r = {x=1; y=2}
+                  ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 67-68:
+    let r: other = {x=1; y=2}
+                    ^
+Error: This record expression is expected to have type M.other
+       The field x does not belong to type M.other
+#     module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+  let f (r : B.t) = r.A.x;; (* fail *)
+                      ^^^
+Error: The field A.x belongs to the record type A.t
+       but a field was expected belonging to the record type B.t
+#             Characters 88-91:
+    let a : t = {x=1;yyz=2}
+                     ^^^
+Error: This record expression is expected to have type t
+       The field yyz does not belong to type t
+Hint: Did you mean yyy?
+#             type t = A
+type s = A
+class f : t -> object  end
+# Characters 12-13:
+  class g = f A;; (* ok *)
+              ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+#   class f : 'a -> 'a -> object  end
+# Characters 13-14:
+  class g = f (A : t) A;; (* warn with -principal *)
+               ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 20-21:
+  class g = f (A : t) A;; (* warn with -principal *)
+                      ^
+Warning 18: this type-based constructor disambiguation is not principal.
+Characters 20-21:
+  class g = f (A : t) A;; (* warn with -principal *)
+                      ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+#                       Characters 199-200:
+    let y : t = {x = 0}
+                 ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 114-120:
+    open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+    ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : t
+  end
+#               Characters 97-103:
+    open M  (* this open shadows label 'x' *)
+    ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+    let y = {x = ""}
+            ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : M.s
+  end
+#                 Characters 167-170:
+    let f (u : u) = match u with `Key {loc} -> loc
+                                       ^^^
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module P6235 :
+  sig
+    type t = { loc : string; }
+    type v = { loc : string; x : int; }
+    type u = [ `Key of t ]
+    val f : u -> string
+  end
+#                     Characters 219-224:
+      |`Key {loc} -> loc
+            ^^^^^
+Warning 41: these field labels belong to several types: v t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 219-224:
+      |`Key {loc} -> loc
+            ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+x
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 214-224:
+      |`Key {loc} -> loc
+       ^^^^^^^^^^
+Error: This pattern matches values of type [? `Key of v ]
+       but a pattern was expected which matches values of type u
+       Types for tag `Key are incompatible
+# 
diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference
new file mode 100644
index 00000000..349721e6
--- /dev/null
+++ b/testsuite/tests/typing-warnings/records.ml.reference
@@ -0,0 +1,313 @@
+
+#         module M1 :
+  sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+#                 Characters 49-50:
+    let f1 (r:t) = r.x (* ok *)
+                     ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 89-90:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                               ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 151-152:
+      match r with {x; y} -> y + y (* ok *)
+                       ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 27: unused variable x.
+module OK :
+  sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+#         Characters 55-61:
+    let f r = match r with {x; y} -> y + y
+                           ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+    let f r = match r with {x; y} -> y + y
+                                     ^
+Error: This expression has type bool but an expression was expected of type
+         int
+#               Characters 86-87:
+         {x; y} -> y + y
+          ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 89-90:
+         {x; y} -> y + y
+             ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 86-87:
+         {x; y} -> y + y
+          ^
+Warning 27: unused variable x.
+module F2 : sig val f : M1.t -> int end
+#           module M : sig type t = { x : int; } type u = { x : bool; } end
+# Characters 18-21:
+  let f (r:M.t) = r.M.x;; (* ok *)
+                    ^^^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = 
+# Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not 
+be selected if the type becomes unknown.
+Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+val f : M.t -> int = 
+# Characters 8-9:
+  let f ({x}:M.t) = x;; (* warning *)
+          ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 7-10:
+  let f ({x}:M.t) = x;; (* warning *)
+         ^^^
+Warning 40: this record of type M.t contains fields that are 
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = 
+#       module M : sig type t = { x : int; y : int; } end
+#     module N : sig type u = { x : bool; y : bool; } end
+#         Characters 57-58:
+    let f (r:M.t) = r.x
+                      ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 30-36:
+    open N
+    ^^^^^^
+Warning 33: unused open N.
+module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type t = { x : int; }
+    module N : sig type s = t = { x : int; } end
+    type u = { x : bool; }
+  end
+#       module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type u = { x : bool; y : int; z : char; }
+    type t = { x : int; y : bool; }
+  end
+#       Characters 37-38:
+    let f {x;z} = x,z
+           ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 36-41:
+    let f {x;z} = x,z
+          ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+module OK : sig val f : M.u -> bool * char end
+#       Characters 38-52:
+    let r = {x=true;z='z'}
+            ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+#           Characters 90-91:
+    let r = {x=3; y=true}
+             ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 95-96:
+    let r = {x=3; y=true}
+                  ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module OK :
+  sig
+    type u = { x : int; y : bool; }
+    type t = { x : bool; y : int; z : char; }
+    val r : u
+  end
+#               Characters 111-112:
+    let b : bar = {x=3; y=4}
+                        ^
+Error: This record expression is expected to have type bar
+       The field y does not belong to type bar
+#   module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+  let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+                     ^^^
+Error: The record field N.y belongs to the type N.bar
+       but is mixed here with fields of type M.foo
+#     module MN :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = N.bar = { x : int; y : int; }
+  end
+module NM :
+  sig
+    type bar = N.bar = { x : int; y : int; }
+    type foo = M.foo = { x : int; y : int; }
+  end
+# Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+                     ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+       but is mixed here with fields of type MN.bar = N.bar
+#             module M :
+  sig
+    type foo = { x : int; y : int; }
+    type bar = { x : int; y : int; z : int; }
+  end
+#       Characters 65-66:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                       ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 72-73:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                              ^
+Error: This record expression is expected to have type M.foo
+       The field z does not belong to type M.foo
+#       module M :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = M.bar = { x : int; y : int; z : int; }
+    type other = { a : int; b : int; }
+  end
+#       Characters 66-67:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                        ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 73-74:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                               ^
+Error: This record expression is expected to have type M.foo
+       The field a does not belong to type M.foo
+#         Characters 39-40:
+    let r = {x=1; y=2}
+             ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 44-45:
+    let r = {x=1; y=2}
+                  ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 67-68:
+    let r: other = {x=1; y=2}
+                    ^
+Error: This record expression is expected to have type M.other
+       The field x does not belong to type M.other
+#     module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+  let f (r : B.t) = r.A.x;; (* fail *)
+                      ^^^
+Error: The field A.x belongs to the record type A.t
+       but a field was expected belonging to the record type B.t
+#             Characters 88-91:
+    let a : t = {x=1;yyz=2}
+                     ^^^
+Error: This record expression is expected to have type t
+       The field yyz does not belong to type t
+Hint: Did you mean yyy?
+#             type t = A
+type s = A
+class f : t -> object  end
+# Characters 12-13:
+  class g = f A;; (* ok *)
+              ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+#   class f : 'a -> 'a -> object  end
+# Characters 13-14:
+  class g = f (A : t) A;; (* warn with -principal *)
+               ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 20-21:
+  class g = f (A : t) A;; (* warn with -principal *)
+                      ^
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+class g : f
+#                       Characters 199-200:
+    let y : t = {x = 0}
+                 ^
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Characters 114-120:
+    open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+    ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : t
+  end
+#               Characters 97-103:
+    open M  (* this open shadows label 'x' *)
+    ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+    let y = {x = ""}
+            ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : M.s
+  end
+#                 Characters 167-170:
+    let f (u : u) = match u with `Key {loc} -> loc
+                                       ^^^
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module P6235 :
+  sig
+    type t = { loc : string; }
+    type v = { loc : string; x : int; }
+    type u = [ `Key of t ]
+    val f : u -> string
+  end
+#                     Characters 220-223:
+      |`Key {loc} -> loc
+             ^^^
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+module P6235' :
+  sig
+    type t = { loc : string; }
+    type v = { loc : string; x : int; }
+    type u = [ `Key of t ]
+    val f : u -> string
+  end
+# 
diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml
new file mode 100644
index 00000000..791d9fd8
--- /dev/null
+++ b/testsuite/tests/typing-warnings/unused_types.ml
@@ -0,0 +1,76 @@
+module Unused : sig
+end = struct
+  type unused = int
+end
+;;
+
+module Unused_nonrec : sig
+end = struct
+  type nonrec used = int
+  type nonrec unused = used
+end
+;;
+
+module Unused_rec : sig
+end = struct
+  type unused = A of unused
+end
+;;
+
+module Unused_exception : sig
+end = struct
+  exception Nobody_uses_me
+end
+;;
+
+module Unused_extension_constructor : sig
+  type t = ..
+end = struct
+  type t = ..
+  type t += Nobody_uses_me
+end
+;;
+
+module Unused_exception_outside_patterns : sig
+  val falsity : exn -> bool
+end = struct
+  exception Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_extension_outside_patterns : sig
+  type t = ..
+  val falsity : t -> bool
+end = struct
+  type t = ..
+  type t += Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_private_exception : sig
+  type exn += private Private_exn
+end = struct
+  exception Private_exn
+end
+;;
+
+module Unused_private_extension : sig
+  type t = ..
+  type t += private Private_ext
+end = struct
+  type t = ..
+  type t += Private_ext
+end
+;;
+
+module Pr7438 : sig
+end = struct
+  module type S = sig type t = private [> `Foo] end
+  module type X = sig type t = private [> `Foo | `Bar] include S with type t := t end
+end;;
diff --git a/testsuite/tests/typing-warnings/unused_types.ml.reference b/testsuite/tests/typing-warnings/unused_types.ml.reference
new file mode 100644
index 00000000..1d318192
--- /dev/null
+++ b/testsuite/tests/typing-warnings/unused_types.ml.reference
@@ -0,0 +1,58 @@
+
+#         Characters 35-52:
+    type unused = int
+    ^^^^^^^^^^^^^^^^^
+Warning 34: unused type unused.
+module Unused : sig  end
+#             Characters 68-93:
+    type nonrec unused = used
+    ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type unused.
+module Unused_nonrec : sig  end
+#           Characters 40-65:
+    type unused = A of unused
+    ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type unused.
+Characters 40-65:
+    type unused = A of unused
+    ^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 37: unused constructor A.
+module Unused_rec : sig  end
+#           Characters 46-70:
+    exception Nobody_uses_me
+    ^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: unused exception Nobody_uses_me
+module Unused_exception : sig  end
+#               Characters 96-110:
+    type t += Nobody_uses_me
+              ^^^^^^^^^^^^^^
+Warning 38: unused extension constructor Nobody_uses_me
+module Unused_extension_constructor : sig type t = .. end
+#                   Characters 91-121:
+    exception Nobody_constructs_me
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_exception_outside_patterns : sig val falsity : exn -> bool end
+#                       Characters 127-147:
+    type t += Nobody_constructs_me
+              ^^^^^^^^^^^^^^^^^^^^
+Warning 38: extension constructor Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_extension_outside_patterns :
+  sig type t = .. val falsity : t -> bool end
+#             Characters 88-109:
+    exception Private_exn
+    ^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Private_exn is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_exception : sig type exn += private Private_exn end
+#                 Characters 124-135:
+    type t += Private_ext
+              ^^^^^^^^^^^
+Warning 38: extension constructor Private_ext is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_extension :
+  sig type t = .. type t += private Private_ext end
+#           module Pr7438 : sig  end
+# 
diff --git a/testsuite/tests/unboxed-primitive-args/Makefile b/testsuite/tests/unboxed-primitive-args/Makefile
new file mode 100644
index 00000000..7a5c5ef1
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/Makefile
@@ -0,0 +1,40 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2015 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=unix bigarray
+MODULES=common
+MAIN_MODULE=main
+C_FILES=test_common stubs
+C_INCLUDES=-I $(OTOPDIR)/otherlibs/bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray \
+	      -I $(OTOPDIR)/otherlibs/$(UNIXLIB)
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+NATIVECODE_ONLY=true
+NATIVECCCOMPOPTS+=-I $(OTOPDIR)/otherlibs/bigarray
+GENERATED_SOURCES+=main.ml stubs.c
+
+main.ml: gen_test.ml
+	@$(OCAML) gen_test.ml ml > $@
+
+stubs.c: gen_test.ml
+	@$(OCAML) gen_test.ml c > $@
+
+common.cmx: common.cmi
+
+compile: stubs.c
diff --git a/testsuite/tests/unboxed-primitive-args/README b/testsuite/tests/unboxed-primitive-args/README
new file mode 100644
index 00000000..4bd7601e
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/README
@@ -0,0 +1,26 @@
+This directory contains tests to check that OCaml values are correctly
+passed between OCaml and C when a primitive takes some or all of its
+arguments unboxed/untagged and/or return its result unboxed/untagged.
+
+To test one primitive we do:
+- write all its argument and expected result in buffer A
+- call the C external using arguments read from buffer A
+- the C function write all the arguments it receive into buffer B
+- the C function read the result from buffer A and returns it
+- on the OCaml side we write the received result into buffer B
+- the test is successful if A and B have the same contents
+
+Between each call, we call a function with 128 value arguments set to
+0 and a function with 32 unboxed float arguments set to 0., just to
+clean-up the registers and stacks in case garbage would make a test
+succeed. We don't pass more floats as it doesn't build on arm32.
+
+We construct the set of primitives to test as follow:
+- all combination of unboxed int32/int64/float arguments for functions
+  taking up to 6 arguments (with more than 6 ocamlopt takes a really
+  long time to compile the test files)
+- a bunch of manual tests for the rest and specific patterns.
+  The list is [Gen_test.manual_tests]
+
+We test the set of primitives a thousand times, with different random
+data each time.
diff --git a/testsuite/tests/unboxed-primitive-args/common.ml b/testsuite/tests/unboxed-primitive-args/common.ml
new file mode 100644
index 00000000..d1f13d34
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/common.ml
@@ -0,0 +1,286 @@
+open StdLabels
+
+open Bigarray
+
+type 'a typ =
+  | Int       : int       typ
+  | Int32     : int32     typ
+  | Int64     : int64     typ
+  | Nativeint : nativeint typ
+  | Float     : float     typ
+
+type 'a proto =
+  | Ret : 'a typ -> 'a proto
+  | Abs : 'a typ * 'b proto -> ('a -> 'b) proto
+
+let ( ** ) x y = Abs (x, y)
+
+(* This form is easier to process programmatically. We don't expose it as
+   ocamlopt takes a really really long time to compile a constant list
+   of these. *)
+type simplified_test = Test : string * 'a * 'a proto -> simplified_test
+
+type test =
+  | T1 : string * ('a -> 'b) * 'a typ * 'b typ -> test
+  | T2 : string * ('a -> 'b -> 'c) * 'a typ * 'b typ * 'c typ -> test
+  | T3 : string * ('a -> 'b -> 'c -> 'd) *
+         'a typ * 'b typ * 'c typ * 'd typ -> test
+  | T4 : string * ('a -> 'b -> 'c -> 'd -> 'e) *
+         'a typ * 'b typ * 'c typ * 'd typ * 'e typ -> test
+  | T5 : string * ('a -> 'b -> 'c -> 'd -> 'e -> 'f) *
+         'a typ * 'b typ * 'c typ * 'd typ * 'e typ * 'f typ -> test
+  | T6 : string * ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) *
+         'a typ * 'b typ * 'c typ * 'd typ * 'e typ * 'f typ * 'g typ -> test
+  | T : string * 'a * 'a proto -> test
+
+let expand_test = function
+  | T1 (s, fn, a, b) -> Test (s, fn, a ** Ret b)
+  | T2 (s, fn, a, b, c) -> Test (s, fn, a ** b ** Ret c)
+  | T3 (s, fn, a, b, c, d) -> Test (s, fn, a ** b ** c ** Ret d)
+  | T4 (s, fn, a, b, c, d, e) -> Test (s, fn, a ** b ** c ** d ** Ret e)
+  | T5 (s, fn, a, b, c, d, e, f) ->
+    Test (s, fn, a ** b ** c ** d ** e ** Ret f)
+  | T6 (s, fn, a, b, c, d, e, f, g) ->
+    Test (s, fn, a ** b ** c ** d ** e ** f ** Ret g)
+  | T (s, fn, p) -> Test (s, fn, p)
+
+let string_of : type a. a typ -> a -> string = function
+  | Int       -> string_of_int
+  | Int32     -> Printf.sprintf "%ldl"
+  | Int64     -> Printf.sprintf "%LdL"
+  | Nativeint -> Printf.sprintf "%ndn"
+  | Float     ->
+      fun f -> Printf.sprintf "float_of_bits 0x%LxL" (Int64.bits_of_float f)
+
+let rec arity : type a. a proto -> int = function
+  | Ret _ -> 0
+  | Abs (_, p) -> 1 + arity p
+
+module Buffer = struct
+  type t = (char, int8_unsigned_elt, c_layout) Array1.t
+
+  let arg_size = 8
+
+  let create ~arity : t =
+    Array1.create char c_layout ((arity + 1) * arg_size)
+
+  let clear (t : t) = Array1.fill t '\000'
+
+  let length : t -> int = Array1.dim
+
+  external init_c_side : ocaml_buffer:t -> c_buffer:t -> unit
+    = "test_set_buffers"
+
+  external get_int32 : t -> int -> int32 = "%caml_bigstring_get32"
+  external get_int64 : t -> int -> int64 = "%caml_bigstring_get64"
+  external set_int32 : t -> int -> int32 -> unit = "%caml_bigstring_set32"
+  external set_int64 : t -> int -> int64 -> unit = "%caml_bigstring_set64"
+
+  let get_int32 t ~arg = get_int32 t (arg * arg_size)
+  let get_int64 t ~arg = get_int64 t (arg * arg_size)
+  let set_int32 t ~arg x = set_int32 t (arg * arg_size) x
+  let set_int64 t ~arg x = set_int64 t (arg * arg_size) x
+
+  let get_nativeint, set_nativeint =
+    match Sys.word_size with
+    | 32 -> ((fun t ~arg -> get_int32 t ~arg |> Nativeint.of_int32),
+             (fun t ~arg x -> set_int32 t ~arg (Nativeint.to_int32 x)))
+    | 64 -> ((fun t ~arg -> get_int64 t ~arg |> Int64.to_nativeint),
+             (fun t ~arg x -> set_int64 t ~arg (Int64.of_nativeint x)))
+    | n  -> Printf.ksprintf failwith "unknown word size (%d)" n
+
+  let get_int =
+    if Sys.word_size = 32 then
+      fun buf ~arg -> get_int32 buf ~arg |> Int32.to_int
+    else
+      fun buf ~arg -> get_int64 buf ~arg |> Int64.to_int
+
+  let set_int =
+    if Sys.word_size = 32 then
+      fun buf ~arg x -> set_int32 buf ~arg (Int32.of_int x)
+    else
+      fun buf ~arg x -> set_int64 buf ~arg (Int64.of_int x)
+
+  let get_float buf ~arg = get_int64 buf ~arg |> Int64.float_of_bits
+  let set_float buf ~arg x = set_int64 buf ~arg (Int64.bits_of_float x)
+
+  let get : type a. a typ -> t -> arg:int -> a = function
+    | Int       -> get_int
+    | Int32     -> get_int32
+    | Int64     -> get_int64
+    | Nativeint -> get_nativeint
+    | Float     -> get_float
+
+  let set : type a. a typ -> t -> arg:int -> a -> unit = function
+    | Int       -> set_int
+    | Int32     -> set_int32
+    | Int64     -> set_int64
+    | Nativeint -> set_nativeint
+    | Float     -> set_float
+
+  (* This is almost a memcpy except that we use get/set which should
+     ensure that the values in [dst] don't overflow. *)
+  let copy_args ~src ~dst proto =
+    let rec loop : type a. a proto -> int -> unit = fun proto arg ->
+      match proto with
+      | Ret typ ->
+        set typ dst ~arg (get typ src ~arg)
+      | Abs (typ, rest) ->
+        set typ dst ~arg (get typ src ~arg);
+        loop rest (arg + 1)
+    in
+    loop proto 0
+end
+
+let exec proto f ~ocaml_buffer ~c_buffer =
+  let rec loop : type a. a proto -> a -> int -> unit = fun proto f arg ->
+    match proto with
+    | Ret typ ->
+      Buffer.set typ c_buffer ~arg f
+    | Abs (typ, rest) ->
+      let x = Buffer.get typ ocaml_buffer ~arg in
+      loop rest (f x) (arg + 1)
+  in
+  loop proto f 0
+
+let strings_of_test_instance name proto buffer =
+  let rec loop : type a. a proto -> int -> string list -> string list * string =
+    fun proto arg acc ->
+      match proto with
+      | Ret typ ->
+        (List.rev acc, string_of typ (Buffer.get typ buffer ~arg))
+      | Abs (typ, rest) ->
+        let s = string_of typ (Buffer.get typ buffer ~arg) in
+        loop rest (arg + 1) (s :: acc)
+  in
+  loop proto 0 []
+
+let typ_size : type a. a typ -> int = function
+  | Int       -> Sys.word_size / 8
+  | Int32     -> 4
+  | Int64     -> 8
+  | Nativeint -> Sys.word_size / 8
+  | Float     -> 8
+
+let rec sizes : type a. a proto -> int list = function
+  | Ret typ         -> [typ_size typ]
+  | Abs (typ, rest) -> typ_size typ :: sizes rest
+
+let print_hex ~sizes ~arity buffer =
+  let printf = Printf.printf in
+  printf "(";
+  for i = 0 to arity do
+    if i = arity then
+      printf ") -> "
+    else if i > 0 then
+      printf ", ";
+    for ofs = i * Buffer.arg_size to i * Buffer.arg_size + sizes.(i) - 1 do
+      printf "%02x" (Char.code buffer.{ofs});
+    done;
+  done
+
+let printed_mismatches = ref 0
+
+let print_mismatch name proto ~ocaml_buffer ~c_buffer =
+  let printf = Printf.printf in
+  printf "Mismatch for %s\n" name;
+  let o_args, o_res = strings_of_test_instance name proto ocaml_buffer in
+  let c_args, c_res = strings_of_test_instance name proto     c_buffer in
+  let o_args, c_args =
+    (* Align arguments *)
+    List.map2 o_args c_args ~f:(fun a b ->
+      let len_a = String.length a and len_b = String.length b in
+      let len = max len_a len_b in
+      (Printf.sprintf "%*s" len a,
+       Printf.sprintf "%*s" len b))
+    |> List.split
+  in
+  printf "ocaml side : (%s) -> %s\n" (String.concat ~sep:", " o_args) o_res;
+  printf "c side     : (%s) -> %s\n" (String.concat ~sep:", " c_args) c_res;
+  let sizes = sizes proto |> Array.of_list in
+  let arity = arity proto in
+  printf "ocaml side : "; print_hex ~sizes ~arity ocaml_buffer; printf "\n";
+  printf "c side     : "; print_hex ~sizes ~arity     c_buffer; printf "\n";
+  incr printed_mismatches;
+  if !printed_mismatches >= 1000 then begin
+    printf "Output truncated at 1000 failures.";
+    exit 0
+  end
+
+external cleanup_normal
+  :  int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int -> int -> int -> int -> int -> int -> int -> int
+  -> int = "" "test_cleanup_normal" [@@noalloc]
+
+external cleanup_float
+  :  float -> float -> float -> float -> float -> float -> float -> float
+  -> float -> float -> float -> float -> float -> float -> float -> float
+  -> float -> float -> float -> float -> float -> float -> float -> float
+  -> float -> float -> float -> float -> float -> float -> float -> float
+  -> float = "" "test_cleanup_float" [@@noalloc] [@@unboxed]
+
+let cleanup_args_and_stack () =
+  let _ : int =
+    cleanup_normal
+      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+  in
+  let _ : float =
+    cleanup_float
+       0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0.
+       0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0.
+  in
+  ()
+
+let run_test ~random_data ~ocaml_buffer ~c_buffer (Test (name, f, proto)) =
+  Buffer.clear ocaml_buffer;
+  Buffer.clear c_buffer;
+  Buffer.copy_args ~src:random_data ~dst:ocaml_buffer proto;
+  cleanup_args_and_stack ();
+  exec proto f ~ocaml_buffer ~c_buffer;
+  let success = ocaml_buffer = c_buffer in
+  if not success then print_mismatch name proto ~ocaml_buffer ~c_buffer;
+  success
+
+let run_tests tests =
+  let tests = List.map tests ~f:expand_test in
+  let max_args =
+    List.fold_left tests ~init:0 ~f:(fun acc (Test (_, _, p)) ->
+      max acc (arity p))
+  in
+
+  let ocaml_buffer = Buffer.create ~arity:max_args
+  and     c_buffer = Buffer.create ~arity:max_args in
+  Buffer.init_c_side ~ocaml_buffer ~c_buffer;
+
+  let random_data = Buffer.create ~arity:max_args in
+  let new_random_data () =
+    for i = 0 to Buffer.length random_data - 1 do
+      random_data.{i} <- char_of_int (Random.int 256)
+    done
+  in
+
+  let failure = ref false in
+  for i = 1 to 1000 do
+    new_random_data ();
+    List.iter tests ~f:(fun test ->
+      if not (run_test ~random_data ~ocaml_buffer ~c_buffer test) then
+        failure := true)
+  done;
+  exit (if !failure then 1 else 0)
diff --git a/testsuite/tests/unboxed-primitive-args/common.mli b/testsuite/tests/unboxed-primitive-args/common.mli
new file mode 100644
index 00000000..b7459bb1
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/common.mli
@@ -0,0 +1,29 @@
+(** Type of arguments/result *)
+type 'a typ =
+  | Int       : int       typ
+  | Int32     : int32     typ
+  | Int64     : int64     typ
+  | Nativeint : nativeint typ
+  | Float     : float     typ
+
+type 'a proto =
+  | Ret : 'a typ -> 'a proto
+  | Abs : 'a typ * 'b proto -> ('a -> 'b) proto
+
+(** Same as [Abs]. We choose this operator for its associativity. *)
+val ( ** ) : 'a typ -> 'b proto -> ('a -> 'b) proto
+
+type test =
+  | T1 : string * ('a -> 'b) * 'a typ * 'b typ -> test
+  | T2 : string * ('a -> 'b -> 'c) * 'a typ * 'b typ * 'c typ -> test
+  | T3 : string * ('a -> 'b -> 'c -> 'd) *
+         'a typ * 'b typ * 'c typ * 'd typ -> test
+  | T4 : string * ('a -> 'b -> 'c -> 'd -> 'e) *
+         'a typ * 'b typ * 'c typ * 'd typ * 'e typ -> test
+  | T5 : string * ('a -> 'b -> 'c -> 'd -> 'e -> 'f) *
+         'a typ * 'b typ * 'c typ * 'd typ * 'e typ * 'f typ -> test
+  | T6 : string * ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) *
+         'a typ * 'b typ * 'c typ * 'd typ * 'e typ * 'f typ * 'g typ -> test
+  | T : string * 'a * 'a proto -> test
+
+val run_tests : test list -> unit
diff --git a/testsuite/tests/unboxed-primitive-args/gen_test.ml b/testsuite/tests/unboxed-primitive-args/gen_test.ml
new file mode 100644
index 00000000..8f4b2dfe
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/gen_test.ml
@@ -0,0 +1,228 @@
+(* This programs generate stubs with various prototype combinations *)
+
+open StdLabels
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+(* Generate primitives with up to this number of arguments *)
+let test_all_combination_up_to_n_args = 6
+
+(* Generate primitives using all combination of these argument
+   representations. No need to test all combination of other
+   representations: regarding the calling convention
+   [Same_as_ocaml_repr], [Untagged_int] and
+   [Unboxed_integer Pnativeint] are all the same, and are the
+   same as [Unboxed_integer Pint].
+
+   We have specific tests for the other representations and for the
+   result representation in [manual_tests].
+*)
+let test_all_args_combination_of =
+  [ Unboxed_float
+  ; Unboxed_integer Pint32
+  ; Unboxed_integer Pint64
+  ]
+
+let code_of_repr = function
+  | Same_as_ocaml_repr         -> "v" (* for "value" *)
+  | Unboxed_float              -> "f"
+  | Unboxed_integer Pint32     -> "l"
+  | Unboxed_integer Pint64     -> "L"
+  | Unboxed_integer Pnativeint -> "n"
+  | Untagged_int               -> "i"
+
+let repr_of_code = function
+  | 'v' -> Same_as_ocaml_repr
+  | 'f' -> Unboxed_float
+  | 'l' -> Unboxed_integer Pint32
+  | 'L' -> Unboxed_integer Pint64
+  | 'n' -> Unboxed_integer Pnativeint
+  | 'i' -> Untagged_int
+  | _   -> assert false
+
+let manual_tests =
+  [ "v_v"
+  ; "f_f"
+  ; "l_l"
+  ; "L_L"
+  ; "n_n"
+  ; "i_i"
+  ; "f_fffff"
+  ; "f_ffffff"
+  ; "f_fffffff"
+  ; "f_fffffffffffffffff"
+  ; "v_iiiiiiiiiiiiiiiii"
+  ; "v_lllllllllllllllll"
+  ; "v_LLLLLLLLLLLLLLLLL"
+  ; "v_iLiLiLiLiLiLiLiLi"
+  ; "v_LiLiLiLiLiLiLiLiL"
+  ; "v_flflflflflflflflflflflflflflflflflfl"
+  ; "v_fLfLfLfLfLfLfLfLfLfLfLfLfLfLfLfLfLfL"
+  ]
+
+let ocaml_type_of_repr = function
+  (* Doesn't really matters what we choose for this case *)
+  | Same_as_ocaml_repr         -> "int"
+  | Unboxed_float              -> "(float [@unboxed])"
+  | Unboxed_integer Pint32     -> "(int32 [@unboxed])"
+  | Unboxed_integer Pint64     -> "(int64 [@unboxed])"
+  | Unboxed_integer Pnativeint -> "(nativeint [@unboxed])"
+  | Untagged_int               -> "(int [@untagged])"
+
+let ocaml_type_gadt_of_repr = function
+  (* Doesn't really matters what we choose for this case *)
+  | Same_as_ocaml_repr         -> "Int"
+  | Unboxed_float              -> "Float"
+  | Unboxed_integer Pint32     -> "Int32"
+  | Unboxed_integer Pint64     -> "Int64"
+  | Unboxed_integer Pnativeint -> "Nativeint"
+  | Untagged_int               -> "Int"
+
+let c_type_of_repr = function
+  | Same_as_ocaml_repr         -> "value"
+  | Unboxed_float              -> "double"
+  | Unboxed_integer Pint32     -> "int32_t"
+  | Unboxed_integer Pint64     -> "int64_t"
+  | Unboxed_integer Pnativeint -> "intnat"
+  | Untagged_int               -> "intnat"
+
+type proto =
+  { params : native_repr list
+  ; return : native_repr
+  }
+
+let rec explode s =
+  let rec loop i acc =
+    if i < 0 then
+      acc
+    else
+      loop (i - 1) (s.[i] :: acc)
+  in
+  loop (String.length s - 1) []
+
+let proto_of_str s =
+  Scanf.sscanf s "%c_%s" (fun return params ->
+    { params = List.map (explode params) ~f:repr_of_code
+    ; return = repr_of_code return
+    })
+
+let function_name_of_proto proto =
+  Printf.sprintf "test_%s_%s" (code_of_repr proto.return)
+    (String.concat ~sep:"" (List.map proto.params ~f:code_of_repr))
+
+let ocaml_type_gadt_of_proto proto =
+  Printf.sprintf "%s ** Ret %s"
+    (String.concat ~sep:" ** "
+       (List.map proto.params ~f:ocaml_type_gadt_of_repr))
+    (ocaml_type_gadt_of_repr proto.return)
+
+let ocaml_type_of_proto proto =
+  String.concat ~sep:" -> "
+    (List.map proto.params ~f:ocaml_type_of_repr
+     @ [ocaml_type_of_repr proto.return])
+
+let c_args_of_proto proto =
+  String.concat ~sep:", "
+    (List.mapi proto.params ~f:(fun i p ->
+       Printf.sprintf "%s x%d" (c_type_of_repr p) i))
+
+let manual_protos = List.map manual_tests ~f:proto_of_str
+
+let iter_protos ~f =
+  let iter_for_arity arity =
+    let rec loop params to_gen =
+      List.iter test_all_args_combination_of ~f:(fun repr ->
+        let params = repr :: params in
+        let to_gen = to_gen - 1 in
+        if to_gen = 0 then
+          f { params = List.rev params
+            ; return = Same_as_ocaml_repr
+            }
+        else
+          loop params to_gen)
+    in
+    loop [] arity
+  in
+  let rec iter_arities arity =
+    if arity <= test_all_combination_up_to_n_args then begin
+      iter_for_arity arity;
+      iter_arities (arity + 1)
+    end
+  in
+  List.iter manual_protos ~f;
+  iter_arities 1
+
+let pr fmt = Printf.ksprintf (fun s -> print_string s; print_char '\n') fmt
+
+let generate_ml () =
+  pr "open Common";
+  pr "";
+  iter_protos ~f:(fun proto ->
+    let name = function_name_of_proto proto in
+    pr "external %s : %s = \"\" %S [@@noalloc]"
+      name (ocaml_type_of_proto proto) name;
+  );
+  pr "";
+  pr "let tests = []";
+  iter_protos ~f:(fun proto ->
+    let name = function_name_of_proto proto in
+    let arity = List.length proto.params in
+    if arity <= 6 then
+      pr "let tests = T%d (%S, %s, %s, %s) :: tests"
+        arity name name
+        (List.map proto.params ~f:ocaml_type_gadt_of_repr
+         |> String.concat ~sep:", ")
+        (ocaml_type_gadt_of_repr proto.return)
+    else
+      pr "let tests = T (%S, %s, %s) :: tests"
+        name name (ocaml_type_gadt_of_proto proto));
+  pr "";
+  pr "let () = run_tests (List.rev tests)"
+
+let generate_stubs () =
+  pr "#include ";
+  pr "#include ";
+  pr "#include \"test_common.h\"";
+  iter_protos ~f:(fun proto ->
+      let name = function_name_of_proto proto in
+      pr "";
+      pr "%s %s(%s)"
+        (c_type_of_repr proto.return)
+        name
+        (c_args_of_proto proto);
+      pr "{";
+      List.iteri proto.params ~f:(fun i p ->
+        pr "  %(%d%d%);"
+          (match p with
+           | Same_as_ocaml_repr         -> "set_intnat(%d, Long_val(x%d))"
+           | Unboxed_float              -> "set_double(%d, x%d)"
+           | Unboxed_integer Pint32     -> "set_int32(%d, x%d)"
+           | Unboxed_integer Pint64     -> "set_int64(%d, x%d)"
+           | Unboxed_integer Pnativeint -> "set_intnat(%d, x%d)"
+           | Untagged_int               -> "set_intnat(%d, x%d)")
+          i i);
+      pr "  return %(%d%);"
+        (match proto.return with
+         | Same_as_ocaml_repr         -> "Val_long(get_intnat(%d))"
+         | Unboxed_float              -> "get_double(%d)"
+         | Unboxed_integer Pint32     -> "get_int32(%d)"
+         | Unboxed_integer Pint64     -> "get_int64(%d)"
+         | Unboxed_integer Pnativeint -> "get_intnat(%d)"
+         | Untagged_int               -> "get_intnat(%d)")
+        (List.length proto.params);
+      pr "}"
+  )
+
+let () =
+  match Sys.argv with
+  | [|_; "ml"|] -> generate_ml ()
+  | [|_; "c" |] -> generate_stubs ()
+  | _ ->
+    prerr_endline "Usage: ocaml gen_test.ml {ml|c}";
+    exit 2
diff --git a/testsuite/tests/unboxed-primitive-args/main.reference b/testsuite/tests/unboxed-primitive-args/main.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/unboxed-primitive-args/test_common.c b/testsuite/tests/unboxed-primitive-args/test_common.c
new file mode 100644
index 00000000..8fe2765f
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/test_common.c
@@ -0,0 +1,37 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                  Jeremie Dimino, Jane Street Europe                    */
+/*                                                                        */
+/*   Copyright 2015 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include 
+#include 
+
+char *ocaml_buffer;
+char *c_buffer;
+
+value test_set_buffers(value v_ocaml_buffer, value v_c_buffer)
+{
+  ocaml_buffer = Caml_ba_data_val(v_ocaml_buffer);
+  c_buffer = Caml_ba_data_val(v_c_buffer);
+  return Val_unit;
+}
+
+value test_cleanup_normal(void)
+{
+  return Val_int(0);
+}
+
+double test_cleanup_float(void)
+{
+  return 0.;
+}
diff --git a/testsuite/tests/unboxed-primitive-args/test_common.h b/testsuite/tests/unboxed-primitive-args/test_common.h
new file mode 100644
index 00000000..2a1019ca
--- /dev/null
+++ b/testsuite/tests/unboxed-primitive-args/test_common.h
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                OCaml                                   */
+/*                                                                        */
+/*                  Jeremie Dimino, Jane Street Europe                    */
+/*                                                                        */
+/*   Copyright 2015 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef __TEST_COMMON_H
+#define __TEST_COMMON_H
+
+/* Where the OCaml side stores the arguments and result for a test
+   case. The C function will read the result it is supposed to return
+   from this buffer.
+
+   Argument [n] is stored at [n * 8] and the result is stored at
+   [arity * 8].
+*/
+extern char *ocaml_buffer;
+
+/* Where the C function stores the arguments it receive for a test
+   case. The OCaml side will store the result from the C function in
+   this buffer. At the of a test case, both these buffers must be
+   equal. */
+extern char *c_buffer;
+
+#define get_intnat(n) *(intnat*)(ocaml_buffer+((n)*8))
+#define get_int32(n) *(int32_t*)(ocaml_buffer+((n)*8))
+#define get_int64(n) *(int64_t*)(ocaml_buffer+((n)*8))
+#define get_double(n) *(double*)(ocaml_buffer+((n)*8))
+
+#define set_intnat(n, x) *(intnat*)(c_buffer+((n)*8)) = (x)
+#define set_int32(n, x) *(int32_t*)(c_buffer+((n)*8)) = (x)
+#define set_int64(n, x) *(int64_t*)(c_buffer+((n)*8)) = (x)
+#define set_double(n, x) *(double*)(c_buffer+((n)*8)) = (x)
+
+#endif /* __TEST_COMMON_H */
diff --git a/testsuite/tests/unwind/Makefile b/testsuite/tests/unwind/Makefile
new file mode 100644
index 00000000..614808b0
--- /dev/null
+++ b/testsuite/tests/unwind/Makefile
@@ -0,0 +1,41 @@
+BASEDIR=../..
+
+# The -keep_dwarf_unwind option of ld was introduced in ld version 224.1.
+# (The last released version where it is not supported is version 136.)
+default:
+	@printf " ... testing 'unwind_test':"
+	@if [ ! $(SYSTEM) = macosx ]; then \
+	  echo " => skipped (not on Mac OSX)"; \
+	elif $(BYTECODE_ONLY); then \
+	  echo " => skipped (bytecode only)"; \
+	else \
+	  LDFULL="`ld -v 2>&1`"; \
+	  LD="`echo $$LDFULL | grep -o \"ld64-[0-9]*\"`"; \
+	  LDVER="`echo $$LD | sed \"s/ld64-//\"`"; \
+	  if [[ -z "$$LD" ]]; then \
+	    echo " => skipped (unknown linker: pattern ld64-[0-9]* not found" \
+	    echo "    in 'ld -v' output)"; \
+	  elif [[ $$LDVER -lt 224 ]]; then \
+	   echo " => skipped (ld version is $$LDVER, only 224 or above " \
+	   echo "    are supported)"; \
+	  else \
+	    $(MAKE) native_macosx_tests; \
+	  fi; \
+	fi
+
+native_macosx_tests:
+	@$(MAKE) clean ; $(MAKE) unwind_test && \
+	./unwind_test >/dev/null 2>&1 && echo " => passed" || echo " => failed"
+
+unwind_test:
+	@$(OCAMLOPT) -c -opaque mylib.mli
+	@$(OCAMLOPT) -c driver.ml
+	@$(OCAMLOPT) -c mylib.ml
+	@$(OCAMLOPT) -ccopt "-I$(CTOPDIR)/byterun" -c stack_walker.c
+	@$(OCAMLOPT) -cclib -Wl,-keep_dwarf_unwind -o unwind_test mylib.cmx \
+	             driver.cmx stack_walker.o
+
+clean:
+	@rm -f *.cm* *.o unwind_test
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/unwind/README b/testsuite/tests/unwind/README
new file mode 100644
index 00000000..ff467e25
--- /dev/null
+++ b/testsuite/tests/unwind/README
@@ -0,0 +1,9 @@
+This test case is motivated by the fact that on OS X, external functions may
+cause stack walks into the OCaml-generated stack frames. In particular, the
+Objective-C runtime does so in function objc_addExceptionHandler. This function
+is invoked from Cocoa. Errors in the stack unwinding info generated by OCaml
+can cause random crashes. This test case checks that, for at least one OCaml
+program, correct unwind info is generated such that the platform's unwinder
+(called libunwind) correctly walks the stack up to the main function. OCaml
+used to generate incorrect stack unwinding information for this program. See
+PR#7118, PR#7120.
diff --git a/testsuite/tests/unwind/driver.ml b/testsuite/tests/unwind/driver.ml
new file mode 100644
index 00000000..cd289b6b
--- /dev/null
+++ b/testsuite/tests/unwind/driver.ml
@@ -0,0 +1,3 @@
+let () =
+  Mylib.foo1 Mylib.bar 1 2 3 4 5 6 7 8 9 10;
+  Mylib.foo2 Mylib.baz 1 2 3 4 5 6 7 8 9 10
diff --git a/testsuite/tests/unwind/mylib.ml b/testsuite/tests/unwind/mylib.ml
new file mode 100644
index 00000000..318b537a
--- /dev/null
+++ b/testsuite/tests/unwind/mylib.ml
@@ -0,0 +1,20 @@
+let foo1 f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
+  f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
+
+let foo2 f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
+  f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
+
+external func_with_10_params:
+  int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> unit
+  = "ml_func_with_10_params_bytecode" "ml_func_with_10_params_native"
+
+let bar x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
+  func_with_10_params x1 x2 x3 x4 x5 x6 x7 x8 x9 x10;
+  func_with_10_params x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
+
+external perform_stack_walk: unit -> unit = "ml_perform_stack_walk"
+
+let baz x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
+  func_with_10_params x1 x2 x3 x4 x5 x6 x7 x8 x9 x10;
+  func_with_10_params x1 x2 x3 x4 x5 x6 x7 x8 x9 x10;
+  perform_stack_walk ()
diff --git a/testsuite/tests/unwind/mylib.mli b/testsuite/tests/unwind/mylib.mli
new file mode 100644
index 00000000..c1655228
--- /dev/null
+++ b/testsuite/tests/unwind/mylib.mli
@@ -0,0 +1,10 @@
+val foo1: ('a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> unit)
+          -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> unit
+
+val foo2: ('a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> unit)
+          -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> unit
+
+val bar:
+  int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> unit
+val baz:
+  int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> unit
diff --git a/testsuite/tests/unwind/stack_walker.c b/testsuite/tests/unwind/stack_walker.c
new file mode 100644
index 00000000..09afcadd
--- /dev/null
+++ b/testsuite/tests/unwind/stack_walker.c
@@ -0,0 +1,59 @@
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+
+value ml_func_with_10_params_native(value x1, value x2, value x3, value x4,
+                                    value x5, value x6, value x7, value x8,
+                                    value x9, value x10) {
+    return Val_unit;
+}
+
+void error() {
+    exit(1);
+}
+
+void perform_stack_walk() {
+    unw_context_t ctxt;
+    unw_getcontext(&ctxt);
+
+    unw_cursor_t cursor;
+    {
+        int result = unw_init_local(&cursor, &ctxt);
+        if (result != 0) error();
+    }
+
+    int reached_main = 0;
+
+    for (;;) {
+        {
+            char procname[256];
+            unw_word_t ip_offset; // IP - start_of_proc
+            int result = unw_get_proc_name(&cursor, procname, sizeof(procname),
+                                           &ip_offset);
+            if (result != 0) error();
+            if (strcmp(procname, "main") == 0)
+                reached_main = 1;
+            //printf("%s + %lld\n", procname, (long long int)ip_offset);
+        }
+
+        {
+            int result = unw_step(&cursor);
+            if (result == 0) break;
+            if (result < 0) error();
+        }
+    }
+
+    //printf("Reached end of stack.\n");
+    if (!reached_main) {
+        //printf("Failure: Did not reach main.\n");
+        error();
+    }
+}
+
+value ml_perform_stack_walk() {
+    perform_stack_walk();
+    return Val_unit;
+}
diff --git a/testsuite/tests/utils/Makefile b/testsuite/tests/utils/Makefile
new file mode 100644
index 00000000..f2d74860
--- /dev/null
+++ b/testsuite/tests/utils/Makefile
@@ -0,0 +1,25 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                         Alain Frisch, LexiFi                           *
+#*                                                                        *
+#*   Copyright 2012 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=testing misc identifiable numbers strongly_connected_components
+INCLUDES= -I $(OTOPDIR)/utils
+ADD_COMPFLAGS=$(INCLUDES)
+CMO_FILES+="misc.cmo"
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+BYTECODE_ONLY=true
diff --git a/testsuite/tests/utils/edit_distance.ml b/testsuite/tests/utils/edit_distance.ml
new file mode 100644
index 00000000..294b02ce
--- /dev/null
+++ b/testsuite/tests/utils/edit_distance.ml
@@ -0,0 +1,48 @@
+let edit_distance = Misc.edit_distance
+
+let show_cutoff n =
+  if n = max_int then "max_int" else Printf.sprintf "%d" n
+;;
+
+let test =
+  let counter = ref 0 in
+  fun a b cutoff expected ->
+    let show_result = function
+      | None -> "None"
+      | Some d -> "Some " ^ string_of_int d in
+    incr counter;
+    Printf.printf "[%02d] (edit_distance %S %S %s), expected %s\n"
+      !counter a b (show_cutoff cutoff) (show_result expected);
+    let result = edit_distance a b cutoff in
+    if result = expected
+    then print_endline "OK"
+    else Printf.printf "FAIL: got %s\n%!" (show_result result)
+
+let () =
+  test "a" "a" 1 (Some 0);
+  test "a" "a" 0 (Some 0);
+  test "a" "b" 1 (Some 1);
+  test "a" "b" 0 None;
+  test "add" "adad" 3 (Some 1);
+  test "delete" "delte" 3 (Some 1);
+  test "subst" "sabst" 3 (Some 1);
+  test "swap" "sawp" 3 (Some 1);
+  test "abbb" "bbba" 3 (Some 2);
+  test "abbb" "bbba" 1 None;
+
+  (* check for bugs where a small common suffix, or common prefix, is
+     enough to make the distance goes down *)
+  test "xyzwabc" "mnpqrabc" 10 (Some 5);
+  test "abcxyzw" "abcmnpqr" 10 (Some 5);
+
+  (* check that using "max_int" as cutoff works *)
+  test "a" "a" max_int (Some 0);
+  test "a" "b" max_int (Some 1);
+  test "abc" "ade" max_int (Some 2);
+
+  (* check empty strings*)
+  test "" "" 3 (Some 0);
+  test "" "abc" 3 (Some 3);
+  test "abcd" "" 3 None;
+
+  ()
diff --git a/testsuite/tests/utils/edit_distance.reference b/testsuite/tests/utils/edit_distance.reference
new file mode 100644
index 00000000..c2816dab
--- /dev/null
+++ b/testsuite/tests/utils/edit_distance.reference
@@ -0,0 +1,38 @@
+[01] (edit_distance "a" "a" 1), expected Some 0
+OK
+[02] (edit_distance "a" "a" 0), expected Some 0
+OK
+[03] (edit_distance "a" "b" 1), expected Some 1
+OK
+[04] (edit_distance "a" "b" 0), expected None
+OK
+[05] (edit_distance "add" "adad" 3), expected Some 1
+OK
+[06] (edit_distance "delete" "delte" 3), expected Some 1
+OK
+[07] (edit_distance "subst" "sabst" 3), expected Some 1
+OK
+[08] (edit_distance "swap" "sawp" 3), expected Some 1
+OK
+[09] (edit_distance "abbb" "bbba" 3), expected Some 2
+OK
+[10] (edit_distance "abbb" "bbba" 1), expected None
+OK
+[11] (edit_distance "xyzwabc" "mnpqrabc" 10), expected Some 5
+OK
+[12] (edit_distance "abcxyzw" "abcmnpqr" 10), expected Some 5
+OK
+[13] (edit_distance "a" "a" max_int), expected Some 0
+OK
+[14] (edit_distance "a" "b" max_int), expected Some 1
+OK
+[15] (edit_distance "abc" "ade" max_int), expected Some 2
+OK
+[16] (edit_distance "" "" 3), expected Some 0
+OK
+[17] (edit_distance "" "abc" 3), expected Some 3
+OK
+[18] (edit_distance "abcd" "" 3), expected None
+OK
+
+All tests succeeded.
diff --git a/testsuite/tests/utils/test_strongly_connected_components.ml b/testsuite/tests/utils/test_strongly_connected_components.ml
new file mode 100644
index 00000000..8f3392e4
--- /dev/null
+++ b/testsuite/tests/utils/test_strongly_connected_components.ml
@@ -0,0 +1,29 @@
+module Int = Numbers.Int
+module SCC = Strongly_connected_components.Make (Int)
+
+let graph_1 =
+  [1, [2;3;4];
+   2, [3;5];
+   3, [5];
+   4, [1];
+   5, [5]]
+
+let empty = []
+
+let print_scc scc =
+  Printf.printf "begin\n";
+  Array.iter (function
+      | SCC.No_loop e -> Printf.printf "%i\n" e
+      | SCC.Has_loop l ->
+          Printf.printf "[%s]\n"
+            (String.concat "; " (List.map string_of_int l))) scc;
+  Printf.printf "end\n"
+
+let scc graph =
+  SCC.connected_components_sorted_from_roots_to_leaf
+    (Int.Map.map Int.Set.of_list (Int.Map.of_list graph))
+
+let run () =
+  print_scc (scc empty);
+  print_scc (scc graph_1);
+  Format.printf "done@."
diff --git a/testsuite/tests/utils/test_strongly_connected_components.reference b/testsuite/tests/utils/test_strongly_connected_components.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/utils/test_strongly_connected_components.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/warnings/Makefile b/testsuite/tests/warnings/Makefile
new file mode 100644
index 00000000..7bf93ad2
--- /dev/null
+++ b/testsuite/tests/warnings/Makefile
@@ -0,0 +1,61 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+FLAGS=-w A
+
+run-all:
+	@$(OCAMLC) $(FLAGS) -c deprecated_module.mli
+	@$(OCAMLC) $(FLAGS) -c module_without_cmx.mli
+	@$(OCAMLC) $(FLAGS) -c w60.mli
+	@for file in *.ml; do \
+	  printf " ... testing '$$file':"; \
+	  F="`basename $$file .ml`"; \
+	  $(OCAMLC) $(FLAGS) -c $$file 2>$$F.result; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@for file in *.opt.ml; do \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  if $(BYTECODE_ONLY); then echo " => skipped"; else \
+	    F="`basename $$file .ml`"; \
+	    $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.opt_result; \
+	    $(DIFF) $$F.opt_reference $$F.opt_result >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  fi \
+	done;
+	@for file in *.opt_backend.ml; do \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  if $(BYTECODE_ONLY); then echo " => skipped"; else \
+	    F="`basename $$file .ml`"; \
+	    $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.$(BACKEND).opt_result; \
+	    $(DIFF) $$F.$(BACKEND).opt_reference $$F.$(BACKEND).opt_result \
+	            >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  fi \
+	done;
+
+promote: defaultpromote
+
+clean: defaultclean
+	@rm -f *.result *.opt_result
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+ifeq "$(FLAMBDA)" "true"
+BACKEND=flambda
+else
+BACKEND=clambda
+endif
diff --git a/testsuite/tests/warnings/deprecated_module.ml b/testsuite/tests/warnings/deprecated_module.ml
new file mode 100755
index 00000000..092e9d09
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module.ml
@@ -0,0 +1,9 @@
+module M = struct
+  type t = int
+
+  let x = 10
+end
+[@@ocaml.deprecated]
+
+let _ = M.x
+include M
diff --git a/testsuite/tests/warnings/deprecated_module.mli b/testsuite/tests/warnings/deprecated_module.mli
new file mode 100755
index 00000000..dbcb19b6
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module.mli
@@ -0,0 +1,13 @@
+[@@@ocaml.deprecated {|
+  As you could guess, Deprecated_module is deprecated.
+  Please use something else!
+|} ]
+
+module M: sig
+  val x: int
+    [@@ocaml.deprecated]
+
+  type t
+    [@@ocaml.deprecated]
+end
+[@@ocaml.deprecated]
diff --git a/testsuite/tests/warnings/deprecated_module.reference b/testsuite/tests/warnings/deprecated_module.reference
new file mode 100644
index 00000000..9dcde99a
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module.reference
@@ -0,0 +1,4 @@
+File "deprecated_module.ml", line 8, characters 8-11:
+Warning 3: deprecated: module M
+File "deprecated_module.ml", line 9, characters 8-9:
+Warning 3: deprecated: module M
diff --git a/testsuite/tests/warnings/deprecated_module_use.ml b/testsuite/tests/warnings/deprecated_module_use.ml
new file mode 100755
index 00000000..f04e6f52
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module_use.ml
@@ -0,0 +1,6 @@
+open Deprecated_module
+
+type s = M.t
+
+open M
+let _ = x
diff --git a/testsuite/tests/warnings/deprecated_module_use.reference b/testsuite/tests/warnings/deprecated_module_use.reference
new file mode 100644
index 00000000..a7615cd6
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module_use.reference
@@ -0,0 +1,14 @@
+File "deprecated_module_use.ml", line 1, characters 5-22:
+Warning 3: deprecated: module Deprecated_module
+
+  As you could guess, Deprecated_module is deprecated.
+  Please use something else!
+
+File "deprecated_module_use.ml", line 3, characters 9-12:
+Warning 3: deprecated: module Deprecated_module.M
+File "deprecated_module_use.ml", line 3, characters 9-12:
+Warning 3: deprecated: Deprecated_module.M.t
+File "deprecated_module_use.ml", line 5, characters 5-6:
+Warning 3: deprecated: module Deprecated_module.M
+File "deprecated_module_use.ml", line 6, characters 8-9:
+Warning 3: deprecated: Deprecated_module.M.x
diff --git a/testsuite/tests/warnings/module_without_cmx.mli b/testsuite/tests/warnings/module_without_cmx.mli
new file mode 100644
index 00000000..36ca7dba
--- /dev/null
+++ b/testsuite/tests/warnings/module_without_cmx.mli
@@ -0,0 +1,2 @@
+
+val id : 'a -> 'a
diff --git a/testsuite/tests/warnings/w01.ml b/testsuite/tests/warnings/w01.ml
new file mode 100644
index 00000000..08e2f291
--- /dev/null
+++ b/testsuite/tests/warnings/w01.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/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference
new file mode 100644
index 00000000..5221256f
--- /dev/null
+++ b/testsuite/tests/warnings/w01.reference
@@ -0,0 +1,15 @@
+File "w01.ml", line 4, characters 12-14:
+Warning 2: this is not the end of a comment.
+File "w01.ml", line 10, characters 0-3:
+Warning 5: this function application is partial,
+maybe some arguments are missing.
+File "w01.ml", line 20, characters 4-5:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+0
+File "w01.ml", line 25, characters 0-1:
+Warning 10: this expression should have type unit.
+File "w01.ml", line 9, characters 8-9:
+Warning 27: unused variable y.
+File "w01.ml", line 32, characters 2-3:
+Warning 11: this match case is unused.
diff --git a/testsuite/tests/warnings/w04.ml b/testsuite/tests/warnings/w04.ml
new file mode 100644
index 00000000..e46b6bf7
--- /dev/null
+++ b/testsuite/tests/warnings/w04.ml
@@ -0,0 +1,12 @@
+[@@@ocaml.warning "+4"]
+
+type expr = E of int [@@unboxed]
+
+      
+let f x = match x with (E e) -> e
+
+type t = A | B
+
+let g x = match x with
+| A -> 0
+| _ -> 1
diff --git a/testsuite/tests/warnings/w04.reference b/testsuite/tests/warnings/w04.reference
new file mode 100644
index 00000000..df194ead
--- /dev/null
+++ b/testsuite/tests/warnings/w04.reference
@@ -0,0 +1,3 @@
+File "w04.ml", line 10, characters 10-40:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t.
diff --git a/testsuite/tests/warnings/w06.ml b/testsuite/tests/warnings/w06.ml
new file mode 100644
index 00000000..6e8a1bca
--- /dev/null
+++ b/testsuite/tests/warnings/w06.ml
@@ -0,0 +1,6 @@
+let foo ~bar = ignore bar (* one label *)
+
+let bar ~foo ~baz = ignore (foo, baz) (* two labels *)
+
+let () = foo 2
+let () = bar 4 2
diff --git a/testsuite/tests/warnings/w06.reference b/testsuite/tests/warnings/w06.reference
new file mode 100644
index 00000000..b3019f4d
--- /dev/null
+++ b/testsuite/tests/warnings/w06.reference
@@ -0,0 +1,4 @@
+File "w06.ml", line 5, characters 9-12:
+Warning 6: label bar was omitted in the application of this function.
+File "w06.ml", line 6, characters 9-12:
+Warning 6: labels foo, baz were omitted in the application of this function.
diff --git a/testsuite/tests/warnings/w33.ml b/testsuite/tests/warnings/w33.ml
new file mode 100644
index 00000000..628fae3f
--- /dev/null
+++ b/testsuite/tests/warnings/w33.ml
@@ -0,0 +1,16 @@
+(** Test unused opens, in particular in presence of
+     pattern open *)
+
+module M = struct end
+module N = struct type t = A | B end
+module R = struct type r = {x: int} end
+
+let f M.(x) = x (* useless open *)
+let g N.(A|B) = () (* used open *)
+let h R.{x} = R.{x}
+
+open N (* used open *)
+let i (A|B) = B
+
+open! M (* open! also deactivates unused open warning *)
+open M (* useless open *)
diff --git a/testsuite/tests/warnings/w33.reference b/testsuite/tests/warnings/w33.reference
new file mode 100644
index 00000000..9915965c
--- /dev/null
+++ b/testsuite/tests/warnings/w33.reference
@@ -0,0 +1,4 @@
+File "w33.ml", line 8, characters 6-11:
+Warning 33: unused open M.
+File "w33.ml", line 16, characters 0-6:
+Warning 33: unused open M.
diff --git a/testsuite/tests/warnings/w45.ml b/testsuite/tests/warnings/w45.ml
new file mode 100755
index 00000000..efe89ffe
--- /dev/null
+++ b/testsuite/tests/warnings/w45.ml
@@ -0,0 +1,16 @@
+module T1 = struct
+  type t = A
+  type s = X
+end
+
+module T2 = struct
+  type t = T1.t = A
+  type s = X
+end
+
+module T3 = struct
+  open T1 (* unused open *)
+  open T2 (* shadow X, which is later used; but not A, see #6762 *)
+
+  let _ = (A, X) (* X belongs to several types *)
+end
diff --git a/testsuite/tests/warnings/w45.reference b/testsuite/tests/warnings/w45.reference
new file mode 100644
index 00000000..8c77ab05
--- /dev/null
+++ b/testsuite/tests/warnings/w45.reference
@@ -0,0 +1,7 @@
+File "w45.ml", line 13, characters 2-9:
+Warning 45: this open statement shadows the constructor X (which is later used)
+File "w45.ml", line 15, characters 14-15:
+Warning 41: X belongs to several types: T2.s T1.s
+The first one was selected. Please disambiguate if this is wrong.
+File "w45.ml", line 12, characters 2-9:
+Warning 33: unused open T1.
diff --git a/testsuite/tests/warnings/w47_inline.ml b/testsuite/tests/warnings/w47_inline.ml
new file mode 100644
index 00000000..26794510
--- /dev/null
+++ b/testsuite/tests/warnings/w47_inline.ml
@@ -0,0 +1,15 @@
+
+let a = (fun x -> x) [@inline] (* accepted *)
+let b = (fun x -> x) [@inline never] (* accepted *)
+let c = (fun x -> x) [@inline always] (* accepted *)
+let d = (fun x -> x) [@inline malformed attribute] (* rejected *)
+let e = (fun x -> x) [@inline malformed_attribute] (* rejected *)
+let f = (fun x -> x) [@inline : malformed_attribute] (* rejected *)
+let g = (fun x -> x) [@inline ? malformed_attribute] (* rejected *)
+
+let h x = (a [@inlined]) x (* accepted *)
+let i x = (a [@inlined never]) x (* accepted *)
+let j x = (a [@inlined always]) x (* accepted *)
+let k x = (a [@inlined malformed]) x (* rejected *)
+
+let l x = x [@@inline] (* accepted *)
diff --git a/testsuite/tests/warnings/w47_inline.reference b/testsuite/tests/warnings/w47_inline.reference
new file mode 100644
index 00000000..edc2d48b
--- /dev/null
+++ b/testsuite/tests/warnings/w47_inline.reference
@@ -0,0 +1,15 @@
+File "w47_inline.ml", line 13, characters 15-22:
+Warning 47: illegal payload for attribute 'inlined'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 8, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 7, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 6, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 5, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
diff --git a/testsuite/tests/warnings/w50.ml b/testsuite/tests/warnings/w50.ml
new file mode 100755
index 00000000..14877bbe
--- /dev/null
+++ b/testsuite/tests/warnings/w50.ml
@@ -0,0 +1,7 @@
+module A : sig end = struct
+  module L = List
+
+  module X1 = struct end
+
+  module Y1 = X1
+end
diff --git a/testsuite/tests/warnings/w50.reference b/testsuite/tests/warnings/w50.reference
new file mode 100644
index 00000000..db08d0aa
--- /dev/null
+++ b/testsuite/tests/warnings/w50.reference
@@ -0,0 +1,4 @@
+File "w50.ml", line 2, characters 2-17:
+Warning 60: unused module L.
+File "w50.ml", line 6, characters 2-16:
+Warning 60: unused module Y1.
diff --git a/testsuite/tests/warnings/w51.ml b/testsuite/tests/warnings/w51.ml
new file mode 100644
index 00000000..25e08706
--- /dev/null
+++ b/testsuite/tests/warnings/w51.ml
@@ -0,0 +1,5 @@
+
+let rec fact = function
+  | 1 -> 1
+  | n -> n * (fact [@tailcall]) (n-1)
+;;
diff --git a/testsuite/tests/warnings/w51.reference b/testsuite/tests/warnings/w51.reference
new file mode 100644
index 00000000..5e3cf374
--- /dev/null
+++ b/testsuite/tests/warnings/w51.reference
@@ -0,0 +1,2 @@
+File "w51.ml", line 4, characters 13-37:
+Warning 51: expected tailcall
diff --git a/testsuite/tests/warnings/w51_bis.ml b/testsuite/tests/warnings/w51_bis.ml
new file mode 100644
index 00000000..810fcdd4
--- /dev/null
+++ b/testsuite/tests/warnings/w51_bis.ml
@@ -0,0 +1,5 @@
+let rec foldl op acc = function
+    [] -> acc
+    | x :: xs ->
+        try (foldl [@tailcall]) op (op x acc) xs
+        with Not_found -> assert false
diff --git a/testsuite/tests/warnings/w51_bis.reference b/testsuite/tests/warnings/w51_bis.reference
new file mode 100644
index 00000000..ee5cab5a
--- /dev/null
+++ b/testsuite/tests/warnings/w51_bis.reference
@@ -0,0 +1,2 @@
+File "w51_bis.ml", line 4, characters 12-48:
+Warning 51: expected tailcall
diff --git a/testsuite/tests/warnings/w53.ml b/testsuite/tests/warnings/w53.ml
new file mode 100644
index 00000000..9d77c3cc
--- /dev/null
+++ b/testsuite/tests/warnings/w53.ml
@@ -0,0 +1,31 @@
+
+let h x = x [@inline] (* rejected *)
+let h x = x [@ocaml.inline] (* rejected *)
+
+let i x = x [@inlined] (* rejected *)
+let j x = x [@ocaml.inlined] (* rejected *)
+let k x = (h [@inlined]) x (* accepted *)
+let k' x = (h [@ocaml.inlined]) x (* accepted *)
+let l x = h x [@inlined] (* rejected *)
+
+let m x = x [@tailcall] (* rejected *)
+let n x = x [@ocaml.tailcall] (* rejected *)
+let o x = (h [@tailcall]) x (* accepted *)
+let p x = (h [@ocaml.tailcall]) x (* accepted *)
+let q x = h x [@tailcall] (* rejected *)
+
+module type E = sig end
+
+module A(E:E) = struct end [@@inline] (* accepted *)
+module A'(E:E) = struct end [@@ocaml.inline] (* accepted *)
+module B = ((functor (E:E) -> struct end) [@inline]) (* accepted *)
+module B' = ((functor (E:E) -> struct end) [@ocaml.inline]) (* accepted *)
+module C = struct end [@@inline] (* rejected *)
+module C' = struct end [@@ocaml.inline] (* rejected *)
+module D = struct end [@@inlined] (* rejected *)
+module D' = struct end [@@ocaml.inlined] (* rejected *)
+
+module F = (A [@inlined])(struct end) (* accepted *)
+module F' = (A [@ocaml.inlined])(struct end) (* accepted *)
+module G = (A [@inline])(struct end) (* rejected *)
+module G' = (A [@ocaml.inline])(struct end) (* rejected *)
diff --git a/testsuite/tests/warnings/w53.reference b/testsuite/tests/warnings/w53.reference
new file mode 100644
index 00000000..0f70e504
--- /dev/null
+++ b/testsuite/tests/warnings/w53.reference
@@ -0,0 +1,26 @@
+File "w53.ml", line 2, characters 4-5:
+Warning 32: unused value h.
+File "w53.ml", line 31, characters 17-29:
+Warning 53: the "ocaml.inline" attribute cannot appear in this context
+File "w53.ml", line 30, characters 16-22:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 24, characters 0-39:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 23, characters 0-32:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 15, characters 16-24:
+Warning 53: the "tailcall" attribute cannot appear in this context
+File "w53.ml", line 12, characters 14-28:
+Warning 53: the "ocaml.tailcall" attribute cannot appear in this context
+File "w53.ml", line 11, characters 14-22:
+Warning 53: the "tailcall" attribute cannot appear in this context
+File "w53.ml", line 9, characters 16-23:
+Warning 53: the "inlined" attribute cannot appear in this context
+File "w53.ml", line 6, characters 14-27:
+Warning 53: the "ocaml.inlined" attribute cannot appear in this context
+File "w53.ml", line 5, characters 14-21:
+Warning 53: the "inlined" attribute cannot appear in this context
+File "w53.ml", line 3, characters 14-26:
+Warning 53: the "ocaml.inline" attribute cannot appear in this context
+File "w53.ml", line 2, characters 14-20:
+Warning 53: the "inline" attribute cannot appear in this context
diff --git a/testsuite/tests/warnings/w54.ml b/testsuite/tests/warnings/w54.ml
new file mode 100644
index 00000000..6ea66238
--- /dev/null
+++ b/testsuite/tests/warnings/w54.ml
@@ -0,0 +1,9 @@
+
+let f = (fun x -> x) [@inline] [@inline never]
+let g = (fun x -> x) [@inline] [@something_else] [@ocaml.inline]
+
+let h x = (g [@inlined] [@ocaml.inlined never]) x
+
+let v = ((fun x -> x) [@inline] [@inlined]) 1 (* accepted *)
+
+let i = ((fun x -> x) [@inline]) [@@inline]
diff --git a/testsuite/tests/warnings/w54.reference b/testsuite/tests/warnings/w54.reference
new file mode 100644
index 00000000..39c5d75d
--- /dev/null
+++ b/testsuite/tests/warnings/w54.reference
@@ -0,0 +1,8 @@
+File "w54.ml", line 9, characters 0-43:
+Warning 54: the "inline" attribute is used more than once on this expression
+File "w54.ml", line 5, characters 26-39:
+Warning 54: the "ocaml.inlined" attribute is used more than once on this expression
+File "w54.ml", line 3, characters 51-63:
+Warning 54: the "ocaml.inline" attribute is used more than once on this expression
+File "w54.ml", line 2, characters 33-39:
+Warning 54: the "inline" attribute is used more than once on this expression
diff --git a/testsuite/tests/warnings/w55.opt_backend.clambda.opt_reference b/testsuite/tests/warnings/w55.opt_backend.clambda.opt_reference
new file mode 100644
index 00000000..933e5d2a
--- /dev/null
+++ b/testsuite/tests/warnings/w55.opt_backend.clambda.opt_reference
@@ -0,0 +1,12 @@
+File "w55.opt_backend.ml", line 4, characters 10-26:
+Warning 55: Cannot inline: Function information unavailable
+File "w55.opt_backend.ml", line 8, characters 10-27:
+Warning 55: Cannot inline: Unknown function
+File "w55.opt_backend.ml", line 12, characters 10-26:
+Warning 55: Cannot inline: Partial application
+File "w55.opt_backend.ml", line 18, characters 12-30:
+Warning 55: Cannot inline: Over-application
+File "w55.opt_backend.ml", line 18, characters 12-30:
+Warning 55: Cannot inline: Function information unavailable
+File "w55.opt_backend.ml", line 21, characters 10-26:
+Warning 55: Cannot inline: Function information unavailable
diff --git a/testsuite/tests/warnings/w55.opt_backend.flambda.opt_reference b/testsuite/tests/warnings/w55.opt_backend.flambda.opt_reference
new file mode 100644
index 00000000..b1b51205
--- /dev/null
+++ b/testsuite/tests/warnings/w55.opt_backend.flambda.opt_reference
@@ -0,0 +1,6 @@
+File "w55.opt_backend.ml", line 12, characters 10-26:
+Warning 55: Cannot inline: [@inlined] attributes may not be used on partial applications
+File "w55.opt_backend.ml", line 8, characters 10-27:
+Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
+File "w55.opt_backend.ml", line 18, characters 12-30:
+Warning 55: Cannot inline: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
diff --git a/testsuite/tests/warnings/w55.opt_backend.ml b/testsuite/tests/warnings/w55.opt_backend.ml
new file mode 100644
index 00000000..aef2af50
--- /dev/null
+++ b/testsuite/tests/warnings/w55.opt_backend.ml
@@ -0,0 +1,21 @@
+
+let f = (fun x -> x + 1) [@inline never]
+
+let g x = (f [@inlined]) x
+
+let h = ref f
+
+let i x = (!h [@inlined]) x
+
+let j x y = x + y
+
+let h x = (j [@inlined]) x
+
+let a x =
+  let b = x + 1 in
+  fun y -> y + b
+
+let b x y = (a [@inlined]) x y
+
+let c x = x + 1 [@@inline never]
+let d x = (c [@inlined]) x
diff --git a/testsuite/tests/warnings/w55.opt_backend.reference b/testsuite/tests/warnings/w55.opt_backend.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/warnings/w58.opt.ml b/testsuite/tests/warnings/w58.opt.ml
new file mode 100644
index 00000000..8f7bfd27
--- /dev/null
+++ b/testsuite/tests/warnings/w58.opt.ml
@@ -0,0 +1,2 @@
+
+let () = print_endline (Module_without_cmx.id "Hello World")
diff --git a/testsuite/tests/warnings/w58.opt.opt_reference b/testsuite/tests/warnings/w58.opt.opt_reference
new file mode 100644
index 00000000..f913ef94
--- /dev/null
+++ b/testsuite/tests/warnings/w58.opt.opt_reference
@@ -0,0 +1,2 @@
+File "_none_", line 1:
+Warning 58: no cmx file was found in path for module Module_without_cmx, and its interface was not compiled with -opaque
diff --git a/testsuite/tests/warnings/w58.opt.reference b/testsuite/tests/warnings/w58.opt.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
new file mode 100644
index 00000000..a7e8b93c
--- /dev/null
+++ b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
@@ -0,0 +1,44 @@
+File "w59.opt_backend.ml", line 25, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 26, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 27, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 28, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 25, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 26, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 27, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 28, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
diff --git a/testsuite/tests/warnings/w59.opt_backend.ml b/testsuite/tests/warnings/w59.opt_backend.ml
new file mode 100644
index 00000000..91e51474
--- /dev/null
+++ b/testsuite/tests/warnings/w59.opt_backend.ml
@@ -0,0 +1,44 @@
+
+(* Check that the warning 59 (assignment to immutable value) does not
+   trigger on those examples *)
+let a = Lazy.force (lazy "a")
+let b = Lazy.force (lazy 1)
+let c = Lazy.force (lazy 3.14)
+let d = Lazy.force (lazy 'a')
+let e = Lazy.force (lazy (fun x -> x+1))
+let rec f (x:int) : int = g x and g x = f x
+let h = Lazy.force (lazy f)
+let i = Lazy.force (lazy g)
+let j = Lazy.force (lazy 1L)
+let k = Lazy.force (lazy (1,2))
+let l = Lazy.force (lazy [|3.14|])
+let m = Lazy.force (lazy (Sys.opaque_identity 3.14))
+let n = Lazy.force (lazy None)
+
+(* Check that obviously wrong code is reported *)
+let o = (1,2)
+let p = fun x -> x
+let q = 3.14
+let r = 1
+
+let () =
+  Obj.set_field (Obj.repr o) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr p) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr q) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr r) 0 (Obj.repr 3)
+
+let set v =
+  Obj.set_field (Obj.repr v) 0 (Obj.repr 3)
+  [@@inline]
+
+let () =
+  set o
+
+(* Sys.opaque_identity hide all information and shouldn't warn *)
+
+let opaque = Sys.opaque_identity (1,2)
+let set_opaque =
+  Obj.set_field
+    (Obj.repr opaque)
+    0
+    (Obj.repr 3)
diff --git a/testsuite/tests/warnings/w59.opt_backend.reference b/testsuite/tests/warnings/w59.opt_backend.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/warnings/w60.ml b/testsuite/tests/warnings/w60.ml
new file mode 100755
index 00000000..01aed6f8
--- /dev/null
+++ b/testsuite/tests/warnings/w60.ml
@@ -0,0 +1,23 @@
+(* PR#7314 *)
+
+module type Comparable = sig
+  val id: int
+end
+
+module Make_graph (P:sig module Id:Comparable end) = struct
+  let foo = P.Id.id
+end
+
+module Fold_ordered(P: sig module Id:Comparable end) =
+struct
+  include Make_graph(struct module Id = P.Id end)
+end
+
+
+(* PR#7314 *)
+
+module M = struct
+  module N = struct end
+end
+
+module O = M.N
diff --git a/testsuite/tests/warnings/w60.mli b/testsuite/tests/warnings/w60.mli
new file mode 100755
index 00000000..f3c5740c
--- /dev/null
+++ b/testsuite/tests/warnings/w60.mli
@@ -0,0 +1,12 @@
+module type Comparable = sig
+  val id: int
+end
+
+module Fold_ordered(P: sig module Id:Comparable end): sig
+  val foo: int
+end
+
+
+
+module M : sig end
+module O : sig end
diff --git a/testsuite/tests/warnings/w60.reference b/testsuite/tests/warnings/w60.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile
new file mode 100644
index 00000000..8c9dd05a
--- /dev/null
+++ b/testsuite/tools/Makefile
@@ -0,0 +1,31 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Jeremie Dimino, Jane Street Europe                     *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=..
+MAIN=expect_test
+PROG=$(MAIN)$(EXE)
+COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
+          -I $(OTOPDIR)/driver -I $(OTOPDIR)/toplevel
+LIBRARIES=../../compilerlibs/ocamlcommon \
+          ../../compilerlibs/ocamlbytecomp \
+          ../../compilerlibs/ocamltoplevel
+
+$(PROG): $(MAIN).cmo
+	$(OCAMLC) -linkall -o $(PROG) $(LIBRARIES:=.cma) $(MAIN).cmo
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+.PHONY: clean
+clean: defaultclean
+	rm -f $(PROG)
diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml
new file mode 100644
index 00000000..6ddd44ba
--- /dev/null
+++ b/testsuite/tools/expect_test.ml
@@ -0,0 +1,366 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2016 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Execute a list of phrases from a .ml file and compare the result to the
+   expected output, written inside [%%expect ...] nodes. At the end, create
+   a .corrected file containing the corrected expectations. The test is
+   successful if there is no differences between the two files.
+
+   An [%%expect] node always contains both the expected outcome with and
+   without -principal. When the two differ the expectation is written as
+   follows:
+
+   {[
+     [%%expect {|
+     output without -principal
+     |}, Principal{|
+     output with -principal
+     |}]
+   ]}
+*)
+
+[@@@ocaml.warning "-40"]
+
+open StdLabels
+
+(* representation of: {tag|str|tag} *)
+type string_constant =
+  { str : string
+  ; tag : string
+  }
+
+type expectation =
+  { extid_loc   : Location.t (* Location of "expect" in "[%%expect ...]" *)
+  ; payload_loc : Location.t (* Location of the whole payload *)
+  ; normal      : string_constant (* expectation without -principal *)
+  ; principal   : string_constant (* expectation with -principal *)
+  }
+
+(* A list of phrases with the expected toplevel output *)
+type chunk =
+  { phrases     : Parsetree.toplevel_phrase list
+  ; expectation : expectation
+  }
+
+type correction =
+  { corrected_expectations : expectation list
+  ; trailing_output        : string
+  }
+
+let match_expect_extension (ext : Parsetree.extension) =
+  match ext with
+  | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) ->
+    let invalid_payload () =
+      Location.raise_errorf ~loc:extid_loc
+        "invalid [%%%%expect payload]"
+    in
+    let string_constant (e : Parsetree.expression) =
+      match e.pexp_desc with
+      | Pexp_constant (Pconst_string (str, Some tag)) ->
+        { str; tag }
+      | _ -> invalid_payload ()
+    in
+    let expectation =
+      match payload with
+      | PStr [{ pstr_desc = Pstr_eval (e, []) }] ->
+        let normal, principal =
+          match e.pexp_desc with
+          | Pexp_tuple
+              [ a
+              ; { pexp_desc = Pexp_construct
+                                ({ txt = Lident "Principal"; _ }, Some b) }
+              ] ->
+            (string_constant a, string_constant b)
+          | _ -> let s = string_constant e in (s, s)
+        in
+        { extid_loc
+        ; payload_loc = e.pexp_loc
+        ; normal
+        ; principal
+        }
+      | PStr [] ->
+        let s = { tag = ""; str = "" } in
+        { extid_loc
+        ; payload_loc  = { extid_loc with loc_start = extid_loc.loc_end }
+        ; normal    = s
+        ; principal = s
+        }
+      | _ -> invalid_payload ()
+    in
+    Some expectation
+  | _ ->
+    None
+
+(* Split a list of phrases from a .ml file *)
+let split_chunks phrases =
+  let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc =
+    match phrases with
+    | [] ->
+      if code_acc = [] then
+        (List.rev acc, None)
+      else
+        (List.rev acc, Some (List.rev code_acc))
+    | phrase :: phrases ->
+      match phrase with
+      | Ptop_def [] -> loop phrases code_acc acc
+      | Ptop_def [{pstr_desc = Pstr_extension(ext, [])}] -> begin
+          match match_expect_extension ext with
+          | None -> loop phrases (phrase :: code_acc) acc
+          | Some expectation ->
+            let chunk =
+              { phrases     = List.rev code_acc
+              ; expectation
+              }
+            in
+            loop phrases [] (chunk :: acc)
+        end
+      | _ -> loop phrases (phrase :: code_acc) acc
+  in
+  loop phrases [] []
+
+module Compiler_messages = struct
+  let print_loc ppf (loc : Location.t) =
+    let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+    let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+    Format.fprintf ppf "Line _";
+    if startchar >= 0 then
+      Format.fprintf ppf ", characters %d-%d" startchar endchar;
+    Format.fprintf ppf ":@."
+
+  let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)=
+    print_loc ppf loc;
+    Format.fprintf ppf "%a %s" Location.print_error_prefix () msg;
+    List.iter sub ~f:(fun err ->
+      Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err)
+
+  let warning_printer loc ppf w =
+    if Warnings.is_active w then begin
+      print_loc ppf loc;
+      Format.fprintf ppf "Warning %a@." Warnings.print w
+    end
+
+  let capture ppf ~f =
+    Misc.protect_refs
+      [ R (Location.formatter_for_warnings , ppf            )
+      ; R (Location.warning_printer        , warning_printer)
+      ; R (Location.error_reporter         , error_reporter )
+      ]
+      f
+end
+
+let collect_formatters buf pps ~f =
+  List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
+  let save =
+    List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps
+  in
+  let restore () =
+    List.iter2
+      (fun pp out_functions ->
+         Format.pp_print_flush pp ();
+         Format.pp_set_formatter_out_functions pp out_functions)
+      pps save
+  in
+  let out_string str ofs len = Buffer.add_substring buf str ofs len
+  and out_flush = ignore
+  and out_newline () = Buffer.add_char buf '\n'
+  and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
+  let out_functions =
+    { Format.out_string; out_flush; out_newline; out_spaces }
+  in
+  List.iter
+    (fun pp -> Format.pp_set_formatter_out_functions pp out_functions)
+    pps;
+  match f () with
+  | x             -> restore (); x
+  | exception exn -> restore (); raise exn
+
+(* Invariant: ppf = Format.formatter_of_buffer buf *)
+let capture_everything buf ppf ~f =
+  collect_formatters buf [Format.std_formatter; Format.err_formatter]
+                     ~f:(fun () -> Compiler_messages.capture ppf ~f)
+
+let exec_phrase ppf phrase =
+  if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase;
+  if !Clflags.dump_source    then Pprintast.top_phrase ppf phrase;
+  Toploop.execute_phrase true ppf phrase
+
+let parse_contents ~fname contents =
+  let lexbuf = Lexing.from_string contents in
+  Location.init lexbuf fname;
+  Location.input_name := fname;
+  Parse.use_file lexbuf
+
+let eval_expectation expectation ~output =
+  let s =
+    if !Clflags.principal then
+      expectation.principal
+    else
+      expectation.normal
+  in
+  if s.str = output then
+    None
+  else
+    let s = { s with str = output } in
+    Some (
+      if !Clflags.principal then
+        { expectation with principal = s }
+      else
+        { expectation with normal = s }
+    )
+
+let shift_lines delta phrases =
+  let position (pos : Lexing.position) =
+    { pos with pos_lnum = pos.pos_lnum + delta }
+  in
+  let location _this (loc : Location.t) =
+    { loc with
+      loc_start = position loc.loc_start
+    ; loc_end   = position loc.loc_end
+    }
+  in
+  let mapper = { Ast_mapper.default_mapper with location } in
+  List.map phrases ~f:(function
+    | Parsetree.Ptop_dir _ as p -> p
+    | Parsetree.Ptop_def st ->
+      Parsetree.Ptop_def (mapper.structure mapper st))
+
+let rec min_line_number : Parsetree.toplevel_phrase list -> int option =
+function
+  | [] -> None
+  | (Ptop_dir _  | Ptop_def []) :: l -> min_line_number l
+  | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum
+
+let eval_expect_file _fname ~file_contents =
+  Warnings.reset_fatal ();
+  let chunks, trailing_code =
+    parse_contents ~fname:"" file_contents |> split_chunks
+  in
+  let buf = Buffer.create 1024 in
+  let ppf = Format.formatter_of_buffer buf in
+  let exec_phrases phrases =
+    let phrases =
+      match min_line_number phrases with
+      | None -> phrases
+      | Some lnum -> shift_lines (1 - lnum) phrases
+    in
+    (* For formatting purposes *)
+    Buffer.add_char buf '\n';
+    let _ : bool =
+      List.fold_left phrases ~init:true ~f:(fun acc phrase ->
+        acc &&
+        try
+          exec_phrase ppf phrase
+        with exn ->
+          Location.report_exception ppf exn;
+          false)
+    in
+    Format.pp_print_flush ppf ();
+    let len = Buffer.length buf in
+    if len > 0 && Buffer.nth buf (len - 1) <> '\n' then
+      (* For formatting purposes *)
+      Buffer.add_char buf '\n';
+    let s = Buffer.contents buf in
+    Buffer.clear buf;
+    Misc.delete_eol_spaces s
+  in
+  let corrected_expectations =
+    capture_everything buf ppf ~f:(fun () ->
+      List.fold_left chunks ~init:[] ~f:(fun acc chunk ->
+        let output = exec_phrases chunk.phrases in
+        match eval_expectation chunk.expectation ~output with
+        | None -> acc
+        | Some correction -> correction :: acc)
+      |> List.rev)
+  in
+  let trailing_output =
+    match trailing_code with
+    | None -> ""
+    | Some phrases ->
+      capture_everything buf ppf ~f:(fun () -> exec_phrases phrases)
+  in
+  { corrected_expectations; trailing_output }
+
+let output_slice oc s a b =
+  output_string oc (String.sub s ~pos:a ~len:(b - a))
+
+let output_corrected oc ~file_contents correction =
+  let output_body oc { str; tag } =
+    Printf.fprintf oc "{%s|%s|%s}" tag str tag
+  in
+  let ofs =
+    List.fold_left correction.corrected_expectations ~init:0
+      ~f:(fun ofs c ->
+        output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum;
+        output_body oc c.normal;
+        if c.normal.str <> c.principal.str then begin
+          output_string oc ", Principal";
+          output_body oc c.principal
+        end;
+        c.payload_loc.loc_end.pos_cnum)
+  in
+  output_slice oc file_contents ofs (String.length file_contents);
+  match correction.trailing_output with
+  | "" -> ()
+  | s  -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s
+
+let write_corrected ~file ~file_contents correction =
+  let oc = open_out file in
+  output_corrected oc ~file_contents correction;
+  close_out oc
+
+let process_expect_file fname =
+  let corrected_fname = fname ^ ".corrected" in
+  let file_contents =
+    let ic = open_in_bin fname in
+    match really_input_string ic (in_channel_length ic) with
+    | s           -> close_in ic; Misc.normalise_eol s
+    | exception e -> close_in ic; raise e
+  in
+  let correction = eval_expect_file fname ~file_contents in
+  write_corrected ~file:corrected_fname ~file_contents correction
+
+let repo_root = ref ""
+
+let main fname =
+  Toploop.override_sys_argv
+    (Array.sub Sys.argv ~pos:!Arg.current
+       ~len:(Array.length Sys.argv - !Arg.current));
+  (* Ignore OCAMLRUNPARAM=b to be reproducible *)
+  Printexc.record_backtrace false;
+  List.iter [ "stdlib" ] ~f:(fun s ->
+    Topdirs.dir_directory (Filename.concat !repo_root s));
+  Toploop.initialize_toplevel_env ();
+  Sys.interactive := false;
+  process_expect_file fname;
+  exit 0
+
+let args =
+  Arg.align
+    [ "-repo-root", Set_string repo_root,
+      " root of the OCaml repository"
+    ; "-principal", Set Clflags.principal,
+      " Evaluate the file with -principal set"
+    ]
+
+let usage = "Usage: expect_test  [script-file [arguments]]\n\
+             options are:"
+
+let () =
+  try
+    Arg.parse args main usage;
+    Printf.eprintf "expect_test: no input file\n";
+    exit 2
+  with exn ->
+    Location.report_exception Format.err_formatter exn;
+    exit 2
diff --git a/testsuite/typing b/testsuite/typing
new file mode 100644
index 00000000..3fbfcec1
--- /dev/null
+++ b/testsuite/typing
@@ -0,0 +1,40 @@
+tests/basic
+tests/basic-float
+tests/basic-io
+tests/basic-io-2
+tests/basic-manyargs
+tests/basic-modules
+tests/basic-more
+tests/basic-multdef
+tests/basic-private
+tests/typing-extension-constructor
+tests/typing-extensions
+tests/typing-fstclassmod
+tests/typing-gadts
+tests/typing-immediate
+tests/typing-implicit_unpack
+tests/typing-labels
+tests/typing-misc
+tests/typing-misc-bugs
+tests/typing-missing-cmi
+tests/typing-modules
+tests/typing-modules-bugs
+tests/typing-objects
+tests/typing-objects-bugs
+tests/typing-poly
+tests/typing-poly-bugs
+tests/typing-polyvariants-bugs
+tests/typing-polyvariants-bugs-2
+tests/typing-private
+tests/typing-private-bugs
+tests/typing-recmod
+tests/typing-recordarg
+tests/typing-rectypes-bugs
+tests/typing-safe-linking
+tests/typing-short-paths
+tests/typing-signatures
+tests/typing-sigsubst
+tests/typing-typeparam
+tests/typing-unboxed
+tests/typing-warnings
+tests/warnings
diff --git a/tools/.depend b/tools/.depend
new file mode 100644
index 00000000..5dcb7ed8
--- /dev/null
+++ b/tools/.depend
@@ -0,0 +1,93 @@
+addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
+    ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
+addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
+    ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi
+cmpbyt.cmo : ../bytecomp/bytesections.cmi
+cmpbyt.cmx : ../bytecomp/bytesections.cmx
+cmt2annot.cmo : ../typing/untypeast.cmi ../typing/types.cmi \
+    ../typing/typedtree.cmi ../typing/tast_mapper.cmi ../typing/stypes.cmi \
+    ../parsing/pprintast.cmi ../typing/path.cmi ../typing/oprint.cmi \
+    ../parsing/location.cmi ../typing/ident.cmi ../typing/envaux.cmi \
+    ../typing/env.cmi ../utils/config.cmi ../typing/cmt_format.cmi \
+    ../parsing/asttypes.cmi ../typing/annot.cmi
+cmt2annot.cmx : ../typing/untypeast.cmx ../typing/types.cmx \
+    ../typing/typedtree.cmx ../typing/tast_mapper.cmx ../typing/stypes.cmx \
+    ../parsing/pprintast.cmx ../typing/path.cmx ../typing/oprint.cmx \
+    ../parsing/location.cmx ../typing/ident.cmx ../typing/envaux.cmx \
+    ../typing/env.cmx ../utils/config.cmx ../typing/cmt_format.cmx \
+    ../parsing/asttypes.cmi ../typing/annot.cmi
+cvt_emit.cmo :
+cvt_emit.cmx :
+dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
+    ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \
+    ../typing/ident.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \
+    ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi
+dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
+    ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \
+    ../typing/ident.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \
+    ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi
+eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
+    ../parsing/location.cmi ../parsing/asttypes.cmi
+eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
+    ../parsing/location.cmx ../parsing/asttypes.cmi
+lintapidiff.cmo : ../typing/printtyp.cmi ../driver/pparse.cmi \
+    ../typing/path.cmi ../parsing/parsetree.cmi ../parsing/parse.cmi \
+    ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi
+lintapidiff.cmx : ../typing/printtyp.cmx ../driver/pparse.cmx \
+    ../typing/path.cmx ../parsing/parsetree.cmi ../parsing/parse.cmx \
+    ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx
+make_opcodes.cmo :
+make_opcodes.cmx :
+objinfo.cmo : ../utils/tbl.cmi ../middle_end/base_types/symbol.cmi \
+    ../asmcomp/printclambda.cmi ../utils/misc.cmi \
+    ../middle_end/base_types/linkage_name.cmi ../typing/ident.cmi \
+    ../asmcomp/export_info.cmi ../utils/config.cmi \
+    ../middle_end/base_types/compilation_unit.cmi ../asmcomp/cmx_format.cmi \
+    ../typing/cmt_format.cmi ../bytecomp/cmo_format.cmi \
+    ../typing/cmi_format.cmi ../bytecomp/bytesections.cmi
+objinfo.cmx : ../utils/tbl.cmx ../middle_end/base_types/symbol.cmx \
+    ../asmcomp/printclambda.cmx ../utils/misc.cmx \
+    ../middle_end/base_types/linkage_name.cmx ../typing/ident.cmx \
+    ../asmcomp/export_info.cmx ../utils/config.cmx \
+    ../middle_end/base_types/compilation_unit.cmx ../asmcomp/cmx_format.cmi \
+    ../typing/cmt_format.cmx ../bytecomp/cmo_format.cmi \
+    ../typing/cmi_format.cmx ../bytecomp/bytesections.cmx
+ocaml299to3.cmo :
+ocaml299to3.cmx :
+ocamlcp.cmo : ../driver/main_args.cmi
+ocamlcp.cmx : ../driver/main_args.cmx
+ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \
+    ../parsing/parser.cmi ../parsing/parse.cmi ../utils/misc.cmi \
+    ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
+    ../parsing/depend.cmi ../utils/config.cmi ../driver/compplugin.cmi \
+    ../driver/compenv.cmi ../utils/clflags.cmi
+ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \
+    ../parsing/parser.cmx ../parsing/parse.cmx ../utils/misc.cmx \
+    ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
+    ../parsing/depend.cmx ../utils/config.cmx ../driver/compplugin.cmx \
+    ../driver/compenv.cmx ../utils/clflags.cmx
+ocamlmklib.cmo : ocamlmklibconfig.cmo ../utils/misc.cmi ../utils/config.cmi
+ocamlmklib.cmx : ocamlmklibconfig.cmx ../utils/misc.cmx ../utils/config.cmx
+ocamlmklibconfig.cmo :
+ocamlmklibconfig.cmx :
+ocamlmktop.cmo : ../utils/ccomp.cmi
+ocamlmktop.cmx : ../utils/ccomp.cmx
+ocamloptp.cmo : ../driver/main_args.cmi
+ocamloptp.cmx : ../driver/main_args.cmx
+ocamlprof.cmo : ../utils/warnings.cmi ../parsing/parsetree.cmi \
+    ../parsing/parse.cmi ../parsing/location.cmi
+ocamlprof.cmx : ../utils/warnings.cmx ../parsing/parsetree.cmi \
+    ../parsing/parse.cmx ../parsing/location.cmx
+opnames.cmo :
+opnames.cmx :
+primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
+primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
+profiling.cmo : profiling.cmi
+profiling.cmx : profiling.cmi
+profiling.cmi :
+read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
+read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
+scrapelabels.cmo :
+scrapelabels.cmx :
+stripdebug.cmo : ../utils/misc.cmi ../bytecomp/bytesections.cmi
+stripdebug.cmx : ../utils/misc.cmx ../bytecomp/bytesections.cmx
diff --git a/tools/Makefile b/tools/Makefile
new file mode 100644
index 00000000..9a8cf652
--- /dev/null
+++ b/tools/Makefile
@@ -0,0 +1,397 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+MAKEFLAGS := -r -R
+include ../config/Makefile
+INSTALL_BINDIR:=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR:=$(DESTDIR)$(LIBDIR)
+INSTALL_COMPLIBDIR:=$(DESTDIR)$(COMPLIBDIR)
+INSTALL_STUBLIBDIR:=$(DESTDIR)$(STUBLIBDIR)
+INSTALL_MANDIR:=$(DESTDIR)$(MANDIR)
+
+ifeq ($(SYSTEM),unix)
+override define shellquote
+$i := $$(subst ",\",$$(subst $$$$,\$$$$,$$(subst `,\`,$i)))#")#
+endef
+$(foreach i,BINDIR LIBDIR COMPLIBDIR STUBLIBDIR MANDIR,$(eval $(shellquote)))
+endif
+
+CAMLRUN ?= ../boot/ocamlrun
+CAMLYACC ?= ../boot/ocamlyacc
+DESTDIR ?=
+# Setup GNU make variables storing per-target source and target,
+# a list of installed tools, and a function to quote a filename for
+# the shell.
+override installed_tools := ocamldep ocamlprof ocamlcp ocamloptp \
+                   ocamlmktop ocamlmklib ocamlobjinfo
+
+install_files :=
+define byte2native
+$(patsubst %.cmo,%.cmx,$(patsubst %.cma,%.cmxa,$1))
+endef
+
+# $1 = target, $2 = OCaml object dependencies, $3 = other dependencies
+# There is a lot of subtle code here.  The multiple layers of expansion
+# are due to `make`'s eval() function, which evaluates the string
+# passed to it as a makefile fragment.  So it is crucial that variables
+# not get expanded too many times.
+define byte_and_opt_
+# This check is defensive programming
+$(and $(filter-out 1,$(words $1)),$(error \
+   cannot build file with whitespace in name))
+$1: $3 $2
+	$$(CAMLC) $$(LINKFLAGS) -I .. -o $$@ $2
+
+$1.opt: $3 $$(call byte2native,$2)
+	$$(CAMLOPT) $$(LINKFLAGS) -I .. -o $$@ $$(call byte2native,$2)
+
+all: $1
+
+opt.opt: $1.opt
+
+ifeq '$(filter $(installed_tools),$1)' '$1'
+install_files += $1
+endif
+clean::
+	rm -f -- $1 $1.opt
+
+endef
+
+# Escape any $ characters in the arguments and eval the result.
+define byte_and_opt
+$(eval $(call \
+ byte_and_opt_,$(subst $$,$$$$,$1),$(subst $$,$$$$,$2),$(subst $$,$$$$,$3)))
+endef
+
+ROOTDIR=..
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
+
+CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot \
+      -use-prims ../byterun/primitives -I ..
+CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
+ifeq "$(UNIX_OR_WIN32)" "win32"
+  ifneq "$(wildcard ../flexdll/Makefile)" ""
+    CAMLOPT := OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" \
+      $(CAMLOPT)
+  endif
+endif
+CAMLLEX=$(CAMLRUN) ../boot/ocamllex
+INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
+         -I ../middle_end -I ../middle_end/base_types -I ../driver \
+         -I ../toplevel
+COMPFLAGS= -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \
+ -safe-string -strict-formats -bin-annot $(INCLUDES)
+LINKFLAGS=$(INCLUDES)
+VPATH := $(filter-out -I,$(INCLUDES))
+
+# scrapelabels addlabels
+
+.PHONY: all opt.opt
+
+# The dependency generator
+
+CAMLDEP_OBJ=ocamldep.cmo
+CAMLDEP_IMPORTS= \
+  ../compilerlibs/ocamlcommon.cma \
+  ../compilerlibs/ocamlbytecomp.cma
+ocamldep: LINKFLAGS += -compat-32
+$(call byte_and_opt,ocamldep,$(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ),)
+ocamldep: depend.cmi
+ocamldep.opt: depend.cmi
+
+# ocamldep is precious: sometimes we are stuck in the middle of a
+# bootstrap and we need to remake the dependencies
+clean::
+	if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi
+	rm -f ocamldep.opt
+
+
+# The profiler
+
+CSLPROF=ocamlprof.cmo
+CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \
+  arg_helper.cmo clflags.cmo terminfo.cmo \
+  warnings.cmo location.cmo longident.cmo docstrings.cmo \
+  syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
+
+$(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),)
+
+ocamlcp_cmos = misc.cmo warnings.cmo config.cmo identifiable.cmo numbers.cmo \
+	       arg_helper.cmo clflags.cmo main_args.cmo
+
+$(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,)
+$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,)
+
+opt:: profiling.cmx
+
+install::
+	cp -- profiling.cmi profiling.cmo profiling.cmt profiling.cmti "$(INSTALL_LIBDIR)"
+
+installopt::
+	cp -- profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
+
+# To help building mixed-mode libraries (OCaml + C)
+
+$(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo misc.cmo \
+	         ocamlmklib.cmo,)
+
+
+ocamlmklibconfig.ml: ../config/Makefile Makefile
+	(echo 'let bindir = "$(BINDIR)"'; \
+         echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\
+         echo 'let byteccrpath = "$(BYTECCRPATH)"'; \
+         echo 'let nativeccrpath = "$(NATIVECCRPATH)"'; \
+         echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \
+         echo 'let toolpref = "$(TOOLPREF)"'; \
+         sed -n -e 's/^#ml //p' ../config/Makefile) \
+        > ocamlmklibconfig.ml
+
+beforedepend:: ocamlmklibconfig.ml
+
+clean::
+	rm -f ocamlmklibconfig.ml
+
+# To make custom toplevels
+
+OCAMLMKTOP=ocamlmktop.cmo
+OCAMLMKTOP_IMPORTS=misc.cmo identifiable.cmo numbers.cmo config.cmo \
+		   arg_helper.cmo clflags.cmo ccomp.cmo
+
+$(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),)
+
+# Converter olabl/ocaml 2.99 to ocaml 3
+
+OCAML299TO3= lexer299.cmo ocaml299to3.cmo
+LIBRARY3= misc.cmo warnings.cmo location.cmo
+
+ocaml299to3: $(OCAML299TO3)
+	$(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
+
+lexer299.ml: lexer299.mll
+	$(CAMLLEX) lexer299.mll
+
+#install::
+#	cp ocaml299to3 "$(INSTALL_BINDIR)/ocaml299to3$(EXE)"
+
+clean::
+	rm -f ocaml299to3 lexer299.ml
+
+# Label remover for interface files (upgrade 3.02 to 3.03)
+
+SCRAPELABELS= lexer301.cmo scrapelabels.cmo
+
+scrapelabels: $(SCRAPELABELS)
+	$(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS)
+
+lexer301.ml: lexer301.mll
+	$(CAMLLEX) lexer301.mll
+
+#install::
+#	cp scrapelabels "$(INSTALL_LIBDIR)"
+
+clean::
+	rm -f scrapelabels lexer301.ml
+
+# Insert labels following an interface file (upgrade 3.02 to 3.03)
+
+ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \
+  identifiable.cmo numbers.cmo terminfo.cmo \
+  warnings.cmo location.cmo longident.cmo docstrings.cmo \
+  syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
+
+addlabels: addlabels.cmo
+	$(CAMLC) $(LINKFLAGS) -w sl -o addlabels \
+		$(ADDLABELS_IMPORTS) addlabels.cmo
+
+#install::
+#	cp addlabels "$(INSTALL_LIBDIR)"
+
+ifeq ($(UNIX_OR_WIN32),unix)
+LN := ln -sf
+else
+LN := cp -pf
+endif
+
+install::
+	for i in $(install_files); \
+	do \
+	  cp -- "$$i" "$(INSTALL_BINDIR)/$$i.byte$(EXE)" && \
+	  if test -f "$$i".opt; then \
+	    cp -- "$$i.opt" "$(INSTALL_BINDIR)/$$i.opt$(EXE)" && \
+	    (cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.opt$(EXE)" "$$i$(EXE)"); \
+	  else \
+	    (cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.byte$(EXE)" "$$i$(EXE)"); \
+	  fi; \
+	done
+
+clean::
+	rm -f addlabels
+
+# The preprocessor for asm generators
+
+CVT_EMIT=cvt_emit.cmo
+
+cvt_emit: $(CVT_EMIT)
+	$(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT)
+
+# cvt_emit is precious: sometimes we are stuck in the middle of a
+# bootstrap and we need to remake the dependencies
+.PRECIOUS: cvt_emit
+clean::
+	if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi
+
+cvt_emit.ml: cvt_emit.mll
+	$(CAMLLEX) cvt_emit.mll
+
+clean::
+	rm -f cvt_emit.ml
+
+beforedepend:: cvt_emit.ml
+
+# Reading cmt files
+
+READ_CMT= \
+          ../compilerlibs/ocamlcommon.cma \
+          ../compilerlibs/ocamlbytecomp.cma \
+          \
+          cmt2annot.cmo read_cmt.cmo
+
+# Reading cmt files
+$(call byte_and_opt,read_cmt,$(READ_CMT),)
+
+
+# The bytecode disassembler
+
+DUMPOBJ=opnames.cmo dumpobj.cmo
+
+$(call byte_and_opt,dumpobj,misc.cmo identifiable.cmo numbers.cmo tbl.cmo \
+                    config.cmo ident.cmo opcodes.cmo bytesections.cmo \
+		    $(DUMPOBJ),)
+
+make_opcodes.ml: make_opcodes.mll
+	$(CAMLLEX) make_opcodes.mll
+
+make_opcodes: make_opcodes.ml
+	$(CAMLC) make_opcodes.ml -o $@
+
+opnames.ml: ../byterun/caml/instruct.h make_opcodes
+	$(CAMLRUN) make_opcodes -opnames < $< > $@
+
+clean::
+	rm -f opnames.ml make_opcodes make_opcodes.ml
+
+beforedepend:: opnames.ml
+
+# Display info on compiled files
+
+ifeq "$(SYSTEM)" "macosx"
+DEF_SYMBOL_PREFIX = '-Dsymbol_prefix="_"'
+else
+DEF_SYMBOL_PREFIX = '-Dsymbol_prefix=""'
+endif
+
+ifeq "$(CCOMPTYPE)" "msvc"
+CCOUT = -Fe
+else
+EMPTY =
+CCOUT = -o $(EMPTY)
+endif
+
+objinfo_helper$(EXE): objinfo_helper.c ../config/s.h
+	$(BYTECC) $(CCOUT)objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \
+          $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) objinfo_helper.c $(LIBBFD_LINK)
+
+OBJINFO=../compilerlibs/ocamlcommon.cma \
+        ../compilerlibs/ocamlbytecomp.cma \
+        ../compilerlibs/ocamlmiddleend.cma \
+        ../asmcomp/printclambda.cmo \
+        ../asmcomp/export_info.cmo \
+        objinfo.cmo
+
+$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE))
+
+install::
+	cp objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
+
+# Scan object files for required primitives
+$(call byte_and_opt,primreq,config.cmo primreq.cmo,)
+
+LINTAPIDIFF=../compilerlibs/ocamlcommon.cmxa \
+        ../compilerlibs/ocamlbytecomp.cmxa \
+        ../compilerlibs/ocamlmiddleend.cmxa \
+        ../asmcomp/printclambda.cmx \
+        ../asmcomp/export_info.cmx \
+	../otherlibs/str/str.cmxa \
+	lintapidiff.cmx
+
+lintapidiff.opt: INCLUDES+= -I ../otherlibs/str
+lintapidiff.opt: $(LINTAPIDIFF)
+	$(CAMLOPT) $(LINKFLAGS) -I .. -o $@ $(LINTAPIDIFF)
+clean::
+	rm -f -- lintapidiff.opt lintapidiff.cm? lintapidiff.o
+
+
+clean::
+	rm -f "objinfo_helper$(EXE)" "objinfo_helper$(EXE).manifest"
+
+
+# Copy a bytecode executable, stripping debug info
+
+stripdebug=../compilerlibs/ocamlcommon.cma \
+           ../compilerlibs/ocamlbytecomp.cma \
+           stripdebug.cmo
+
+$(call byte_and_opt,stripdebug,$(stripdebug),)
+
+# Compare two bytecode executables
+
+CMPBYT=../compilerlibs/ocamlcommon.cma \
+       ../compilerlibs/ocamlbytecomp.cma \
+       cmpbyt.cmo
+
+$(call byte_and_opt,cmpbyt,$(CMPBYT),)
+
+ifeq "$(RUNTIMEI)" "true"
+install::
+	cp ocaml-instr-graph ocaml-instr-report "$(INSTALL_BINDIR)/"
+endif
+
+# Common stuff
+
+.SUFFIXES:
+
+%.cmo: %.ml
+	$(CAMLC) -c $(COMPFLAGS) - $<
+
+%.cmi: %.mli
+	$(CAMLC) -c $(COMPFLAGS) - $<
+
+%.cmx: %.ml
+	$(CAMLOPT) $(COMPFLAGS) -c - $<
+
+clean::
+	rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a
+
+depend: beforedepend
+	$(CAMLRUN) ./ocamldep -slash $(INCLUDES) *.mli *.ml > .depend
+
+.PHONY: clean install beforedepend depend
+
+include .depend
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/tools/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
new file mode 100644
index 00000000..2153b37c
--- /dev/null
+++ b/tools/addlabels.ml
@@ -0,0 +1,469 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              Jacques Garrigue, Kyoto University RIMS                   *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2001 Kyoto University                                      *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open StdLabels
+open Asttypes
+open Parsetree
+
+let norec = ref false
+
+let input_file file =
+  let ic = try open_in file with _ -> failwith ("input_file : " ^ file) in
+  let b = Buffer.create 1024 in
+  let buf = String.create 1024 and len = ref 0 in
+  while len := input ic buf 0 1024; !len > 0 do
+    Buffer.add_substring b buf 0 !len
+  done;
+  close_in ic;
+  Buffer.contents b
+
+module SMap = struct
+  include Map.Make(struct type t = string let compare = compare end)
+  let rec removes l m =
+    match l with [] -> m
+    | k::l ->
+        let m = try remove k m with Not_found -> m in
+        removes l m
+end
+
+let rec labels_of_sty sty =
+  match sty.ptyp_desc with
+    Ptyp_arrow (lab, _, rem) -> lab :: labels_of_sty rem
+  | Ptyp_alias (rem, _)      -> labels_of_sty rem
+  |  _                       -> []
+
+let rec labels_of_cty cty =
+  match cty.pcty_desc with
+    Pcty_arrow (lab, _, rem) ->
+      let (labs, meths) = labels_of_cty rem in
+      (lab :: labs, meths)
+  | Pcty_signature { pcsig_fields = fields } ->
+      ([],
+       List.fold_left fields ~init:[] ~f:
+          begin fun meths -> function
+          { pctf_desc = Pctf_meth (s, _, sty) } -> (s, labels_of_sty sty)::meths
+            | _ -> meths
+          end)
+  |  _ ->
+      ([],[])
+
+let rec pattern_vars pat =
+  match pat.ppat_desc with
+    Ppat_var s -> [s.txt]
+  | Ppat_alias (pat, s) ->
+      s.txt :: pattern_vars pat
+  | Ppat_tuple l
+  | Ppat_array l ->
+      List.concat (List.map pattern_vars l)
+  | Ppat_construct (_, Some pat)
+  | Ppat_variant (_, Some pat)
+  | Ppat_constraint (pat, _) ->
+      pattern_vars pat
+  | Ppat_record(l, _) ->
+      List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p))
+  | Ppat_or (pat1, pat2) ->
+      pattern_vars pat1 @ pattern_vars pat2
+  | Ppat_lazy pat -> pattern_vars pat
+  | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
+  | Ppat_type _ | Ppat_unpack _ ->
+      []
+
+let pattern_name pat =
+  match pat.ppat_desc with
+    Ppat_var s -> Some s
+  | Ppat_constraint ({ppat_desc = Ppat_var s}, _) -> Some s
+  | _ -> None
+
+let insertions = ref []
+let add_insertion pos s = insertions := (pos,s) :: !insertions
+let sort_insertions () =
+  List.sort !insertions ~cmp:(fun (pos1,_) (pos2,_) -> pos1 - pos2)
+
+let is_space = function ' '|'\t'|'\n'|'\r' -> true | _ -> false
+let is_alphanum = function 'A'..'Z'|'a'..'z'|'_'|'\192'..'\214'|'\216'..'\246'
+  | '\248'..'\255'|'\''|'0'..'9' -> true
+  | _ -> false
+
+(* Remove "(" or "begin" before a pattern *)
+let rec insertion_point pos ~text =
+  let pos' = ref (pos-1) in
+  while is_space text.[!pos'] do decr pos' done;
+  if text.[!pos'] = '(' then insertion_point !pos' ~text else
+  if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin"
+  && not (is_alphanum text.[!pos'-5]) then insertion_point (!pos'-4) ~text
+  else pos
+
+(* Search "=" or "->" before "function" *)
+let rec insertion_point2 pos ~text =
+  let pos' = ref (pos-1) in
+  while is_space text.[!pos'] do decr pos' done;
+  if text.[!pos'] = '(' then insertion_point2 !pos' ~text else
+  if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin"
+  && not (is_alphanum text.[!pos'-5]) then insertion_point2 (!pos'-4) ~text
+  else if text.[!pos'] = '=' then Some !pos' else
+  if !pos' >= 1 && text.[!pos'-1] = '-' && text.[!pos'] = '>'
+  then Some (!pos' - 1)
+  else None
+
+let rec insert_labels ~labels ~text expr =
+  match labels, expr.pexp_desc with
+    l::labels, Pexp_function(l', _, [pat, rem]) ->
+      if l <> "" && l.[0] <> '?' && l' = "" then begin
+        let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in
+        let pos = insertion_point start_c ~text in
+        match pattern_name pat with
+        | Some name when l = name.txt -> add_insertion pos "~"
+        | _ -> add_insertion pos ("~" ^ l ^ ":")
+      end;
+      insert_labels ~labels ~text rem
+  | l::labels, Pexp_function(l', _, lst) ->
+      let pos = expr.pexp_loc.Location.loc_start.Lexing.pos_cnum in
+      if l <> "" && l.[0] <> '?' && l' = ""
+      && String.sub text ~pos ~len:8 = "function" then begin
+        String.blit ~src:"match th" ~src_pos:0 ~dst:text
+          ~dst_pos:pos ~len:8;
+        add_insertion (pos+6) (l ^ " wi");
+        match insertion_point2 pos ~text with
+          Some pos' ->
+            add_insertion pos' ("~" ^ l ^ " ")
+        | None ->
+            add_insertion pos ("fun ~" ^ l ^ " -> ")
+      end;
+      List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e)
+  | _, Pexp_match( _, lst) ->
+      List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e)
+  | _, Pexp_try(expr, lst) ->
+      insert_labels ~labels ~text expr;
+      List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e)
+  | _, ( Pexp_let(_,_,e) | Pexp_sequence(_,e) | Pexp_when(_,e)
+       | Pexp_constraint(e,_,_) | Pexp_letmodule(_,_,e)
+       | Pexp_ifthenelse(_,e,None) ) ->
+      insert_labels ~labels ~text e
+  | _, Pexp_ifthenelse (_, e1, Some e2) ->
+      insert_labels ~labels ~text e1;
+      insert_labels ~labels ~text e2
+  | _ ->
+      ()
+
+let rec insert_labels_class ~labels ~text expr =
+  match labels, expr.pcl_desc with
+    l::labels, Pcl_fun(l', _, pat, rem) ->
+      if l <> "" && l.[0] <> '?' && l' = "" then begin
+        let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in
+        let pos = insertion_point start_c ~text in
+        match pattern_name pat with
+        | Some name when l = name.txt -> add_insertion pos "~"
+        | _ -> add_insertion pos ("~" ^ l ^ ":")
+      end;
+      insert_labels_class ~labels ~text rem
+  | labels, (Pcl_constraint (expr, _) | Pcl_let (_, _, expr)) ->
+      insert_labels_class ~labels ~text expr
+  | _ ->
+      ()
+
+let rec insert_labels_type ~labels ~text ty =
+  match labels, ty.ptyp_desc with
+    l::labels, Ptyp_arrow(l', _, rem) ->
+      if l <> "" && l.[0] <> '?' && l' = "" then begin
+        let start_c = ty.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
+        let pos = insertion_point start_c ~text in
+        add_insertion pos (l ^ ":")
+      end;
+      insert_labels_type ~labels ~text rem
+  | _ ->
+      ()
+
+let rec insert_labels_app ~labels ~text args =
+  match labels, args with
+    l::labels, (l',arg)::args ->
+      if l <> "" && l.[0] <> '?' && l' = "" then begin
+        let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in
+        let pos = insertion_point pos0 ~text in
+        match arg.pexp_desc with
+        | Pexp_ident({ txt = Longident.Lident name })
+          when l = name && pos = pos0 ->
+            add_insertion pos "~"
+        | _ -> add_insertion pos ("~" ^ l ^ ":")
+      end;
+      insert_labels_app ~labels ~text args
+  | _ ->
+      ()
+
+let insert_labels_app ~labels ~text args =
+  let labels, opt_labels =
+    List.partition labels ~f:(fun l -> l = "" || l.[0] <> '?') in
+  let nopt_labels =
+    List.map opt_labels
+      ~f:(fun l -> String.sub l ~pos:1 ~len:(String.length l - 1)) in
+  (* avoid ambiguous labels *)
+  if List.exists labels ~f:(List.mem ~set:nopt_labels) then () else
+  let aopt_labels = opt_labels @ nopt_labels in
+  let args, lab_args = List.partition args ~f:(fun (l,_) -> l = "") in
+  (* only optional arguments are labeled *)
+  if List.for_all lab_args ~f:(fun (l,_) -> List.mem l ~set:aopt_labels)
+  then insert_labels_app ~labels ~text args
+
+let rec add_labels_expr ~text ~values ~classes expr =
+  let add_labels_rec ?(values=values) expr =
+    add_labels_expr ~text ~values ~classes expr in
+  match expr.pexp_desc with
+    Pexp_apply ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })}, args) ->
+      begin try
+        let labels = SMap.find s values in
+        insert_labels_app ~labels ~text args
+      with Not_found -> ()
+      end;
+      List.iter args ~f:(fun (_,e) -> add_labels_rec e)
+  | Pexp_apply ({pexp_desc=Pexp_send
+                   ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},
+                    meth)},
+                args) ->
+      begin try
+        if SMap.find s values = [""] then
+          let labels = SMap.find (s ^ "#" ^ meth) values in
+          insert_labels_app ~labels ~text args
+      with Not_found -> ()
+      end
+  | Pexp_apply ({pexp_desc=Pexp_new ({ txt = Longident.Lident s })}, args) ->
+      begin try
+        let labels = SMap.find s classes in
+        insert_labels_app ~labels ~text args
+      with Not_found -> ()
+      end
+  | Pexp_let (recp, lst, expr) ->
+      let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in
+      let vals = SMap.removes vars values in
+      List.iter lst ~f:
+        begin fun (_,e) ->
+          add_labels_rec e ~values:(if recp = Recursive then vals else values)
+        end;
+      add_labels_rec expr ~values:vals
+  | Pexp_function (_, None, lst) ->
+      List.iter lst ~f:
+        (fun (p,e) ->
+          add_labels_rec e ~values:(SMap.removes (pattern_vars p) values))
+  | Pexp_function (_, Some e, lst)
+  | Pexp_match (e, lst)
+  | Pexp_try (e, lst) ->
+      add_labels_rec e;
+      List.iter lst ~f:
+        (fun (p,e) ->
+          add_labels_rec e ~values:(SMap.removes (pattern_vars p) values))
+  | Pexp_apply (e, args) ->
+      List.iter add_labels_rec (e :: List.map snd args)
+  | Pexp_tuple l | Pexp_array l ->
+      List.iter add_labels_rec l
+  | Pexp_construct (_, Some e)
+  | Pexp_variant (_, Some e)
+  | Pexp_field (e, _)
+  | Pexp_constraint (e, _, _)
+  | Pexp_send (e, _)
+  | Pexp_setinstvar (_, e)
+  | Pexp_letmodule (_, _, e)
+  | Pexp_assert e
+  | Pexp_lazy e
+  | Pexp_poly (e, _)
+  | Pexp_newtype (_, e)
+  | Pexp_open (_, e) ->
+      add_labels_rec e
+  | Pexp_record (lst, opt) ->
+      List.iter lst ~f:(fun (_,e) -> add_labels_rec e);
+      begin match opt with Some e -> add_labels_rec e | None -> () end
+  | Pexp_setfield (e1, _, e2)
+  | Pexp_ifthenelse (e1, e2, None)
+  | Pexp_sequence (e1, e2)
+  | Pexp_while (e1, e2)
+  | Pexp_when (e1, e2) ->
+      add_labels_rec e1; add_labels_rec e2
+  | Pexp_ifthenelse (e1, e2, Some e3) ->
+      add_labels_rec e1; add_labels_rec e2; add_labels_rec e3
+  | Pexp_for (s, e1, e2, _, e3) ->
+      add_labels_rec e1; add_labels_rec e2;
+      add_labels_rec e3 ~values:(SMap.removes [s.txt] values)
+  | Pexp_override lst ->
+      List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
+  | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
+  | Pexp_new _ | Pexp_object _ | Pexp_pack _ ->
+      ()
+
+let rec add_labels_class ~text ~classes ~values ~methods cl =
+  match cl.pcl_desc with
+    Pcl_constr _ -> ()
+  | Pcl_structure { pcstr_self = p; pcstr_fields = l } ->
+      let values = SMap.removes (pattern_vars p) values in
+      let values =
+        match pattern_name p with None -> values
+        | Some s ->
+            List.fold_left methods
+              ~init:(SMap.add s.txt [""] values)
+              ~f:(fun m (k,l) -> SMap.add (s.txt^"#"^k) l m)
+      in
+      ignore (List.fold_left l ~init:values ~f:
+        begin fun values -> function e -> match e.pcf_desc with
+          | Pcf_val (s, _, _, e) ->
+              add_labels_expr ~text ~classes ~values e;
+              SMap.removes [s.txt] values
+          | Pcf_meth (s, _, _, e) ->
+              begin try
+                let labels = List.assoc s.txt methods in
+                insert_labels ~labels ~text e
+              with Not_found -> ()
+              end;
+              add_labels_expr ~text ~classes ~values e;
+              values
+          | Pcf_init e ->
+              add_labels_expr ~text ~classes ~values e;
+              values
+          | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> values
+        end)
+  | Pcl_fun (_, opt, pat, cl) ->
+      begin match opt with None -> ()
+      | Some e -> add_labels_expr ~text ~classes ~values e
+      end;
+      let values = SMap.removes (pattern_vars pat) values in
+      add_labels_class ~text ~classes ~values ~methods cl
+  | Pcl_apply (cl, args) ->
+      List.iter args ~f:(fun (_,e) -> add_labels_expr ~text ~classes ~values e);
+      add_labels_class ~text ~classes ~values ~methods cl
+  | Pcl_let (recp, lst, cl) ->
+      let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in
+      let vals = SMap.removes vars values in
+      List.iter lst ~f:
+        begin fun (_,e) ->
+          add_labels_expr e ~text ~classes
+            ~values:(if recp = Recursive then vals else values)
+        end;
+      add_labels_class cl ~text ~classes ~values:vals ~methods
+  | Pcl_constraint (cl, _) ->
+      add_labels_class ~text ~classes ~values ~methods cl
+
+let add_labels ~intf ~impl ~file =
+  insertions := [];
+  let values, classes =
+    List.fold_left intf ~init:(SMap.empty, SMap.empty) ~f:
+      begin fun (values, classes as acc) item ->
+        match item.psig_desc with
+          Psig_value (name, {pval_type = sty}) ->
+            (SMap.add name.txt (labels_of_sty sty) values, classes)
+        | Psig_class l ->
+          (values,
+           List.fold_left l ~init:classes ~f:
+             begin fun classes {pci_name=name; pci_expr=cty} ->
+               SMap.add name.txt (labels_of_cty cty) classes
+             end)
+        | _ ->
+            acc
+      end
+  in
+  let text = input_file file in
+  ignore (List.fold_right impl ~init:(values, classes) ~f:
+    begin fun item (values, classes as acc) ->
+      match item.pstr_desc with
+        Pstr_value (recp, l) ->
+          let names =
+            List.concat (List.map l ~f:(fun (p,_) -> pattern_vars p)) in
+          List.iter l ~f:
+            begin fun (pat, expr) ->
+              begin match pattern_name pat with
+              | Some s ->
+                  begin try
+                    let labels = SMap.find s.txt values in
+                    insert_labels ~labels ~text expr;
+                    if !norec then () else
+                    let values =
+                      SMap.fold
+                        (fun s l m ->
+                          if List.mem s names then SMap.add s l m else m)
+                        values SMap.empty in
+                    add_labels_expr expr ~text ~values ~classes:SMap.empty
+                  with Not_found -> ()
+                  end
+              | None -> ()
+              end;
+            end;
+          (SMap.removes names values, classes)
+      | Pstr_primitive (s, {pval_type=sty}) ->
+          begin try
+            let labels = SMap.find s.txt values in
+            insert_labels_type ~labels ~text sty;
+            (SMap.removes [s.txt] values, classes)
+          with Not_found -> acc
+          end
+      | Pstr_class l ->
+          let names = List.map l ~f:(fun pci -> pci.pci_name.txt) in
+          List.iter l ~f:
+            begin fun {pci_name=name; pci_expr=expr} ->
+              try
+                let (labels, methods) = SMap.find name.txt classes in
+                insert_labels_class ~labels ~text expr;
+                if !norec then () else
+                let classes =
+                  SMap.fold
+                    (fun s (l,_) m ->
+                      if List.mem s names then SMap.add s l m else m)
+                    classes SMap.empty in
+                add_labels_class expr ~text ~classes ~methods
+                  ~values:SMap.empty
+              with Not_found -> ()
+            end;
+          (values, SMap.removes names classes)
+      | _ ->
+          acc
+    end);
+  if !insertions <> [] then begin
+    let backup = file ^ ".bak" in
+    if Sys.file_exists backup then Sys.remove file
+    else Sys.rename file backup;
+    let oc = open_out file in
+    let last_pos =
+      List.fold_left (sort_insertions ()) ~init:0 ~f:
+        begin fun pos (pos', s) ->
+          output oc text pos (pos'-pos);
+          output_string oc s;
+          pos'
+        end in
+    if last_pos < String.length text then
+      output oc text last_pos (String.length text - last_pos);
+    close_out oc
+  end
+  else prerr_endline ("No labels to insert in " ^ file)
+
+let process_file file =
+  prerr_endline ("Processing " ^ file);
+  if Filename.check_suffix file ".ml" then
+    let intf = Filename.chop_suffix file ".ml" ^ ".mli" in
+    let ic = open_in intf in
+    let lexbuf = Lexing.from_channel ic in
+    Location.init lexbuf intf;
+    let intf = Parse.interface lexbuf in
+    close_in ic;
+    let ic = open_in file in
+    let lexbuf = Lexing.from_channel ic in
+    Location.init lexbuf file;
+    let impl = Parse.implementation lexbuf in
+    close_in ic;
+    add_labels ~intf ~impl ~file
+  else prerr_endline (file ^ " is not an implementation")
+
+let main () =
+  let files = ref [] in
+  Arg.parse ["-norec", Arg.Set norec, "do not labelize recursive calls"]
+    (fun f -> files := f :: !files)
+    "addlabels [-norec] ";
+  let files = List.rev !files in
+  List.iter files ~f:process_file
+
+let () = main ()
diff --git a/tools/check-typo b/tools/check-typo
new file mode 100755
index 00000000..550ce252
--- /dev/null
+++ b/tools/check-typo
@@ -0,0 +1,299 @@
+#!/bin/sh
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2012 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# check-typo - Check typographic conventions on OCaml sources.
+
+# This program will check files for the following rules:
+
+# - absence of TAB characters (tab)
+# - absence of non-ASCII characters (non-ascii)
+# - absence of non-printing ASCII characters (non-printing)
+# - absence of white space at end of line (white-at-eol)
+# - absence of empty lines at end of file (white-at-eof)
+# - presence of a LF character at the end of the file (missing-lf)
+# - maximum line length of 80 characters (long-line)
+# - maximum line length of 132 characters (very-long-line)
+# - presence of a copyright header (missing-header)
+# - absence of a leftover "$Id" string (svn-keyword)
+
+# Exceptions are handled with a git attribute: "ocaml-typo".
+# Its value for a given file is a comma-separated list of rule names,
+# which lists the rules that should be disabled for this file.
+# The rule names are the ones shown above in parentheses.
+
+# Built-in exceptions:
+# - Any file git identifies as binary
+#   is automatically exempt from all the rules.
+# - Any file whose name matches one of the following patterns is
+#   automatically exempt from all rules
+#     *.reference
+#     *.opt_reference
+#     */reference
+#     */.depend*
+# - Any file whose name begins with "Makefile" is automatically exempt
+#   from the "tabs" rule.
+# - Any file whose name matches one of the following patterns is
+#   automatically exempt from the "missing-header" rule.
+#     *.mlpack
+#     *.mllib
+#     *.mltop
+#     *.odocl
+#     *.clib
+# - Any file whose name matches the following pattern is automatically
+#   exempt from the "long-line" rule (but not from "very-long-line").
+#   */ocamldoc/*
+
+# ASCII characters are bytes from 0 to 127.  Any other byte is
+# flagged as a non-ASCII character.
+
+# For the purpose of this tool, printing ASCII characters are:
+# - the non-white printable ASCII characters (33 to 126)
+# - TAB (09)
+# - LF (10)
+# - SPC (32)
+# Anything else is flagged as a non-printing ASCII character.
+
+# This program will recursively explore the files and directories given
+# on the command line (or by default the current directory), and check
+# every file therein for compliance to the rules.
+
+# Directories named .git (and their contents) are always ignored.
+# This program ignores any file that is not under git control, unless
+# explicitly given on the command line.
+
+# If a directory has the git attribute "ocaml-typo" set to "prune",
+# then it and its contents are ignored.
+
+# You can ignore a rule by giving the option - on the command
+# line (before any file names).
+
+# First prevent i18n from messing up everything.
+export LC_ALL=C
+
+# Special case for recursive call from the find command (see IGNORE_DIRS).
+case "$1" in
+  --check-prune)
+    case `git check-attr ocaml-typo "$2" 2>/dev/null` in
+      *prune*) echo "INFO: pruned directory $2 (ocaml-typo=prune)" >&2; exit 0;;
+      *) exit 3;;
+    esac;;
+esac
+
+usage () {
+  echo "usage: check-typo {-} [--] {}" >&2
+  exit 2
+}
+
+userrules=''
+
+while : ; do
+  case "$1" in
+    -help|--help) usage;;
+    -*) userrules="${1#-},$userrules"; shift;;
+    --) shift; break;;
+    *) break;;
+  esac
+done
+
+IGNORE_DIRS="
+  -name .git -prune -o
+  -type d -exec $0 --check-prune {} ; -prune -o
+"
+
+( case $# in
+    0) find . $IGNORE_DIRS -type f -print;;
+    *) for i in "$@"; do find "$i" $IGNORE_DIRS -type f -print; done;;
+  esac
+) | (
+  while read f; do
+    case `git ls-files "$f" 2>&1` in
+      "") is_svn=false;;
+      *) is_svn=true;;
+    esac
+    case "$*" in
+      *$f*) is_cmd_line=true;;
+      *) is_cmd_line=false;;
+    esac
+    if $is_svn || $is_cmd_line; then :; else continue; fi
+    svnrules=''
+    if $is_svn; then
+      # Below is a git plumbing command to detect whether git regards a
+      # particular file as binary. This takes into account .gitattributes, but
+      # also works if the file has been automatically detected as binary by git.
+      # EMPTY is the hash of the empty tree (which is specially known to git -
+      # it is automatically included in every repository) as a way to get
+      # `diff-tree` to print the whole tree state; its `--numstat` output then
+      # prints a summary where two dashes in the first two columns indicates a
+      # binary file.
+      #   (See https://git-scm.com/docs/git-diff-tree#_other_diff_formats and
+      #    the documentation for the --numstat option. Commands designated as
+      #    "plumbing" commands in git have stable output intended for parsing)
+      EMPTY=`git hash-object -t tree /dev/null`
+      git diff-tree --numstat $EMPTY HEAD -- "$f" | grep -q "^-[[:blank:]]-" \
+        && continue
+      svnrules=`git check-attr ocaml-typo "$f" | sed -e 's/.*: //'`
+      case $svnrules in unspecified) svnrules= ;; esac
+    fi
+    rules="$userrules"
+    add_hd(){ rules="missing-header,$rules"; }
+    case "$f" in
+      Makefile*|*/Makefile*) rules="tab,$rules";;
+      *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) add_hd;;
+      *.reference|*.opt_reference|*/reference|*/.depend*) continue;;
+    esac
+    case "$f" in
+      ocamldoc/*|*/ocamldoc/*) rules="long-line,$rules";;
+    esac
+
+    (cat "$f" | tr -d '\r'; echo) \
+    | awk -v rules="$rules" -v svnrules="$svnrules" -v file="$f" \
+      '
+        function err(name, msg) {
+          ++ counts[name];
+          if (("," rules svnrules ",") !~ ("[, ]" name "[, ]") \
+              && counts[name] <= 10){
+            printf ("%s:%d.%d:", file, NR, RSTART + RLENGTH);
+            printf (" [%s] %s\n", name, msg);
+            got_errors = 1;
+            if (counts[name] == 10){
+              printf ("WARNING: too many [%s] in this file.", name);
+              printf ("  Others will not be reported.\n");
+            }
+          }
+        }
+
+        function more_columns(str, limit,       c){
+          c = 0;
+          for (i = 1; i <= length(str); i++){
+            if (substr(str, i, 1) == "\t"){
+              c = int((c + 8) / 8) * 8;
+            }else{
+              ++ c;
+            }
+          }
+          return c > limit;
+        }
+
+        BEGIN { state = "(first line)"; }
+
+        match($0, /\t/) {
+          err("tab", "TAB character(s)");
+          if (more_columns($0, 80)){
+            RSTART=81;
+            RLENGTH = 0;
+            err("long-line", "line is over 80 columns");
+          }
+          if (more_columns($0, 132)){
+            RSTART=133;
+            RLENGTH = 0;
+            err("very-long-line", "line is over 132 columns");
+          }
+        }
+
+        match($0, /[\200-\377]/) {
+          err("non-ascii", "non-ASCII character(s)");
+        }
+
+        match($0, /[^\t\200-\377 -~]/) {
+          err("non-printing", "non-printing ASCII character(s)");
+        }
+
+        match($0, /[ \t]+$/) {
+          err("white-at-eol", "whitespace at end of line");
+        }
+
+        match($0, /\$Id(: .*)?\$/) {
+          err("svn-keyword", "SVN keyword marker");
+        }
+
+        $0 !~ /\t/ && length($0) > 80 {
+          RSTART = 81;
+          RLENGTH = 0;
+          err("long-line", "line is over 80 columns");
+        }
+
+        $0 !~ /\t/ && length($0) > 132 {
+          RSTART = 133;
+          RLENGTH = 0;
+          err("very-long-line", "line is over 132 columns");
+        }
+
+        # Header-recognition automaton. Read this from bottom to top.
+
+        state == "close" && $0 ~ /\*{74}/ { state = "OK"; }
+        state == "close" { state = "(last line)"; }
+        state == "blurb" && $0 ~ /\* {72}\*/ { state = "close"; }
+        state == "blurb" && $0 ~ /\/LICENSE/ { state = "(license path)" }
+        state == "blurb1" && $0 ~ /\*   All rights reserved. .{47} \*/ \
+                                                 { state = "blurb"; }
+        state == "blurb1" { state = "(blurb line 1)"; }
+        state == "copyright" && $0 ~ /\* {72}\*/ { state = "blurb1"; }
+        state == "copyright" && $0 !~ /\*   Copyright [0-9]{4}.{54} \*/ \
+                             && $0 !~ /\*     .{66} \*/ \
+                      { state = "(copyright lines)"; }
+        state == "authors" && $0 ~ /\* {72}\*/ { state = "copyright"; }
+        state == "authors" && $0 !~ /\* .{70} \*/ { state = "(authors)"; }
+        state == "blank2" && $0 ~ /\* {72}\*/ { state = "authors"; }
+        state == "blank2" { state = "(blank line 2)"; }
+        state == "title" && $0 ~ /\* {33}OCaml {34}\*/ { state = "blank2"; }
+        state == "title" { state = "(title line)"; }
+        state == "blank1" && $0 ~ /\* {72}\*/ { state = "title"; }
+        state == "blank1" { state = "(blank line 1)"; }
+        state == "(first line)" && NR < 4 && $0 ~ /\*{74}/ { state = "blank1"; }
+
+        {
+          prev_line = last_line;
+          last_line = $0;
+        }
+
+        END {
+          if (match(last_line, /.+/)){
+            err("missing-lf", "missing linefeed at EOF");
+            prev_line = last_line;
+            ++ NR;
+            empty_file = 0;
+          }else{
+            empty_file = NR == 1;
+          }
+          if (!empty_file && match(prev_line, /^$/)){
+            err("white-at-eof", "empty line(s) at EOF");
+          }
+          if (state != "OK"){
+            if (NR >= 10){
+              NR = 1;
+              RSTART = 1;
+              RLENGTH = 0;
+              err("missing-header", sprintf("bad copyright header %s", state));
+            }else{
+              counts["missing-header"] = 1;
+            }
+          }
+          split(svnrules, r, "[, ]");
+          for (i in r){
+            name = r[i];
+            if (name != "" && !counts[name]){
+              NR = 1;
+              RSTART = 1;
+              RLENGTH = 0;
+              err("unused-prop", sprintf("unused [%s] in ocaml-typo", name));
+            }
+          }
+          exit got_errors;
+        }
+      '
+  done
+)
diff --git a/tools/checkstack.c b/tools/checkstack.c
new file mode 100644
index 00000000..c6c213f0
--- /dev/null
+++ b/tools/checkstack.c
@@ -0,0 +1,43 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*           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 GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+#define MINSTACKBYTES (384 * 1024 * sizeof (long))
+
+int main(int argc, char ** argv)
+{
+  struct rlimit limit;
+  int rc;
+
+  rc = getrlimit (RLIMIT_STACK, &limit);
+  if (rc != 0) exit (0);
+  if (limit.rlim_cur < MINSTACKBYTES){
+    fprintf (stderr,
+             "\nThe current stack size limit is too low (%luk)\n"
+             "You must increase it with one of the following commands:\n"
+             "Under sh, bash, zsh:  ulimit -s %lu\n"
+             "Under csh, tcsh:      limit stacksize %lu\n\n",
+             (unsigned long) (limit.rlim_cur / 1024),
+             (unsigned long) (MINSTACKBYTES / 1024),
+             (unsigned long) (MINSTACKBYTES / 1024));
+    exit (3);
+  }
+  exit (0);
+}
diff --git a/tools/ci-build b/tools/ci-build
new file mode 100755
index 00000000..46af368b
--- /dev/null
+++ b/tools/ci-build
@@ -0,0 +1,209 @@
+#!/bin/sh
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*          Damien Doligez, projet Gallium, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 2014 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# This script is run on our continuous-integration servers to recompile
+# from scratch and run the test suite.
+
+# To know the slave's architecture, this script looks at the OCAML_ARCH
+# environment variable. For a given node NODe, this variable can be defined
+# in Jenkins at the following address:
+# https://ci.inria.fr/ocaml/computer/NODE/configure
+
+# arguments:
+# -conf configure-option  add configure-option to configure cmd line
+# -patch1 file-name       apply patch with -p1
+# -no-native              do not build "opt" and "opt.opt"
+
+error () {
+  echo "$1" >&2
+  exit 3
+}
+
+arch_error() {
+  configure_url="https://ci.inria.fr/ocaml/computer/${NODE_NAME}/configure"
+  msg="Unknown architecture. Make sure the OCAML_ARCH environemnt"
+  msg="$msg variable has been defined."
+  msg="$msg\nSee ${configure_url}"
+  error "$msg"
+}
+
+# Kill a task on Windows
+# Errors are ignored
+kill_task()
+{
+  task=$1
+  taskkill /f /im ${task} || true
+}
+
+quote1 () {
+  printf "'%s'" "`printf %s "$1" | sed -e "s/'/'\\\\\\\\''/g"`";
+}
+
+#########################################################################
+# be verbose
+set -x
+
+#########################################################################
+# Save the current directory (on cygwin, /etc/profile changes it)
+jenkinsdir="$(pwd)"
+echo jenkinsdir=${jenkinsdir}
+
+#########################################################################
+# If we are called from a Windows batch script, we must set up the
+# Unix environment variables (e.g. PATH).
+
+case "${OCAML_ARCH}" in
+  bsd|macos|linux) ;;
+  cygwin|mingw|mingw64)
+    . /etc/profile
+    . "$HOME/.profile"
+  ;;
+  msvc)
+    . /etc/profile
+    . "$HOME/.profile"
+    . "$HOME/.msenv32"
+  ;;
+  msvc64)
+    . /etc/profile
+    . "$HOME/.profile"
+    . "$HOME/.msenv64"
+  ;;
+  *) arch_error;;
+esac
+
+#########################################################################
+
+# be verbose and stop on error
+set -ex
+
+#########################################################################
+# set up variables
+
+# default values
+make=make
+instdir="$HOME/ocaml-tmp-install"
+configure=unix
+confoptions="${OCAML_CONFIGURE_OPTIONS}"
+make_native=true
+cleanup=false
+
+case "${OCAML_ARCH}" in
+  bsd) make=gmake ;;
+  macos) ;;
+  linux)
+    confoptions="${confoptions} -with-instrumented-runtime"
+  ;;
+  cygwin)
+    cleanup=true;;
+  mingw)
+    instdir='C:/ocamlmgw'
+    configure=nt
+    cleanup=true
+  ;;
+  mingw64)
+    instdir='C:/ocamlmgw64'
+    configure=nt
+    cleanup=true
+  ;;
+  msvc)
+    instdir='C:/ocamlms'
+    configure=nt
+    cleanup=true
+  ;;
+  msvc64)
+    instdir='C:/ocamlms64'
+    configure=nt
+    cleanup=true
+  ;;
+  *) arch_error;;
+esac
+
+# Make sure two builds won't use the same install directory
+instdir="$instdir-$$"
+
+#########################################################################
+# On Windows, cleanup processes that may remain from previous run
+
+if $cleanup; then
+  tasks="tee ocamlrun program"
+  for task in ${tasks}; do kill_task ${task}.exe; done
+fi
+
+#########################################################################
+# Go to the right directory
+
+pwd
+cd "$jenkinsdir"
+
+#########################################################################
+# parse optional command-line arguments (has to be done after the "cd")
+
+while [ $# -gt 0 ]; do
+  case $1 in
+    -conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
+    -patch1) patch -f -p1 <"$2"; shift;;
+    -no-native) make_native=false;;
+    *) error "unknown option $1";;
+  esac
+  shift
+done
+
+#########################################################################
+# Do the work
+
+# Tell gcc to use only ASCII in its diagnostic outputs.
+export LC_ALL=C
+
+$make distclean || :
+
+# `make distclean` does not clean the files from previous versions that
+# are not produced by the current version, so use `git clean` in addition.
+git clean -f -d -x
+
+case $configure in
+  unix)
+    confoptions="$confoptions -with-debug-runtime"
+    if $flambda; then
+      confoptions="$confoptions -flambda"
+    fi
+    eval "./configure -prefix '$instdir' $confoptions"
+  ;;
+  nt)
+    cp config/m-nt.h config/m.h
+    cp config/s-nt.h config/s.h
+    cp config/Makefile.${OCAML_ARCH} config/Makefile
+    sed -i "s%PREFIX=\(.\+\)%PREFIX=${instdir}%" config/Makefile
+    sed -i 's%RUNTIMED=.\+%RUNTIMED=true%' config/Makefile
+    if $flambda; then
+      sed -i 's%FLAMBDA=.\+%FLAMBDA=true%' config/Makefile
+    fi
+  ;;
+  *) error "internal error";;
+esac
+
+$make coldstart
+$make core
+$make coreboot
+$make world
+if $make_native; then
+  $make opt
+  $make opt.opt
+fi
+$make install
+
+rm -rf "$instdir"
+cd testsuite
+$make all
diff --git a/tools/cleanup-header b/tools/cleanup-header
new file mode 100644
index 00000000..5945597b
--- /dev/null
+++ b/tools/cleanup-header
@@ -0,0 +1,29 @@
+#!/bin/sed -f
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2002 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Remove private parts from runtime include files, before installation
+# in /usr/local/lib/ocaml/caml
+
+/\/\*  \*\// {
+  r ../config/m.h
+  d
+}
+/\/\*  \*\// {
+  r ../config/s.h
+  d
+}
+/\/\*  \*\//,/\/\* <\/private> \*\//d
diff --git a/tools/cmpbyt.ml b/tools/cmpbyt.ml
new file mode 100644
index 00000000..983234fe
--- /dev/null
+++ b/tools/cmpbyt.ml
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compare two bytecode executables for equality.
+   Ignore loader prefix and debug infos. *)
+
+open Printf
+
+let readtoc ic =
+  Bytesections.read_toc ic;
+  (Bytesections.toc(), Bytesections.pos_first_section ic)
+
+type cmpresult = Same | Differ of int
+
+let rec cmpbytes ic1 ic2 len ofs =
+  if len <= 0 then Same else begin
+    let c1 = input_char ic1 and c2 = input_char ic2 in
+    if c1 = c2 then cmpbytes ic1 ic2 (len - 1) (ofs + 1) else Differ ofs
+  end
+
+let skip_section name =
+  name = "DBUG"
+
+let cmpbyt file1 file2 =
+  let ic1 = open_in_bin file1 in
+  let (toc1, pos1) = readtoc ic1 in
+  let ic2 = open_in_bin file2 in
+  let (toc2, pos2) = readtoc ic2 in
+  seek_in ic1 pos1;
+  seek_in ic2 pos2;
+  let rec cmpsections t1 t2 =
+    match t1, t2 with
+    | [], [] ->
+        true
+    | (name1, len1) :: t1, t2  when skip_section name1 ->
+        seek_in ic1 (pos_in ic1 + len1);
+         cmpsections t1 t2
+    | t1, (name2, len2) :: t2  when skip_section name2 ->
+        seek_in ic2 (pos_in ic2 + len2);
+        cmpsections t1 t2
+    | [], _  ->
+        eprintf "%s has more sections than %s\n" file2 file1;
+        false
+    | _,  [] ->
+        eprintf "%s has more sections than %s\n" file1 file2;
+        false
+    | (name1, len1) :: t1, (name2, len2) :: t2 ->
+        if name1 <> name2 then begin
+          eprintf "Section mismatch: %s (in %s) / %s (in %s)\n"
+                  name1 file1 name2 file2;
+          false
+        end else if len1 <> len2 then begin
+          eprintf "Length of section %s differ: %d (in %s) / %d (in %s)\n"
+                  name1 len1 file1 len2 file2;
+          false
+        end else begin
+          match cmpbytes ic1 ic2 len1 0 with
+          | Differ ofs ->
+              eprintf "Files %s and %s differ: section %s, offset %d\n"
+                      file1 file2 name1 ofs;
+              false
+          | Same ->
+              cmpsections t1 t2
+        end
+  in
+  let res = cmpsections toc1 toc2 in
+  close_in ic1; close_in ic2;
+  res
+
+let _ =
+  if Array.length Sys.argv <> 3 then begin
+    eprintf "Usage: cmpbyt  \n";
+    exit 2
+  end;
+  if cmpbyt Sys.argv.(1) Sys.argv.(2) then exit 0 else exit 1
diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
new file mode 100644
index 00000000..53299f98
--- /dev/null
+++ b/tools/cmt2annot.ml
@@ -0,0 +1,214 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Generate an .annot file from a .cmt file. *)
+
+open Asttypes
+open Typedtree
+open Tast_mapper
+
+let bind_variables scope =
+  let super = Tast_mapper.default in
+  let pat sub p =
+    begin match p.pat_desc with
+    | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
+        Stypes.record (Stypes.An_ident (p.pat_loc,
+                                        Ident.name id,
+                                        Annot.Idef scope))
+    | _ -> ()
+    end;
+    super.pat sub p;
+  in
+  {super with pat}
+
+let bind_variables scope =
+  let o = bind_variables scope in
+  fun p -> ignore (o.pat o p)
+
+let bind_bindings scope bindings =
+  let o = bind_variables scope in
+  List.iter (fun x -> o x.vb_pat) bindings
+
+let bind_cases l =
+  List.iter
+    (fun {c_lhs; c_guard; c_rhs} ->
+      let loc =
+        let open Location in
+        match c_guard with
+        | None -> c_rhs.exp_loc
+        | Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start}
+      in
+      bind_variables loc  c_lhs
+    )
+    l
+
+let rec iterator ~scope rebuild_env =
+  let super = Tast_mapper.default in
+  let class_expr sub node =
+    Stypes.record (Stypes.Ti_class node);
+    super.class_expr sub node
+
+  and module_expr _sub node =
+    Stypes.record (Stypes.Ti_mod node);
+    super.module_expr (iterator ~scope:node.mod_loc rebuild_env) node
+
+  and expr sub exp =
+    begin match exp.exp_desc with
+    | Texp_ident (path, _, _) ->
+        let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
+        let env =
+          if rebuild_env then
+            try
+              Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
+            with Envaux.Error err ->
+              Format.eprintf "%a@." Envaux.report_error err;
+              exit 2
+          else
+            exp.exp_env
+        in
+        let annot =
+          try
+            let desc = Env.find_value path env in
+            let dloc = desc.Types.val_loc in
+            if dloc.Location.loc_ghost then Annot.Iref_external
+            else Annot.Iref_internal dloc
+          with Not_found ->
+            Annot.Iref_external
+        in
+        Stypes.record
+          (Stypes.An_ident (exp.exp_loc, full_name , annot))
+    | Texp_let (Recursive, bindings, _) ->
+        bind_bindings exp.exp_loc bindings
+    | Texp_let (Nonrecursive, bindings, body) ->
+        bind_bindings body.exp_loc bindings
+    | Texp_match (_, f1, f2, _) ->
+        bind_cases f1;
+        bind_cases f2
+    | Texp_function { cases = f; }
+    | Texp_try (_, f) ->
+        bind_cases f
+    | _ -> ()
+    end;
+    Stypes.record (Stypes.Ti_expr exp);
+    super.expr sub exp
+
+  and pat sub p =
+    Stypes.record (Stypes.Ti_pat p);
+    super.pat sub p
+  in
+
+  let structure_item_rem sub s rem =
+    begin match s with
+    | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} ->
+        let open Location in
+        let doit loc_start = bind_bindings {scope with loc_start} bindings in
+        begin match rec_flag, rem with
+        | Recursive, _ -> doit loc.loc_start
+        | Nonrecursive, [] -> doit loc.loc_end
+        | Nonrecursive,  {str_loc = loc2} :: _ -> doit loc2.loc_start
+        end
+    | _ ->
+        ()
+    end;
+    Stypes.record_phrase s.str_loc;
+    super.structure_item sub s
+  in
+  let structure_item sub s =
+    (* This will be used for Partial_structure_item.
+       We don't have here the location of the "next" item,
+       this will give a slightly different scope for the non-recursive
+       binding case. *)
+    structure_item_rem sub s []
+  and structure sub l =
+    let rec loop = function
+      | str :: rem -> structure_item_rem sub str rem :: loop rem
+      | [] -> []
+    in
+    {l with str_items = loop l.str_items}
+  in
+  {super with class_expr; module_expr; expr; pat; structure_item; structure}
+
+let binary_part iter x =
+  let app f x = ignore (f iter x) in
+  let open Cmt_format in
+  match x with
+  | Partial_structure x -> app iter.structure x
+  | Partial_structure_item x -> app iter.structure_item x
+  | Partial_expression x -> app iter.expr x
+  | Partial_pattern x -> app iter.pat x
+  | Partial_class_expr x -> app iter.class_expr x
+  | Partial_signature x -> app iter.signature x
+  | Partial_signature_item x -> app iter.signature_item x
+  | Partial_module_type x -> app iter.module_type x
+
+let gen_annot target_filename filename
+              {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} =
+  let open Cmt_format in
+  Envaux.reset_cache ();
+  Config.load_path := cmt_loadpath;
+  let target_filename =
+    match target_filename with
+    | None -> Some (filename ^ ".annot")
+    | Some "-" -> None
+    | Some _ -> target_filename
+  in
+  let iterator = iterator ~scope:Location.none cmt_use_summaries in
+  match cmt_annots with
+  | Implementation typedtree ->
+      ignore (iterator.structure iterator typedtree);
+      Stypes.dump target_filename
+  | Interface _ ->
+      Printf.eprintf "Cannot generate annotations for interface file\n%!";
+      exit 2
+  | Partial_implementation parts ->
+      Array.iter (binary_part iterator) parts;
+      Stypes.dump target_filename
+  | _ ->
+      Printf.fprintf stderr "File was generated with an error\n%!";
+      exit 2
+
+
+
+let gen_ml target_filename filename cmt =
+  let (printer, ext) =
+    match cmt.Cmt_format.cmt_annots with
+      | Cmt_format.Implementation typedtree ->
+        (fun ppf -> Pprintast.structure ppf
+                                        (Untypeast.untype_structure typedtree)),
+        ".ml"
+      | Cmt_format.Interface typedtree ->
+        (fun ppf -> Pprintast.signature ppf
+                                        (Untypeast.untype_signature typedtree)),
+        ".mli"
+      | _ ->
+        Printf.fprintf stderr "File was generated with an error\n%!";
+        exit 2
+  in
+  let target_filename = match target_filename with
+      None -> Some (filename ^ ext)
+    | Some "-" -> None
+    | Some _ -> target_filename
+  in
+  let oc = match target_filename with
+      None -> None
+    | Some filename -> Some (open_out filename) in
+  let ppf = match oc with
+      None -> Format.std_formatter
+    | Some oc -> Format.formatter_of_out_channel oc in
+  printer ppf;
+  Format.pp_print_flush ppf ();
+  match oc with
+      None -> flush stdout
+    | Some oc -> close_out oc
diff --git a/tools/cvt_emit.mll b/tools/cvt_emit.mll
new file mode 100644
index 00000000..396f644b
--- /dev/null
+++ b/tools/cvt_emit.mll
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+{
+let first_item = ref false
+let command_beginning = ref 0
+
+let add_semicolon () =
+  if !first_item
+  then first_item := false
+  else print_string "; "
+
+let print_unescaped_string s =
+  let l = String.length s in
+  let i = ref 0 in
+  while !i < l do
+    if s.[!i] = '\\'
+    && !i+1 < l
+    && (let c = s.[!i+1] in c = '{' || c = '`') (* ` *)
+    then i := !i+1;
+    print_char s.[!i];
+    i := !i + 1
+  done
+}
+
+rule main = parse
+    "`" { command_beginning := Lexing.lexeme_start lexbuf;
+          first_item := true;
+          print_char '(';
+          command lexbuf;
+          print_char ')';
+          main lexbuf }
+  | "\\`"
+        { print_string "`"; main lexbuf }
+  | eof { () }
+  | _   { print_char(Lexing.lexeme_char lexbuf 0); main lexbuf }
+
+and command = parse
+    "`" { () }
+  | eof { prerr_string "Unterminated `...` at character ";
+          prerr_int !command_beginning;
+          prerr_newline();
+          exit 2 }
+  | "{" [^ '}'] * "}"
+        { let s = Lexing.lexeme lexbuf in
+          add_semicolon();
+          print_string (String.sub s 1 (String.length s - 2));
+          command lexbuf }
+  | ( [^ '`' '{' '\\'] |
+      '\\' ['\\' '"' 'n' 't' 'b' 'r' '`' '{' ] |
+      '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] |
+      '\\' ('\n' | "\r\n")) +
+        { let s = Lexing.lexeme lexbuf in
+          add_semicolon();
+          (* Optimise one-character strings *)
+          if String.length s = 1 && s.[0] <> '\\' && s.[0] <> '\''
+          || String.length s = 2 && s.[0] = '\\' && s.[1] <> '`' && s.[1]<>'{'
+          (* ` *)
+          then begin
+            print_string "emit_char '";
+            print_unescaped_string s;
+            print_string "'"
+          end else begin
+            print_string "emit_string \"";
+            print_unescaped_string s;
+            print_string "\""
+          end;
+          command lexbuf }
+
+{
+let _ = main(Lexing.from_channel stdin)
+
+let _ = exit (0)
+}
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
new file mode 100644
index 00000000..c3d60bff
--- /dev/null
+++ b/tools/dumpobj.ml
@@ -0,0 +1,580 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Disassembler for executable and .cmo object files *)
+
+open Asttypes
+open Config
+open Instruct
+open Lambda
+open Location
+open Opcodes
+open Opnames
+open Cmo_format
+open Printf
+
+let print_locations = ref true
+let print_reloc_info = ref false
+
+(* Read signed and unsigned integers *)
+
+let inputu ic =
+  let b1 = input_byte ic in
+  let b2 = input_byte ic in
+  let b3 = input_byte ic in
+  let b4 = input_byte ic in
+  (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1
+
+let inputs ic =
+  let b1 = input_byte ic in
+  let b2 = input_byte ic in
+  let b3 = input_byte ic in
+  let b4 = input_byte ic in
+  let b4' = if b4 >= 128 then b4-256 else b4 in
+  (b4' lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1
+
+(* Global variables *)
+
+type global_table_entry =
+    Empty
+  | Global of Ident.t
+  | Constant of Obj.t
+
+let start = ref 0                              (* Position of beg. of code *)
+let reloc = ref ([] : (reloc_info * int) list) (* Relocation table *)
+let globals = ref ([||] : global_table_entry array) (* Global map *)
+let primitives = ref ([||] : string array)     (* Table of primitives *)
+let objfile = ref false                        (* true if dumping a .cmo *)
+
+(* Events (indexed by PC) *)
+
+let event_table = (Hashtbl.create 253 : (int, debug_event) Hashtbl.t)
+
+let relocate_event orig ev =
+  ev.ev_pos <- orig + ev.ev_pos;
+  match ev.ev_repr with
+    Event_parent repr -> repr := ev.ev_pos
+  | _                 -> ()
+
+let record_events orig evl =
+  List.iter
+    (fun ev ->
+      relocate_event orig ev;
+      Hashtbl.add event_table ev.ev_pos ev)
+    evl
+
+(* Print a structured constant *)
+
+let print_float f =
+  if String.contains f '.'
+  then printf "%s" f
+  else printf "%s." f
+;;
+
+let rec print_struct_const = function
+    Const_base(Const_int i) -> printf "%d" i
+  | Const_base(Const_float f) -> print_float f
+  | Const_base(Const_string (s, _)) -> printf "%S" s
+  | Const_immstring s -> printf "%S" s
+  | Const_base(Const_char c) -> printf "%C" c
+  | Const_base(Const_int32 i) -> printf "%ldl" i
+  | Const_base(Const_nativeint i) -> printf "%ndn" i
+  | Const_base(Const_int64 i) -> printf "%LdL" i
+  | Const_pointer n -> printf "%da" n
+  | Const_block(tag, args) ->
+      printf "<%d>" tag;
+      begin match args with
+        [] -> ()
+      | [a1] ->
+          printf "("; print_struct_const a1; printf ")"
+      | a1::al ->
+          printf "("; print_struct_const a1;
+          List.iter (fun a -> printf ", "; print_struct_const a) al;
+          printf ")"
+      end
+  | Const_float_array a ->
+      printf "[|";
+      List.iter (fun f -> print_float f; printf "; ") a;
+      printf "|]"
+
+(* Print an obj *)
+
+let same_custom x y =
+  Obj.field x 0 = Obj.field (Obj.repr y) 0
+
+let rec print_obj x =
+  if Obj.is_block x then begin
+    let tag = Obj.tag x in
+    if tag = Obj.string_tag then
+        printf "%S" (Obj.magic x : string)
+    else if tag = Obj.double_tag then
+        printf "%.12g" (Obj.magic x : float)
+    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
+          if i > 0 then printf ", ";
+          printf "%.12g" a.(i)
+        done;
+        printf "|]"
+    end else if tag = Obj.custom_tag && same_custom x 0l then
+        printf "%ldl" (Obj.magic x : int32)
+    else if tag = Obj.custom_tag && same_custom x 0n then
+        printf "%ndn" (Obj.magic x : nativeint)
+    else if tag = Obj.custom_tag && same_custom x 0L then
+        printf "%LdL" (Obj.magic x : int64)
+    else if tag < Obj.no_scan_tag then begin
+        printf "<%d>" (Obj.tag x);
+        match Obj.size x with
+          0 -> ()
+        | 1 ->
+            printf "("; print_obj (Obj.field x 0); printf ")"
+        | n ->
+            printf "("; print_obj (Obj.field x 0);
+            for i = 1 to n - 1 do
+              printf ", "; print_obj (Obj.field x i)
+            done;
+            printf ")"
+    end else
+        printf "" tag
+  end else
+    printf "%d" (Obj.magic x : int)
+
+(* Current position in input file *)
+
+let currpos ic =
+  pos_in ic - !start
+
+(* Access in the relocation table *)
+
+let rec rassoc key = function
+    [] -> raise Not_found
+  | (a,b) :: l -> if b = key then a else rassoc key l
+
+let find_reloc ic =
+  rassoc (pos_in ic - !start) !reloc
+
+(* Symbolic printing of global names, etc *)
+
+let print_getglobal_name ic =
+  if !objfile then begin
+    begin try
+      match find_reloc ic with
+          Reloc_getglobal id -> print_string (Ident.name id)
+        | Reloc_literal sc -> print_struct_const sc
+        | _ -> print_string ""
+    with Not_found ->
+      print_string ""
+    end;
+    ignore (inputu ic);
+  end
+  else begin
+    let n = inputu ic in
+    if n >= Array.length !globals || n < 0
+    then print_string ""
+    else match !globals.(n) with
+           Global id -> print_string(Ident.name id)
+         | Constant obj -> print_obj obj
+         | _ -> print_string "???"
+  end
+
+let print_setglobal_name ic =
+  if !objfile then begin
+    begin try
+      match find_reloc ic with
+        Reloc_setglobal id -> print_string (Ident.name id)
+      | _ -> print_string ""
+    with Not_found ->
+      print_string ""
+    end;
+    ignore (inputu ic);
+  end
+  else begin
+    let n = inputu ic in
+    if n >= Array.length !globals || n < 0
+    then print_string ""
+    else match !globals.(n) with
+           Global id -> print_string(Ident.name id)
+         | _ -> print_string "???"
+  end
+
+let print_primitive ic =
+  if !objfile then begin
+    begin try
+      match find_reloc ic with
+        Reloc_primitive s -> print_string s
+      | _ -> print_string ""
+    with Not_found ->
+      print_string ""
+    end;
+    ignore (inputu ic);
+  end
+  else begin
+    let n = inputu ic in
+    if n >= Array.length !primitives || n < 0
+    then print_int n
+    else print_string !primitives.(n)
+  end
+
+(* Disassemble one instruction *)
+
+let currpc ic =
+  currpos ic / 4
+
+type shape =
+  | Nothing
+  | Uint
+  | Sint
+  | Uint_Uint
+  | Disp
+  | Uint_Disp
+  | Sint_Disp
+  | Getglobal
+  | Getglobal_Uint
+  | Setglobal
+  | Primitive
+  | Uint_Primitive
+  | Switch
+  | Closurerec
+  | Pubmet
+;;
+
+let op_shapes = [
+  opACC0, Nothing;
+  opACC1, Nothing;
+  opACC2, Nothing;
+  opACC3, Nothing;
+  opACC4, Nothing;
+  opACC5, Nothing;
+  opACC6, Nothing;
+  opACC7, Nothing;
+  opACC, Uint;
+  opPUSH, Nothing;
+  opPUSHACC0, Nothing;
+  opPUSHACC1, Nothing;
+  opPUSHACC2, Nothing;
+  opPUSHACC3, Nothing;
+  opPUSHACC4, Nothing;
+  opPUSHACC5, Nothing;
+  opPUSHACC6, Nothing;
+  opPUSHACC7, Nothing;
+  opPUSHACC, Uint;
+  opPOP, Uint;
+  opASSIGN, Uint;
+  opENVACC1, Nothing;
+  opENVACC2, Nothing;
+  opENVACC3, Nothing;
+  opENVACC4, Nothing;
+  opENVACC, Uint;
+  opPUSHENVACC1, Nothing;
+  opPUSHENVACC2, Nothing;
+  opPUSHENVACC3, Nothing;
+  opPUSHENVACC4, Nothing;
+  opPUSHENVACC, Uint;
+  opPUSH_RETADDR, Disp;
+  opAPPLY, Uint;
+  opAPPLY1, Nothing;
+  opAPPLY2, Nothing;
+  opAPPLY3, Nothing;
+  opAPPTERM, Uint_Uint;
+  opAPPTERM1, Uint;
+  opAPPTERM2, Uint;
+  opAPPTERM3, Uint;
+  opRETURN, Uint;
+  opRESTART, Nothing;
+  opGRAB, Uint;
+  opCLOSURE, Uint_Disp;
+  opCLOSUREREC, Closurerec;
+  opOFFSETCLOSUREM2, Nothing;
+  opOFFSETCLOSURE0, Nothing;
+  opOFFSETCLOSURE2, Nothing;
+  opOFFSETCLOSURE, Sint;  (* was Uint *)
+  opPUSHOFFSETCLOSUREM2, Nothing;
+  opPUSHOFFSETCLOSURE0, Nothing;
+  opPUSHOFFSETCLOSURE2, Nothing;
+  opPUSHOFFSETCLOSURE, Sint; (* was Nothing *)
+  opGETGLOBAL, Getglobal;
+  opPUSHGETGLOBAL, Getglobal;
+  opGETGLOBALFIELD, Getglobal_Uint;
+  opPUSHGETGLOBALFIELD, Getglobal_Uint;
+  opSETGLOBAL, Setglobal;
+  opATOM0, Nothing;
+  opATOM, Uint;
+  opPUSHATOM0, Nothing;
+  opPUSHATOM, Uint;
+  opMAKEBLOCK, Uint_Uint;
+  opMAKEBLOCK1, Uint;
+  opMAKEBLOCK2, Uint;
+  opMAKEBLOCK3, Uint;
+  opMAKEFLOATBLOCK, Uint;
+  opGETFIELD0, Nothing;
+  opGETFIELD1, Nothing;
+  opGETFIELD2, Nothing;
+  opGETFIELD3, Nothing;
+  opGETFIELD, Uint;
+  opGETFLOATFIELD, Uint;
+  opSETFIELD0, Nothing;
+  opSETFIELD1, Nothing;
+  opSETFIELD2, Nothing;
+  opSETFIELD3, Nothing;
+  opSETFIELD, Uint;
+  opSETFLOATFIELD, Uint;
+  opVECTLENGTH, Nothing;
+  opGETVECTITEM, Nothing;
+  opSETVECTITEM, Nothing;
+  opGETSTRINGCHAR, Nothing;
+  opSETSTRINGCHAR, Nothing;
+  opBRANCH, Disp;
+  opBRANCHIF, Disp;
+  opBRANCHIFNOT, Disp;
+  opSWITCH, Switch;
+  opBOOLNOT, Nothing;
+  opPUSHTRAP, Disp;
+  opPOPTRAP, Nothing;
+  opRAISE, Nothing;
+  opCHECK_SIGNALS, Nothing;
+  opC_CALL1, Primitive;
+  opC_CALL2, Primitive;
+  opC_CALL3, Primitive;
+  opC_CALL4, Primitive;
+  opC_CALL5, Primitive;
+  opC_CALLN, Uint_Primitive;
+  opCONST0, Nothing;
+  opCONST1, Nothing;
+  opCONST2, Nothing;
+  opCONST3, Nothing;
+  opCONSTINT, Sint;
+  opPUSHCONST0, Nothing;
+  opPUSHCONST1, Nothing;
+  opPUSHCONST2, Nothing;
+  opPUSHCONST3, Nothing;
+  opPUSHCONSTINT, Sint;
+  opNEGINT, Nothing;
+  opADDINT, Nothing;
+  opSUBINT, Nothing;
+  opMULINT, Nothing;
+  opDIVINT, Nothing;
+  opMODINT, Nothing;
+  opANDINT, Nothing;
+  opORINT, Nothing;
+  opXORINT, Nothing;
+  opLSLINT, Nothing;
+  opLSRINT, Nothing;
+  opASRINT, Nothing;
+  opEQ, Nothing;
+  opNEQ, Nothing;
+  opLTINT, Nothing;
+  opLEINT, Nothing;
+  opGTINT, Nothing;
+  opGEINT, Nothing;
+  opOFFSETINT, Sint;
+  opOFFSETREF, Sint;
+  opISINT, Nothing;
+  opGETMETHOD, Nothing;
+  opGETDYNMET, Nothing;
+  opGETPUBMET, Pubmet;
+  opBEQ, Sint_Disp;
+  opBNEQ, Sint_Disp;
+  opBLTINT, Sint_Disp;
+  opBLEINT, Sint_Disp;
+  opBGTINT, Sint_Disp;
+  opBGEINT, Sint_Disp;
+  opULTINT, Nothing;
+  opUGEINT, Nothing;
+  opBULTINT, Uint_Disp;
+  opBUGEINT, Uint_Disp;
+  opSTOP, Nothing;
+  opEVENT, Nothing;
+  opBREAK, Nothing;
+  opRERAISE, Nothing;
+  opRAISE_NOTRACE, Nothing;
+];;
+
+let print_event ev =
+  if !print_locations then
+    let ls = ev.ev_loc.loc_start in
+    let le = ev.ev_loc.loc_end in
+    printf "File \"%s\", line %d, characters %d-%d:\n" ls.Lexing.pos_fname
+      ls.Lexing.pos_lnum (ls.Lexing.pos_cnum - ls.Lexing.pos_bol)
+      (le.Lexing.pos_cnum - ls.Lexing.pos_bol)
+
+let print_instr ic =
+  let pos = currpos ic in
+  List.iter print_event (Hashtbl.find_all event_table pos);
+  printf "%8d  " (pos / 4);
+  let op = inputu ic in
+  if op >= Array.length names_of_instructions || op < 0
+  then (print_string "*** unknown opcode : "; print_int op)
+  else print_string names_of_instructions.(op);
+  begin try
+    let shape = List.assoc op op_shapes in
+    if shape <> Nothing then print_string " ";
+    match shape with
+    | Uint -> print_int (inputu ic)
+    | Sint -> print_int (inputs ic)
+    | Uint_Uint
+       -> print_int (inputu ic); print_string ", "; print_int (inputu ic)
+    | Disp -> let p = currpc ic in print_int (p + inputs ic)
+    | Uint_Disp
+       -> print_int (inputu ic); print_string ", ";
+          let p = currpc ic in print_int (p + inputs ic)
+    | Sint_Disp
+       -> print_int (inputs ic); print_string ", ";
+          let p = currpc ic in print_int (p + inputs ic)
+    | Getglobal -> print_getglobal_name ic
+    | Getglobal_Uint
+       -> print_getglobal_name ic; print_string ", "; print_int (inputu ic)
+    | Setglobal -> print_setglobal_name ic
+    | Primitive -> print_primitive ic
+    | Uint_Primitive
+       -> print_int(inputu ic); print_string ", "; print_primitive ic
+    | Switch
+       -> let n = inputu ic in
+          let orig = currpc ic in
+          for i = 0 to (n land 0xFFFF) - 1 do
+            print_string "\n        int "; print_int i; print_string " -> ";
+            print_int(orig + inputs ic);
+          done;
+          for i = 0 to (n lsr 16) - 1 do
+            print_string "\n        tag "; print_int i; print_string " -> ";
+            print_int(orig + inputs ic);
+          done;
+    | Closurerec
+       -> let nfuncs = inputu ic in
+          let nvars = inputu ic in
+          let orig = currpc ic in
+          print_int nvars;
+          for _i = 0 to nfuncs - 1 do
+            print_string ", ";
+            print_int (orig + inputs 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;
+  print_string "\n";
+;;
+
+(* Disassemble a block of code *)
+
+let print_code ic len =
+  start := pos_in ic;
+  let stop = !start + len in
+  while pos_in ic < stop do print_instr ic done
+
+(* Dump relocation info *)
+
+let print_reloc (info, pos) =
+  printf "    %d    (%d)    " pos (pos/4);
+  match info with
+    Reloc_literal sc -> print_struct_const sc; printf "\n"
+  | Reloc_getglobal id -> printf "require    %s\n" (Ident.name id)
+  | Reloc_setglobal id -> printf "provide    %s\n" (Ident.name id)
+  | Reloc_primitive s -> printf "prim    %s\n" s
+
+(* Print a .cmo file *)
+
+let dump_obj ic =
+  let buffer = really_input_string ic (String.length cmo_magic_number) in
+  if buffer <> cmo_magic_number then begin
+    prerr_endline "Not an object file"; exit 2
+  end;
+  let cu_pos = input_binary_int ic in
+  seek_in ic cu_pos;
+  let cu = (input_value ic : compilation_unit) in
+  reloc := cu.cu_reloc;
+  if !print_reloc_info then
+    List.iter print_reloc cu.cu_reloc;
+  if cu.cu_debug > 0 then begin
+    seek_in ic cu.cu_debug;
+    let evl = (input_value ic : debug_event list) in
+    ignore (input_value ic); (* Skip the list of absolute directory names *)
+    record_events 0 evl
+  end;
+  seek_in ic cu.cu_pos;
+  print_code ic cu.cu_codesize
+
+(* Read the primitive table from an executable *)
+
+let read_primitive_table ic len =
+  let p = really_input_string ic len in
+  String.split_on_char '\000' p |> List.filter ((<>) "") |> Array.of_list
+
+(* Print an executable file *)
+
+let dump_exe ic =
+  Bytesections.read_toc ic;
+  let prim_size = Bytesections.seek_section ic "PRIM" in
+  primitives := read_primitive_table ic prim_size;
+  ignore(Bytesections.seek_section ic "DATA");
+  let init_data = (input_value ic : Obj.t array) in
+  globals := Array.make (Array.length init_data) Empty;
+  for i = 0 to Array.length init_data - 1 do
+    !globals.(i) <- Constant (init_data.(i))
+  done;
+  ignore(Bytesections.seek_section ic "SYMB");
+  let (_, sym_table) = (input_value ic : int * (Ident.t, int) Tbl.t) in
+  Tbl.iter (fun id pos -> !globals.(pos) <- Global id) sym_table;
+  begin try
+    ignore (Bytesections.seek_section ic "DBUG");
+    let num_eventlists = input_binary_int ic in
+    for _i = 1 to num_eventlists do
+      let orig = input_binary_int ic in
+      let evl = (input_value ic : debug_event list) in
+      ignore (input_value ic); (* Skip the list of absolute directory names *)
+      record_events orig evl
+    done
+  with Not_found -> ()
+  end;
+  let code_size = Bytesections.seek_section ic "CODE" in
+  print_code ic code_size
+
+let arg_list = [
+  "-noloc", Arg.Clear print_locations, " : don't print source information";
+  "-reloc", Arg.Set print_reloc_info, " : print relocation information";
+  "-args", Arg.Expand Arg.read_arg,
+     " Read additional newline separated command line arguments \n\
+     \      from ";
+  "-args0", Arg.Expand Arg.read_arg0,
+     " Read additional NUL separated command line arguments from \n\
+     \      ";
+]
+let arg_usage =
+  Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files"
+                 Sys.argv.(0)
+
+let first_file = ref true
+
+let arg_fun filename =
+  let ic = open_in_bin filename in
+  if not !first_file then print_newline ();
+  first_file := false;
+  printf "## start of ocaml dump of %S\n%!" filename;
+  begin try
+          objfile := false; dump_exe ic
+    with Bytesections.Bad_magic_number ->
+      objfile := true; seek_in ic 0; dump_obj ic
+  end;
+  close_in ic;
+  printf "## end of ocaml dump of %S\n%!" filename
+
+let main() =
+  Arg.parse_expand arg_list arg_fun arg_usage;
+    exit 0
+
+let _ = main ()
diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml
new file mode 100644
index 00000000..ae204bfb
--- /dev/null
+++ b/tools/eqparsetree.ml
@@ -0,0 +1,784 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Hongbo Zhang (University of Pennsylvania)                           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(*
+  This module is mainly used to diff two parsetree, it helps to automate the
+  test for parsing/pprintast.ml
+ *)
+
+
+open Parsetree
+let curry f (g, h) = f g h
+let eq_int : (int*int)->bool = curry (=)
+let eq_char : (char*char)->bool=curry (=)
+let eq_string : (string*string)->bool = curry (=)
+let eq_int32 : (int32*int32)->bool=curry (=)
+let eq_int64 : (int64*int64)->bool =curry (=)
+let eq_nativeint : (nativeint*nativeint)->bool= curry (=)
+let eq_bool :(bool*bool) -> bool = curry (=)
+let eq_list mf_a (xs, ys) =
+  let rec loop =
+    function
+      | ([], []) -> true
+        | (x :: xs, y :: ys) -> (mf_a (x, y)) && (loop (xs, ys))
+        | (_, _) -> false
+  in loop (xs, ys)
+let eq_option mf_a (x, y) =
+  match (x, y) with
+  | (None, None) -> true
+  | (Some x, Some y) -> mf_a (x, y)
+  | (_, _) -> false
+
+module Location =struct
+  include Location
+  let eq_t : (t*t) -> bool = fun (_,_) -> true
+end
+module Longident = struct
+  include Longident
+  let rec eq_t : (t * t) -> 'result =
+    function
+    | (Lident a0, Lident b0) -> eq_string (a0, b0)
+    | (Ldot (a0, a1), Ldot (b0, b1)) ->
+      (eq_t (a0, b0)) && (eq_string (a1, b1))
+    | (Lapply (a0, a1), Lapply (b0, b1)) ->
+      (eq_t (a0, b0)) && (eq_t (a1, b1))
+    | (_, _) -> false
+end
+module Asttypes = struct
+  open Asttypes
+  let eq_constant : (constant * constant) -> 'result =
+    function
+    | (Const_int a0, Const_int b0) -> eq_int (a0, b0)
+    | (Const_char a0, Const_char b0) -> eq_char (a0, b0)
+    | (Const_string a0, Const_string b0) -> eq_string (a0, b0)
+    | (Const_float a0, Const_float b0) -> eq_string (a0, b0)
+    | (Const_int32 a0, Const_int32 b0) -> eq_int32 (a0, b0)
+    | (Const_int64 a0, Const_int64 b0) -> eq_int64 (a0, b0)
+    | (Const_nativeint a0, Const_nativeint b0) -> eq_nativeint (a0, b0)
+    | (_, _) -> false
+
+  let eq_rec_flag : (rec_flag * rec_flag) -> 'result =
+    function
+    | (Nonrecursive, Nonrecursive) -> true
+    | (Recursive, Recursive) -> true
+    | (Default, Default) -> true
+    | (_, _) -> false
+
+  let eq_direction_flag :
+    (direction_flag * direction_flag) -> 'result =
+    function
+    | (Upto, Upto) -> true
+    | (Downto, Downto) -> true
+    | (_, _) -> false
+
+  let eq_private_flag : (private_flag * private_flag) -> 'result =
+    function
+    | (Private, Private) -> true
+    | (Public, Public) -> true
+    | (_, _) -> false
+
+  let eq_mutable_flag : (mutable_flag * mutable_flag) -> 'result =
+    function
+    | (Immutable, Immutable) -> true
+    | (Mutable, Mutable) -> true
+    | (_, _) -> false
+
+  let eq_virtual_flag : (virtual_flag * virtual_flag) -> 'result =
+    function
+    | (Virtual, Virtual) -> true
+    | (Concrete, Concrete) -> true
+    | (_, _) -> false
+
+  let eq_override_flag : (override_flag * override_flag) -> 'result =
+    function
+    | (Override, Override) -> true
+    | (Fresh, Fresh) -> true
+    | (_, _) -> false
+
+  let eq_closed_flag : (closed_flag * closed_flag) -> 'result =
+    function
+    | (Closed, Closed) -> true
+    | (Open, Open) -> true
+    | (_, _) -> false
+
+  let eq_label : (label * label) -> 'result =
+    fun (a0, a1) -> eq_string (a0, a1)
+
+  let  eq_loc :
+    'all_a0.
+      (('all_a0 * 'all_a0) -> 'result) ->
+        (('all_a0 loc) * ('all_a0 loc)) -> 'result =
+    fun mf_a ({ txt = a0; loc = a1 }, { txt = b0; loc = b1 }) ->
+      (mf_a (a0, b0)) && (Location.eq_t (a1, b1))
+
+end
+
+let rec eq_row_field : (row_field * row_field) -> 'result =
+  function
+  | (Rtag (a0, a1, a2), Rtag (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) && (eq_bool (a1, b1))) &&
+        (eq_list eq_core_type (a2, b2))
+  | (Rinherit a0, Rinherit b0) -> eq_core_type (a0, b0)
+  | (_, _) -> false
+and eq_core_field_desc :
+  (core_field_desc * core_field_desc) -> 'result =
+  function
+  | (Pfield (a0, a1), Pfield (b0, b1)) ->
+      (eq_string (a0, b0)) && (eq_core_type (a1, b1))
+  | (Pfield_var, Pfield_var) -> true
+  | (_, _) -> false
+and eq_core_field_type :
+  (core_field_type * core_field_type) -> 'result =
+  fun
+    ({ pfield_desc = a0; pfield_loc = a1 },
+     { pfield_desc = b0; pfield_loc = b1 })
+    -> (eq_core_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_package_type : (package_type * package_type) -> 'result =
+  fun (a0, a1) ->
+    (fun ((a0, a1), (b0, b1)) ->
+       (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_list
+            (fun ((a0, a1), (b0, b1)) ->
+               (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+                 (eq_core_type (a1, b1)))
+            (a1, b1)))
+      (a0, a1)
+and eq_core_type_desc :
+  (core_type_desc * core_type_desc) -> 'result =
+  function
+  | (Ptyp_any, Ptyp_any) -> true
+  | (Ptyp_var a0, Ptyp_var b0) -> eq_string (a0, b0)
+  | (Ptyp_arrow (a0, a1, a2), Ptyp_arrow (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) && (eq_core_type (a1, b1))) &&
+        (eq_core_type (a2, b2))
+  | (Ptyp_tuple a0, Ptyp_tuple b0) -> eq_list eq_core_type (a0, b0)
+  | (Ptyp_constr (a0, a1), Ptyp_constr (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_list eq_core_type (a1, b1))
+  | (Ptyp_object a0, Ptyp_object b0) ->
+      eq_list eq_core_field_type (a0, b0)
+  | (Ptyp_class (a0, a1, a2), Ptyp_class (b0, b1, b2)) ->
+      ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_list eq_core_type (a1, b1)))
+        && (eq_list Asttypes.eq_label (a2, b2))
+  | (Ptyp_alias (a0, a1), Ptyp_alias (b0, b1)) ->
+      (eq_core_type (a0, b0)) && (eq_string (a1, b1))
+  | (Ptyp_variant (a0, a1, a2), Ptyp_variant (b0, b1, b2)) ->
+      ((eq_list eq_row_field (a0, b0)) && (eq_bool (a1, b1))) &&
+        (eq_option (eq_list Asttypes.eq_label) (a2, b2))
+  | (Ptyp_poly (a0, a1), Ptyp_poly (b0, b1)) ->
+      (eq_list eq_string (a0, b0)) && (eq_core_type (a1, b1))
+  | (Ptyp_package a0, Ptyp_package b0) -> eq_package_type (a0, b0)
+  | (_, _) -> false
+and eq_core_type : (core_type * core_type) -> 'result =
+  fun
+    ({ ptyp_desc = a0; ptyp_loc = a1 },
+     { ptyp_desc = b0; ptyp_loc = b1 })
+    -> (eq_core_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
+let eq_class_infos :
+  'all_a0.
+    (('all_a0 * 'all_a0) -> 'result) ->
+      (('all_a0 class_infos) * ('all_a0 class_infos)) -> 'result =
+  fun mf_a
+    ({
+       pci_virt = a0;
+       pci_params = a1;
+       pci_name = a2;
+       pci_expr = a3;
+       pci_variance = a4;
+       pci_loc = a5
+     },
+     {
+       pci_virt = b0;
+       pci_params = b1;
+       pci_name = b2;
+       pci_expr = b3;
+       pci_variance = b4;
+       pci_loc = b5
+     })
+    ->
+    (((((Asttypes.eq_virtual_flag (a0, b0)) &&
+          ((fun ((a0, a1), (b0, b1)) ->
+              (eq_list (Asttypes.eq_loc eq_string) (a0, b0)) &&
+                (Location.eq_t (a1, b1)))
+             (a1, b1)))
+         && (Asttypes.eq_loc eq_string (a2, b2)))
+        && (mf_a (a3, b3)))
+       &&
+       (eq_list
+          (fun ((a0, a1), (b0, b1)) ->
+             (eq_bool (a0, b0)) && (eq_bool (a1, b1)))
+          (a4, b4)))
+      && (Location.eq_t (a5, b5))
+
+let rec eq_pattern_desc : (pattern_desc * pattern_desc) -> 'result =
+  function
+  | (Ppat_any, Ppat_any) -> true
+  | (Ppat_var a0, Ppat_var b0) -> Asttypes.eq_loc eq_string (a0, b0)
+  | (Ppat_alias (a0, a1), Ppat_alias (b0, b1)) ->
+      (eq_pattern (a0, b0)) && (Asttypes.eq_loc eq_string (a1, b1))
+  | (Ppat_constant a0, Ppat_constant b0) ->
+      Asttypes.eq_constant (a0, b0)
+  | (Ppat_tuple a0, Ppat_tuple b0) -> eq_list eq_pattern (a0, b0)
+  | (Ppat_construct (a0, a1), Ppat_construct (b0, b1)) ->
+      ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_option eq_pattern (a1, b1)))
+  | (Ppat_variant (a0, a1), Ppat_variant (b0, b1)) ->
+      (Asttypes.eq_label (a0, b0)) && (eq_option eq_pattern (a1, b1))
+  | (Ppat_record (a0, a1), Ppat_record (b0, b1)) ->
+      (eq_list
+         (fun ((a0, a1), (b0, b1)) ->
+            (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+              (eq_pattern (a1, b1)))
+         (a0, b0))
+        && (Asttypes.eq_closed_flag (a1, b1))
+  | (Ppat_array a0, Ppat_array b0) -> eq_list eq_pattern (a0, b0)
+  | (Ppat_or (a0, a1), Ppat_or (b0, b1)) ->
+      (eq_pattern (a0, b0)) && (eq_pattern (a1, b1))
+  | (Ppat_constraint (a0, a1), Ppat_constraint (b0, b1)) ->
+      (eq_pattern (a0, b0)) && (eq_core_type (a1, b1))
+  | (Ppat_type a0, Ppat_type b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Ppat_lazy a0, Ppat_lazy b0) -> eq_pattern (a0, b0)
+  | (Ppat_unpack a0, Ppat_unpack b0) ->
+      Asttypes.eq_loc eq_string (a0, b0)
+  | (_, _) -> false
+and eq_pattern : (pattern * pattern) -> 'result =
+  fun
+    ({ ppat_desc = a0; ppat_loc = a1 },
+     { ppat_desc = b0; ppat_loc = b1 })
+    -> (eq_pattern_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
+let rec eq_structure_item_desc :
+  (structure_item_desc * structure_item_desc) -> 'result =
+  function
+  | (Pstr_eval a0, Pstr_eval b0) -> eq_expression (a0, b0)
+  | (Pstr_value (a0, a1), Pstr_value (b0, b1)) ->
+      (Asttypes.eq_rec_flag (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pstr_primitive (a0, a1), Pstr_primitive (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_value_description (a1, b1))
+  | (Pstr_type (a0, a1), Pstr_type (b0, b1)) ->
+      (Asttypes.eq_rec_flag (a0, b0)) &&
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_type_declaration (a1, b1)))
+        (a1, b1)
+  | (Pstr_exception (a0, a1), Pstr_exception (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_exception_declaration (a1, b1))
+  | (Pstr_exn_rebind (a0, a1), Pstr_exn_rebind (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (Asttypes.eq_loc Longident.eq_t (a1, b1))
+  | (Pstr_module (a0, a1), Pstr_module (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_module_expr (a1, b1))
+  | (Pstr_recmodule a0, Pstr_recmodule b0) ->
+      eq_list
+        (fun ((a0, a1, a2), (b0, b1, b2)) ->
+           ((Asttypes.eq_loc eq_string (a0, b0)) &&
+              (eq_module_type (a1, b1)))
+             && (eq_module_expr (a2, b2)))
+        (a0, b0)
+  | (Pstr_modtype (a0, a1), Pstr_modtype (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_module_type (a1, b1))
+  | (Pstr_open a0, Pstr_open b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pstr_class a0, Pstr_class b0) ->
+      eq_list eq_class_declaration (a0, b0)
+  | (Pstr_class_type a0, Pstr_class_type b0) ->
+      eq_list eq_class_type_declaration (a0, b0)
+  | (Pstr_include a0, Pstr_include b0) -> eq_module_expr (a0, b0)
+  | (_, _) -> false
+and eq_structure_item :
+  (structure_item * structure_item) -> 'result =
+  fun
+    ({ pstr_desc = a0; pstr_loc = a1 },
+     { pstr_desc = b0; pstr_loc = b1 })
+    -> (eq_structure_item_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_structure : (structure * structure) -> 'result =
+  fun (a0, a1) -> eq_list eq_structure_item (a0, a1)
+and eq_module_expr_desc :
+  (module_expr_desc * module_expr_desc) -> 'result =
+  function
+  | (Pmod_ident a0, Pmod_ident b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pmod_structure a0, Pmod_structure b0) -> eq_structure (a0, b0)
+  | (Pmod_functor (a0, a1, a2), Pmod_functor (b0, b1, b2)) ->
+      ((Asttypes.eq_loc eq_string (a0, b0)) &&
+         (eq_module_type (a1, b1)))
+        && (eq_module_expr (a2, b2))
+  | (Pmod_apply (a0, a1), Pmod_apply (b0, b1)) ->
+      (eq_module_expr (a0, b0)) && (eq_module_expr (a1, b1))
+  | (Pmod_constraint (a0, a1), Pmod_constraint (b0, b1)) ->
+      (eq_module_expr (a0, b0)) && (eq_module_type (a1, b1))
+  | (Pmod_unpack a0, Pmod_unpack b0) -> eq_expression (a0, b0)
+  | (_, _) -> false
+and eq_module_expr : (module_expr * module_expr) -> 'result =
+  fun
+    ({ pmod_desc = a0; pmod_loc = a1 },
+     { pmod_desc = b0; pmod_loc = b1 })
+    -> (eq_module_expr_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_with_constraint :
+  (with_constraint * with_constraint) -> 'result =
+  function
+  | (Pwith_type a0, Pwith_type b0) -> eq_type_declaration (a0, b0)
+  | (Pwith_module a0, Pwith_module b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pwith_typesubst a0, Pwith_typesubst b0) ->
+      eq_type_declaration (a0, b0)
+  | (Pwith_modsubst a0, Pwith_modsubst b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (_, _) -> false
+and eq_modtype_declaration :
+  (modtype_declaration * modtype_declaration) -> 'result =
+  function
+  | (Pmodtype_abstract, Pmodtype_abstract) -> true
+  | (Pmodtype_manifest a0, Pmodtype_manifest b0) ->
+      eq_module_type (a0, b0)
+  | (_, _) -> false
+and eq_signature_item_desc :
+  (signature_item_desc * signature_item_desc) -> 'result =
+  function
+  | (Psig_value (a0, a1), Psig_value (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_value_description (a1, b1))
+  | (Psig_type (a0, a1), Psig_type (b0, b1)) ->
+      (Asttypes.eq_rec_flag (a0, b0)) &&
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_type_declaration (a1, b1)))
+        (a1, b1)
+  | (Psig_exception (a0, a1), Psig_exception (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_exception_declaration (a1, b1))
+  | (Psig_module (a0, a1), Psig_module (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_module_type (a1, b1))
+  | (Psig_recmodule a0, Psig_recmodule b0) ->
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_module_type (a1, b1)))
+        (a0, b0)
+  | (Psig_modtype (a0, a1), Psig_modtype (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_modtype_declaration (a1, b1))
+  | (Psig_open a0, Psig_open b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Psig_include a0, Psig_include b0) -> eq_module_type (a0, b0)
+  | (Psig_class a0, Psig_class b0) ->
+      eq_list eq_class_description (a0, b0)
+  | (Psig_class_type a0, Psig_class_type b0) ->
+      eq_list eq_class_type_declaration (a0, b0)
+  | (_, _) -> false
+and eq_signature_item :
+  (signature_item * signature_item) -> 'result =
+  fun
+    ({ psig_desc = a0; psig_loc = a1 },
+     { psig_desc = b0; psig_loc = b1 })
+    -> (eq_signature_item_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_signature : (signature * signature) -> 'result =
+  fun (a0, a1) -> eq_list eq_signature_item (a0, a1)
+and eq_module_type_desc :
+  (module_type_desc * module_type_desc) -> 'result =
+  function
+  | (Pmty_ident a0, Pmty_ident b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pmty_signature a0, Pmty_signature b0) -> eq_signature (a0, b0)
+  | (Pmty_functor (a0, a1, a2), Pmty_functor (b0, b1, b2)) ->
+      ((Asttypes.eq_loc eq_string (a0, b0)) &&
+         (eq_module_type (a1, b1)))
+        && (eq_module_type (a2, b2))
+  | (Pmty_with (a0, a1), Pmty_with (b0, b1)) ->
+      (eq_module_type (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+                (eq_with_constraint (a1, b1)))
+           (a1, b1))
+  | (Pmty_typeof a0, Pmty_typeof b0) -> eq_module_expr (a0, b0)
+  | (_, _) -> false
+and eq_module_type : (module_type * module_type) -> 'result =
+  fun
+    ({ pmty_desc = a0; pmty_loc = a1 },
+     { pmty_desc = b0; pmty_loc = b1 })
+    -> (eq_module_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_declaration :
+  (class_declaration * class_declaration) -> 'result =
+  fun (a0, a1) -> eq_class_infos eq_class_expr (a0, a1)
+and eq_class_field_desc :
+  (class_field_desc * class_field_desc) -> 'result =
+  function
+  | (Pcf_inher (a0, a1, a2), Pcf_inher (b0, b1, b2)) ->
+      ((Asttypes.eq_override_flag (a0, b0)) &&
+         (eq_class_expr (a1, b1)))
+        && (eq_option eq_string (a2, b2))
+  | (Pcf_valvirt a0, Pcf_valvirt b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((Asttypes.eq_loc eq_string (a0, b0)) &&
+            (Asttypes.eq_mutable_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pcf_val a0, Pcf_val b0) ->
+      (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+         (((Asttypes.eq_loc eq_string (a0, b0)) &&
+             (Asttypes.eq_mutable_flag (a1, b1)))
+            && (Asttypes.eq_override_flag (a2, b2)))
+           && (eq_expression (a3, b3)))
+        (a0, b0)
+  | (Pcf_virt a0, Pcf_virt b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((Asttypes.eq_loc eq_string (a0, b0)) &&
+            (Asttypes.eq_private_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pcf_meth a0, Pcf_meth b0) ->
+      (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+         (((Asttypes.eq_loc eq_string (a0, b0)) &&
+             (Asttypes.eq_private_flag (a1, b1)))
+            && (Asttypes.eq_override_flag (a2, b2)))
+           && (eq_expression (a3, b3)))
+        (a0, b0)
+  | (Pcf_constr a0, Pcf_constr b0) ->
+      (fun ((a0, a1), (b0, b1)) ->
+         (eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+        (a0, b0)
+  | (Pcf_init a0, Pcf_init b0) -> eq_expression (a0, b0)
+  | (_, _) -> false
+and eq_class_field : (class_field * class_field) -> 'result =
+  fun
+    ({ pcf_desc = a0; pcf_loc = a1 }, { pcf_desc = b0; pcf_loc = b1
+     })
+    -> (eq_class_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_structure :
+  (class_structure * class_structure) -> 'result =
+  fun
+    ({ pcstr_self = a0; pcstr_fields = a1 },
+     { pcstr_self = b0; pcstr_fields = b1 })
+    -> (eq_pattern (a0, b0)) && (eq_list eq_class_field (a1, b1))
+and eq_class_expr_desc :
+  (class_expr_desc * class_expr_desc) -> 'result =
+  function
+  | (Pcl_constr (a0, a1), Pcl_constr (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_list eq_core_type (a1, b1))
+  | (Pcl_structure a0, Pcl_structure b0) ->
+      eq_class_structure (a0, b0)
+  | (Pcl_fun (a0, a1, a2, a3), Pcl_fun (b0, b1, b2, b3)) ->
+      (((Asttypes.eq_label (a0, b0)) &&
+          (eq_option eq_expression (a1, b1)))
+         && (eq_pattern (a2, b2)))
+        && (eq_class_expr (a3, b3))
+  | (Pcl_apply (a0, a1), Pcl_apply (b0, b1)) ->
+      (eq_class_expr (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (Asttypes.eq_label (a0, b0)) &&
+                (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pcl_let (a0, a1, a2), Pcl_let (b0, b1, b2)) ->
+      ((Asttypes.eq_rec_flag (a0, b0)) &&
+         (eq_list
+            (fun ((a0, a1), (b0, b1)) ->
+               (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+            (a1, b1)))
+        && (eq_class_expr (a2, b2))
+  | (Pcl_constraint (a0, a1), Pcl_constraint (b0, b1)) ->
+      (eq_class_expr (a0, b0)) && (eq_class_type (a1, b1))
+  | (_, _) -> false
+and eq_class_expr : (class_expr * class_expr) -> 'result =
+  fun
+    ({ pcl_desc = a0; pcl_loc = a1 }, { pcl_desc = b0; pcl_loc = b1
+     })
+    -> (eq_class_expr_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_type_declaration :
+  (class_type_declaration * class_type_declaration) -> 'result =
+  fun (a0, a1) -> eq_class_infos eq_class_type (a0, a1)
+and eq_class_description :
+  (class_description * class_description) -> 'result =
+  fun (a0, a1) -> eq_class_infos eq_class_type (a0, a1)
+and eq_class_type_field_desc :
+  (class_type_field_desc * class_type_field_desc) -> 'result =
+  function
+  | (Pctf_inher a0, Pctf_inher b0) -> eq_class_type (a0, b0)
+  | (Pctf_val a0, Pctf_val b0) ->
+      (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+         (((eq_string (a0, b0)) &&
+             (Asttypes.eq_mutable_flag (a1, b1)))
+            && (Asttypes.eq_virtual_flag (a2, b2)))
+           && (eq_core_type (a3, b3)))
+        (a0, b0)
+  | (Pctf_virt a0, Pctf_virt b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((eq_string (a0, b0)) && (Asttypes.eq_private_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pctf_meth a0, Pctf_meth b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((eq_string (a0, b0)) && (Asttypes.eq_private_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pctf_cstr a0, Pctf_cstr b0) ->
+      (fun ((a0, a1), (b0, b1)) ->
+         (eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+        (a0, b0)
+  | (_, _) -> false
+and eq_class_type_field :
+  (class_type_field * class_type_field) -> 'result =
+  fun
+    ({ pctf_desc = a0; pctf_loc = a1 },
+     { pctf_desc = b0; pctf_loc = b1 })
+    ->
+    (eq_class_type_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_signature :
+  (class_signature * class_signature) -> 'result =
+  fun
+    ({ pcsig_self = a0; pcsig_fields = a1; pcsig_loc = a2 },
+     { pcsig_self = b0; pcsig_fields = b1; pcsig_loc = b2 })
+    ->
+    ((eq_core_type (a0, b0)) &&
+       (eq_list eq_class_type_field (a1, b1)))
+      && (Location.eq_t (a2, b2))
+and eq_class_type_desc :
+  (class_type_desc * class_type_desc) -> 'result =
+  function
+  | (Pcty_constr (a0, a1), Pcty_constr (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_list eq_core_type (a1, b1))
+  | (Pcty_signature a0, Pcty_signature b0) ->
+      eq_class_signature (a0, b0)
+  | (Pcty_arrow (a0, a1, a2), Pcty_arrow (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) && (eq_core_type (a1, b1))) &&
+        (eq_class_type (a2, b2))
+  | (_, _) -> false
+and eq_class_type : (class_type * class_type) -> 'result =
+  fun
+    ({ pcty_desc = a0; pcty_loc = a1 },
+     { pcty_desc = b0; pcty_loc = b1 })
+    -> (eq_class_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_exception_declaration :
+  (exception_declaration * exception_declaration) -> 'result =
+  fun (a0, a1) -> eq_list eq_core_type (a0, a1)
+and eq_type_kind : (type_kind * type_kind) -> 'result =
+  function
+  | (Ptype_abstract, Ptype_abstract) -> true
+  | (Ptype_variant a0, Ptype_variant b0) ->
+      eq_list
+        (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+           (((Asttypes.eq_loc eq_string (a0, b0)) &&
+               (eq_list eq_core_type (a1, b1)))
+              && (eq_option eq_core_type (a2, b2)))
+             && (Location.eq_t (a3, b3)))
+        (a0, b0)
+  | (Ptype_record a0, Ptype_record b0) ->
+      eq_list
+        (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+           (((Asttypes.eq_loc eq_string (a0, b0)) &&
+               (Asttypes.eq_mutable_flag (a1, b1)))
+              && (eq_core_type (a2, b2)))
+             && (Location.eq_t (a3, b3)))
+        (a0, b0)
+  | (_, _) -> false
+and eq_type_declaration :
+  (type_declaration * type_declaration) -> 'result =
+  fun
+    ({
+       ptype_params = a0;
+       ptype_cstrs = a1;
+       ptype_kind = a2;
+       ptype_private = a3;
+       ptype_manifest = a4;
+       ptype_variance = a5;
+       ptype_loc = a6
+     },
+     {
+       ptype_params = b0;
+       ptype_cstrs = b1;
+       ptype_kind = b2;
+       ptype_private = b3;
+       ptype_manifest = b4;
+       ptype_variance = b5;
+       ptype_loc = b6
+     })
+    ->
+    ((((((eq_list (eq_option (Asttypes.eq_loc eq_string)) (a0, b0))
+           &&
+           (eq_list
+              (fun ((a0, a1, a2), (b0, b1, b2)) ->
+                 ((eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+                   && (Location.eq_t (a2, b2)))
+              (a1, b1)))
+          && (eq_type_kind (a2, b2)))
+         && (Asttypes.eq_private_flag (a3, b3)))
+        && (eq_option eq_core_type (a4, b4)))
+       &&
+       (eq_list
+          (fun ((a0, a1), (b0, b1)) ->
+             (eq_bool (a0, b0)) && (eq_bool (a1, b1)))
+          (a5, b5)))
+      && (Location.eq_t (a6, b6))
+and eq_value_description :
+  (value_description * value_description) -> 'result =
+  fun
+    ({ pval_type = a0; pval_prim = a1; pval_loc = a2 },
+     { pval_type = b0; pval_prim = b1; pval_loc = b2 })
+    ->
+    ((eq_core_type (a0, b0)) && (eq_list eq_string (a1, b1))) &&
+      (Location.eq_t (a2, b2))
+and eq_expression_desc :
+  (expression_desc * expression_desc) -> 'result =
+  function
+  | (Pexp_ident a0, Pexp_ident b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pexp_constant a0, Pexp_constant b0) ->
+      Asttypes.eq_constant (a0, b0)
+  | (Pexp_let (a0, a1, a2), Pexp_let (b0, b1, b2)) ->
+      ((Asttypes.eq_rec_flag (a0, b0)) &&
+         (eq_list
+            (fun ((a0, a1), (b0, b1)) ->
+               (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+            (a1, b1)))
+        && (eq_expression (a2, b2))
+  | Pexp_fun (a1, a1, a2, a3), Pexp_function (b0, b1, b2, b3) ->
+      ((Asttypes.eq_label (a0, b0)) &&
+       (eq_option eq_expression (a1, b1)) &&
+       (eq_pattern a2 b2) &&
+       (eq_expression (a3, b3)))
+  | (Pexp_function (a0, a1, a2), Pexp_function (b0, b1, b2)) ->
+      (* FIX *)
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+          (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+        (a2, b2)
+  | (Pexp_apply (a0, a1), Pexp_apply (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (Asttypes.eq_label (a0, b0)) &&
+                (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pexp_match (a0, a1), Pexp_match (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pexp_try (a0, a1), Pexp_try (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pexp_tuple a0, Pexp_tuple b0) -> eq_list eq_expression (a0, b0)
+  | (Pexp_construct (a0, a1), Pexp_construct (b0, b1)) ->
+      ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_option eq_expression (a1, b1)))
+  | (Pexp_variant (a0, a1), Pexp_variant (b0, b1)) ->
+      (Asttypes.eq_label (a0, b0)) &&
+        (eq_option eq_expression (a1, b1))
+  | (Pexp_record (a0, a1), Pexp_record (b0, b1)) ->
+      (eq_list
+         (fun ((a0, a1), (b0, b1)) ->
+            (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+              (eq_expression (a1, b1)))
+         (a0, b0))
+        && (eq_option eq_expression (a1, b1))
+  | (Pexp_field (a0, a1), Pexp_field (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (Asttypes.eq_loc Longident.eq_t (a1, b1))
+  | (Pexp_setfield (a0, a1, a2), Pexp_setfield (b0, b1, b2)) ->
+      ((eq_expression (a0, b0)) &&
+         (Asttypes.eq_loc Longident.eq_t (a1, b1)))
+        && (eq_expression (a2, b2))
+  | (Pexp_array a0, Pexp_array b0) -> eq_list eq_expression (a0, b0)
+  | (Pexp_ifthenelse (a0, a1, a2), Pexp_ifthenelse (b0, b1, b2)) ->
+      ((eq_expression (a0, b0)) && (eq_expression (a1, b1))) &&
+        (eq_option eq_expression (a2, b2))
+  | (Pexp_sequence (a0, a1), Pexp_sequence (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_while (a0, a1), Pexp_while (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_for (a0, a1, a2, a3, a4), Pexp_for (b0, b1, b2, b3, b4)) ->
+      ((((Asttypes.eq_loc eq_string (a0, b0)) &&
+           (eq_expression (a1, b1)))
+          && (eq_expression (a2, b2)))
+         && (Asttypes.eq_direction_flag (a3, b3)))
+        && (eq_expression (a4, b4))
+  | (Pexp_constraint (a0, a1, a2), Pexp_constraint (b0, b1, b2)) ->
+      ((eq_expression (a0, b0)) && (eq_option eq_core_type (a1, b1)))
+        && (eq_option eq_core_type (a2, b2))
+  | (Pexp_when (a0, a1), Pexp_when (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_send (a0, a1), Pexp_send (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_string (a1, b1))
+  | (Pexp_new a0, Pexp_new b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pexp_setinstvar (a0, a1), Pexp_setinstvar (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_expression (a1, b1))
+  | (Pexp_override a0, Pexp_override b0) ->
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_expression (a1, b1)))
+        (a0, b0)
+  | (Pexp_letmodule (a0, a1, a2), Pexp_letmodule (b0, b1, b2)) ->
+      ((Asttypes.eq_loc eq_string (a0, b0)) &&
+         (eq_module_expr (a1, b1)))
+        && (eq_expression (a2, b2))
+  | (Pexp_assert a0, Pexp_assert b0) -> eq_expression (a0, b0)
+  | (Pexp_lazy a0, Pexp_lazy b0) -> eq_expression (a0, b0)
+  | (Pexp_poly (a0, a1), Pexp_poly (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_option eq_core_type (a1, b1))
+  | (Pexp_object a0, Pexp_object b0) -> eq_class_structure (a0, b0)
+  | (Pexp_newtype (a0, a1), Pexp_newtype (b0, b1)) ->
+      (eq_string (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_pack a0, Pexp_pack b0) -> eq_module_expr (a0, b0)
+  | (Pexp_open (a0, a1), Pexp_open (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_expression (a1, b1))
+  | (_, _) -> false
+and eq_expression : (expression * expression) -> 'result =
+  fun
+    ({ pexp_desc = a0; pexp_loc = a1 },
+     { pexp_desc = b0; pexp_loc = b1 })
+    -> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
+let rec eq_directive_argument :
+  (directive_argument * directive_argument) -> 'result =
+  function
+  | (Pdir_none, Pdir_none) -> true
+  | (Pdir_string a0, Pdir_string b0) -> eq_string (a0, b0)
+  | (Pdir_int a0, Pdir_int b0) -> eq_int (a0, b0)
+  | (Pdir_ident a0, Pdir_ident b0) -> Longident.eq_t (a0, b0)
+  | (Pdir_bool a0, Pdir_bool b0) -> eq_bool (a0, b0)
+  | (_, _) -> false
+and eq_toplevel_phrase :
+  (toplevel_phrase * toplevel_phrase) -> 'result =
+  function
+  | (Ptop_def a0, Ptop_def b0) -> eq_structure (a0, b0)
+  | (Ptop_dir (a0, a1), Ptop_dir (b0, b1)) ->
+      (eq_string (a0, b0)) && (eq_directive_argument (a1, b1))
+  | (_, _) -> false
diff --git a/tools/gdb-macros b/tools/gdb-macros
new file mode 100644
index 00000000..3c8c33a6
--- /dev/null
+++ b/tools/gdb-macros
@@ -0,0 +1,321 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Damien Doligez, Jane Street Group, LLC                 *
+#*                                                                        *
+#*   Copyright 2015 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# A set of macros for low-level debugging of OCaml programs and of the
+# OCaml runtime itself (both native and byte-code).
+
+# This file should be loaded in gdb with [ source gdb-macros ].
+# It defines one command: [caml]
+# Usage:
+# [caml ]
+# If  is an OCaml value, this will display it in a low-level
+# but legible format, including the header information.
+
+# To do: a [camlsearch] command to find all (gc-traceable) pointers to
+# a given heap block.
+
+set $camlwordsize = sizeof(char *)
+
+if $camlwordsize == 8
+  set $caml_unalloc_mask = 0xFF00FFFFFF00FFFF
+  set $caml_unalloc_value = 0xD700D7D7D700D6D7
+else
+  set $caml_unalloc_mask = 0xFF00FFFF
+  set $caml_unalloc_value = 0xD700D6D7
+end
+
+define camlcheckheader
+  if $arg0 >> 10 <= 0 || $arg0 >> 10 >= 0x1000000000000
+    if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value
+      set $camlcheckheader_result = 2
+    else
+      if $arg0 == (unsigned long) 0
+        set $camlcheckheader_result = 3
+      else
+        set $camlcheckheader_result = 1
+      end
+    end
+  else
+    set $camlcheckheader_result = 0
+  end
+end
+
+define camlheader
+  set $hd = * (unsigned long *) ($arg0 - $camlwordsize)
+  set $tag = $hd & 0xFF
+  set $color = ($hd >> 8) & 3
+  set $size = $hd >> 10
+
+  camlcheckheader $hd
+  if $camlcheckheader_result != 0
+    if $camlcheckheader_result == 2
+      printf "[UNALLOCATED MEMORY]"
+    else
+      if $camlcheckheader_result == 3
+        printf "[** fragment **] 0x%016lu", $hd
+      else
+        printf "[**invalid header**] 0x%016lu", $hd
+      end
+    end
+    set $size = 0
+  else
+    printf "["
+    if $color == 0
+      printf "white "
+    end
+    if $color == 1
+      printf "gray "
+    end
+    if $color == 2
+      printf "blue "
+    end
+    if $color == 3
+      printf "black "
+    end
+
+    if $tag < 246
+      printf "tag%d ", $tag
+    end
+    if $tag == 246
+      printf "Lazy "
+    end
+    if $tag == 247
+      printf "Closure "
+    end
+    if $tag == 248
+      printf "Object "
+    end
+    if $tag == 249
+      printf "Infix "
+    end
+    if $tag == 250
+      printf "Forward "
+    end
+    if $tag == 251
+      printf "Abstract "
+    end
+    if $tag == 252
+      printf "String "
+    end
+    if $tag == 253
+      printf "Double "
+    end
+    if $tag == 254
+      printf "Double_array "
+    end
+    if $tag == 255
+      printf "Custom "
+    end
+
+    printf "%lu]", $size
+  end
+end
+
+define camlheap
+  if $arg0 >= caml_young_start && $arg0 < caml_young_end
+    printf "YOUNG"
+    set $camlheap_result = 1
+  else
+    set $chunk = caml_heap_start
+    set $found = 0
+    while $chunk != 0 && ! $found
+      set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize)
+      if $arg0 > $chunk && $arg0 <= $chunk + $chunk_size
+        printf "OLD"
+        set $found = 1
+      end
+      set $chunk = * (unsigned long *) ($chunk - $camlwordsize)
+    end
+    if $found
+      set $camlheap_result = 1
+    else
+      printf "OUT-OF-HEAP"
+      set $camlheap_result = 0
+    end
+  end
+end
+
+define camlint
+  if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value
+    printf "UNALLOCATED MEMORY"
+  else
+    printf "INT %ld", ($arg0 >> 1)
+  end
+  if ($arg0 & 0xFF) == 0xF9 && ($arg0 >> 10) < 0x1000000000000
+    printf " [possible infix header]"
+  end
+end
+
+define camlblock
+  printf "%#lx: ", $arg0 - $camlwordsize
+  camlheap $arg0
+  printf " "
+  camlheader $arg0
+  set $mysize = $size
+  set $camlnext = $arg0 + $camlwordsize * ($size + 1)
+  printf "\n"
+
+  if $tag == 252
+    x/s $arg0
+  end
+  if $tag == 253
+    x/f $arg0
+  end
+  if $tag == 254
+    while $count < $mysize && $count < 10
+      if $count + 1 < $size
+        x/2f $arg0 + $camlwordsize * $count
+      else
+        x/f $arg0 + $camlwordsize * $count
+      end
+      set $count = $count + 2
+    end
+    if $count < $mysize
+      printf "... truncated ...\n"
+    end
+  end
+
+  if $tag == 249
+    printf "... infix header, displaying enclosing block:\n"
+    set $mybaseaddr = $arg0 - $camlwordsize * $mysize
+    camlblock $mybaseaddr
+    # reset $tag, which was clobbered by the recursive call (yuck)
+    set $tag = 249
+  end
+
+  if $tag != 249 && $tag != 252 && $tag != 253 && $tag != 254
+    set $isvalues = $tag < 251
+    set $count = 0
+    while $count < $mysize && $count < 10
+      set $adr = $arg0 + $camlwordsize * $count
+      set $field = * (unsigned long *) $adr
+      printf "%#lx: [%d] 0x%016lx ", $adr, $count, $field
+      if ($field & 7) == 0 && $isvalues
+        camlheap $field
+        if $camlheap_result
+          printf " "
+          camlheader $field
+        end
+      end
+      if ($field & 1) == 1
+        camlint $field
+      end
+      printf "\n"
+      set $count = $count + 1
+    end
+    if $count < $mysize
+      printf "... truncated ...\n"
+    end
+  end
+  printf "next block head: %#lx   value: %#lx\n", \
+         $arg0 + $camlwordsize * $mysize, $arg0 + $camlwordsize * ($mysize+1)
+end
+
+# displays an OCaml value
+define caml
+  set $camllast = (long) $arg0
+  if ($camllast & 1) == 1
+    set $camlnext = 0
+    camlint $camllast
+    printf "\n"
+  end
+  if ($camllast & 7) == 0
+    camlblock $camllast
+  end
+  if ($camllast & 7) != 0 && ($camllast & 1) != 1
+    set $camlnext = 0
+    printf "invalid pointer: %#016lx\n", $camllast
+  end
+end
+
+# displays the next OCaml value in memory
+define camlnext
+  caml $camlnext
+end
+
+# displays the n-th field of the previously displayed value
+define camlfield
+  set $camlfield_addr = ((long *) $camllast)[$arg0]
+  caml $camlfield_addr
+end
+
+# displays the list of heap chunks
+define camlchunks
+  set $chunk = * (unsigned long *) &caml_heap_start
+  while $chunk != 0
+    set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize)
+    set $chunk_alloc = * (unsigned long *) ($chunk - 3 * $camlwordsize)
+    printf "chunk: addr = %#lx .. %#lx", $chunk, $chunk + $chunk_size
+    printf "  (size = %#lx; alloc = %#lx)\n", $chunk_size, $chunk_alloc
+    set $chunk = * (unsigned long *) ($chunk - $camlwordsize)
+  end
+end
+
+# walk the heap and launch command `camlvisitfun` on each block
+# the variables `$hp` `$val` `$hd` `$tag` `$color` and `$size`
+# are set before calling `camlvisitfun`
+# `camlvisitfun` can set `$camlvisitstop` to stop the iteration
+
+define camlvisit
+  set $cvchunk = * (unsigned long *) &caml_heap_start
+  set $camlvisitstop = 0
+  while $cvchunk != 0 && ! $camlvisitstop
+    set $cvchunk_size = * (unsigned long *) ($cvchunk - 2 * $camlwordsize)
+    set $cvhp = $cvchunk
+    while $cvhp < $cvchunk + $cvchunk_size && !$camlvisitstop
+      set $hp = $cvhp
+      set $val = $hp + $camlwordsize
+      set $hd = * (unsigned long *) $hp
+      set $tag = $hd & 0xFF
+      set $color = ($hd >> 8) & 3
+      set $cvsize = $hd >> 10
+      set $size = $cvsize
+      camlvisitfun
+      set $cvhp = $cvhp + (($cvsize + 1) * $camlwordsize)
+    end
+    set $cvchunk = * (unsigned long *) ($cvchunk - $camlwordsize)
+  end
+end
+
+define caml_cv_check_fl0
+  if $hp == * (unsigned long *) &caml_heap_start
+    set $flcheck_prev = ((unsigned long) &sentinels + 16)
+  end
+  if $color == 2 && $size > 5
+    if $val != * (unsigned long *) $flcheck_prev
+      printf "free-list: missing link %#x -> %#x\n", $flcheck_prev, $val
+      set $camlvisitstop = 1
+    end
+    set $flcheck_prev = $val
+  end
+end
+
+define caml_check_fl
+  set $listsize = $arg0
+  set $blueseen = $listsize == 0
+  set $val = * (unsigned long *) ((long) &sentinels + 16 + 32 * $listsize)
+  while $val != 0
+    printf "%#x\n", $val
+    set $hd = * (unsigned long *) ($val - 8)
+    set $color = ($hd >> 8) & 3
+    if $blueseen && $color != 2
+      printf "non-blue block at address %#x\n", $val
+      loop_break
+    else
+      set $blueseen = 1
+    end
+    set $val = * (unsigned long *) $val
+  end
+end
diff --git a/tools/lexer299.mll b/tools/lexer299.mll
new file mode 100644
index 00000000..13453999
--- /dev/null
+++ b/tools/lexer299.mll
@@ -0,0 +1,461 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexer definition *)
+
+{
+open Lexing
+open Misc
+
+type token =
+    AMPERAMPER
+  | AMPERSAND
+  | AND
+  | AS
+  | ASSERT
+  | BACKQUOTE
+  | BAR
+  | BARBAR
+  | BARRBRACKET
+  | BEGIN
+  | CHAR of (char)
+  | CLASS
+  | COLON
+  | COLONCOLON
+  | COLONEQUAL
+  | COLONGREATER
+  | COMMA
+  | CONSTRAINT
+  | DO
+  | DONE
+  | DOT
+  | DOTDOT
+  | DOWNTO
+  | ELSE
+  | END
+  | EOF
+  | EQUAL
+  | EXCEPTION
+  | EXTERNAL
+  | FALSE
+  | FLOAT of (string)
+  | FOR
+  | FUN
+  | FUNCTION
+  | FUNCTOR
+  | GREATER
+  | GREATERRBRACE
+  | GREATERRBRACKET
+  | HASH
+  | IF
+  | IN
+  | INCLUDE
+  | INFIXOP0 of (string)
+  | INFIXOP1 of (string)
+  | INFIXOP2 of (string)
+  | INFIXOP3 of (string)
+  | INFIXOP4 of (string)
+  | INHERIT
+  | INITIALIZER
+  | INT of (int)
+  | LABEL of (string)
+  | LABELID of (string)
+  | LAZY
+  | LBRACE
+  | LBRACELESS
+  | LBRACKET
+  | LBRACKETBAR
+  | LBRACKETLESS
+  | LESS
+  | LESSMINUS
+  | LET
+  | LIDENT of (string)
+  | LPAREN
+  | MATCH
+  | METHOD
+  | MINUSGREATER
+  | MODULE
+  | MUTABLE
+  | NEW
+  | OBJECT
+  | OF
+  | OPEN
+  | OR
+  | PARSER
+  | PREFIXOP of (string)
+  | PRIVATE
+  | QUESTION
+  | QUESTION2
+  | QUOTE
+  | RBRACE
+  | RBRACKET
+  | REC
+  | RPAREN
+  | SEMI
+  | SEMISEMI
+  | SIG
+  | STAR
+  | STRING of (string)
+  | STRUCT
+  | SUBTRACTIVE of (string)
+  | THEN
+  | TO
+  | TRUE
+  | TRY
+  | TYPE
+  | UIDENT of (string)
+  | UNDERSCORE
+  | VAL
+  | VIRTUAL
+  | WHEN
+  | WHILE
+  | WITH
+
+type error =
+  | Illegal_character of char
+  | Unterminated_comment
+  | Unterminated_string
+  | Unterminated_string_in_comment
+;;
+
+exception Error of error * int * int
+
+(* The table of keywords *)
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+    "parser", PARSER;
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lor", INFIXOP3("lor");
+    "lxor", INFIXOP3("lxor");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr")
+]
+
+(* 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 =
+  let c = 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) in
+  Char.chr(c land 0xFF)
+
+(* To store the position of the beginning of a string and comment *)
+let string_start_pos = ref 0;;
+let comment_start_pos = ref [];;
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Illegal_character c ->
+      fprintf ppf "Illegal character (%s)" (Char.escaped c)
+  | Unterminated_comment ->
+      fprintf ppf "Comment not terminated"
+  | Unterminated_string ->
+      fprintf ppf "String literal not terminated"
+  | Unterminated_string_in_comment ->
+      fprintf ppf "This comment contains an unterminated string literal"
+;;
+
+}
+
+let blank = [' ' '\010' '\013' '\009' '\012']
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let symbolchar2 =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' '<' '=' '>' '?' '@' '^' '|' '~']
+(*  ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *)
+let decimal_literal = ['0'-'9']+
+let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
+let oct_literal = '0' ['o' 'O'] ['0'-'7']+
+let bin_literal = '0' ['b' 'B'] ['0'-'1']+
+let float_literal =
+  ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+
+rule token = parse
+    blank +
+      { token lexbuf }
+  | "_"
+      { UNDERSCORE }
+  | lowercase identchar * ':' [ ^ ':' '=' '>']
+      { let s = Lexing.lexeme lexbuf in
+        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 * ':'
+      { let s = Lexing.lexeme lexbuf in
+        LABEL (String.sub s 0 (String.length s - 1)) }
+  | '%' lowercase identchar *
+*)
+  | ':' lowercase identchar *
+      { let s = Lexing.lexeme lexbuf in
+        let l = String.length s - 1 in
+        LABELID (String.sub s 1 l) }
+  | lowercase identchar *
+      { let s = Lexing.lexeme lexbuf in
+          try
+            Hashtbl.find keyword_table s
+          with Not_found ->
+            LIDENT s }
+  | uppercase identchar *
+      { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
+  | decimal_literal | hex_literal | oct_literal | bin_literal
+      { INT (int_of_string(Lexing.lexeme lexbuf)) }
+  | float_literal
+      { FLOAT (Lexing.lexeme lexbuf) }
+  | "\""
+      { reset_string_buffer();
+        let string_start = Lexing.lexeme_start lexbuf in
+        string_start_pos := string_start;
+        string lexbuf;
+        lexbuf.Lexing.lex_start_pos <-
+          string_start - lexbuf.Lexing.lex_abs_pos;
+        STRING (get_stored_string()) }
+  | "'" [^ '\\' '\''] "'"
+      { CHAR(Lexing.lexeme_char lexbuf 1) }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "(*"
+      { comment_start_pos := [Lexing.lexeme_start lexbuf];
+        comment lexbuf;
+        token lexbuf }
+  | "(*)"
+      { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf;
+                    Location.loc_end = Lexing.lexeme_end_p lexbuf;
+                    Location.loc_ghost = false }
+        in
+        Location.prerr_warning loc (Warnings.Comment_start);
+        comment_start_pos := [Lexing.lexeme_start lexbuf];
+        comment lexbuf;
+        token lexbuf
+      }
+  | "*)"
+      { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf;
+                    Location.loc_end = Lexing.lexeme_end_p lexbuf;
+                    Location.loc_ghost = false }
+        in
+        Location.prerr_warning loc Warnings.Comment_not_end;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        STAR
+      }
+  | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
+      (* # linenum ...  *)
+      { token lexbuf }
+  | "#"  { HASH }
+  | "&"  { AMPERSAND }
+  | "&&" { AMPERAMPER }
+  | "`"  { BACKQUOTE }
+  | "'"  { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "*"  { STAR }
+  | ","  { COMMA }
+  | "?"  { QUESTION }
+  | "??" { QUESTION2 }
+  | "->" { MINUSGREATER }
+  | "."  { DOT }
+  | ".." { DOTDOT }
+  | ":"  { COLON }
+  | "::" { COLONCOLON }
+  | ":=" { COLONEQUAL }
+  | ":>" { COLONGREATER }
+  | ";"  { SEMI }
+  | ";;" { SEMISEMI }
+  | "<"  { LESS }
+  | "<-" { LESSMINUS }
+  | "="  { EQUAL }
+  | "["  { LBRACKET }
+  | "[|" { LBRACKETBAR }
+  | "[<" { LBRACKETLESS }
+  | "]"  { RBRACKET }
+  | "{"  { LBRACE }
+  | "{<" { LBRACELESS }
+  | "|"  { BAR }
+  | "||" { BARBAR }
+  | "|]" { BARRBRACKET }
+  | ">"  { GREATER }
+  | ">]" { GREATERRBRACKET }
+  | "}"  { RBRACE }
+  | ">}" { GREATERRBRACE }
+
+  | "!=" { INFIXOP0 "!=" }
+  | "-"  { SUBTRACTIVE "-" }
+  | "-." { SUBTRACTIVE "-." }
+
+  | ['!' '~'] symbolchar *
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | '?' symbolchar2 *
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar *
+            { INFIXOP0(Lexing.lexeme lexbuf) }
+  | ['@' '^'] symbolchar *
+            { INFIXOP1(Lexing.lexeme lexbuf) }
+  | ['+' '-'] symbolchar *
+            { INFIXOP2(Lexing.lexeme lexbuf) }
+  | "**" symbolchar *
+            { INFIXOP4(Lexing.lexeme lexbuf) }
+  | ['*' '/' '%'] symbolchar *
+            { INFIXOP3(Lexing.lexeme lexbuf) }
+  | eof { EOF }
+  | _
+      { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]),
+                     Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) }
+
+and comment = parse
+    "(*"
+      { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
+        comment lexbuf;
+      }
+  | "*)"
+      { match !comment_start_pos with
+        | [] -> assert false
+        | [x] -> ()
+        | _ :: l -> comment_start_pos := l;
+                    comment lexbuf;
+       }
+  | "\""
+      { reset_string_buffer();
+        string_start_pos := Lexing.lexeme_start lexbuf;
+        begin try string lexbuf
+        with Error (Unterminated_string, _, _) ->
+          let st = List.hd !comment_start_pos in
+          raise (Error (Unterminated_string_in_comment, st, st + 2))
+        end;
+        string_buff := initial_string_buffer;
+        comment lexbuf }
+  | "''"
+      { comment lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      { comment lexbuf }
+  | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { comment lexbuf }
+  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { comment lexbuf }
+  | eof
+      { let st = List.hd !comment_start_pos in
+        raise (Error (Unterminated_comment, st, st + 2));
+      }
+  | _
+      { comment lexbuf }
+
+and string = parse
+    '"'
+      { () }
+  | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
+      { 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,
+                      !string_start_pos, !string_start_pos+1)) }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        string lexbuf }
diff --git a/tools/lexer301.mll b/tools/lexer301.mll
new file mode 100644
index 00000000..e574c365
--- /dev/null
+++ b/tools/lexer301.mll
@@ -0,0 +1,462 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The lexer definition *)
+
+{
+open Misc
+
+type token =
+    AMPERAMPER
+  | AMPERSAND
+  | AND
+  | AS
+  | ASSERT
+  | BACKQUOTE
+  | BAR
+  | BARBAR
+  | BARRBRACKET
+  | BEGIN
+  | CHAR of (char)
+  | CLASS
+  | COLON
+  | COLONCOLON
+  | COLONEQUAL
+  | COLONGREATER
+  | COMMA
+  | CONSTRAINT
+  | DO
+  | DONE
+  | DOT
+  | DOTDOT
+  | DOWNTO
+  | ELSE
+  | END
+  | EOF
+  | EQUAL
+  | EXCEPTION
+  | EXTERNAL
+  | FALSE
+  | FLOAT of (string)
+  | FOR
+  | FUN
+  | FUNCTION
+  | FUNCTOR
+  | GREATER
+  | GREATERRBRACE
+  | GREATERRBRACKET
+  | HASH
+  | IF
+  | IN
+  | INCLUDE
+  | INFIXOP0 of (string)
+  | INFIXOP1 of (string)
+  | INFIXOP2 of (string)
+  | INFIXOP3 of (string)
+  | INFIXOP4 of (string)
+  | INHERIT
+  | INITIALIZER
+  | INT of (int)
+  | LABEL of (string)
+  | LAZY
+  | LBRACE
+  | LBRACELESS
+  | LBRACKET
+  | LBRACKETBAR
+  | LBRACKETLESS
+  | LESS
+  | LESSMINUS
+  | LET
+  | LIDENT of (string)
+  | LPAREN
+  | MATCH
+  | METHOD
+  | MINUS
+  | MINUSDOT
+  | MINUSGREATER
+  | MODULE
+  | MUTABLE
+  | NEW
+  | OBJECT
+  | OF
+  | OPEN
+  | OPTLABEL of (string)
+  | OR
+  | PARSER
+  | PLUS
+  | PREFIXOP of (string)
+  | PRIVATE
+  | QUESTION
+  | QUESTION2
+  | QUOTE
+  | RBRACE
+  | RBRACKET
+  | REC
+  | RPAREN
+  | SEMI
+  | SEMISEMI
+  | SIG
+  | STAR
+  | STRING of (string)
+  | STRUCT
+  | THEN
+  | TILDE
+  | TO
+  | TRUE
+  | TRY
+  | TYPE
+  | UIDENT of (string)
+  | UNDERSCORE
+  | VAL
+  | VIRTUAL
+  | WHEN
+  | WHILE
+  | WITH
+
+type error =
+  | Illegal_character of char
+  | Unterminated_comment
+  | Unterminated_string
+  | Unterminated_string_in_comment
+  | Keyword_as_label of string
+;;
+
+exception Error of error * int * int
+
+(* The table of keywords *)
+
+let keyword_table =
+  create_hashtable 149 [
+    "and", AND;
+    "as", AS;
+    "assert", ASSERT;
+    "begin", BEGIN;
+    "class", CLASS;
+    "constraint", CONSTRAINT;
+    "do", DO;
+    "done", DONE;
+    "downto", DOWNTO;
+    "else", ELSE;
+    "end", END;
+    "exception", EXCEPTION;
+    "external", EXTERNAL;
+    "false", FALSE;
+    "for", FOR;
+    "fun", FUN;
+    "function", FUNCTION;
+    "functor", FUNCTOR;
+    "if", IF;
+    "in", IN;
+    "include", INCLUDE;
+    "inherit", INHERIT;
+    "initializer", INITIALIZER;
+    "lazy", LAZY;
+    "let", LET;
+    "match", MATCH;
+    "method", METHOD;
+    "module", MODULE;
+    "mutable", MUTABLE;
+    "new", NEW;
+    "object", OBJECT;
+    "of", OF;
+    "open", OPEN;
+    "or", OR;
+    "parser", PARSER;
+    "private", PRIVATE;
+    "rec", REC;
+    "sig", SIG;
+    "struct", STRUCT;
+    "then", THEN;
+    "to", TO;
+    "true", TRUE;
+    "try", TRY;
+    "type", TYPE;
+    "val", VAL;
+    "virtual", VIRTUAL;
+    "when", WHEN;
+    "while", WHILE;
+    "with", WITH;
+
+    "mod", INFIXOP3("mod");
+    "land", INFIXOP3("land");
+    "lor", INFIXOP3("lor");
+    "lxor", INFIXOP3("lxor");
+    "lsl", INFIXOP4("lsl");
+    "lsr", INFIXOP4("lsr");
+    "asr", INFIXOP4("asr")
+]
+
+(* 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 =
+  let c = 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) in
+  Char.chr(c land 0xFF)
+
+(* To store the position of the beginning of a string and comment *)
+let string_start_pos = ref 0;;
+let comment_start_pos = ref [];;
+let in_comment () = !comment_start_pos <> [];;
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Illegal_character c ->
+      fprintf ppf "Illegal character (%s)" (Char.escaped c)
+  | Unterminated_comment ->
+      fprintf ppf "Comment not terminated"
+  | Unterminated_string ->
+      fprintf ppf "String literal not terminated"
+  | Unterminated_string_in_comment ->
+      fprintf ppf "This comment contains an unterminated string literal"
+  | Keyword_as_label kwd ->
+      fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
+;;
+
+}
+
+let blank = [' ' '\010' '\013' '\009' '\012']
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar =
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let symbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let decimal_literal = ['0'-'9']+
+let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
+let oct_literal = '0' ['o' 'O'] ['0'-'7']+
+let bin_literal = '0' ['b' 'B'] ['0'-'1']+
+let float_literal =
+  ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+
+rule token = parse
+    blank +
+      { token lexbuf }
+  | "_"
+      { UNDERSCORE }
+  | "~"  { TILDE }
+  | "~" lowercase identchar * ':'
+      { let s = Lexing.lexeme lexbuf in
+        let name = String.sub s 1 (String.length s - 2) in
+        if Hashtbl.mem keyword_table name then
+          raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
+                       Lexing.lexeme_end lexbuf));
+        LABEL name }
+  | "?"  { QUESTION }
+  | "?" lowercase identchar * ':'
+      { let s = Lexing.lexeme lexbuf in
+        let name = String.sub s 1 (String.length s - 2) in
+        if Hashtbl.mem keyword_table name then
+          raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
+                       Lexing.lexeme_end lexbuf));
+        OPTLABEL name }
+  | lowercase identchar *
+      { let s = Lexing.lexeme lexbuf in
+          try
+            Hashtbl.find keyword_table s
+          with Not_found ->
+            LIDENT s }
+  | uppercase identchar *
+      { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
+  | decimal_literal | hex_literal | oct_literal | bin_literal
+      { INT (int_of_string(Lexing.lexeme lexbuf)) }
+  | float_literal
+      { FLOAT (Lexing.lexeme lexbuf) }
+  | "\""
+      { reset_string_buffer();
+        let string_start = Lexing.lexeme_start lexbuf in
+        string_start_pos := string_start;
+        string lexbuf;
+        lexbuf.Lexing.lex_start_pos <-
+          string_start - lexbuf.Lexing.lex_abs_pos;
+        STRING (get_stored_string()) }
+  | "'" [^ '\\' '\''] "'"
+      { CHAR(Lexing.lexeme_char lexbuf 1) }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "(*"
+      { comment_start_pos := [Lexing.lexeme_start lexbuf];
+        comment lexbuf;
+        token lexbuf }
+  | "(*)"
+      { let loc = Location.curr lexbuf
+        and warn = Warnings.Comment_start
+        in
+        Location.prerr_warning loc warn;
+        comment_start_pos := [Lexing.lexeme_start lexbuf];
+        comment lexbuf;
+        token lexbuf
+      }
+  | "*)"
+      { let loc = Location.curr lexbuf
+        and warn = Warnings.Comment_not_end
+        in
+        Location.prerr_warning loc warn;
+        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        STAR
+      }
+  | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
+      (* # linenum ...  *)
+      { token lexbuf }
+  | "#"  { HASH }
+  | "&"  { AMPERSAND }
+  | "&&" { AMPERAMPER }
+  | "`"  { BACKQUOTE }
+  | "'"  { QUOTE }
+  | "("  { LPAREN }
+  | ")"  { RPAREN }
+  | "*"  { STAR }
+  | ","  { COMMA }
+  | "??" { QUESTION2 }
+  | "->" { MINUSGREATER }
+  | "."  { DOT }
+  | ".." { DOTDOT }
+  | ":"  { COLON }
+  | "::" { COLONCOLON }
+  | ":=" { COLONEQUAL }
+  | ":>" { COLONGREATER }
+  | ";"  { SEMI }
+  | ";;" { SEMISEMI }
+  | "<"  { LESS }
+  | "<-" { LESSMINUS }
+  | "="  { EQUAL }
+  | "["  { LBRACKET }
+  | "[|" { LBRACKETBAR }
+  | "[<" { LBRACKETLESS }
+  | "]"  { RBRACKET }
+  | "{"  { LBRACE }
+  | "{<" { LBRACELESS }
+  | "|"  { BAR }
+  | "||" { BARBAR }
+  | "|]" { BARRBRACKET }
+  | ">"  { GREATER }
+  | ">]" { GREATERRBRACKET }
+  | "}"  { RBRACE }
+  | ">}" { GREATERRBRACE }
+
+  | "!=" { INFIXOP0 "!=" }
+  | "+"  { PLUS }
+  | "-"  { MINUS }
+  | "-." { MINUSDOT }
+
+  | "!" symbolchar *
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['~' '?'] symbolchar +
+            { PREFIXOP(Lexing.lexeme lexbuf) }
+  | ['=' '<' '>' '|' '&' '$'] symbolchar *
+            { INFIXOP0(Lexing.lexeme lexbuf) }
+  | ['@' '^'] symbolchar *
+            { INFIXOP1(Lexing.lexeme lexbuf) }
+  | ['+' '-'] symbolchar *
+            { INFIXOP2(Lexing.lexeme lexbuf) }
+  | "**" symbolchar *
+            { INFIXOP4(Lexing.lexeme lexbuf) }
+  | ['*' '/' '%'] symbolchar *
+            { INFIXOP3(Lexing.lexeme lexbuf) }
+  | eof { EOF }
+  | _
+      { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]),
+                     Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) }
+
+and comment = parse
+    "(*"
+      { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
+        comment lexbuf;
+      }
+  | "*)"
+      { match !comment_start_pos with
+        | [] -> assert false
+        | [x] -> comment_start_pos := [];
+        | _ :: l -> comment_start_pos := l;
+                    comment lexbuf;
+       }
+  | "\""
+      { reset_string_buffer();
+        string_start_pos := Lexing.lexeme_start lexbuf;
+        begin try string lexbuf
+        with Error (Unterminated_string, _, _) ->
+          let st = List.hd !comment_start_pos in
+          raise (Error (Unterminated_string_in_comment, st, st + 2))
+        end;
+        string_buff := initial_string_buffer;
+        comment lexbuf }
+  | "''"
+      { comment lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      { comment lexbuf }
+  | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { comment lexbuf }
+  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { comment lexbuf }
+  | eof
+      { let st = List.hd !comment_start_pos in
+        raise (Error (Unterminated_comment, st, st + 2));
+      }
+  | _
+      { comment lexbuf }
+
+and string = parse
+    '"'
+      { () }
+  | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
+      { 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,
+                      !string_start_pos, !string_start_pos+1)) }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        string lexbuf }
diff --git a/tools/lintapidiff.ml b/tools/lintapidiff.ml
new file mode 100644
index 00000000..87cf1d4b
--- /dev/null
+++ b/tools/lintapidiff.ml
@@ -0,0 +1,313 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*   Copyright 2016--2017 Edwin Török                                     *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detects newly added symbols that are missing "@since" annotations,
+   or removed symbols that didn't have "@deprecated" annotation before.
+
+   Handles: values, exceptions.
+   Ignores: variants, record fields, classes, module aliasing or includes, ...
+   Out of scope: changes in arity, parameters, ...
+
+   Missing attributes on undocumented identifiers in undocumented modules
+   are not reported.
+
+   Use 'make lintapidiff' in the root directory to run
+*)
+open Location
+open Parsetree
+
+(* oldest Ocaml version that we show missing @since errors for *)
+let oldest = "4.00.0"
+
+(* do not check @since annotations for these *)
+let ignore_changes_for = [
+  "type Pervasives.format6" (* this used to be a built-in type *);
+  (* discarded by stop comments: *)
+  "type Unix.map_file_impl";
+  "value Unix.map_file_impl";
+]
+
+module IdMap = Map.Make(String)
+
+module Version : sig
+  type t
+  val oldest : t
+  val is_same : t -> t -> bool
+  val is_strictly_older: t -> than:t -> bool
+  val of_string_exn : string -> t
+  val pp : Format.formatter -> t -> unit
+end = struct
+  type t = int * int * int
+
+  let is_same a b = a = b
+  let is_strictly_older a ~than = a < than
+  let of_string_exn str =
+    try Scanf.sscanf str "%u.%u.%u" (fun a b c -> (a,b,c))
+    with _ -> Scanf.sscanf str "%u.%u" (fun a b -> (a,b,0))
+
+  let oldest = of_string_exn oldest
+  let pp ppf (major,minor,patch) =
+    Format.fprintf ppf "%u.%02u.%u" major minor patch
+end
+
+module Doc = struct
+  type t = {
+    since: Version.t option;
+    deprecated: bool;
+    loc: Location.t;
+    has_doc_parent: bool;
+    has_doc: bool;
+  }
+
+  let empty = {since = None; deprecated=false; loc=Location.none;
+               has_doc_parent=false;has_doc=false}
+
+  let since = Str.regexp "\\(.\\|\n\\)*@since +\\([^ ]+\\).*"
+
+  let find_attr lst attrs =
+    try Some (List.find (fun (loc, _) -> List.mem loc.txt lst) attrs)
+    with Not_found -> None
+
+  let get_doc lst attrs = match find_attr lst attrs with
+    | Some (_, PStr [{pstr_desc=Pstr_eval(
+        {pexp_desc=Pexp_constant(Pconst_string (doc, _));_}, _);_}])
+      when doc <> "/*" && doc <> "" -> Some doc
+    | _ -> None
+
+  let is_deprecated attrs =
+    find_attr ["ocaml.deprecated"; "deprecated"] attrs <> None ||
+    match get_doc ["ocaml.text"] attrs with (* for toplevel module annotation *)
+    | None -> false
+    | Some text ->
+        try Misc.search_substring "@deprecated" text 0 >= 0
+        with Not_found -> false
+
+  let get parent_info loc attrs =
+    let doc = get_doc ["ocaml.doc"; "ocaml.text"] attrs in
+    {
+      since = (match doc with
+          | Some doc ->
+              if Str.string_match since doc 0 then
+                Some (Str.matched_group 2 doc |> String.trim
+                      |> Version.of_string_exn)
+              else parent_info.since
+          | None -> parent_info.since);
+      deprecated = parent_info.deprecated || is_deprecated attrs;
+      loc;
+      has_doc_parent = parent_info.has_doc_parent || parent_info.has_doc;
+      has_doc = doc <> None
+    }
+end
+
+module Ast = struct
+  let add_path ~f prefix path name attrs inherits map =
+    let path = Path.Pdot (path, name.txt, 0) in
+    let id = prefix ^ " " ^ (Printtyp.string_of_path path) in
+    (* inherits: annotation on parent is inherited by all children,
+       so it suffices to annotate just the new module, and not all its elements
+    *)
+    let info = f inherits name.loc attrs in
+    IdMap.add id info map
+
+  let rec add_item ~f path inherits map item =
+    let rec add_module_type path ty (inherits, map) =
+      let self = add_item ~f path inherits in
+      match ty.pmty_desc with
+      | Pmty_signature lst -> List.fold_left self map lst
+      | Pmty_functor ({txt;_}, _, m) ->
+          let path = Path.Papply(path, Path.Pident (Ident.create txt)) in
+          add_module_type path m (inherits, map)
+      | Pmty_ident _ | Pmty_with _ | Pmty_typeof _| Pmty_extension _
+      | Pmty_alias _ -> map
+    in
+    let enter_path path name ty attrs map =
+      let path = Path.Pdot (path, name.txt, 0) in
+      let inherits = f inherits name.loc attrs in
+      add_module_type path ty (inherits, map)
+    in
+    let add_module map m =
+      enter_path  path m.pmd_name m.pmd_type m.pmd_attributes map
+    in
+    match item.psig_desc with
+    | Psig_value vd ->
+        add_path ~f "value" path vd.pval_name vd.pval_attributes inherits map
+    | Psig_type (_,lst) ->
+        List.fold_left (fun map t ->
+            add_path ~f "type" path t.ptype_name t.ptype_attributes inherits map
+          ) map lst
+    | Psig_exception e ->
+        add_path ~f "exception" path e.pext_name e.pext_attributes inherits map
+    | Psig_module m -> add_module map m
+    | Psig_recmodule lst -> List.fold_left add_module map lst
+    | Psig_modtype s ->
+        begin match s.pmtd_type with
+        | None -> map
+        | Some ty ->
+            enter_path path s.pmtd_name ty s.pmtd_attributes map
+        end
+    | Psig_typext _|Psig_open _|Psig_include _|Psig_class _|Psig_class_type _
+    | Psig_attribute _|Psig_extension _ -> map
+
+  let add_items ~f path (inherits,map) items =
+    (* module doc *)
+    let inherits = List.fold_left (fun inherits -> function
+        | {psig_desc=Psig_attribute a;_}
+          when (Doc.get_doc ["ocaml.doc";"ocaml.text"][a] <> None) ->
+            f inherits (Location.none) [a]
+        | _ -> inherits
+      ) inherits items in
+    List.fold_left (add_item ~f path inherits) map items
+
+  let parse_file ~orig ~f ~init input =
+    try
+      let id =
+        orig |> Filename.chop_extension |> Filename.basename |>
+        String.capitalize_ascii |> Ident.create in
+      let ast = Pparse.file ~tool_name:"lintapidiff" Format.err_formatter input
+          Parse.interface Pparse.Signature in
+      Location.input_name := orig;
+      add_items ~f (Path.Pident id) (init,IdMap.empty) ast
+    with e ->
+      Format.eprintf "%a@." Location.report_exception e;
+      raise e
+end
+
+module Git = struct
+  let with_show ~f rev path =
+    let obj = rev ^ ":" ^ path in
+    let suffix = Printf.sprintf "-%s:%s" rev (Filename.basename path) in
+    let tmp = Filename.temp_file "lintapidiff" suffix in
+    let cmd = Printf.sprintf "git show %s >%s 2>/dev/null"
+        (Filename.quote obj) (Filename.quote tmp) in
+    Misc.try_finally (fun () ->
+        match Sys.command cmd with
+        | 0 -> Ok (f tmp)
+        | 128 -> Error `Not_found
+        | r ->
+            Location.errorf ~loc:(in_file obj) "exited with code %d" r |>
+            Format.eprintf "%a@." Location.report_error;
+            Error `Exit)
+      (fun () -> Misc.remove_file tmp)
+end
+
+module Diff = struct
+  type seen_info = {
+    last_not_seen: Version.t option;
+    first_seen: Version.t;
+    deprecated: bool;
+  }
+
+  let err k (loc, msg, seen, latest) =
+    let info_seen ppf = function
+      | None ->
+          Format.fprintf ppf "%s was not seen in any analyzed version" k
+      | Some a ->
+          begin match a.last_not_seen with
+          | Some v ->
+              Format.fprintf ppf "%s was not seen in version %a" k Version.pp v
+          | None -> Format.fprintf ppf "%s was seen in all analyzed versions" k
+          end;
+          Format.fprintf ppf "@,%s was seen in version %a"
+            k Version.pp a.first_seen;
+          if a.deprecated then
+            Format.fprintf ppf "@,%s was marked as deprecated" k
+    in
+    let info_latest ppf = function
+      | None -> Format.fprintf ppf "%s was deleted in HEAD" k
+      | Some s ->
+          begin match s.Doc.since with
+          | Some v -> Format.fprintf ppf "%s has @since %a" k Version.pp v
+          | None -> Format.fprintf ppf "%s has no @since annotation" k
+          end;
+          if s.Doc.deprecated then
+            Format.fprintf ppf "@,%s is marked as deprecated" k
+    in
+    Location.errorf ~loc "@[%s %s@,%a@,%a@]" msg k
+      info_seen seen info_latest latest |>
+    Format.eprintf "%a@." Location.report_error
+
+  let parse_file_at_rev ~path (prev,accum) rev =
+    let merge _ a b = match a, b with
+      | Some a, Some b ->
+          Some { a with  deprecated=b.deprecated }
+      | None, Some a -> Some { a with last_not_seen=prev }
+      | Some _, None -> None (* deleted *)
+      | None, None -> assert false
+    in
+    let first_seen = Version.of_string_exn rev in
+    let empty = {last_not_seen=None;first_seen;deprecated=false} in
+    let f = Ast.parse_file ~orig:path ~init:empty ~f:(fun _ _ attrs ->
+        { last_not_seen=None;first_seen; deprecated=Doc.is_deprecated attrs }) in
+    let map = match Git.with_show ~f rev path with
+      | Ok r -> r
+      | Error `Not_found -> IdMap.empty
+      | Error `Exit -> raise Exit in
+    Some first_seen, IdMap.merge merge accum map
+
+  let check_changes ~first ~last default k seen latest =
+    let is_old v = Version.is_strictly_older v ~than:Version.oldest ||
+                   Version.is_same v first
+    in
+    if List.mem k ignore_changes_for then None (* ignored *)
+    else let open! Doc in
+    match (seen:seen_info option), latest with
+    | None, None -> assert false
+    | _, Some {has_doc_parent=false;has_doc=false;deprecated=false;_} ->
+        None (* undocumented *)
+    | Some {deprecated=true;_}, None -> None (* deleted deprecated *)
+    | Some _, None ->
+        Some (default, "deleted non-deprecated", seen, latest)
+    | _, Some {deprecated=true;since=None;_} -> None (* marked as deprecated *)
+    | None, Some {loc; since=None; _} ->
+        Some (loc, "missing @since for new", seen, latest)
+    | Some {first_seen;_}, Some {loc; since=None;_} ->
+        if is_old first_seen then None
+        else Some (loc, "missing @since", seen, latest)
+    | Some {first_seen;_}, Some {loc; since=Some s;_} ->
+        if Version.is_same first_seen s then None (* OK, @since matches *)
+        else Some (loc, "mismatched @since", seen, latest)
+    | None, Some {loc; since=Some s;_} ->
+        if Version.is_strictly_older s ~than:last ||
+           Version.is_same s last then
+          Some (loc, "too old @since for new", seen, latest)
+        else None
+
+  let file path tags =
+    let _,syms_vers = List.fold_left (parse_file_at_rev ~path)
+        (None,IdMap.empty) tags in
+    let current = Ast.parse_file ~orig:path ~f:Doc.get ~init:Doc.empty path in
+    let loc = Location.in_file path in
+    let first = List.hd tags |> Version.of_string_exn
+    and last = List.hd (List.rev tags) |> Version.of_string_exn in
+    IdMap.merge (check_changes ~first ~last loc) syms_vers current
+end
+
+let rec read_lines accum =
+  match input_line stdin with
+  | line -> read_lines (line :: accum)
+  | exception End_of_file -> accum
+
+let () =
+  let tags = Sys.argv |> Array.to_list |> List.tl in
+  if tags = [] then begin
+    Printf.eprintf "tags list is empty!\n";
+    exit 1;
+  end;
+  let paths = read_lines [] in
+  Printf.printf "Parsing\n%!";
+  let count = List.fold_left (fun count path ->
+      let problems = Diff.file path tags in
+      IdMap.iter Diff.err problems;
+      count + IdMap.cardinal problems
+    ) 0 paths in
+  Printf.printf "Found %d potential problems\n%!" count;
+  if count > 0 then exit 2
diff --git a/tools/magic b/tools/magic
new file mode 100644
index 00000000..089f169a
--- /dev/null
+++ b/tools/magic
@@ -0,0 +1,11 @@
+# Here are some definitions that can be added to the /usr/share/magic
+# database so that the file(1) command recognizes OCaml compiled files.
+# Contributed by Sven Luther.
+0       string  Caml1999        OCaml
+>8      string  X               bytecode executable
+>8      string  I               interface data (.cmi)
+>8      string  O               bytecode object data (.cmo)
+>8      string  A               bytecode library data (.cma)
+>8      string  Y               native object data (.cmx)
+>8      string  Z               native library data (.cmxa)
+>9      string  >\0             (Version %3.3s).
diff --git a/tools/make-package-macosx b/tools/make-package-macosx
new file mode 100755
index 00000000..1ac36a01
--- /dev/null
+++ b/tools/make-package-macosx
@@ -0,0 +1,138 @@
+#!/bin/sh
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*          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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+cd package-macosx
+rm -rf ocaml.pkg ocaml-rw.dmg
+
+VERSION=`sed -e 1q ../VERSION`
+VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION`
+VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION`
+
+cat >Description.plist <
+  
+  
+  
+          IFPkgDescriptionDeleteWarning
+          
+          IFPkgDescriptionDescription
+          The OCaml compiler and tools
+          IFPkgDescriptionTitle
+          OCaml
+          IFPkgDescriptionVersion
+          ${VERSION}
+  
+  
+EOF
+
+cat >Info.plist <
+
+
+
+        CFBundleGetInfoString
+        OCaml ${VERSION}
+        CFBundleIdentifier
+        fr.inria.ocaml
+        CFBundleName
+        OCaml
+        CFBundleShortVersionString
+        ${VERSION}
+        IFMajorVersion
+        ${VERSION_MAJOR}
+        IFMinorVersion
+        ${VERSION_MINOR}
+        IFPkgFlagAllowBackRev
+        
+        IFPkgFlagAuthorizationAction
+        AdminAuthorization
+        IFPkgFlagDefaultLocation
+        /usr/local
+        IFPkgFlagInstallFat
+        
+        IFPkgFlagIsRequired
+        
+        IFPkgFlagRelocatable
+        
+        IFPkgFlagRestartAction
+        NoRestart
+        IFPkgFlagRootVolumeOnly
+        
+        IFPkgFlagUpdateInstalledLanguages
+        
+        IFPkgFormatVersion
+        0.10000000149011612
+
+
+EOF
+
+mkdir -p resources
+
+#                                         stop here -> |
+cat >resources/ReadMe.txt <&2
+  exit 3
+fi
+open "/Volumes/$volname"
+sleep 2
+hdiutil detach $name
+
+rm -rf "ocaml-${VERSION}.dmg"
+hdiutil convert ocaml-rw.dmg -format UDZO -o "ocaml-${VERSION}.dmg"
diff --git a/tools/make-version-header.sh b/tools/make-version-header.sh
new file mode 100755
index 00000000..ce3b70c6
--- /dev/null
+++ b/tools/make-version-header.sh
@@ -0,0 +1,55 @@
+#!/bin/sh
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*          Damien Doligez, projet Gallium, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 2003 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  As an exception to the licensing rules of      *
+#*   OCaml, this file is freely redistributable, modified or not,         *
+#*   without constraints.                                                 *
+#*                                                                        *
+#**************************************************************************
+
+# This script extracts the components from an OCaml version number
+# and provides them as C defines:
+# OCAML_VERSION_MAJOR: the major version number
+# OCAML_VERSION_MAJOR: the minor version number
+# OCAML_VERSION_PATCHLEVEL: the patchlevel number if present, or 0 if absent
+# OCAML_VERSION_ADDITIONAL: this is defined only if the additional-info
+#  field is present, and is a string that contains that field.
+# Note that additional-info is always absent in officially-released
+# versions of OCaml.
+
+# usage:
+# make-version-header.sh [version-file]
+# The argument is the VERSION file from the OCaml sources.
+# If the argument is not given, the version number from "ocamlc -v" will
+# be used.
+
+case $# in
+  0) version="`ocamlc -v | tr -d '\r' | sed -n -e 's/.*version //p'`";;
+  1) version="`sed -e 1q $1 | tr -d '\r'`";;
+  *) echo "usage: make-version-header.sh [version-file]" >&2
+     exit 2;;
+esac
+
+major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`"
+minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`"
+patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`"
+suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`"
+
+echo "#define OCAML_VERSION_MAJOR $major"
+printf "#define OCAML_VERSION_MINOR %d\n" $minor
+case $patchlvl in "") patchlvl=0;; esac
+echo "#define OCAML_VERSION_PATCHLEVEL $patchlvl"
+case "$suffix" in
+  "") echo "#undef OCAML_VERSION_ADDITIONAL";;
+  *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";;
+esac
+printf "#define OCAML_VERSION %d%02d%02d\n" $major $minor $patchlvl
+echo "#define OCAML_VERSION_STRING \"$version\""
diff --git a/tools/make_opcodes.mll b/tools/make_opcodes.mll
new file mode 100644
index 00000000..5c7cd854
--- /dev/null
+++ b/tools/make_opcodes.mll
@@ -0,0 +1,47 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                      Nicolas Ojeda Bar, LexiFi                      *)
+(*                                                                     *)
+(*  Copyright 2016 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+let ident = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''0'-'9''_']*
+let space = [' ''\n''\r''\t']*
+
+rule find_enum = parse
+| "enum" space (ident as id) space '{' { id, opnames lexbuf }
+| _                                    { find_enum lexbuf }
+
+and opnames = parse
+| space (ident as op) space ','        { op :: opnames lexbuf }
+| space ident space '}'                { [] }
+
+{
+  let print_opnames = ref false
+  let print_opcodes = ref false
+
+  open Printf
+
+  let () =
+    let spec =
+      [
+        "-opnames", Arg.Set print_opnames, " Dump opcode names";
+        "-opcodes", Arg.Set print_opcodes, " Dump opcode numbers";
+      ]
+    in
+    Arg.parse (Arg.align spec) ignore "Extract opcode info from instruct.h";
+    let lexbuf = Lexing.from_channel stdin in
+    let id, opnames = find_enum lexbuf in
+    if !print_opnames then begin
+      printf "let names_of_%s = [|\n" id;
+      List.iter (fun s -> printf "  %S;\n" s) opnames;
+      printf "|]\n"
+    end;
+    if !print_opcodes then
+      List.iteri (fun i op -> printf "let op%s = %i\n" op i) opnames
+}
diff --git a/tools/msvs-promote-path b/tools/msvs-promote-path
new file mode 100755
index 00000000..668fc55d
--- /dev/null
+++ b/tools/msvs-promote-path
@@ -0,0 +1,51 @@
+#!/bin/bash
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                David Allsopp, MetaStack Solutions Ltd.                 *
+#*                                                                        *
+#*   Copyright 2015 MetaStack Solutions Ltd.                              *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Ensure that the Microsoft Linker isn't being messed up by /usr/bin/link
+if [ "`link --version | head -1 | \
+     fgrep "Microsoft (R) Incremental Linker"`" != "" ] ; then
+  echo "link already refers to the Microsoft Linker">&2
+  exit 0
+fi
+
+IFS=:
+T=
+FOUND=0
+FIRST=1
+for i in $PATH
+do
+  if [ $FIRST -eq 1 ] ; then
+    T="$i"
+    FIRST=0
+  else
+    if [ $FOUND -eq 0 -a -x $i/link ] && [ "`$i/link --version | head -1 | \
+                       fgrep "Microsoft (R) Incremental Linker"`" != "" ] ; then
+      FOUND=1
+      T="$i:$T"
+      PROM=$i
+    else
+      T="$T:$i"
+    fi
+  fi
+done
+unset IFS
+
+if [ $FOUND -eq 0 ] ; then
+  echo The Microsoft Linker was not found in any of the PATH entries!>&2
+  exit 1
+else
+  echo "$PROM moved to the front of \$PATH">&2
+  echo export PATH=\"$T\"
+fi
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
new file mode 100644
index 00000000..6f0dfaac
--- /dev/null
+++ b/tools/objinfo.ml
@@ -0,0 +1,340 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*         Mehdi Dogguy, PPS laboratory, University Paris Diderot         *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2010 Mehdi Dogguy                                          *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files
+   and on bytecode executables. *)
+
+open Printf
+open Misc
+open Config
+open Cmo_format
+
+(* Command line option to prevent printing approximation and function code *)
+let no_approx = ref false
+let no_code = ref false
+
+let input_stringlist ic len =
+  let get_string_list sect len =
+    let rec fold s e acc =
+      if e != len then
+        if sect.[e] = '\000' then
+          fold (e+1) (e+1) (String.sub sect s (e-s) :: acc)
+        else fold s (e+1) acc
+      else acc
+    in fold 0 0 []
+  in
+  let sect = really_input_string ic len in
+  get_string_list sect len
+
+let dummy_crc = String.make 32 '-'
+
+let print_name_crc (name, crco) =
+  let crc =
+    match crco with
+      None -> dummy_crc
+    | Some crc -> Digest.to_hex crc
+  in
+    printf "\t%s\t%s\n" crc name
+
+let print_line name =
+  printf "\t%s\n" name
+
+let print_required_global id =
+  printf "\t%s\n" (Ident.name id)
+
+let print_cmo_infos cu =
+  printf "Unit name: %s\n" cu.cu_name;
+  print_string "Interfaces imported:\n";
+  List.iter print_name_crc cu.cu_imports;
+  print_string "Required globals:\n";
+  List.iter print_required_global cu.cu_required_globals;
+  printf "Uses unsafe features: ";
+  (match cu.cu_primitives with
+    | [] -> printf "no\n"
+    | l  ->
+        printf "YES\n";
+        printf "Primitives declared in this module:\n";
+        List.iter print_line l);
+  printf "Force link: %s\n" (if cu.cu_force_link then "YES" else "no")
+
+let print_spaced_string s =
+  printf " %s" s
+
+let print_cma_infos (lib : Cmo_format.library) =
+  printf "Force custom: %s\n" (if lib.lib_custom then "YES" else "no");
+  printf "Extra C object files:";
+  (* PR#4949: print in linking order *)
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  printf "\nExtra C options:";
+  List.iter print_spaced_string lib.lib_ccopts;
+  printf "\n";
+  print_string "Extra dynamically-loaded libraries:";
+  List.iter print_spaced_string lib.lib_dllibs;
+  printf "\n";
+  List.iter print_cmo_infos lib.lib_units
+
+let print_cmi_infos name crcs =
+  printf "Unit name: %s\n" name;
+  printf "Interfaces imported:\n";
+  List.iter print_name_crc crcs
+
+let print_cmt_infos cmt =
+  let open Cmt_format in
+  printf "Cmt unit name: %s\n" cmt.cmt_modname;
+  print_string "Cmt interfaces imported:\n";
+  List.iter print_name_crc cmt.cmt_imports;
+  printf "Source file: %s\n"
+         (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f);
+  printf "Compilation flags:";
+  Array.iter print_spaced_string cmt.cmt_args;
+  printf "\nLoad path:";
+  List.iter print_spaced_string cmt.cmt_loadpath;
+  printf "\n";
+  printf "cmt interface digest: %s\n"
+    (match cmt.cmt_interface_digest with
+     | None -> ""
+     | Some crc -> Digest.to_hex crc)
+
+let print_general_infos name crc defines cmi cmx =
+  printf "Name: %s\n" name;
+  printf "CRC of implementation: %s\n" (Digest.to_hex crc);
+  printf "Globals defined:\n";
+  List.iter print_line defines;
+  printf "Interfaces imported:\n";
+  List.iter print_name_crc cmi;
+  printf "Implementations imported:\n";
+  List.iter print_name_crc cmx
+
+let print_global_table table =
+  printf "Globals defined:\n";
+  Tbl.iter
+    (fun id _ -> print_line (Ident.name id))
+    table.num_tbl
+
+open Cmx_format
+
+let print_cmx_infos (ui, crc) =
+  print_general_infos
+    ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
+  begin match ui.ui_export_info with
+  | Clambda approx ->
+    if not !no_approx then begin
+      printf "Clambda approximation:\n";
+      Format.fprintf Format.std_formatter "  %a@." Printclambda.approx approx
+    end else
+      Format.printf "Clambda unit@.";
+  | Flambda export ->
+    if not !no_approx || not !no_code then
+      printf "Flambda export information:\n"
+    else
+      printf "Flambda unit\n";
+    if not !no_approx then begin
+      let cu =
+        Compilation_unit.create (Ident.create_persistent ui.ui_name)
+          (Linkage_name.create "__dummy__")
+      in
+      Compilation_unit.set_current cu;
+      let root_symbols =
+        List.map (fun s ->
+            Symbol.unsafe_create cu (Linkage_name.create ("caml"^s)))
+          ui.ui_defines
+      in
+      Format.printf "approximations@ %a@.@."
+        Export_info.print_approx (export, root_symbols)
+    end;
+    if not !no_code then
+      Format.printf "functions@ %a@.@."
+        Export_info.print_functions export
+  end;
+  let pr_funs _ fns =
+    List.iter (fun arity -> printf " %d" arity) fns in
+  printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun;
+  printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun;
+  printf "Send functions:%a\n" pr_funs ui.ui_send_fun;
+  printf "Force link: %s\n" (if ui.ui_force_link then "YES" else "no")
+
+let print_cmxa_infos (lib : Cmx_format.library_infos) =
+  printf "Extra C object files:";
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  printf "\nExtra C options:";
+  List.iter print_spaced_string lib.lib_ccopts;
+  printf "\n";
+  List.iter print_cmx_infos lib.lib_units
+
+let print_cmxs_infos header =
+  List.iter
+    (fun ui ->
+       print_general_infos
+         ui.dynu_name
+         ui.dynu_crc
+         ui.dynu_defines
+         ui.dynu_imports_cmi
+         ui.dynu_imports_cmx)
+    header.dynu_units
+
+let p_title title = printf "%s:\n" title
+
+let p_section title = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print_name_crc l
+
+let p_list title print = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print l
+
+let dump_byte ic =
+  Bytesections.read_toc ic;
+  let toc = Bytesections.toc () in
+  let toc = List.sort Pervasives.compare toc in
+  List.iter
+    (fun (section, _) ->
+       try
+         let len = Bytesections.seek_section ic section in
+         if len > 0 then match section with
+           | "CRCS" ->
+               p_section
+                 "Imported units"
+                 (input_value ic : (string * Digest.t option) list)
+           | "DLLS" ->
+               p_list
+                 "Used DLLs"
+                 print_line
+                 (input_stringlist ic len)
+           | "DLPT" ->
+               p_list
+                 "Additional DLL paths"
+                 print_line
+                 (input_stringlist ic len)
+           | "PRIM" ->
+               p_list
+                 "Primitives used"
+                 print_line
+                 (input_stringlist ic len)
+           | "SYMB" ->
+               print_global_table (input_value ic)
+           | _ -> ()
+       with _ -> ()
+    )
+    toc
+
+let read_dyn_header filename ic =
+  let tempfile = Filename.temp_file "objinfo" ".out" in
+  let helper = Filename.concat Config.standard_library "objinfo_helper" in
+  try
+    try_finally
+      (fun () ->
+        let rc = Sys.command (sprintf "%s %s > %s"
+                                (Filename.quote helper)
+                                (Filename.quote filename)
+                                tempfile) in
+        if rc <> 0 then failwith "cannot read";
+        let tc = Scanf.Scanning.from_file tempfile in
+        try_finally
+          (fun () ->
+            let ofs = Scanf.bscanf tc "%Ld" (fun x -> x) in
+            LargeFile.seek_in ic ofs;
+            Some(input_value ic : dynheader))
+          (fun () -> Scanf.Scanning.close_in tc))
+      (fun () -> remove_file tempfile)
+  with Failure _ | Sys_error _ -> None
+
+let dump_obj filename =
+  printf "File %s\n" filename;
+  let ic = open_in_bin filename in
+  let len_magic_number = String.length cmo_magic_number in
+  let magic_number = really_input_string ic len_magic_number in
+  if magic_number = cmo_magic_number then begin
+    let cu_pos = input_binary_int ic in
+    seek_in ic cu_pos;
+    let cu = (input_value ic : compilation_unit) in
+    close_in ic;
+    print_cmo_infos cu
+  end else if magic_number = cma_magic_number then begin
+    let toc_pos = input_binary_int ic in
+    seek_in ic toc_pos;
+    let toc = (input_value ic : library) in
+    close_in ic;
+    print_cma_infos toc
+  end else if magic_number = cmi_magic_number ||
+              magic_number = cmt_magic_number then begin
+    close_in ic;
+    let cmi, cmt = Cmt_format.read filename in
+    begin match cmi with
+     | None -> ()
+     | Some cmi ->
+         print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs
+    end;
+    begin match cmt with
+     | None -> ()
+     | Some cmt -> print_cmt_infos cmt
+    end
+  end else if magic_number = cmx_magic_number then begin
+    let ui = (input_value ic : unit_infos) in
+    let crc = Digest.input ic in
+    close_in ic;
+    print_cmx_infos (ui, crc)
+  end else if magic_number = cmxa_magic_number then begin
+    let li = (input_value ic : library_infos) in
+    close_in ic;
+    print_cmxa_infos li
+  end else begin
+    let pos_trailer = in_channel_length ic - len_magic_number in
+    let _ = seek_in ic pos_trailer in
+    let magic_number = really_input_string ic len_magic_number in
+    if magic_number = Config.exec_magic_number then begin
+      dump_byte ic;
+      close_in ic
+    end else if Filename.check_suffix filename ".cmxs" then begin
+      flush stdout;
+      match read_dyn_header filename ic with
+      | None ->
+          printf "Unable to read info on file %s\n" filename;
+          exit 2
+      | Some header ->
+          if header.dynu_magic = Config.cmxs_magic_number then
+            print_cmxs_infos header
+          else begin
+            printf "Wrong magic number\n"; exit 2
+          end;
+          close_in ic
+    end else begin
+      printf "Not an OCaml object file\n"; exit 2
+    end
+  end
+
+let arg_list = [
+  "-no-approx", Arg.Set no_approx, " Do not print module approximation information";
+  "-no-code", Arg.Set no_code, " Do not print code from exported flambda functions";
+  "-args", Arg.Expand Arg.read_arg,
+     " Read additional newline separated command line arguments \n\
+     \      from ";
+  "-args0", Arg.Expand Arg.read_arg0,
+     " Read additional NUL separated command line arguments from \n\
+     \      ";
+]
+let arg_usage =
+   Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0)
+
+let main() =
+  Arg.parse_expand arg_list dump_obj arg_usage;
+  exit 0
+
+let _ = main ()
diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c
new file mode 100644
index 00000000..7a36b388
--- /dev/null
+++ b/tools/objinfo_helper.c
@@ -0,0 +1,100 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*         Mehdi Dogguy, PPS laboratory, University Paris Diderot         */
+/*                                                                        */
+/*   Copyright 2010 Mehdi Dogguy                                          */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "../config/s.h"
+#include 
+
+#ifdef HAS_LIBBFD
+#include 
+#include 
+
+// PACKAGE: protect against binutils change
+//   https://sourceware.org/bugzilla/show_bug.cgi?id=14243
+#define PACKAGE "ocamlobjinfo"
+#include 
+#undef PACKAGE
+
+#define plugin_header_sym (symbol_prefix "caml_plugin_header")
+
+int main(int argc, char ** argv)
+{
+  bfd *fd;
+  asection *sec;
+  file_ptr offset;
+  long st_size;
+  asymbol ** symbol_table;
+  long sym_count, i;
+
+  if (argc != 2) {
+    fprintf(stderr, "Usage: objinfo_helper \n");
+    return 2;
+  }
+
+  fd = bfd_openr(argv[1], "default");
+  if (!fd) {
+    fprintf(stderr, "Error opening file %s\n", argv[1]);
+    return 2;
+  }
+  if (! bfd_check_format (fd, bfd_object)) {
+    fprintf(stderr, "Error: wrong format\n");
+    bfd_close(fd);
+    return 2;
+  }
+
+  sec = bfd_get_section_by_name(fd, ".data");
+  if (! sec) {
+    fprintf(stderr, "Error: section .data not found\n");
+    bfd_close(fd);
+    return 2;
+  }
+
+  offset = sec->filepos;
+  st_size = bfd_get_dynamic_symtab_upper_bound (fd);
+  if (st_size <= 0) {
+    fprintf(stderr, "Error: size of section .data unknown\n");
+    bfd_close(fd);
+    return 2;
+  }
+
+  symbol_table = malloc(st_size);
+  if (! symbol_table) {
+    fprintf(stderr, "Error: out of memory\n");
+    bfd_close(fd);
+    return 2;
+  }
+
+  sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table);
+
+  for (i = 0; i < sym_count; i++) {
+    if (strcmp(symbol_table[i]->name, plugin_header_sym) == 0) {
+      printf("%ld\n", (long) (offset + symbol_table[i]->value));
+      bfd_close(fd);
+      return 0;
+    }
+  }
+
+  fprintf(stderr, "Error: missing symbol %s\n", plugin_header_sym);
+  bfd_close(fd);
+  return 2;
+}
+
+#else
+
+int main(int argc, char ** argv)
+{
+  fprintf(stderr,"BFD library unavailable, cannot print info on .cmxs files\n");
+  return 2;
+}
+
+#endif
diff --git a/tools/ocaml-instr-graph b/tools/ocaml-instr-graph
new file mode 100755
index 00000000..5792da11
--- /dev/null
+++ b/tools/ocaml-instr-graph
@@ -0,0 +1,116 @@
+#!/bin/bash
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                  Damien Doligez, Jane Street Group, LLC                *
+#*                                                                        *
+#*   Copyright 2015 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Use this script on OCAML_INSTR_FILE files
+
+default_curves=major,minor,coll,dispatch
+
+usage () {
+    echo 'usage: ocaml-instr-graph file [options]'
+    echo '  options:'
+    echo "  -d names   plot the data for names (default: $default_curves)"
+    echo '  -t title   set the graph title'
+    echo '  -m n       clip the values to n (default 1G)'
+    echo '  -rt n      set the range for times to 0..n'
+    echo '  -rn n      set the range for counts to 0..n'
+    echo '  -from t    start at time t'
+    echo '  -to t      stop at time t'
+    echo '  -help      display this help message and exit'
+}
+
+datafile=
+curves=,
+title=
+titleset=false
+max=1000000000
+ranget=
+rangen=
+from=0
+to=1e19
+
+while [[ $# > 0 ]]; do
+    case $1 in
+        -d) curves=$curves$2,; shift 2;;
+        -t) title=$2; titleset=true; shift 2;;
+        -m) max=$2; shift 2;;
+        -rt) ranget="set yrange [0:$2]"; shift 2;;
+        -rn) rangen="set y2range [0:$2]"; shift 2;;
+        -from) from=$2; shift 2;;
+        -to) to=$2; shift 2;;
+        -help) usage; exit 0;;
+        *) datafile=$1; shift 1;;
+    esac
+done
+
+if [[ "$curves" = , ]]; then
+    curves=,$default_curves,
+fi
+
+if ! $titleset; then
+    title=$datafile
+fi
+
+tmpfile=/tmp/ocaml-instr-graph.$$
+
+rm -f $tmpfile-*
+
+awk -v curves="$curves" -v clip=$max -v tmpfile="$tmpfile" -v from=$from \
+    -v to=$to '
+  function output (filename){
+    time = ($2 - starttime) / 1e9;
+    if (time < from || time >= to) return;
+    if (index(curves, "," filename ",") != 0){
+      gsub (/\//,":",filename);
+      if (filename ~ /#/){
+        point = $3;
+      }else{
+        point = ($3 - $2) / 1000;
+      }
+      if (point > clip) point = clip;
+      printf ("%.6f %.3f\n", time, point) >> tmpfile "-" filename;
+    }
+  }
+  BEGIN {starttime = 9e18;}
+  $1 != "@@" { next; }
+  $2 < starttime { starttime = $2 }
+  { output($4); }
+' $datafile
+
+( echo set title \"$title\"
+  echo set key left top
+  echo set ytics nomirror
+  echo 'set format y "%gus"'
+  echo "$ranget"
+  echo "$rangen"
+  echo set y2tics nomirror
+  echo 'set format x "%gs"'
+  printf "plot "
+  for curve in ${curves//,/ }; do
+      f=$tmpfile-${curve//\//:}
+      if [ -f $f ]; then
+          case $f in
+              *#) printf "\"%s\" using 1:2 axes x1y2 title '%s', " "$f" \
+                         "$curve"
+                  ;;
+              *)  printf "\"%s\" using 1:2 title '%s', " "$f" "$curve";;
+          esac
+      fi
+  done
+  printf "\n"
+) | gnuplot -p
+
+rm -f $tmpfile-*
diff --git a/tools/ocaml-instr-report b/tools/ocaml-instr-report
new file mode 100755
index 00000000..bac4f6ba
--- /dev/null
+++ b/tools/ocaml-instr-report
@@ -0,0 +1,162 @@
+#!/bin/awk -f
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                  Damien Doligez, Jane Street Group, LLC                *
+#*                                                                        *
+#*   Copyright 2014 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# usage:
+#   ocaml-instr-report { file ... }
+#   generate a report from the data files (or stdin if no file is given)
+
+function short(n, kind,    i, r){
+    for (i = 0; i < 5; i++){
+        if (n < 1000) break;
+        n /= 1000;
+    }
+    r = sprintf ("%f", n);
+    if (index(r, ".") == 3){
+        r = substr(r, 1, 2);
+    }else{
+        r = substr(r, 1, 3);
+    }
+    return sprintf("%s%s", r, units[kind,i]);
+}
+
+function add(limit){
+    lim[nscales] = limit;
+    scale["t",nscales] = short(limit, "t");
+    scale["n",nscales] = short(limit, "n");
+    ++ nscales;
+}
+
+# kind is "t" (for timer) or "n" (for number)
+# events are simply a special kind of timer
+
+BEGIN {
+    units["t",0] = "ns";
+    units["t",1] = "us";
+    units["t",2] = "ms";
+    units["t",3] = "s";
+    units["t",4] = "ks";
+    units["t",5] = "Ms";
+
+    units["n",0] = "";
+    units["n",1] = "k";
+    units["n",2] = "M";
+    units["n",3] = "G";
+    units["n",4] = "T";
+    units["n",5] = "P";
+
+    nscales=0;
+    add(0);
+    for (mul = 100; mul < 10000000000; mul *= 10){
+        add(mul);
+        add(2.2 * mul);
+        add(4.7 * mul);
+    }
+}
+
+function store(value, tag) {
+    ++ total[tag];
+    for (i = 0; i < nscales; i++){
+        if (value <= lim[i]){
+            ++ bin[tag, lim[i]];
+            val[tag, lim[i]] = value;
+            return;
+        }
+    }
+    ++ bin[tag, "off-scale"];
+    val[tag, "off-scale"] = value;
+}
+
+$1 == "@@" && $4 ~ /@/ { total[$4] += $3; }
+
+$1 == "@@" && $4 ~ /#/ { store($3, $4); }
+
+$1 == "@@" { store($3 - $2, $4); }
+
+function display(n, val, kind,    i) {
+    graph_width = 35;
+
+    if (n > 0){
+        for (i = 0; i < log (n) / log (2); i++){
+            printf("#");
+        }
+        if (n == 1){
+            printf(" %-6d", n);
+            printf ("%-*s", graph_width - 7 - i,
+                    sprintf("(%s)", short(val, kind)));
+        }else{
+            printf(" %-*d", graph_width - 1 - i, n);
+        }
+    }else{
+        printf("%*s", graph_width, "");
+    }
+}
+
+END {
+    n = asorti(total,tags);
+    total_alloc = 0;
+    for (i = 1; i <= n; i++){
+        t = tags[i];
+        if (t ~ /^alloc/) total_alloc += total[t];
+    }
+    for (i = 1; i <= n; i++){
+        t = tags[i];
+        if (t ~ /#/){
+            kind = "n";        # number
+        }else if (t ~ /@/){
+            kind = "e";        # event
+        }else{
+            kind = "t";        # timer
+        }
+        if (kind == "e"){
+            printf ("==== %-12s:%9d", t, total[t]);
+            if (t ~ /^alloc/){
+                cumul += total[t] / total_alloc;
+                printf(" (%6.2f%%)", cumul * 100);
+            }
+            printf ("\n");
+            continue;
+        }else{
+            printf ("==== %s: %d\n", t, total[t]);
+        }
+        num = bin[t,0];
+        found = num;
+        if (num == total[t] && kind == "t"){
+            /* nothing */
+        }else if (num > 0){
+            printf ("           0: ");
+            display(bin[t,0], val[t, 0], kind);
+            printf ("%6.2f%%\n", found * 100 / total[t]);
+        }
+        for (j = 1; j < nscales; j++){
+            if (found == total[t]) break;
+            num = bin [t, lim[j]];
+            found += num;
+            if (found > 0){
+                printf ("%5s..%-5s: ", scale[kind,j-1], scale[kind,j]);
+                display(num, val[t, lim[j]], kind);
+                printf ("%6.2f%%\n", found * 100 / total[t]);
+            }
+        }
+        num = bin[t, "off-scale"];
+        if (num != 0){
+            printf ("  off scale : ");
+            display(bin[t, "off-scale"], val[t, "off-scale"]);
+            printf ("\n");
+        }
+        printf ("====\n");
+    }
+}
diff --git a/tools/ocaml-objcopy-macosx b/tools/ocaml-objcopy-macosx
new file mode 100755
index 00000000..3b8dcc2a
--- /dev/null
+++ b/tools/ocaml-objcopy-macosx
@@ -0,0 +1,54 @@
+#!/bin/bash
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Damien Doligez, projet Cristal, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2005 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+TMP="${TMPDIR=/tmp}"
+TEMP="${TMP}"/ocaml-objcopy-$$.o
+UNDEF="${TMP}"/ocaml-objcopy-$$.sym
+
+usage () {
+  echo "usage: objcopy {--redefine-sym =} file.o" >&2
+  exit 2
+}
+
+: > "$UNDEF"
+
+while : ; do
+  case $# in
+    0) break;;
+    *) case $1 in
+         --redefine-sym)
+           case $2 in
+             *=*) ALIAS="$ALIAS -i${2#*=}:${2%%=*}"
+                  echo ${2%%=*} >>"$UNDEF"
+                  ;;
+             *) usage;;
+           esac
+           shift 2
+           ;;
+         -*) usage;;
+         *) case $FILE in
+              "") FILE=$1; shift;;
+              *) usage;;
+            esac;;
+       esac;;
+  esac
+done
+
+ld -o "$TEMP" -r $ALIAS "$FILE"
+ld -o "$FILE" -r -unexported_symbols_list "$UNDEF" "$TEMP"
+
+rm -f "$TEMP" "$UNDEF"
diff --git a/tools/ocaml299to3.ml b/tools/ocaml299to3.ml
new file mode 100644
index 00000000..f0352c19
--- /dev/null
+++ b/tools/ocaml299to3.ml
@@ -0,0 +1,141 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jacques Garrigue, Kyoto University RIMS                  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexer299
+
+let input_buffer = Buffer.create 16383
+let input_function ic buf len =
+  let len = input ic buf 0 len in
+  Buffer.add_substring input_buffer buf 0 len;
+  len
+
+let output_buffer = Buffer.create 16383
+
+let modified = ref false
+
+let convert buffer =
+  let input_pos = ref 0 in
+  let copy_input stop =
+    Buffer.add_substring output_buffer (Buffer.contents input_buffer)
+      !input_pos (stop - !input_pos);
+    input_pos := stop
+  in
+  let last = ref (EOF, 0, 0) in
+  try while true do
+    let token = Lexer299.token buffer
+    and start = Lexing.lexeme_start buffer
+    and stop = Lexing.lexeme_end buffer
+    and last_token, last_start, last_stop = !last in
+    begin match token with
+    | LABEL l0 ->
+        let l = if l0 = "fun" then "f" else l0 in
+        begin match last_token with
+        | PREFIXOP "?(" ->
+            modified := true;
+            copy_input last_start;
+            Buffer.add_char output_buffer '?';
+            Buffer.add_string output_buffer l;
+            Buffer.add_string output_buffer ":(";
+            input_pos := stop
+        | QUESTION | LPAREN | LBRACE | SEMI | MINUSGREATER
+        | EQUAL | COLON | COLONGREATER
+        | VAL | MUTABLE | EXTERNAL | METHOD | OF ->
+            if l0 = "fun" then begin
+              modified := true;
+              copy_input start;
+              Buffer.add_string output_buffer l;
+              Buffer.add_char output_buffer ':';
+              input_pos := stop
+            end
+        | _ ->
+            modified := true;
+            copy_input start;
+            Buffer.add_char output_buffer '~';
+            Buffer.add_string output_buffer l;
+            Buffer.add_char output_buffer ':';
+            input_pos := stop
+        end
+    | LABELID l ->
+        modified := true;
+        begin match last_token with
+        | PREFIXOP "?(" ->
+            copy_input last_start;
+            Buffer.add_string output_buffer "?(";
+            Buffer.add_string output_buffer l;
+            input_pos := stop
+        | LPAREN ->
+            copy_input last_start;
+            Buffer.add_string output_buffer "~(";
+            Buffer.add_string output_buffer l;
+            input_pos := stop
+        | QUESTION ->
+            copy_input last_stop;
+            Buffer.add_string output_buffer l;
+            input_pos := stop
+        | _ ->
+            copy_input start;
+            Buffer.add_char output_buffer '~';
+            Buffer.add_string output_buffer l;
+            input_pos := stop
+       end
+    | EOF -> raise End_of_file
+    | _ -> ()
+    end;
+    if last_token = QUESTION && token = LPAREN then
+      last := (PREFIXOP "?(", last_start, stop)
+    else
+      last := (token, start, stop)
+  done with
+    End_of_file ->
+      copy_input (Buffer.length input_buffer)
+
+let convert_file name =
+  let ic = open_in name in
+  Buffer.clear input_buffer;
+  Buffer.clear output_buffer;
+  modified := false;
+  begin
+    try convert (Lexing.from_function (input_function ic)); close_in ic
+    with exn -> close_in ic; raise exn
+  end;
+  if !modified then begin
+    let backup = name ^ ".bak" in
+    if Sys.file_exists backup then Sys.remove name
+    else Sys.rename name backup;
+    let oc = open_out name in
+    Buffer.output_buffer oc output_buffer;
+    close_out oc
+  end
+
+let _ =
+  if Array.length Sys.argv < 2 || Sys.argv.(1) = "-h" || Sys.argv.(1) = "-help"
+  then begin
+    print_endline "Usage: ocaml299to3  ...";
+    print_endline "Description:";
+    print_endline
+      "Convert OCaml 2.99 O'Labl-style labels in implementation files to";
+    print_endline
+      "a syntax compatible with version 3. Also `fun:' labels are replaced \
+       by `f:'.";
+    print_endline "Other syntactic changes are not handled.";
+    print_endline "Old files are renamed to .bak.";
+    print_endline "Interface files do not need label syntax conversion.";
+    exit 0
+  end;
+  for i = 1 to Array.length Sys.argv - 1 do
+    let name = Sys.argv.(i) in
+    prerr_endline ("Converting " ^ name);
+    Printexc.catch convert_file name
+  done
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
new file mode 100644
index 00000000..278952f7
--- /dev/null
+++ b/tools/ocamlcp.ml
@@ -0,0 +1,174 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+let compargs = ref ([] : string list)
+let profargs = ref ([] : string list)
+let toremove = ref ([] : string list)
+
+let option opt () = compargs := opt :: !compargs
+let option_with_arg opt arg =
+  compargs := (Filename.quote arg) :: opt :: !compargs
+;;
+
+let make_archive = ref false;;
+let with_impl = ref false;;
+let with_intf = ref false;;
+let with_mli = ref false;;
+let with_ml = ref false;;
+
+let process_file filename =
+  if Filename.check_suffix filename ".ml" then with_ml := true;
+  if Filename.check_suffix filename ".mli" then with_mli := true;
+  compargs := (Filename.quote filename) :: !compargs
+;;
+
+let usage = "Usage: ocamlcp  \noptions are:"
+
+let incompatible o =
+  fprintf stderr "ocamlcp: profiling is incompatible with the %s option\n" o;
+  exit 2
+
+module Options = Main_args.Make_bytecomp_options (struct
+  let _a () = make_archive := true; option "-a" ()
+  let _absname = option "-absname"
+  let _annot = option "-annot"
+  let _binannot = option "-bin-annot"
+  let _c = option "-c"
+  let _cc s = option_with_arg "-cc" s
+  let _cclib s = option_with_arg "-cclib" s
+  let _ccopt s = option_with_arg "-ccopt" s
+  let _config = option "-config"
+  let _compat_32 = option "-compat-32"
+  let _custom = option "-custom"
+  let _dllib = option_with_arg "-dllib"
+  let _dllpath = option_with_arg "-dllpath"
+  let _dtypes = option "-dtypes"
+  let _for_pack = option_with_arg "-for-pack"
+  let _g = option "-g"
+  let _i = option "-i"
+  let _I s = option_with_arg "-I" s
+  let _impl s = with_impl := true; option_with_arg "-impl" s
+  let _intf s = with_intf := true; option_with_arg "-intf" s
+  let _intf_suffix s = option_with_arg "-intf-suffix" s
+  let _keep_docs = option "-keep-docs"
+  let _no_keep_docs = option "-no-keep-docs"
+  let _keep_locs = option "-keep-locs"
+  let _no_keep_locs = option "-no-keep-locs"
+  let _labels = option "-labels"
+  let _linkall = option "-linkall"
+  let _make_runtime = option "-make-runtime"
+  let _alias_deps = option "-alias-deps"
+  let _no_alias_deps = option "-no-alias-deps"
+  let _app_funct = option "-app-funct"
+  let _no_app_funct = option "-no-app-funct"
+  let _no_check_prims = option "-no-check-prims"
+  let _noassert = option "-noassert"
+  let _nolabels = option "-nolabels"
+  let _noautolink = option "-noautolink"
+  let _nostdlib = option "-nostdlib"
+  let _o s = option_with_arg "-o" s
+  let _opaque = option "-opaque"
+  let _open s = option_with_arg "-open" s
+  let _output_obj = option "-output-obj"
+  let _output_complete_obj = option "-output-complete-obj"
+  let _pack = option "-pack"
+  let _plugin = option_with_arg "-plugin"
+  let _pp _s = incompatible "-pp"
+  let _ppx _s = incompatible "-ppx"
+  let _principal = option "-principal"
+  let _no_principal = option "-no-principal"
+  let _rectypes = option "-rectypes"
+  let _no_rectypes = option "-no-rectypes"
+  let _runtime_variant s = option_with_arg "-runtime-variant" s
+  let _safe_string = option "-safe-string"
+  let _short_paths = option "-short-paths"
+  let _strict_sequence = option "-strict-sequence"
+  let _no_strict_sequence = option "-no-strict-sequence"
+  let _strict_formats = option "-strict-formats"
+  let _no_strict_formats = option "-no-strict-formats"
+  let _thread () = option "-thread" ()
+  let _vmthread () = option "-vmthread" ()
+  let _unboxed_types = option "-unboxed-types"
+  let _no_unboxed_types = option "-no-unboxed-types"
+  let _unsafe = option "-unsafe"
+  let _unsafe_string = option "-unsafe-string"
+  let _use_prims s = option_with_arg "-use-prims" s
+  let _use_runtime s = option_with_arg "-use-runtime" s
+  let _v = option "-v"
+  let _version = option "-version"
+  let _vnum = option "-vnum"
+  let _verbose = option "-verbose"
+  let _w = option_with_arg "-w"
+  let _warn_error = option_with_arg "-warn-error"
+  let _warn_help = option "-warn-help"
+  let _color s = option_with_arg "-color" s
+  let _where = option "-where"
+  let _nopervasives = option "-nopervasives"
+  let _dsource = option "-dsource"
+  let _dparsetree = option "-dparsetree"
+  let _dtypedtree = option "-dtypedtree"
+  let _drawlambda = option "-drawlambda"
+  let _dlambda = option "-dlambda"
+  let _dflambda = option "-dflambda"
+  let _dinstr = option "-dinstr"
+  let _dtimings = option "-dtimings"
+  let _args = Arg.read_arg
+  let _args0 = Arg.read_arg0
+  let anonymous = process_file
+end);;
+
+let add_profarg s =
+  profargs := (Filename.quote s) :: "-m" :: !profargs
+;;
+
+let optlist =
+    ("-P", Arg.String add_profarg,
+           "[afilmt]  Profile constructs specified by argument (default fm):\n\
+        \032     a  Everything\n\
+        \032     f  Function calls and method calls\n\
+        \032     i  if ... then ... else\n\
+        \032     l  while and for loops\n\
+        \032     m  match ... with\n\
+        \032     t  try ... with")
+    :: ("-p", Arg.String add_profarg, "[afilmt]  Same as option -P")
+    :: Options.list
+in
+Arg.parse_expand optlist process_file usage;
+if !with_impl && !with_intf then begin
+  fprintf stderr "ocamlcp cannot deal with both \"-impl\" and \"-intf\"\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_impl && !with_mli then begin
+  fprintf stderr "ocamlcp cannot deal with both \"-impl\" and .mli files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_intf && !with_ml then begin
+  fprintf stderr "ocamlcp cannot deal with both \"-intf\" and .ml files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end;
+if !with_impl then profargs := "-impl" :: !profargs;
+if !with_intf then profargs := "-intf" :: !profargs;
+let status =
+  Sys.command
+    (Printf.sprintf "ocamlc -pp \"ocamlprof -instrument %s\" %s %s"
+        (String.concat " " (List.rev !profargs))
+        (if !make_archive then "" else "profiling.cmo")
+        (String.concat " " (List.rev !compargs)))
+in
+exit status
+;;
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
new file mode 100644
index 00000000..215de187
--- /dev/null
+++ b/tools/ocamldep.ml
@@ -0,0 +1,608 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Compenv
+open Parsetree
+module StringMap = Depend.StringMap
+
+let ppf = Format.err_formatter
+(* Print the dependencies *)
+
+type file_kind = ML | MLI;;
+
+let load_path = ref ([] : (string * string array) list)
+let ml_synonyms = ref [".ml"]
+let mli_synonyms = ref [".mli"]
+let native_only = ref false
+let bytecode_only = ref false
+let error_occurred = ref false
+let raw_dependencies = ref false
+let sort_files = ref false
+let all_dependencies = ref false
+let one_line = ref false
+let files = ref []
+let allow_approximation = ref false
+let map_files = ref []
+let module_map = ref StringMap.empty
+let debug = ref false
+
+(* Fix path to use '/' as directory separator instead of '\'.
+   Only under Windows. *)
+
+let fix_slash s =
+  if Sys.os_type = "Unix" then s else begin
+    String.map (function '\\' -> '/' | c -> c) s
+  end
+
+(* Since we reinitialize load_path after reading OCAMLCOMP,
+  we must use a cache instead of calling Sys.readdir too often. *)
+let dirs = ref StringMap.empty
+let readdir dir =
+  try
+    StringMap.find dir !dirs
+  with Not_found ->
+    let contents =
+      try
+        Sys.readdir dir
+      with Sys_error msg ->
+        Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+        error_occurred := true;
+        [||]
+    in
+    dirs := StringMap.add dir contents !dirs;
+    contents
+
+let add_to_list li s =
+  li := s :: !li
+
+let add_to_load_path dir =
+  try
+    let dir = Misc.expand_directory Config.standard_library dir in
+    let contents = readdir dir in
+    add_to_list load_path (dir, contents)
+  with Sys_error msg ->
+    Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+    error_occurred := true
+
+let add_to_synonym_list synonyms suffix =
+  if (String.length suffix) > 1 && suffix.[0] = '.' then
+    add_to_list synonyms suffix
+  else begin
+    Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
+    error_occurred := true
+  end
+
+(* Find file 'name' (capitalized) in search path *)
+let find_file name =
+  let uname = String.uncapitalize_ascii name in
+  let rec find_in_array a pos =
+    if pos >= Array.length a then None else begin
+      let s = a.(pos) in
+      if s = name || s = uname then Some s else find_in_array a (pos + 1)
+    end in
+  let rec find_in_path = function
+    [] -> raise Not_found
+  | (dir, contents) :: rem ->
+      match find_in_array contents 0 with
+        Some truename ->
+          if dir = "." then truename else Filename.concat dir truename
+      | None -> find_in_path rem in
+  find_in_path !load_path
+
+let rec find_file_in_list = function
+  [] -> raise Not_found
+| x :: rem -> try find_file x with Not_found -> find_file_in_list rem
+
+
+let find_dependency target_kind modname (byt_deps, opt_deps) =
+  try
+    let candidates = List.map ((^) modname) !mli_synonyms in
+    let filename = find_file_in_list candidates in
+    let basename = Filename.chop_extension filename in
+    let cmi_file = basename ^ ".cmi" in
+    let cmx_file = basename ^ ".cmx" in
+    let ml_exists =
+      List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
+    let new_opt_dep =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  ->
+          cmi_file :: (if ml_exists then [ cmx_file ] else [])
+      else
+        (* this is a make-specific hack that makes .cmx to be a 'proxy'
+           target that would force the dependency on .cmi via transitivity *)
+        if ml_exists
+        then [ cmx_file ]
+        else [ cmi_file ]
+    in
+    ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
+  with Not_found ->
+  try
+    (* "just .ml" case *)
+    let candidates = List.map ((^) modname) !ml_synonyms in
+    let filename = find_file_in_list candidates in
+    let basename = Filename.chop_extension filename in
+    let cmi_file = basename ^ ".cmi" in
+    let cmx_file = basename ^ ".cmx" in
+    let bytenames =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  -> [ cmi_file ]
+      else
+        (* again, make-specific hack *)
+        [basename ^ (if !native_only then ".cmx" else ".cmo")] in
+    let optnames =
+      if !all_dependencies
+      then match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  -> [ cmi_file; cmx_file ]
+      else [ cmx_file ]
+    in
+    (bytenames @ byt_deps, optnames @  opt_deps)
+  with Not_found ->
+    (byt_deps, opt_deps)
+
+let (depends_on, escaped_eol) = (":", " \\\n    ")
+
+let print_filename s =
+  let s = if !Clflags.force_slash then fix_slash s else s in
+  if not (String.contains s ' ') then begin
+    print_string s;
+  end else begin
+    let rec count n i =
+      if i >= String.length s then n
+      else if s.[i] = ' ' then count (n+1) (i+1)
+      else count n (i+1)
+    in
+    let spaces = count 0 0 in
+    let result = Bytes.create (String.length s + spaces) in
+    let rec loop i j =
+      if i >= String.length s then ()
+      else if s.[i] = ' ' then begin
+        Bytes.set result j '\\';
+        Bytes.set result (j+1) ' ';
+        loop (i+1) (j+2);
+      end else begin
+        Bytes.set result j s.[i];
+        loop (i+1) (j+1);
+      end
+    in
+    loop 0 0;
+    print_bytes result;
+  end
+;;
+
+let print_dependencies target_files deps =
+  let rec print_items pos = function
+    [] -> print_string "\n"
+  | dep :: rem ->
+    if !one_line || (pos + 1 + String.length dep <= 77) then begin
+        if pos <> 0 then print_string " "; print_filename dep;
+        print_items (pos + String.length dep + 1) rem
+      end else begin
+        print_string escaped_eol; print_filename dep;
+        print_items (String.length dep + 4) rem
+      end in
+  print_items 0 (target_files @ [depends_on] @ deps)
+
+let print_raw_dependencies source_file deps =
+  print_filename source_file; print_string depends_on;
+  Depend.StringSet.iter
+    (fun dep ->
+       (* filter out "*predef*" *)
+      if (String.length dep > 0)
+          && (match dep.[0] with
+              | 'A'..'Z' | '\128'..'\255' -> true
+              | _ -> false) then
+        begin
+          print_char ' ';
+          print_string dep
+        end)
+    deps;
+  print_char '\n'
+
+
+(* Process one file *)
+
+let report_err exn =
+  error_occurred := true;
+  match exn with
+    | Sys_error msg ->
+        Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
+    | x ->
+        match Location.error_of_exn x with
+        | Some err ->
+            Format.fprintf Format.err_formatter "@[%a@]@."
+              Location.report_error err
+        | None -> raise x
+
+let tool_name = "ocamldep"
+
+let rec lexical_approximation lexbuf =
+  (* Approximation when a file can't be parsed.
+     Heuristic:
+     - first component of any path starting with an uppercase character is a
+       dependency.
+     - always skip the token after a dot, unless dot is preceded by a
+       lower-case identifier
+     - always skip the token after a backquote
+  *)
+  try
+    let rec process after_lident lexbuf =
+      match Lexer.token lexbuf with
+      | Parser.UIDENT name ->
+          Depend.free_structure_names :=
+            Depend.StringSet.add name !Depend.free_structure_names;
+          process false lexbuf
+      | Parser.LIDENT _ -> process true lexbuf
+      | Parser.DOT when after_lident -> process false lexbuf
+      | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf
+      | Parser.EOF -> ()
+      | _ -> process false lexbuf
+    and skip_one lexbuf =
+      match Lexer.token lexbuf with
+      | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf
+      | Parser.EOF -> ()
+      | _ -> process false lexbuf
+
+    in
+    process false lexbuf
+  with Lexer.Error _ -> lexical_approximation lexbuf
+
+let read_and_approximate inputfile =
+  error_occurred := false;
+  Depend.free_structure_names := Depend.StringSet.empty;
+  let ic = open_in_bin inputfile in
+  try
+    seek_in ic 0;
+    Location.input_name := inputfile;
+    let lexbuf = Lexing.from_channel ic in
+    Location.init lexbuf inputfile;
+    lexical_approximation lexbuf;
+    close_in ic;
+    !Depend.free_structure_names
+  with exn ->
+    close_in ic;
+    report_err exn;
+    !Depend.free_structure_names
+
+let read_parse_and_extract parse_function extract_function def ast_kind
+                           source_file =
+  Depend.free_structure_names := Depend.StringSet.empty;
+  try
+    let input_file = Pparse.preprocess source_file in
+    begin try
+      let ast =
+        Pparse.file ~tool_name Format.err_formatter
+                    input_file parse_function ast_kind
+      in
+      let bound_vars =
+        List.fold_left
+          (fun bv modname ->
+            Depend.open_module bv (Longident.parse modname))
+          !module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
+      in
+      let r = extract_function bound_vars ast in
+      Pparse.remove_preprocessed input_file;
+      (!Depend.free_structure_names, r)
+    with x ->
+      Pparse.remove_preprocessed input_file;
+      raise x
+    end
+  with x -> begin
+    report_err x;
+    if not !allow_approximation
+    then (Depend.StringSet.empty, def)
+    else (read_and_approximate source_file, def)
+  end
+
+let print_ml_dependencies source_file extracted_deps =
+  let basename = Filename.chop_extension source_file in
+  let byte_targets = [ basename ^ ".cmo" ] in
+  let native_targets =
+    if !all_dependencies
+    then [ basename ^ ".cmx"; basename ^ ".o" ]
+    else [ basename ^ ".cmx" ] in
+  let init_deps = if !all_dependencies then [source_file] else [] in
+  let cmi_name = basename ^ ".cmi" in
+  let init_deps, extra_targets =
+    if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
+        !mli_synonyms
+    then (cmi_name :: init_deps, cmi_name :: init_deps), []
+    else (init_deps, init_deps),
+         (if !all_dependencies then [cmi_name] else [])
+  in
+  let (byt_deps, native_deps) =
+    Depend.StringSet.fold (find_dependency ML)
+      extracted_deps init_deps in
+  if not !native_only then
+    print_dependencies (byte_targets @ extra_targets) byt_deps;
+  if not !bytecode_only then
+    print_dependencies (native_targets @ extra_targets) native_deps
+
+let print_mli_dependencies source_file extracted_deps =
+  let basename = Filename.chop_extension source_file in
+  let (byt_deps, _opt_deps) =
+    Depend.StringSet.fold (find_dependency MLI)
+      extracted_deps ([], []) in
+  print_dependencies [basename ^ ".cmi"] byt_deps
+
+let print_file_dependencies (source_file, kind, extracted_deps) =
+  if !raw_dependencies then begin
+    print_raw_dependencies source_file extracted_deps
+  end else
+    match kind with
+    | ML -> print_ml_dependencies source_file extracted_deps
+    | MLI -> print_mli_dependencies source_file extracted_deps
+
+
+let ml_file_dependencies source_file =
+  let parse_use_file_as_impl lexbuf =
+    let f x =
+      match x with
+      | Ptop_def s -> s
+      | Ptop_dir _ -> []
+    in
+    List.flatten (List.map f (Parse.use_file lexbuf))
+  in
+  let (extracted_deps, ()) =
+    read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
+                           Pparse.Structure source_file
+  in
+  files := (source_file, ML, extracted_deps) :: !files
+
+let mli_file_dependencies source_file =
+  let (extracted_deps, ()) =
+    read_parse_and_extract Parse.interface Depend.add_signature ()
+                           Pparse.Signature source_file
+  in
+  files := (source_file, MLI, extracted_deps) :: !files
+
+let process_file_as process_fun def source_file =
+  Compenv.readenv ppf (Before_compile source_file);
+  load_path := [];
+  List.iter add_to_load_path (
+      (!Compenv.last_include_dirs @
+       !Clflags.include_dirs @
+       !Compenv.first_include_dirs
+      ));
+  Location.input_name := source_file;
+  try
+    if Sys.file_exists source_file then process_fun source_file else def
+  with x -> report_err x; def
+
+let process_file source_file ~ml_file ~mli_file ~def =
+  if List.exists (Filename.check_suffix source_file) !ml_synonyms then
+    process_file_as ml_file def source_file
+  else if List.exists (Filename.check_suffix source_file) !mli_synonyms then
+    process_file_as mli_file def source_file
+  else def
+
+let file_dependencies source_file =
+  process_file source_file ~def:()
+    ~ml_file:ml_file_dependencies
+    ~mli_file:mli_file_dependencies
+
+let file_dependencies_as kind =
+  match kind with
+  | ML -> process_file_as ml_file_dependencies ()
+  | MLI -> process_file_as mli_file_dependencies ()
+
+let sort_files_by_dependencies files =
+  let h = Hashtbl.create 31 in
+  let worklist = ref [] in
+
+(* Init Hashtbl with all defined modules *)
+  let files = List.map (fun (file, file_kind, deps) ->
+    let modname =
+      String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
+    in
+    let key = (modname, file_kind) in
+    let new_deps = ref [] in
+    Hashtbl.add h key (file, new_deps);
+    worklist := key :: !worklist;
+    (modname, file_kind, deps, new_deps)
+  ) files in
+
+(* Keep only dependencies to defined modules *)
+  List.iter (fun (modname, file_kind, deps, new_deps) ->
+    let add_dep modname kind =
+      new_deps := (modname, kind) :: !new_deps;
+    in
+    Depend.StringSet.iter (fun modname ->
+      match file_kind with
+          ML -> (* ML depends both on ML and MLI *)
+            if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
+            if Hashtbl.mem h (modname, ML) then add_dep modname ML
+        | MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
+          if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+          else if Hashtbl.mem h (modname, ML) then add_dep modname ML
+    ) deps;
+    if file_kind = ML then (* add dep from .ml to .mli *)
+      if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+  ) files;
+
+(* Print and remove all files with no remaining dependency. Iterate
+   until all files have been removed (worklist is empty) or
+   no file was removed during a turn (cycle). *)
+  let printed = ref true in
+  while !printed && !worklist <> [] do
+    let files = !worklist in
+    worklist := [];
+    printed := false;
+    List.iter (fun key ->
+      let (file, deps) = Hashtbl.find h key in
+      let set = !deps in
+      deps := [];
+      List.iter (fun key ->
+        if Hashtbl.mem h key then deps := key :: !deps
+      ) set;
+      if !deps = [] then begin
+        printed := true;
+        Printf.printf "%s " file;
+        Hashtbl.remove h key;
+      end else
+        worklist := key :: !worklist
+    ) files
+  done;
+
+  if !worklist <> [] then begin
+    Format.fprintf Format.err_formatter
+      "@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
+    let sorted_deps =
+      let li = ref [] in
+      Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;
+      List.sort (fun (file1, _) (file2, _) -> String.compare file1 file2) !li
+    in
+    List.iter (fun (file, deps) ->
+      Format.fprintf Format.err_formatter "\t@[%s: " file;
+      List.iter (fun (modname, kind) ->
+        Format.fprintf Format.err_formatter "%s.%s " modname
+          (if kind=ML then "ml" else "mli");
+      ) !deps;
+      Format.fprintf Format.err_formatter "@]@.";
+      Printf.printf "%s " file) sorted_deps;
+  end;
+  Printf.printf "\n%!";
+  ()
+
+(* Map *)
+
+let rec dump_map s0 ppf m =
+  let open Depend in
+  StringMap.iter
+    (fun key (Node(s1,m')) ->
+      let s = StringSet.diff s1 s0 in
+      if StringSet.is_empty s then
+        Format.fprintf ppf "@ @[module %s : sig%a@;<1 -2>end@]"
+          key (dump_map (StringSet.union s1 s0)) m'
+      else
+        Format.fprintf ppf "@ module %s = %s" key (StringSet.choose s))
+    m
+
+let process_ml_map =
+  read_parse_and_extract Parse.implementation Depend.add_implementation_binding
+                         StringMap.empty Pparse.Structure
+
+let process_mli_map =
+  read_parse_and_extract Parse.interface Depend.add_signature_binding
+                         StringMap.empty Pparse.Signature
+
+let parse_map fname =
+  map_files := fname :: !map_files ;
+  let old_transp = !Clflags.transparent_modules in
+  Clflags.transparent_modules := true;
+  let (deps, m) =
+    process_file fname ~def:(Depend.StringSet.empty, StringMap.empty)
+      ~ml_file:process_ml_map
+      ~mli_file:process_mli_map
+  in
+  Clflags.transparent_modules := old_transp;
+  let modname =
+    String.capitalize_ascii
+      (Filename.basename (Filename.chop_extension fname)) in
+  if StringMap.is_empty m then
+    report_err (Failure (fname ^ " : empty map file or parse error"));
+  let mm = Depend.make_node m in
+  if !debug then begin
+    Format.printf "@[%s:%t%a@]@." fname
+      (fun ppf -> Depend.StringSet.iter (Format.fprintf ppf " %s") deps)
+      (dump_map deps) (StringMap.add modname mm StringMap.empty)
+  end;
+  let mm = Depend.(weaken_map (StringSet.singleton modname) mm) in
+  module_map := StringMap.add modname mm !module_map
+;;
+
+
+(* Entry point *)
+
+let usage = "Usage: ocamldep [options] \nOptions are:"
+
+let print_version () =
+  Format.printf "ocamldep, version %s@." Sys.ocaml_version;
+  exit 0;
+;;
+
+let print_version_num () =
+  Format.printf "%s@." Sys.ocaml_version;
+  exit 0;
+;;
+
+let _ =
+  Clflags.classic := false;
+  add_to_list first_include_dirs Filename.current_dir_name;
+  Compenv.readenv ppf Before_args;
+  Clflags.add_arguments __LOC__ [
+     "-absname", Arg.Set Location.absname,
+        " Show absolute filenames in error messages";
+     "-all", Arg.Set all_dependencies,
+        " Generate dependencies on all files";
+     "-allow-approx", Arg.Set allow_approximation,
+        " Fallback to a lexer-based approximation on unparseable files";
+     "-as-map", Arg.Set Clflags.transparent_modules,
+      " Omit delayed dependencies for module aliases (-no-alias-deps -w -49)";
+      (* "compiler uses -no-alias-deps, and no module is coerced"; *)
+     "-debug-map", Arg.Set debug,
+        " Dump the delayed dependency map for each map file";
+     "-I", Arg.String (add_to_list Clflags.include_dirs),
+        "  Add  to the list of include directories";
+     "-impl", Arg.String (file_dependencies_as ML),
+        "  Process  as a .ml file";
+     "-intf", Arg.String (file_dependencies_as MLI),
+        "  Process  as a .mli file";
+     "-map", Arg.String parse_map,
+        "  Read  and propagate delayed dependencies to following files";
+     "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
+        "  Consider  as a synonym of the .ml extension";
+     "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
+        "  Consider  as a synonym of the .mli extension";
+     "-modules", Arg.Set raw_dependencies,
+        " Print module dependencies in raw form (not suitable for make)";
+     "-native", Arg.Set native_only,
+        " Generate dependencies for native-code only (no .cmo files)";
+     "-bytecode", Arg.Set bytecode_only,
+        " Generate dependencies for bytecode-code only (no .cmx files)";
+     "-one-line", Arg.Set one_line,
+        " Output one line per file, regardless of the length";
+     "-open", Arg.String (add_to_list Clflags.open_modules),
+        "  Opens the module  before typing";
+     "-plugin", Arg.String Compplugin.load,
+         "  Load dynamic plugin ";
+     "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
+         "  Pipe sources through preprocessor ";
+     "-ppx", Arg.String (add_to_list first_ppx),
+         "  Pipe abstract syntax trees through preprocessor ";
+     "-slash", Arg.Set Clflags.force_slash,
+         " (Windows) Use forward slash / instead of backslash \\ in file paths";
+     "-sort", Arg.Set sort_files,
+        " Sort files according to their dependencies";
+     "-version", Arg.Unit print_version,
+         " Print version and exit";
+     "-vnum", Arg.Unit print_version_num,
+         " Print version number and exit";
+     "-args", Arg.Expand Arg.read_arg,
+         " Read additional newline separated command line arguments \n\
+         \      from ";
+     "-args0", Arg.Expand Arg.read_arg0,
+         " Read additional NUL separated command line arguments from \n\
+         \      "
+  ];
+  Clflags.parse_arguments file_dependencies usage;
+  Compenv.readenv ppf Before_link;
+  if !sort_files then sort_files_by_dependencies !files
+  else List.iter print_file_dependencies (List.sort compare !files);
+  exit (if !error_occurred then 2 else 0)
diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml
new file mode 100644
index 00000000..e5dda65e
--- /dev/null
+++ b/tools/ocamlmklib.ml
@@ -0,0 +1,328 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+open Ocamlmklibconfig
+
+(* PR#4783: under Windows, don't use absolute paths because we do
+   not know where the binary distribution will be installed. *)
+let compiler_path name =
+  if Sys.os_type = "Win32" then name else Filename.concat bindir name
+
+let bytecode_objs = ref []  (* .cmo,.cma,.ml,.mli files to pass to ocamlc *)
+and native_objs = ref []    (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *)
+and c_objs = ref []         (* .o, .a, .obj, .lib, .dll, .dylib, .so files to
+                               pass to mksharedlib and ar *)
+and caml_libs = ref []      (* -cclib to pass to ocamlc, ocamlopt *)
+and caml_opts = ref []      (* -ccopt to pass to ocamlc, ocamlopt *)
+and dynlink = ref supports_shared_libraries
+and failsafe = ref false    (* whether to fall back on static build only *)
+and c_libs = ref []         (* libs to pass to mksharedlib and ocamlc -cclib *)
+and c_Lopts = ref []      (* options to pass to mksharedlib and ocamlc -cclib *)
+and c_opts = ref []       (* options to pass to mksharedlib and ocamlc -ccopt *)
+and ld_opts = ref []        (* options to pass only to the linker *)
+and ocamlc = ref (compiler_path "ocamlc")
+and ocamlc_opts = ref []    (* options to pass only to ocamlc *)
+and ocamlopt = ref (compiler_path "ocamlopt")
+and ocamlopt_opts = ref []  (* options to pass only to ocamlc *)
+and output = ref "a"        (* Output name for OCaml part of library *)
+and output_c = ref ""       (* Output name for C part of library *)
+and rpath = ref []          (* rpath options *)
+and debug = ref false       (* -g option *)
+and verbose = ref false
+
+let starts_with s pref =
+  String.length s >= String.length pref &&
+  String.sub s 0 (String.length pref) = pref
+let ends_with = Filename.check_suffix
+let chop_prefix s pref =
+  String.sub s (String.length pref) (String.length s - String.length pref)
+let chop_suffix = Filename.chop_suffix
+
+exception Bad_argument of string
+
+let print_version () =
+  printf "ocamlmklib, version %s\n" Sys.ocaml_version;
+  exit 0;
+;;
+
+let print_version_num () =
+  printf "%s\n" Sys.ocaml_version;
+  exit 0;
+;;
+
+let parse_arguments argv =
+  let i = ref 1 in
+  let next_arg () =
+    if !i + 1 >= Array.length argv
+    then raise (Bad_argument("Option " ^ argv.(!i) ^ " expects one argument"));
+    incr i; argv.(!i) in
+  while !i < Array.length argv do
+    let s = argv.(!i) in
+    if ends_with s ".cmo" || ends_with s ".cma" then
+      bytecode_objs := s :: !bytecode_objs
+    else if ends_with s ".cmx" || ends_with s ".cmxa" then
+      native_objs := s :: !native_objs
+    else if ends_with s ".ml" || ends_with s ".mli" then
+     (bytecode_objs := s :: !bytecode_objs;
+      native_objs := s :: !native_objs)
+    else if List.exists (ends_with s)
+                        [".o"; ".a"; ".obj"; ".lib"; ".dll"; ".dylib"; ".so"]
+    then
+      c_objs := s :: !c_objs
+    else if s = "-cclib" then
+      caml_libs := next_arg () :: "-cclib" :: !caml_libs
+    else if s = "-ccopt" then
+      caml_opts := next_arg () :: "-ccopt" :: !caml_opts
+    else if s = "-custom" then
+      dynlink := false
+    else if s = "-I" then
+      caml_opts := next_arg () :: "-I" :: !caml_opts
+    else if s = "-failsafe" then
+      failsafe := true
+    else if s = "-g" then
+      debug := true
+    else if s = "-h" || s = "-help" || s = "--help" then
+      raise (Bad_argument "")
+    else if s = "-ldopt" then
+      ld_opts := next_arg () :: !ld_opts
+    else if s = "-linkall" then
+      caml_opts := s :: !caml_opts
+    else if starts_with s "-l" then
+      c_libs := s :: !c_libs
+    else if starts_with s "-L" then
+     (c_Lopts := s :: !c_Lopts;
+      let l = chop_prefix s "-L" in
+      if not (Filename.is_relative l) then rpath := l :: !rpath)
+    else if s = "-ocamlcflags" then
+      ocamlc_opts := next_arg () :: !ocamlc_opts
+    else if s = "-ocamlc" then
+      ocamlc := next_arg ()
+    else if s = "-ocamlopt" then
+      ocamlopt := next_arg ()
+    else if s = "-ocamloptflags" then
+      ocamlopt_opts := next_arg () :: !ocamlopt_opts
+    else if s = "-o" then
+      output := next_arg()
+    else if s = "-oc" then
+      output_c := next_arg()
+    else if s = "-dllpath" || s = "-R" || s = "-rpath" then
+      rpath := next_arg() :: !rpath
+    else if starts_with s "-R" then
+      rpath := chop_prefix s "-R" :: !rpath
+    else if s = "-Wl,-rpath" then
+     (let a = next_arg() in
+      if starts_with a "-Wl,"
+      then rpath := chop_prefix a "-Wl," :: !rpath
+      else raise (Bad_argument("Option -Wl,-rpath expects a -Wl, argument")))
+    else if starts_with s "-Wl,-rpath," then
+      rpath := chop_prefix s "-Wl,-rpath," :: !rpath
+    else if starts_with s "-Wl,-R" then
+      rpath := chop_prefix s "-Wl,-R" :: !rpath
+    else if s = "-v" || s = "-verbose" then
+      verbose := true
+    else if s = "-version" then
+      print_version ()
+    else if s = "-vnum" then
+      print_version_num ()
+    else if starts_with s "-F" then
+      c_opts := s :: !c_opts
+    else if s = "-framework" then
+      (let a = next_arg() in c_opts := a :: s :: !c_opts)
+    else if starts_with s "-" then
+      prerr_endline ("Unknown option " ^ s)
+    else
+      raise (Bad_argument("Don't know what to do with " ^ s));
+    incr i
+  done;
+  List.iter
+    (fun r -> r := List.rev !r)
+    [ bytecode_objs; native_objs; caml_libs; caml_opts;
+      c_libs; c_objs; c_opts; ld_opts; rpath ];
+(* Put -L options in front of -l options in -cclib to mimic -ccopt behavior *)
+  c_libs := !c_Lopts @ !c_libs;
+
+  if !output_c = "" then output_c := !output
+
+let usage = "\
+Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\
+                             .dll|.dylib files>\
+\nOptions are:\
+\n  -cclib    C library passed to ocamlc -a or ocamlopt -a only\
+\n  -ccopt    C option passed to ocamlc -a or ocamlopt -a only\
+\n  -custom        Disable dynamic loading\
+\n  -g             Build with debug information\
+\n  -dllpath  Add  to the run-time search path for DLLs\
+\n  -F        Specify a framework directory (MacOSX)\
+\n  -framework     Use framework  (MacOSX)\
+\n  -help          Print this help message and exit\
+\n  --help         Same as -help\
+\n  -h             Same as -help\
+\n  -I        Add  to the path searched for OCaml object files\
+\n  -failsafe      fall back to static linking if DLL construction failed\
+\n  -ldopt    C option passed to the shared linker only\
+\n  -linkall       Build OCaml archive with link-all behavior\
+\n  -l        Specify a dependent C library\
+\n  -L        Add  to the path searched for C libraries\
+\n  -ocamlc   Use  in place of \"ocamlc\"\
+\n  -ocamlcflags     Pass  to ocamlc\
+\n  -ocamlopt  Use  in place of \"ocamlopt\"\
+\n  -ocamloptflags   Pass  to ocamlopt\
+\n  -o       Generated OCaml library is named .cma or .cmxa\
+\n  -oc      Generated C library is named dll.so or lib.a\
+\n  -rpath    Same as -dllpath \
+\n  -R        Same as -rpath\
+\n  -verbose       Print commands before executing them\
+\n  -v             same as -verbose\
+\n  -version       Print version and exit\
+\n  -vnum          Print version number and exit\
+\n  -Wl,-rpath,     Same as -dllpath \
+\n  -Wl,-rpath -Wl, Same as -dllpath \
+\n  -Wl,-R          Same as -dllpath \
+\n"
+
+let command cmd =
+  if !verbose then (print_string "+ "; print_string cmd; print_newline());
+  Sys.command cmd
+
+let scommand cmd =
+  if command cmd <> 0 then exit 2
+
+let safe_remove s =
+  try Sys.remove s with Sys_error _ -> ()
+
+let make_set l =
+  let rec merge l = function
+    []     -> List.rev l
+  | p :: r -> if List.mem p l then merge l r else merge (p::l) r
+  in
+  merge [] l
+
+let make_rpath flag =
+  if !rpath = [] || flag = ""
+  then ""
+  else flag ^ String.concat ":" (make_set !rpath)
+
+let make_rpath_ccopt flag =
+  if !rpath = [] || flag = ""
+  then ""
+  else "-ccopt " ^ flag ^ String.concat ":" (make_set !rpath)
+
+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 transl_path s =
+  match Sys.os_type with
+    | "Win32" ->
+        let s = Bytes.of_string s in
+        let rec aux i =
+          if i = Bytes.length s || Bytes.get s i = ' ' then s
+          else begin
+            if Bytes.get s i = '/' then Bytes.set s i '\\';
+            aux (i + 1)
+          end
+        in Bytes.to_string (aux 0)
+    | _ -> s
+
+let flexdll_dirs =
+  let dirs =
+    let expand = Misc.expand_directory Config.standard_library in
+    List.map expand Config.flexdll_dirs
+  in
+  let f dir =
+    let dir =
+      if String.contains dir ' ' then
+        "\"" ^ dir ^ "\""
+      else
+        dir
+    in
+      "-L" ^ dir
+  in
+  List.map f dirs
+
+let build_libs () =
+  if !c_objs <> [] then begin
+    if !dynlink then begin
+      let retcode = command
+          (Printf.sprintf "%s %s -o %s %s %s %s %s %s %s"
+             Config.mkdll
+             (if !debug then "-g" else "")
+             (prepostfix "dll" !output_c Config.ext_dll)
+             (String.concat " " !c_objs)
+             (String.concat " " !c_opts)
+             (String.concat " " !ld_opts)
+             (make_rpath mksharedlibrpath)
+             (String.concat " " !c_libs)
+             (String.concat " " flexdll_dirs)
+          )
+      in
+      if retcode <> 0 then if !failsafe then dynlink := false else exit 2
+    end;
+    safe_remove (prepostfix "lib" !output_c Config.ext_lib);
+    scommand
+      (mklib (prepostfix "lib" !output_c Config.ext_lib)
+             (String.concat " " !c_objs) "");
+  end;
+  if !bytecode_objs <> [] then
+    scommand
+      (sprintf "%s -a %s %s %s -o %s.cma %s %s -dllib -l%s -cclib -l%s \
+                   %s %s %s %s"
+                  (transl_path !ocamlc)
+                  (if !debug then "-g" else "")
+                  (if !dynlink then "" else "-custom")
+                  (String.concat " " !ocamlc_opts)
+                  !output
+                  (String.concat " " !caml_opts)
+                  (String.concat " " !bytecode_objs)
+                  (Filename.basename !output_c)
+                  (Filename.basename !output_c)
+                  (String.concat " " (prefix_list "-ccopt " !c_opts))
+                  (make_rpath_ccopt byteccrpath)
+                  (String.concat " " (prefix_list "-cclib " !c_libs))
+                  (String.concat " " !caml_libs));
+  if !native_objs <> [] then
+    scommand
+      (sprintf "%s -a %s %s -o %s.cmxa %s %s -cclib -l%s %s %s %s %s"
+                  (transl_path !ocamlopt)
+                  (if !debug then "-g" else "")
+                  (String.concat " " !ocamlopt_opts)
+                  !output
+                  (String.concat " " !caml_opts)
+                  (String.concat " " !native_objs)
+                  (Filename.basename !output_c)
+                  (String.concat " " (prefix_list "-ccopt " !c_opts))
+                  (make_rpath_ccopt nativeccrpath)
+                  (String.concat " " (prefix_list "-cclib " !c_libs))
+                  (String.concat " " !caml_libs))
+
+let _ =
+  try
+    parse_arguments Sys.argv;
+    build_libs()
+  with
+  | Bad_argument "" ->
+      prerr_string usage; exit 0
+  | Bad_argument s ->
+      prerr_endline s; prerr_string usage; exit 4
+  | Sys_error s ->
+      prerr_string "System error: "; prerr_endline s; exit 4
+  | x ->
+      raise x
diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml
new file mode 100644
index 00000000..ab333966
--- /dev/null
+++ b/tools/ocamlmktop.ml
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let _ =
+  let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in
+  let ocamlmktop = Sys.executable_name in
+  (* On Windows Sys.command calls system() which in turn calls 'cmd.exe /c'.
+     cmd.exe has special quoting rules (see 'cmd.exe /?' for details).
+     Short version: if the string passed to cmd.exe starts with '"',
+     the first and last '"' are removed *)
+  let ocamlc,extra_quote =
+    if Sys.win32 then "ocamlc.exe","\"" else "ocamlc",""
+  in
+  let ocamlc = Filename.(quote (concat (dirname ocamlmktop) ocamlc)) in
+  let cmdline =
+    extra_quote ^ ocamlc ^ " -I +compiler-libs -linkall ocamlcommon.cma " ^
+    "ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo" ^
+    extra_quote
+  in
+  exit(Sys.command cmdline)
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
new file mode 100644
index 00000000..33147ea7
--- /dev/null
+++ b/tools/ocamloptp.ml
@@ -0,0 +1,221 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+let compargs = ref ([] : string list)
+let profargs = ref ([] : string list)
+let toremove = ref ([] : string list)
+
+let option opt () = compargs := opt :: !compargs
+let option_with_arg opt arg =
+  compargs := (Filename.quote arg) :: opt :: !compargs
+;;
+let option_with_int opt arg =
+  compargs := (string_of_int arg) :: opt :: !compargs
+;;
+let option_with_float opt arg =
+  compargs := (string_of_float arg) :: opt :: !compargs
+;;
+
+let make_archive = ref false;;
+let with_impl = ref false;;
+let with_intf = ref false;;
+let with_mli = ref false;;
+let with_ml = ref false;;
+
+let process_file filename =
+  if Filename.check_suffix filename ".ml" then with_ml := true;
+  if Filename.check_suffix filename ".mli" then with_mli := true;
+  compargs := (Filename.quote filename) :: !compargs
+;;
+
+let usage = "Usage: ocamloptp  \noptions are:"
+
+let incompatible o =
+  fprintf stderr "ocamloptp: profiling is incompatible with the %s option\n" o;
+  exit 2
+
+module Options = Main_args.Make_optcomp_options (struct
+  let _a () = make_archive := true; option "-a" ()
+  let _absname = option "-absname"
+  let _afl_instrument = option "-afl-instrument"
+  let _afl_inst_ratio n = option_with_int "-afl-inst-ratio" n
+  let _annot = option "-annot"
+  let _binannot = option "-bin-annot"
+  let _c = option "-c"
+  let _cc s = option_with_arg "-cc" s
+  let _cclib s = option_with_arg "-cclib" s
+  let _ccopt s = option_with_arg "-ccopt" s
+  let _clambda_checks = option "-clambda-checks"
+  let _compact = option "-compact"
+  let _config = option "-config"
+  let _for_pack s = option_with_arg "-for-pack" s
+  let _g = option "-g"
+  let _i = option "-i"
+  let _I s = option_with_arg "-I" s
+  let _impl s = with_impl := true; option_with_arg "-impl" s
+  let _inline s = option_with_arg "-inline" s
+  let _inline_toplevel n = option_with_arg "-inline-toplevel" n
+  let _inlining_report = option "-inlining-report"
+  let _dump_pass = option_with_arg "-dump-pass"
+  let _inline_max_depth n = option_with_arg "-inline-max-depth" n
+  let _rounds n = option_with_int "-rounds" n
+  let _inline_max_unroll n = option_with_arg "-unroll" n
+  let _inline_call_cost n = option_with_arg "-inline-call-cost" n
+  let _inline_alloc_cost n = option_with_arg "-inline-alloc-cost" n
+  let _inline_prim_cost n = option_with_arg "-inline-prim-cost" n
+  let _inline_branch_cost n = option_with_arg "-inline-branch-cost" n
+  let _inline_indirect_cost n = option_with_arg "-inline-indirect-cost" n
+  let _inline_lifting_benefit n = option_with_arg "-inline-lifting-benefit" n
+  let _inline_branch_factor n = option_with_arg "-inline-branch-factor" n
+  let _classic_inlining = option "-Oclassic"
+  let _intf s = with_intf := true; option_with_arg "-intf" s
+  let _intf_suffix s = option_with_arg "-intf-suffix" s
+  let _keep_docs = option "-keep-docs"
+  let _no_keep_docs = option "-no-keep-docs"
+  let _keep_locs = option "-keep-locs"
+  let _no_keep_locs = option "-no-keep-locs"
+  let _labels = option "-labels"
+  let _linkall = option "-linkall"
+  let _alias_deps = option "-alias-deps"
+  let _no_alias_deps = option "-no-alias-deps"
+  let _app_funct = option "-app-funct"
+  let _no_app_funct = option "-no-app-funct"
+  let _no_float_const_prop = option "-no-float-const-prop"
+  let _noassert = option "-noassert"
+  let _noautolink = option "-noautolink"
+  let _nodynlink = option "-nodynlink"
+  let _nolabels = option "-nolabels"
+  let _nostdlib = option "-nostdlib"
+  let _no_unbox_free_vars_of_closures = option "-no-unbox-free-vars-of-closures"
+  let _no_unbox_specialised_args = option "-no-unbox-specialised-args"
+  let _o s = option_with_arg "-o" s
+  let _o2 = option "-O2"
+  let _o3 = option "-O3"
+  let _open s = option_with_arg "-open" s
+  let _output_obj = option "-output-obj"
+  let _output_complete_obj = option "-output-complete-obj"
+  let _p = option "-p"
+  let _pack = option "-pack"
+  let _plugin = option_with_arg "-plugin"
+  let _pp _s = incompatible "-pp"
+  let _ppx _s = incompatible "-ppx"
+  let _principal = option "-principal"
+  let _no_principal = option "-no-principal"
+  let _rectypes = option "-rectypes"
+  let _no_rectypes = option "-no-rectypes"
+  let _remove_unused_arguments = option "-remove-unused-arguments"
+  let _runtime_variant s = option_with_arg "-runtime-variant" s
+  let _S = option "-S"
+  let _safe_string = option "-safe-string"
+  let _short_paths = option "-short-paths"
+  let _strict_sequence = option "-strict-sequence"
+  let _no_strict_sequence = option "-no-strict-sequence"
+  let _strict_formats = option "-strict-formats"
+  let _no_strict_formats = option "-no-strict-formats"
+  let _shared = option "-shared"
+  let _thread = option "-thread"
+  let _unbox_closures = option "-unbox-closures"
+  let _unbox_closures_factor = option_with_int "-unbox-closures"
+  let _unboxed_types = option "-unboxed-types"
+  let _no_unboxed_types = option "-no-unboxed-types"
+  let _unsafe = option "-unsafe"
+  let _unsafe_string = option "-unsafe-string"
+  let _v = option "-v"
+  let _version = option "-version"
+  let _vnum = option "-vnum"
+  let _verbose = option "-verbose"
+  let _w = option_with_arg "-w"
+  let _warn_error = option_with_arg "-warn-error"
+  let _warn_help = option "-warn-help"
+  let _color s = option_with_arg "-color" s
+  let _where = option "-where"
+
+  let _nopervasives = option "-nopervasives"
+  let _dsource = option "-dsource"
+  let _dparsetree = option "-dparsetree"
+  let _dtypedtree = option "-dtypedtree"
+  let _drawlambda = option "-drawlambda"
+  let _dlambda = option "-dlambda"
+  let _drawclambda = option "-drawclambda"
+  let _dclambda = option "-dclambda"
+  let _drawflambda = option "-drawflambda"
+  let _dflambda = option "-dflambda"
+  let _dflambda_no_invariants = option "-dflambda-no-invariants"
+  let _dflambda_let stamp = option_with_int "-dflambda-let" stamp
+  let _dflambda_verbose = option "-dflambda-verbose"
+  let _dcmm = option "-dcmm"
+  let _dsel = option "-dsel"
+  let _dcombine = option "-dcombine"
+  let _dcse = option "-dcse"
+  let _dlive = option "-dlive"
+  let _dspill = option "-dspill"
+  let _dsplit = option "-dsplit"
+  let _dinterf = option "-dinterf"
+  let _dprefer = option "-dprefer"
+  let _dalloc = option "-dalloc"
+  let _dreload = option "-dreload"
+  let _dscheduling = option "-dscheduling"
+  let _dlinear = option "-dlinear"
+  let _dstartup = option "-dstartup"
+  let _dtimings = option "-dtimings"
+  let _opaque = option "-opaque"
+
+  let _args = Arg.read_arg
+  let _args0 = Arg.read_arg0
+  let anonymous = process_file
+end);;
+
+let add_profarg s =
+  profargs := (Filename.quote s) :: "-m" :: !profargs
+;;
+
+let optlist =
+    ("-P", Arg.String add_profarg,
+           "[afilmt]  Profile constructs specified by argument (default fm):\n\
+        \032     a  Everything\n\
+        \032     f  Function calls and method calls\n\
+        \032     i  if ... then ... else\n\
+        \032     l  while and for loops\n\
+        \032     m  match ... with\n\
+        \032     t  try ... with")
+    :: Options.list
+in
+Arg.parse_expand optlist process_file usage;
+if !with_impl && !with_intf then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_impl && !with_mli then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-impl\" and .mli files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_intf && !with_ml then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-intf\" and .ml files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end;
+if !with_impl then profargs := "-impl" :: !profargs;
+if !with_intf then profargs := "-intf" :: !profargs;
+let status =
+  Sys.command
+    (Printf.sprintf "ocamlopt -pp \"ocamlprof -instrument %s\" %s %s"
+        (String.concat " " (List.rev !profargs))
+        (if !make_archive then "" else "profiling.cmx")
+        (String.concat " " (List.rev !compargs)))
+in
+exit status
+;;
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
new file mode 100644
index 00000000..fb08ffd5
--- /dev/null
+++ b/tools/ocamlprof.ml
@@ -0,0 +1,523 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*       Damien Doligez and Francois Rouaix, INRIA Rocquencourt           *)
+(*           Ported to Caml Special Light by John Malecki                 *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Printf
+
+open Location
+open Parsetree
+
+(* User programs must not use identifiers that start with these prefixes. *)
+let idprefix = "__ocaml_prof_";;
+let modprefix = "OCAML__prof_";;
+
+(* Errors specific to the profiler *)
+exception Profiler of string
+
+(* Modes *)
+let instr_fun    = ref false
+and instr_match  = ref false
+and instr_if     = ref false
+and instr_loops  = ref false
+and instr_try    = ref false
+
+let cur_point = ref 0
+and inchan = ref stdin
+and outchan = ref stdout
+
+(* To copy source fragments *)
+let copy_buffer = Bytes.create 256
+
+let copy_chars_unix nchars =
+  let n = ref nchars in
+  while !n > 0 do
+    let m = input !inchan copy_buffer 0 (min !n 256) in
+    if m = 0 then raise End_of_file;
+    output !outchan copy_buffer 0 m;
+    n := !n - m
+  done
+
+let copy_chars_win32 nchars =
+  for _i = 1 to nchars do
+    let c = input_char !inchan in
+    if c <> '\r' then output_char !outchan c
+  done
+
+let copy_chars =
+  match Sys.os_type with
+    "Win32" | "Cygwin" -> copy_chars_win32
+  | _       -> copy_chars_unix
+
+let copy next =
+  assert (next >= !cur_point);
+  seek_in !inchan !cur_point;
+  copy_chars (next - !cur_point);
+  cur_point := next;
+;;
+
+let prof_counter = ref 0;;
+
+let instr_mode = ref false
+
+type insert = Open | Close;;
+let to_insert = ref ([] : (insert * int) list);;
+
+let insert_action st en =
+  to_insert := (Open, st) :: (Close, en) :: !to_insert
+;;
+
+(* Producing instrumented code *)
+let add_incr_counter modul (kind,pos) =
+   copy pos;
+   match kind with
+   | Open ->
+         fprintf !outchan "(%sProfiling.incr %s%s_cnt %d; "
+                 modprefix idprefix modul !prof_counter;
+         incr prof_counter;
+   | Close -> fprintf !outchan ")";
+;;
+
+let counters = ref (Array.make 0 0)
+
+(* User defined marker *)
+let special_id = ref ""
+
+(* Producing results of profile run *)
+let add_val_counter (kind,pos) =
+  if kind = Open then begin
+    copy pos;
+    fprintf !outchan "(* %s%d *) " !special_id !counters.(!prof_counter);
+    incr prof_counter;
+  end
+;;
+
+(* ************* rewrite ************* *)
+
+let insert_profile rw_exp ex =
+  let st = ex.pexp_loc.loc_start.Lexing.pos_cnum
+  and en = ex.pexp_loc.loc_end.Lexing.pos_cnum
+  and gh = ex.pexp_loc.loc_ghost
+  in
+  if gh || st = en then
+    rw_exp true ex
+  else begin
+    insert_action st en;
+    rw_exp false ex;
+  end
+;;
+
+
+let pos_len = ref 0
+
+let init_rewrite modes mod_name =
+  cur_point := 0;
+  if !instr_mode then begin
+    fprintf !outchan "module %sProfiling = Profiling;; " modprefix;
+    fprintf !outchan "let %s%s_cnt = Array.make 000000000" idprefix mod_name;
+    pos_len := pos_out !outchan;
+    fprintf !outchan
+            " 0;; Profiling.counters := \
+              (\"%s\", (\"%s\", %s%s_cnt)) :: !Profiling.counters;; "
+            mod_name modes idprefix mod_name;
+  end
+
+let final_rewrite add_function =
+  to_insert := List.sort (fun x y -> compare (snd x) (snd y)) !to_insert;
+  prof_counter := 0;
+  List.iter add_function !to_insert;
+  copy (in_channel_length !inchan);
+  if !instr_mode then begin
+    let len = string_of_int !prof_counter in
+    if String.length len > 9 then raise (Profiler "too many counters");
+    seek_out !outchan (!pos_len - String.length len);
+    output_string !outchan len
+  end;
+  (* Cannot close because outchan is stdout and Format doesn't like
+     a closed stdout.
+    close_out !outchan;
+  *)
+;;
+
+let rec rewrite_patexp_list iflag l =
+  rewrite_exp_list iflag (List.map (fun x -> x.pvb_expr) l)
+
+and rewrite_cases iflag l =
+  List.iter
+    (fun pc ->
+      begin match pc.pc_guard with
+      | None -> ()
+      | Some g -> rewrite_exp iflag g
+      end;
+      rewrite_exp iflag pc.pc_rhs
+    )
+    l
+
+and rewrite_labelexp_list iflag l =
+  rewrite_exp_list iflag (List.map snd l)
+
+and rewrite_exp_list iflag l =
+  List.iter (rewrite_exp iflag) l
+
+and rewrite_exp iflag sexp =
+  if iflag then insert_profile rw_exp sexp
+           else rw_exp false sexp
+
+and rw_exp iflag sexp =
+  match sexp.pexp_desc with
+    Pexp_ident _lid -> ()
+  | Pexp_constant _cst -> ()
+
+  | Pexp_let(_, spat_sexp_list, sbody) ->
+    rewrite_patexp_list iflag spat_sexp_list;
+    rewrite_exp iflag sbody
+
+  | Pexp_function caselist ->
+    if !instr_fun then
+      rewrite_function iflag caselist
+    else
+      rewrite_cases iflag caselist
+
+  | Pexp_fun (_, _, p, e) ->
+      let l = [{pc_lhs=p; pc_guard=None; pc_rhs=e}] in
+      if !instr_fun then
+        rewrite_function iflag l
+      else
+        rewrite_cases iflag l
+
+  | Pexp_match(sarg, caselist) ->
+    rewrite_exp iflag sarg;
+    if !instr_match && not sexp.pexp_loc.loc_ghost then
+      rewrite_funmatching caselist
+    else
+      rewrite_cases iflag caselist
+
+  | Pexp_try(sbody, caselist) ->
+    rewrite_exp iflag sbody;
+    if !instr_try && not sexp.pexp_loc.loc_ghost then
+      rewrite_trymatching caselist
+    else
+      rewrite_cases iflag caselist
+
+  | Pexp_apply(sfunct, sargs) ->
+    rewrite_exp iflag sfunct;
+    rewrite_exp_list iflag (List.map snd sargs)
+
+  | Pexp_tuple sexpl ->
+    rewrite_exp_list iflag sexpl
+
+  | Pexp_construct(_, None) -> ()
+  | Pexp_construct(_, Some sarg) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_variant(_, None) -> ()
+  | Pexp_variant(_, Some sarg) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_record(lid_sexp_list, None) ->
+    rewrite_labelexp_list iflag lid_sexp_list
+  | Pexp_record(lid_sexp_list, Some sexp) ->
+    rewrite_exp iflag sexp;
+    rewrite_labelexp_list iflag lid_sexp_list
+
+  | Pexp_field(sarg, _) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_setfield(srecord, _, snewval) ->
+    rewrite_exp iflag srecord;
+    rewrite_exp iflag snewval
+
+  | Pexp_array(sargl) ->
+    rewrite_exp_list iflag sargl
+
+  | Pexp_ifthenelse(scond, sifso, None) ->
+      rewrite_exp iflag scond;
+      rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso
+  | Pexp_ifthenelse(scond, sifso, Some sifnot) ->
+      rewrite_exp iflag scond;
+      rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso;
+      rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifnot
+
+  | Pexp_sequence(sexp1, sexp2) ->
+    rewrite_exp iflag sexp1;
+    rewrite_exp iflag sexp2
+
+  | Pexp_while(scond, sbody) ->
+    rewrite_exp iflag scond;
+    if !instr_loops && not sexp.pexp_loc.loc_ghost
+    then insert_profile rw_exp sbody
+    else rewrite_exp iflag sbody
+
+  | Pexp_for(_, slow, shigh, _, sbody) ->
+    rewrite_exp iflag slow;
+    rewrite_exp iflag shigh;
+    if !instr_loops && not sexp.pexp_loc.loc_ghost
+    then insert_profile rw_exp sbody
+    else rewrite_exp iflag sbody
+
+  | Pexp_constraint(sarg, _) | Pexp_coerce(sarg, _, _) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_send (sobj, _) ->
+    rewrite_exp iflag sobj
+
+  | Pexp_new _ -> ()
+
+  | Pexp_setinstvar (_, sarg) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_override l ->
+      List.iter (fun (_, sexp) -> rewrite_exp iflag sexp) l
+
+  | Pexp_letmodule (_, smod, sexp) ->
+      rewrite_mod iflag smod;
+      rewrite_exp iflag sexp
+
+  | Pexp_letexception (_cd, exp) ->
+      rewrite_exp iflag exp
+
+  | Pexp_assert (cond) -> rewrite_exp iflag cond
+
+  | Pexp_lazy (expr) -> rewrite_exp iflag expr
+
+  | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
+
+  | Pexp_object cl ->
+      List.iter (rewrite_class_field iflag) cl.pcstr_fields
+
+  | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
+  | Pexp_open (_ovf, _, e) -> rewrite_exp iflag e
+  | Pexp_pack (smod) -> rewrite_mod iflag smod
+  | Pexp_extension _ -> ()
+  | Pexp_unreachable -> ()
+
+and rewrite_ifbody iflag ghost sifbody =
+  if !instr_if && not ghost then
+    insert_profile rw_exp sifbody
+  else
+    rewrite_exp iflag sifbody
+
+(* called only when !instr_fun *)
+and rewrite_annotate_exp_list l =
+  List.iter
+    (function
+     | {pc_guard=Some scond; pc_rhs=sbody} ->
+         insert_profile rw_exp scond;
+         insert_profile rw_exp sbody;
+     | {pc_rhs={pexp_desc = Pexp_constraint(sbody, _)}} (* let f x : t = e *)
+        -> insert_profile rw_exp sbody
+     | {pc_rhs=sexp} -> insert_profile rw_exp sexp)
+    l
+
+and rewrite_function iflag = function
+  | [{pc_lhs=_; pc_guard=None;
+      pc_rhs={pexp_desc = (Pexp_function _|Pexp_fun _)} as sexp}] ->
+        rewrite_exp iflag sexp
+  | l -> rewrite_funmatching l
+
+and rewrite_funmatching l =
+  rewrite_annotate_exp_list l
+
+and rewrite_trymatching l =
+  rewrite_annotate_exp_list l
+
+(* Rewrite a class definition *)
+
+and rewrite_class_field iflag cf =
+  match cf.pcf_desc with
+    Pcf_inherit (_, cexpr, _)     -> rewrite_class_expr iflag cexpr
+  | Pcf_val (_, _, Cfk_concrete (_, sexp))  -> rewrite_exp iflag sexp
+  | Pcf_method (_, _,
+                Cfk_concrete (_, ({pexp_desc = (Pexp_function _|Pexp_fun _)}
+                                    as sexp))) ->
+      rewrite_exp iflag sexp
+  | Pcf_method (_, _, Cfk_concrete(_, sexp)) ->
+      let loc = cf.pcf_loc in
+      if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
+      else rewrite_exp iflag sexp
+  | Pcf_initializer sexp ->
+      rewrite_exp iflag sexp
+  | Pcf_method (_, _, Cfk_virtual _)
+  | Pcf_val (_, _, Cfk_virtual _)
+  | Pcf_constraint _  -> ()
+  | Pcf_attribute _ -> ()
+  | Pcf_extension _ -> ()
+
+and rewrite_class_expr iflag cexpr =
+  match cexpr.pcl_desc with
+    Pcl_constr _ -> ()
+  | Pcl_structure st ->
+      List.iter (rewrite_class_field iflag) st.pcstr_fields
+  | Pcl_fun (_, _, _, cexpr) ->
+      rewrite_class_expr iflag cexpr
+  | Pcl_apply (cexpr, exprs) ->
+      rewrite_class_expr iflag cexpr;
+      List.iter (rewrite_exp iflag) (List.map snd exprs)
+  | Pcl_let (_, spat_sexp_list, cexpr) ->
+      rewrite_patexp_list iflag spat_sexp_list;
+      rewrite_class_expr iflag cexpr
+  | Pcl_constraint (cexpr, _) ->
+      rewrite_class_expr iflag cexpr
+  | Pcl_extension _ -> ()
+
+and rewrite_class_declaration iflag cl =
+  rewrite_class_expr iflag cl.pci_expr
+
+(* Rewrite a module expression or structure expression *)
+
+and rewrite_mod iflag smod =
+  match smod.pmod_desc with
+    Pmod_ident _ -> ()
+  | Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr
+  | Pmod_functor(_param, _smty, sbody) -> rewrite_mod iflag sbody
+  | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
+  | Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod
+  | Pmod_unpack(sexp) -> rewrite_exp iflag sexp
+  | Pmod_extension _ -> ()
+
+and rewrite_str_item iflag item =
+  match item.pstr_desc with
+    Pstr_eval (exp, _attrs) -> rewrite_exp iflag exp
+  | Pstr_value(_, exps)
+     -> List.iter (fun x -> rewrite_exp iflag x.pvb_expr) exps
+  | Pstr_module x -> rewrite_mod iflag x.pmb_expr
+        (* todo: Pstr_recmodule?? *)
+  | Pstr_class classes -> List.iter (rewrite_class_declaration iflag) classes
+  | _ -> ()
+
+(* Rewrite a .ml file *)
+let rewrite_file srcfile add_function =
+  inchan := open_in_bin srcfile;
+  let lb = Lexing.from_channel !inchan in
+  Location.input_name := srcfile;
+  Location.init lb srcfile;
+  List.iter (rewrite_str_item false) (Parse.implementation lb);
+  final_rewrite add_function;
+  close_in !inchan
+
+(* Copy a non-.ml file without change *)
+let null_rewrite srcfile =
+  inchan := open_in_bin srcfile;
+  copy (in_channel_length !inchan);
+  close_in !inchan
+;;
+
+(* Setting flags from saved config *)
+let set_flags s =
+  for i = 0 to String.length s - 1 do
+    match String.get s i with
+      'f' -> instr_fun := true
+    | 'm' -> instr_match := true
+    | 'i' -> instr_if := true
+    | 'l' -> instr_loops := true
+    | 't' -> instr_try := true
+    | 'a' -> instr_fun := true; instr_match := true;
+             instr_if := true; instr_loops := true;
+             instr_try := true
+    | _ -> ()
+    done
+
+(* Command-line options *)
+
+let modes = ref "fm"
+let dumpfile = ref "ocamlprof.dump"
+
+(* Process a file *)
+
+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;
+     init_rewrite !modes modname;
+     rewrite_file filename (add_incr_counter modname);
+   end else begin
+     (* Results mode *)
+     let ic = open_in_bin !dumpfile in
+     let allcounters =
+       (input_value ic : (string * (string * int array)) list) in
+     close_in ic;
+     let (modes, cv) =
+       try
+         List.assoc modname allcounters
+       with Not_found ->
+         raise(Profiler("Module " ^ modname ^ " not used in this profile."))
+     in
+     counters := cv;
+     set_flags modes;
+     init_rewrite modes modname;
+     rewrite_file filename add_val_counter;
+   end
+;;
+
+let process_anon_file filename =
+  if Filename.check_suffix filename ".ml" then
+    process_impl_file filename
+  else
+    process_intf_file filename
+;;
+
+(* Main function *)
+
+open Format
+
+let usage = "Usage: ocamlprof  \noptions are:"
+
+let print_version () =
+  printf "ocamlprof, version %s@." Sys.ocaml_version;
+  exit 0;
+;;
+
+let print_version_num () =
+  printf "%s@." Sys.ocaml_version;
+  exit 0;
+;;
+
+let main () =
+  try
+    Warnings.parse_options false "a";
+    Arg.parse_expand [
+       "-f", Arg.String (fun s -> dumpfile := s),
+             "     Use  as dump file (default ocamlprof.dump)";
+       "-F", Arg.String (fun s -> special_id := s),
+             "        Insert string  with the counts";
+       "-impl", Arg.String process_impl_file,
+                "  Process  as a .ml file";
+       "-instrument", Arg.Set instr_mode, "  (undocumented)";
+       "-intf", Arg.String process_intf_file,
+                "  Process  as a .mli file";
+       "-m", Arg.String (fun s -> modes := s), "    (undocumented)";
+       "-version", Arg.Unit print_version,
+                   "     Print version and exit";
+       "-vnum", Arg.Unit print_version_num,
+                "        Print version number and exit";
+        "-args", Arg.Expand Arg.read_arg,
+                " Read additional newline separated command line arguments \n\
+                \      from ";
+       "-args0", Arg.Expand Arg.read_arg0,
+               " Read additional NUL separated command line arguments from \n\
+               \      "
+    ] process_anon_file usage;
+    exit 0
+  with
+  | Profiler msg ->
+      fprintf Format.err_formatter "@[%s@]@." msg;
+      exit 2
+  | exn ->
+      Location.report_exception Format.err_formatter exn
+
+let _ = main ()
diff --git a/tools/ocamlsize b/tools/ocamlsize
new file mode 100755
index 00000000..84798ce1
--- /dev/null
+++ b/tools/ocamlsize
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *
+#*                                                                        *
+#*   Copyright 2002 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+foreach $f (@ARGV) {
+    open(FILE, $f) || die("Cannot open $f");
+    seek(FILE, -16, 2);
+    $num_sections = &read_int();
+    read(FILE, $magic, 12);
+    seek(FILE, -16 - 8 * $num_sections, 2);
+    @secname = ();
+    @seclength = ();
+    %length = ();
+    for ($i = 0; $i < $num_sections; $i++) {
+        read(FILE, $sec, 4);
+        $secname[$i] = $sec;
+        $seclength[$i] = &read_int();
+        $length{$sec} = $seclength[$i];
+    }
+    print $f, ":\n" if ($#ARGV > 0);
+    $path =
+        $length{'RNTM'} > 0 ?
+            &read_section('RNTM') :
+            "(default runtime)\n";
+    printf ("\tcode: %-7d data: %-7d symbols: %-7d debug: %-7d\n",
+            $length{'CODE'}, $length{'DATA'},
+            $length{'SYMB'}, $length{'DBUG'});
+    printf ("\tmagic number: %s  runtime system: %s",
+            $magic, $path);
+    close(FILE);
+}
+
+sub read_int {
+    read(FILE, $buff, 4) == 4 || die("Truncated bytecode file $f");
+    @int = unpack("C4", $buff);
+    return ($int[0] << 24) + ($int[1] << 16) + ($int[2] << 8) + $int[3];
+}
+
+sub read_section {
+    local ($sec) = @_;
+    local ($i, $ofs, $data);
+    for ($i = $num_sections - 1; $i >= 0; $i--) {
+        $ofs += $seclength[$i];
+        if ($secname[$i] eq $sec) {
+            seek(FILE, -16 - 8 * $num_sections - $ofs, 2);
+            read(FILE, $data, $seclength[$i]);
+            return $data;
+        }
+    }
+    return '';
+}
diff --git a/tools/primreq.ml b/tools/primreq.ml
new file mode 100644
index 00000000..c84543ae
--- /dev/null
+++ b/tools/primreq.ml
@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Determine the set of C primitives required by the given .cmo and .cma
+   files *)
+
+open Config
+open Cmo_format
+
+module StringSet = Set.Make(struct type t = string let compare = compare end)
+
+let defined = ref true
+let used = ref false
+let exclude_file = ref ""
+
+let primitives = ref StringSet.empty
+
+let scan_reloc = function
+    (Reloc_primitive s, _) -> primitives := StringSet.add s !primitives
+  | _ -> ()
+
+let scan_prim s =
+  primitives := StringSet.add s !primitives
+
+let scan_info cu =
+  if !used then List.iter scan_reloc cu.cu_reloc;
+  if !defined then List.iter scan_prim cu.cu_primitives
+
+let scan_obj filename =
+  let ic = open_in_bin filename in
+  let buffer = really_input_string ic (String.length cmo_magic_number) in
+  if buffer = cmo_magic_number then begin
+    let cu_pos = input_binary_int ic in
+    seek_in ic cu_pos;
+    let cu = (input_value ic : compilation_unit) in
+    close_in ic;
+    scan_info cu
+  end else
+  if buffer = cma_magic_number then begin
+    let toc_pos = input_binary_int ic in
+    seek_in ic toc_pos;
+    let toc = (input_value ic : library) in
+    close_in ic;
+    List.iter scan_info toc.lib_units
+  end else begin
+    prerr_endline "Not an object file"; exit 2
+  end
+
+let exclude filename =
+  let ic = open_in filename in
+  try
+    while true do
+      let s = input_line ic in
+      primitives := StringSet.remove s !primitives
+    done
+  with End_of_file -> close_in ic
+     | x -> close_in ic; raise x
+
+let main() =
+  Arg.parse_expand
+    ["-used", Arg.Unit(fun () -> used := true; defined := false),
+        "show primitives referenced in the object files";
+     "-defined", Arg.Unit(fun () -> defined := true; used := false),
+        "show primitives defined in the object files (default)";
+     "-all", Arg.Unit(fun () -> defined := true; used := true),
+        "show primitives defined or referenced in the object files";
+     "-exclude", Arg.String(fun s -> exclude_file := s),
+     " don't print the primitives mentioned in ";
+     "-args", Arg.Expand Arg.read_arg,
+     " Read additional newline separated command line arguments \n\
+     \      from ";
+     "-args0", Arg.Expand Arg.read_arg0,
+     " Read additional NUL separated command line arguments from \n\
+     \      ";]
+    scan_obj
+    "Usage: primreq [options] <.cmo and .cma files>\nOptions are:";
+  if String.length !exclude_file > 0 then exclude !exclude_file;
+  StringSet.iter
+    (fun s ->
+      if s.[0] <> '%' then begin print_string s; print_newline() end)
+    !primitives;
+  exit 0
+
+let _ = main ()
diff --git a/tools/profiling.ml b/tools/profiling.ml
new file mode 100644
index 00000000..d2eee4df
--- /dev/null
+++ b/tools/profiling.ml
@@ -0,0 +1,56 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*       Damien Doligez and Francois Rouaix, INRIA Rocquencourt           *)
+(*    Ported to Caml Special Light 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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Run-time library for profiled programs *)
+
+type profiling_counters = (string * (string * int array)) list
+
+let counters = ref ([] : profiling_counters);;
+let incr a i = a.(i) <- a.(i) + 1;;
+
+exception Bad_profile
+
+let dump_counters () =
+  let dumpfile =
+    try Sys.getenv "OCAMLPROF_DUMP" with Not_found -> "ocamlprof.dump"
+  in
+  begin try
+    let ic = open_in_bin dumpfile in
+    let prevl = (input_value ic : profiling_counters) in
+    close_in ic;
+    List.iter2
+      (fun (curname, (curmodes,curcount)) (prevname, (prevmodes,prevcount)) ->
+        if curname <> prevname
+        || curmodes <> prevmodes
+        || Array.length curcount <> Array.length prevcount
+        then raise Bad_profile)
+      !counters prevl;
+    List.iter2
+      (fun (_curname, (_,curcount)) (_prevname, (_,prevcount)) ->
+        for i = 0 to Array.length curcount - 1 do
+          curcount.(i) <- curcount.(i) + prevcount.(i)
+        done)
+      !counters prevl
+  with _ -> ()
+  end;
+  begin try
+    let oc = open_out_bin dumpfile in
+    output_value oc !counters;
+    close_out oc
+  with _ -> ()
+  end
+
+let _ = at_exit dump_counters
diff --git a/tools/profiling.mli b/tools/profiling.mli
new file mode 100644
index 00000000..9d97a4a5
--- /dev/null
+++ b/tools/profiling.mli
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*       Damien Doligez and Francois Rouaix, INRIA Rocquencourt           *)
+(*    Ported to OCaml 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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Run-time library for profiled programs *)
+
+val counters: (string * (string * int array)) list ref;;
+val incr: int array -> int -> unit;;
diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml
new file mode 100644
index 00000000..ea8e3c05
--- /dev/null
+++ b/tools/read_cmt.ml
@@ -0,0 +1,103 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let gen_annot = ref false
+let gen_ml = ref false
+let print_info_arg = ref false
+let target_filename = ref None
+
+let arg_list = [
+  "-o", Arg.String (fun s -> target_filename := Some s),
+    " FILE (or -) : dump to file FILE (or stdout)";
+  "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file";
+  "-src", Arg.Set gen_ml,
+    " : convert .cmt or .cmti back to source code (without comments)";
+  "-info", Arg.Set print_info_arg, " : print information on the file";
+  "-args", Arg.Expand Arg.read_arg,
+    "  Read additional newline separated command line arguments \n\
+    \      from ";
+  "-args0", Arg.Expand Arg.read_arg0,
+    " Read additional NUL separated command line arguments from \n\
+    \      ";
+  ]
+
+let arg_usage =
+  "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information"
+
+let dummy_crc = String.make 32 '-'
+
+let print_info cmt =
+  let open Cmt_format in
+      Printf.printf "module name: %s\n" cmt.cmt_modname;
+      begin match cmt.cmt_annots with
+          Packed (_, list) ->
+            Printf.printf "pack: %s\n" (String.concat " " list)
+        | Implementation _ -> Printf.printf "kind: implementation\n"
+        | Interface _ -> Printf.printf "kind: interface\n"
+        | Partial_implementation _ ->
+            Printf.printf "kind: implementation with errors\n"
+        | Partial_interface _ -> Printf.printf "kind: interface with errors\n"
+      end;
+      Printf.printf "command: %s\n"
+                    (String.concat " " (Array.to_list cmt.cmt_args));
+      begin match cmt.cmt_sourcefile with
+          None -> ()
+        | Some name ->
+          Printf.printf "sourcefile: %s\n" name;
+      end;
+      Printf.printf "build directory: %s\n" cmt.cmt_builddir;
+      List.iter (Printf.printf "load path: %s\n%!") cmt.cmt_loadpath;
+      begin
+      match cmt.cmt_source_digest with
+          None -> ()
+        | Some digest ->
+            Printf.printf "source digest: %s\n" (Digest.to_hex digest);
+      end;
+      begin
+      match cmt.cmt_interface_digest with
+          None -> ()
+        | Some digest ->
+            Printf.printf "interface digest: %s\n" (Digest.to_hex digest);
+      end;
+      List.iter (fun (name, crco) ->
+        let crc =
+          match crco with
+            None -> dummy_crc
+          | Some crc -> Digest.to_hex crc
+        in
+          Printf.printf "import: %s %s\n" name crc;
+      ) (List.sort compare cmt.cmt_imports);
+      Printf.printf "%!";
+      ()
+
+let _ =
+  Clflags.annotations := true;
+
+  Arg.parse_expand arg_list  (fun filename ->
+    if
+      Filename.check_suffix filename ".cmt" ||
+        Filename.check_suffix filename ".cmti"
+    then begin
+      (*      init_path(); *)
+      let cmt = Cmt_format.read_cmt filename in
+      if !gen_annot then Cmt2annot.gen_annot !target_filename filename cmt;
+      if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt;
+      if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt;
+    end else begin
+      Printf.fprintf stderr
+                     "Error: the file's extension must be .cmt or .cmti.\n%!";
+      Arg.usage arg_list arg_usage
+    end
+  ) arg_usage
diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml
new file mode 100644
index 00000000..018bc398
--- /dev/null
+++ b/tools/scrapelabels.ml
@@ -0,0 +1,290 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Jacques Garrigue, Kyoto University RIMS                  *)
+(*                                                                        *)
+(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open StdLabels
+open Lexer301
+
+let input_buffer = Buffer.create 16383
+let input_function ic buf len =
+  let len = input ic buf 0 len in
+  Buffer.add_substring input_buffer buf 0 len;
+  len
+
+let output_buffer = Buffer.create 16383
+
+let modified = ref false
+
+let modules =
+  ref [ "Arg"; "BigArray"; "Buffer"; "Condition"; "Dbm"; "Digest"; "Dynlink";
+        "Event"; "Filename"; "Format"; "Gc"; "Genlex"; "Graphics";
+        "Lexing"; "Marshal"; "Mutex"; "Parsing"; "Pervasives"; "Queue";
+        "Sort"; "Stack"; "Str"; "Stream"; "Sys";
+        "Thread"; "ThreadUnix"; "Weak" ]
+
+let stdlabels = ["Array"; "List"; "String"]
+let morelabels = ["Hashtbl"; "Map"; "Set"]
+let alllabels = ref false
+let noopen = ref false
+
+exception Closing of token
+
+let convert_impl buffer =
+  let input_pos = ref 0 in
+  let copy_input stop =
+    Buffer.add_substring output_buffer (Buffer.contents input_buffer)
+      !input_pos (stop - !input_pos);
+    input_pos := stop
+  in
+  let next_token () =
+    let token = Lexer301.token buffer
+    and start = Lexing.lexeme_start buffer
+    and stop = Lexing.lexeme_end buffer in
+    match token with
+      RPAREN | RBRACKET |BARRBRACKET | GREATERRBRACKET | END
+    | RBRACE | GREATERRBRACE ->
+        raise (Closing token)
+    | EOF ->
+        raise End_of_file
+    |  _ ->
+        (token, start, stop)
+  in
+  let openunix = ref None and openstd = ref None and openmore = ref None in
+  let rec may_start (token, s, e) =
+    match token with
+      LIDENT _ -> search_start (dropext (next_token ()))
+    | UIDENT m when List.mem m !modules ->
+        may_discard (dropext (next_token ()))
+    | UIDENT m ->
+        List.iter ~f:
+          (fun (set,r) ->
+            if !r = None && List.mem m ~set then r := Some true)
+          [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore];
+        search_start (next_token ())
+    | _ -> search_start (token, s, e)
+
+  and dropext (token, s, e) =
+    match token with
+      DOT ->
+        let (token, s, e) = next_token () in
+        begin match token with
+          LPAREN | LBRACKET | LBRACE ->
+            process_paren (token, s, e);
+            dropext (next_token ())
+        | UIDENT _ | LIDENT _ ->
+            dropext (next_token ())
+        | _ ->
+            prerr_endline ("bad index at position " ^ string_of_int s);
+            (token, s, e)
+        end
+    | _ ->
+        (token, s, e)
+
+  and may_discard (token, s, e) =
+    match token with
+      TILDE | LABEL _ ->
+        modified := true;
+        copy_input s; input_pos := e;
+        may_discard (next_token ())
+    | _ when !alllabels ->
+        may_discard (next_token ())
+    | LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN
+    | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT->
+        process_paren (token, s, e);
+        may_discard (next_token ())
+    | PREFIXOP _ ->
+        may_discard (next_token ())
+    | LIDENT _ | UIDENT _ ->
+        may_discard (dropext (next_token ()))
+    | BACKQUOTE ->
+        ignore (next_token ());
+        may_discard (next_token ())
+    | INT _ | CHAR _ | STRING _ | FLOAT _ | FALSE | TRUE ->
+        may_discard (next_token ())
+    | _ ->
+        search_start (token, s, e)
+
+  and search_start (token, s, e) =
+    match token with
+      LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN
+    | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT ->
+        process_paren (token, s, e);
+        search_start (next_token ())
+    | EQUAL | SEMI | SEMISEMI | MINUSGREATER | LESSMINUS | COMMA
+    | IF | THEN | ELSE | WHILE | TO | DOWNTO | DO | IN | MATCH | TRY
+    | INFIXOP0 _ | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _ | INFIXOP4 _
+    | PLUS | MINUS | MINUSDOT | STAR | LESS | GREATER
+    | OR | BARBAR | AMPERSAND | AMPERAMPER | COLONEQUAL ->
+        may_start (next_token ())
+    | OPEN ->
+        begin match next_token () with
+        | UIDENT m, _, _ ->
+            List.iter
+              ~f:(fun (set,r) -> if List.mem m ~set then r := Some false)
+              [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore]
+        | _ -> ()
+        end;
+        search_start (next_token ())
+    | _ ->
+        search_start (next_token ())
+
+  and process_paren (token, s, e) =
+    try match token with
+      LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN ->
+        may_start (next_token ())
+    | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT ->
+        search_start (next_token ())
+    | _ ->
+        assert false
+    with Closing last ->
+      match token, last with
+        LPAREN, RPAREN
+      | (LBRACKET|LBRACKETBAR|LBRACKETLESS),
+        (RBRACKET|BARRBRACKET|GREATERRBRACKET)
+      | (BEGIN|STRUCT|SIG|OBJECT), END
+      | LBRACE, RBRACE
+      | LBRACELESS, GREATERRBRACE -> ()
+      | _ -> raise (Closing last)
+  in
+  let first = next_token () in
+  try
+    if !alllabels then may_discard first else may_start first
+  with End_of_file ->
+    copy_input (Buffer.length input_buffer);
+    if not !alllabels
+    && List.exists (fun r -> !r = Some true) [openstd; openunix; openmore]
+    then begin
+      modified := true;
+      let text = Buffer.contents output_buffer in
+      Buffer.clear output_buffer;
+      let (token, s, _) = first in
+      Buffer.add_substring output_buffer text 0 s;
+      List.iter ~f:
+        (fun (r, s) ->
+          if !r = Some true then Buffer.add_string output_buffer s)
+        [ openstd, "open StdLabels\n"; openmore, "open MoreLabels\n";
+          openunix, "module Unix = UnixLabels\n" ];
+      let sep =
+        if List.mem token [CLASS; EXTERNAL; EXCEPTION; FUNCTOR; LET;
+                           MODULE; FUNCTOR; TYPE; VAL]
+        then "\n"
+        else if token = OPEN then "" else ";;\n\n"
+      in
+      Buffer.add_string output_buffer sep;
+      Buffer.add_substring output_buffer text s (String.length text - s)
+    end
+  | Closing _ ->
+      prerr_endline ("bad closing token at position " ^
+                     string_of_int (Lexing.lexeme_start buffer));
+      modified := false
+
+type state = Out | Enter | In | Escape
+
+let convert_intf buffer =
+  let input_pos = ref 0 in
+  let copy_input stop =
+    Buffer.add_substring output_buffer (Buffer.contents input_buffer)
+      !input_pos (stop - !input_pos);
+    input_pos := stop
+  in
+  let last = ref (EOF, 0, 0) in
+  let state = ref Out in
+  try while true do
+    let token = Lexer301.token buffer
+    and start = Lexing.lexeme_start buffer
+    and stop = Lexing.lexeme_end buffer
+    and last_token, last_start, last_stop = !last in
+    begin match token with
+    | EXCEPTION | CONSTRAINT ->
+        state := In
+    | VAL | EXTERNAL | CLASS | METHOD | TYPE | AND ->
+        state := Enter
+    | EQUAL when !state = Enter ->
+        state := In
+    | COLON ->
+        begin match !state, last_token with
+        | In, LIDENT _ ->
+            modified := true;
+            copy_input last_start;
+            input_pos := stop
+        | Enter, _ ->
+            state := In
+        | Escape, _ ->
+            state := In
+        | _ ->
+            state := Out
+        end
+    | LBRACE | SEMI | QUESTION when !state = In ->
+        state := Escape
+    | SEMISEMI | SIG | STRUCT | END | OBJECT | OPEN | INCLUDE | MODULE ->
+        state := Out
+    | EOF -> raise End_of_file
+    | _ -> ()
+    end;
+    last := (token, start, stop)
+  done with
+    End_of_file ->
+      copy_input (Buffer.length input_buffer)
+
+let convert_file ~intf name =
+  let ic = open_in name in
+  Buffer.clear input_buffer;
+  Buffer.clear output_buffer;
+  modified := false;
+  begin
+    let convert = if intf then convert_intf else convert_impl in
+    try convert (Lexing.from_function (input_function ic)); close_in ic
+    with exn -> close_in ic; raise exn
+  end;
+  if !modified then begin
+    let backup = name ^ ".bak" in
+    if Sys.file_exists backup then Sys.remove name
+    else Sys.rename name backup;
+    let oc = open_out name in
+    Buffer.output_buffer oc output_buffer;
+    close_out oc
+  end
+  else prerr_endline ("No changes in " ^ name)
+
+let _ =
+  let files = ref [] and intf = ref false
+  and keepstd = ref false and keepmore = ref false in
+  Arg.parse
+    [ "-intf", Arg.Set intf,
+      " remove all non-optional labels from an interface;\n" ^
+      "         other options are ignored";
+      "-all", Arg.Set alllabels,
+      " remove all labels, possibly including optional ones!";
+      "-keepstd", Arg.Set keepstd,
+      " keep labels for Array, List, String and Unix";
+      "-keepmore", Arg.Set keepmore,
+      " keep also labels for Hashtbl, Map and Set; implies -keepstd";
+      "-m", Arg.String (fun s -> modules := s :: !modules),
+      "  remove also labels for ";
+      "-noopen", Arg.Set noopen,
+      " do not insert `open' statements for -keepstd/-keepmore" ]
+    (fun s -> files := s :: !files)
+    ("Usage: scrapelabels  \n" ^
+     "  Remove labels from function arguments in standard library modules.\n" ^
+     "  With -intf option below, can also process interfaces.\n" ^
+     "  Old files are renamed to .bak if there is no backup yet.\n" ^
+     "Options are:");
+  if !keepmore then keepstd := true;
+  if not !keepstd then modules := "Unix" :: stdlabels @ !modules;
+  if not !keepmore then modules := morelabels @ !modules;
+  List.iter (List.rev !files) ~f:
+    begin fun name ->
+      prerr_endline ("Processing " ^ name);
+      Printexc.catch (convert_file ~intf:!intf) name
+    end
diff --git a/tools/stripdebug.ml b/tools/stripdebug.ml
new file mode 100644
index 00000000..c977609f
--- /dev/null
+++ b/tools/stripdebug.ml
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Copy a bytecode executable, removing debugging information
+   and #! header from the copy.
+   Usage: stripdebug  
+*)
+
+open Printf
+open Misc
+
+let stripdebug infile outfile =
+  let ic = open_in_bin infile in
+  Bytesections.read_toc ic;
+  let toc = Bytesections.toc() in
+  let pos_first_section = Bytesections.pos_first_section ic in
+  let oc =
+    open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
+                 outfile in
+  (* Skip the #! header, going straight to the first section. *)
+  seek_in ic pos_first_section;
+  (* Copy each section except DBUG *)
+  Bytesections.init_record oc;
+  List.iter
+    (fun (name, len) ->
+      if name = "DBUG" then begin
+        seek_in ic (in_channel_length ic + len)
+      end else begin
+        copy_file_chunk ic oc len;
+        Bytesections.record oc name
+      end)
+    toc;
+  (* Rewrite the toc and trailer *)
+  Bytesections.write_toc_and_trailer oc;
+  (* Done *)
+  close_in ic;
+  close_out oc
+
+let _ =
+  if Array.length Sys.argv = 3
+  then stripdebug Sys.argv.(1) Sys.argv.(2)
+  else begin
+    eprintf "Usage: stripdebug  \n";
+    exit 2
+  end
diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
new file mode 100644
index 00000000..e97d8e59
--- /dev/null
+++ b/toplevel/expunge.ml
@@ -0,0 +1,84 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* "Expunge" a toplevel by removing compiler modules from the global map.
+   Usage: expunge    *)
+
+open Misc
+
+module StringSet =
+  Set.Make(struct
+    type t = string
+    let compare = compare
+  end)
+
+let is_exn =
+  let h = Hashtbl.create 64 in
+  Array.iter (fun n -> Hashtbl.add h n ()) Runtimedef.builtin_exceptions;
+  Hashtbl.mem h
+
+let to_keep = ref StringSet.empty
+
+let negate = Sys.argv.(3) = "-v"
+
+let keep =
+  if negate then fun name -> is_exn name || not (StringSet.mem name !to_keep)
+  else fun name -> is_exn name || (StringSet.mem name !to_keep)
+
+let expunge_map tbl =
+  Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl
+
+let expunge_crcs tbl =
+  List.filter (fun (unit, _crc) -> keep unit) tbl
+
+let main () =
+  let input_name = Sys.argv.(1) in
+  let output_name = Sys.argv.(2) in
+  for i = (if negate then 4 else 3) to Array.length Sys.argv - 1 do
+    to_keep := StringSet.add (String.capitalize_ascii Sys.argv.(i)) !to_keep
+  done;
+  let ic = open_in_bin input_name in
+  Bytesections.read_toc ic;
+  let toc = Bytesections.toc() in
+  let pos_first_section = Bytesections.pos_first_section ic in
+  let oc =
+    open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
+                 output_name in
+  (* Copy the file up to the symbol section as is *)
+  seek_in ic 0;
+  copy_file_chunk ic oc pos_first_section;
+  (* Copy each section, modifying the symbol section in passing *)
+  Bytesections.init_record oc;
+  List.iter
+    (fun (name, len) ->
+      begin match name with
+        "SYMB" ->
+          let global_map = (input_value ic : Symtable.global_map) in
+          output_value oc (expunge_map global_map)
+      | "CRCS" ->
+          let crcs = (input_value ic : (string * Digest.t option) list) in
+          output_value oc (expunge_crcs crcs)
+      | _ ->
+          copy_file_chunk ic oc len
+      end;
+      Bytesections.record oc name)
+    toc;
+  (* Rewrite the toc and trailer *)
+  Bytesections.write_toc_and_trailer oc;
+  (* Done *)
+  close_in ic;
+  close_out oc
+
+let _ = Printexc.catch main (); exit 0
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
new file mode 100644
index 00000000..8c7ce660
--- /dev/null
+++ b/toplevel/genprintval.ml
@@ -0,0 +1,582 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* To print values *)
+
+open Misc
+open Format
+open Longident
+open Path
+open Types
+open Outcometree
+
+module type OBJ =
+  sig
+    type t
+    val obj : t -> 'a
+    val is_block : t -> bool
+    val tag : t -> int
+    val size : t -> int
+    val field : t -> int -> t
+  end
+
+module type EVALPATH =
+  sig
+    type valu
+    val eval_path: Env.t -> Path.t -> valu
+    exception Error
+    val same_value: valu -> valu -> bool
+  end
+
+type ('a, 'b) gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
+module type S =
+  sig
+    type t
+    val install_printer :
+          Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
+    val install_generic_printer :
+           Path.t -> Path.t ->
+           (int -> (int -> t -> Outcometree.out_value,
+                    t -> Outcometree.out_value) gen_printer) ->
+           unit
+    val install_generic_printer' :
+           Path.t -> Path.t ->
+           (formatter -> t -> unit,
+            formatter -> t -> unit) gen_printer ->
+           unit
+    val remove_printer : Path.t -> unit
+    val outval_of_untyped_exception : t -> Outcometree.out_value
+    val outval_of_value :
+          int -> int ->
+          (int -> t -> Types.type_expr -> Outcometree.out_value option) ->
+          Env.t -> t -> type_expr -> Outcometree.out_value
+  end
+
+module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
+
+    type t = O.t
+
+    module ObjTbl = Hashtbl.Make(struct
+        type t = O.t
+        let equal = (==)
+        let hash x =
+          try
+            Hashtbl.hash x
+          with _exn -> 0
+      end)
+
+
+    (* Given an exception value, we cannot recover its type,
+       hence we cannot print its arguments in general.
+       Here, we do a feeble attempt to print
+       integer, string and float arguments... *)
+    let outval_of_untyped_exception_args obj start_offset =
+      if O.size obj > start_offset then begin
+        let list = ref [] in
+        for i = start_offset to O.size obj - 1 do
+          let arg = O.field obj i in
+          if not (O.is_block arg) then
+            list := Oval_int (O.obj arg : int) :: !list
+               (* Note: this could be a char or a constant constructor... *)
+          else if O.tag arg = Obj.string_tag then
+            list :=
+              Oval_string (String.escaped (O.obj arg : string)) :: !list
+          else if O.tag arg = Obj.double_tag then
+            list := Oval_float (O.obj arg : float) :: !list
+          else
+            list := Oval_constr (Oide_ident "_", []) :: !list
+        done;
+        List.rev !list
+      end
+      else []
+
+    let outval_of_untyped_exception bucket =
+      if O.tag bucket <> 0 then
+        Oval_constr (Oide_ident (O.obj (O.field bucket 0) : string), [])
+      else
+      let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
+      let args =
+        if (name = "Match_failure"
+            || name = "Assert_failure"
+            || name = "Undefined_recursive_module")
+        && O.size bucket = 2
+        && O.tag(O.field bucket 1) = 0
+        then outval_of_untyped_exception_args (O.field bucket 1) 0
+        else outval_of_untyped_exception_args bucket 1 in
+      Oval_constr (Oide_ident name, args)
+
+    (* The user-defined printers. Also used for some builtin types. *)
+
+    type printer =
+      | Simple of Types.type_expr * (O.t -> Outcometree.out_value)
+      | Generic of Path.t * (int -> (int -> O.t -> Outcometree.out_value,
+                                     O.t -> Outcometree.out_value) gen_printer)
+
+    let printers = ref ([
+      ( Pident(Ident.create "print_int"),
+        Simple (Predef.type_int,
+                (fun x -> Oval_int (O.obj x : int))) );
+      ( Pident(Ident.create "print_float"),
+        Simple (Predef.type_float,
+                (fun x -> Oval_float (O.obj x : float))) );
+      ( Pident(Ident.create "print_char"),
+        Simple (Predef.type_char,
+                (fun x -> Oval_char (O.obj x : char))) );
+      ( Pident(Ident.create "print_string"),
+        Simple (Predef.type_string,
+                (fun x -> Oval_string (O.obj x : string))) );
+      ( Pident(Ident.create "print_int32"),
+        Simple (Predef.type_int32,
+                (fun x -> Oval_int32 (O.obj x : int32))) );
+      ( Pident(Ident.create "print_nativeint"),
+        Simple (Predef.type_nativeint,
+                (fun x -> Oval_nativeint (O.obj x : nativeint))) );
+      ( Pident(Ident.create "print_int64"),
+        Simple (Predef.type_int64,
+                (fun x -> Oval_int64 (O.obj x : int64)) ))
+    ] : (Path.t * printer) list)
+
+    let exn_printer ppf path exn =
+      fprintf ppf "" Printtyp.path path (Printexc.to_string exn)
+
+    let out_exn path exn =
+      Oval_printer (fun ppf -> exn_printer ppf path exn)
+
+    let install_printer path ty fn =
+      let print_val ppf obj =
+        try fn ppf obj with exn -> exn_printer ppf path exn in
+      let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
+      printers := (path, Simple (ty, printer)) :: !printers
+
+    let install_generic_printer function_path constr_path fn =
+      printers := (function_path, Generic (constr_path, fn))  :: !printers
+
+    let install_generic_printer' function_path ty_path fn =
+      let rec build gp depth =
+        match gp with
+        | Zero fn ->
+            let out_printer obj =
+              let printer ppf =
+                try fn ppf obj with exn -> exn_printer ppf function_path exn in
+              Oval_printer printer in
+            Zero out_printer
+        | Succ fn ->
+            let print_val fn_arg =
+              let print_arg ppf o =
+                !Oprint.out_value ppf (fn_arg (depth+1) o) in
+              build (fn print_arg) depth in
+            Succ print_val in
+      printers := (function_path, Generic (ty_path, build fn)) :: !printers
+
+    let remove_printer path =
+      let rec remove = function
+      | [] -> raise Not_found
+      | ((p, _) as printer) :: rem ->
+          if Path.same p path then rem else printer :: remove rem in
+      printers := remove !printers
+
+    (* Print a constructor or label, giving it the same prefix as the type
+       it comes from. Attempt to omit the prefix if the type comes from
+       a module that has been opened. *)
+
+    let tree_of_qualified lookup_fun env ty_path name =
+      match ty_path with
+      | Pident _ ->
+          Oide_ident name
+      | Pdot(p, _s, _pos) ->
+          if try
+               match (lookup_fun (Lident name) env).desc with
+               | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
+               | _ -> false
+             with Not_found -> false
+          then Oide_ident name
+          else Oide_dot (Printtyp.tree_of_path p, name)
+      | Papply _ ->
+          Printtyp.tree_of_path ty_path
+
+    let tree_of_constr =
+      tree_of_qualified
+        (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
+
+    and tree_of_label =
+      tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
+
+    (* An abstract type *)
+
+    let abstract_type =
+      Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil))
+
+    (* The main printing function *)
+
+    let outval_of_value max_steps max_depth check_depth env obj ty =
+
+      let printer_steps = ref max_steps in
+
+      let nested_values = ObjTbl.create 8 in
+      let nest_gen err f depth obj ty =
+        let repr = obj in
+        if not (O.is_block repr) then
+          f depth obj ty
+        else
+          if ObjTbl.mem nested_values repr then
+            err
+          else begin
+            ObjTbl.add nested_values repr ();
+            let ret = f depth obj ty in
+            ObjTbl.remove nested_values repr;
+            ret
+          end
+      in
+
+      let nest f = nest_gen (Oval_stuff "") f in
+
+      let rec tree_of_val depth obj ty =
+        decr printer_steps;
+        if !printer_steps < 0 || depth < 0 then Oval_ellipsis
+        else begin
+        try
+          find_printer depth env ty obj
+        with Not_found ->
+          match (Ctype.repr ty).desc with
+          | Tvar _ | Tunivar _ ->
+              Oval_stuff ""
+          | Tarrow _ ->
+              Oval_stuff ""
+          | Ttuple(ty_list) ->
+              Oval_tuple (tree_of_val_list 0 depth obj ty_list)
+          | Tconstr(path, [ty_arg], _)
+            when Path.same path Predef.path_list ->
+              if O.is_block obj then
+                match check_depth depth obj ty with
+                  Some x -> x
+                | None ->
+                    let rec tree_of_conses tree_list depth obj ty_arg =
+                      if !printer_steps < 0 || depth < 0 then
+                        Oval_ellipsis :: tree_list
+                      else if O.is_block obj then
+                        let tree =
+                          nest tree_of_val (depth - 1) (O.field obj 0) ty_arg
+                        in
+                        let next_obj = O.field obj 1 in
+                        nest_gen (Oval_stuff "" :: tree :: tree_list)
+                          (tree_of_conses (tree :: tree_list))
+                          depth next_obj ty_arg
+                      else tree_list
+                    in
+                    Oval_list (List.rev (tree_of_conses [] depth obj ty_arg))
+              else
+                Oval_list []
+          | Tconstr(path, [ty_arg], _)
+            when Path.same path Predef.path_array ->
+              let length = O.size obj in
+              if length > 0 then
+                match check_depth depth obj ty with
+                  Some x -> x
+                | None ->
+                    let rec tree_of_items tree_list i =
+                      if !printer_steps < 0 || depth < 0 then
+                        Oval_ellipsis :: tree_list
+                      else if i < length then
+                        let tree =
+                          nest tree_of_val (depth - 1) (O.field obj i) ty_arg
+                        in
+                        tree_of_items (tree :: tree_list) (i + 1)
+                      else tree_list
+                    in
+                    Oval_array (List.rev (tree_of_items [] 0))
+              else
+                Oval_array []
+          | Tconstr (path, [ty_arg], _)
+            when Path.same path Predef.path_lazy_t ->
+             let obj_tag = O.tag obj in
+             (* Lazy values are represented in three possible ways:
+
+                1. a lazy thunk that is not yet forced has tag
+                   Obj.lazy_tag
+
+                2. a lazy thunk that has just been forced has tag
+                   Obj.forward_tag; its first field is the forced
+                   result, which we can print
+
+                3. when the GC moves a forced trunk with forward_tag,
+                   or when a thunk is directly created from a value,
+                   we get a third representation where the value is
+                   directly exposed, without the Obj.forward_tag
+                   (if its own tag is not ambiguous, that is neither
+                   lazy_tag nor forward_tag)
+
+                Note that using Lazy.is_val and Lazy.force would be
+                unsafe, because they use the Obj.* functions rather
+                than the O.* functions of the functor argument, and
+                would thus crash if called from the toplevel
+                (debugger/printval instantiates Genprintval.Make with
+                an Obj module talking over a socket).
+              *)
+             if obj_tag = Obj.lazy_tag then Oval_stuff ""
+             else begin
+                 let forced_obj =
+                   if obj_tag = Obj.forward_tag then O.field obj 0 else obj
+                 in
+                 (* calling oneself recursively on forced_obj risks
+                    having a false positive for cycle detection;
+                    indeed, in case (3) above, the value is stored
+                    as-is instead of being wrapped in a forward
+                    pointer. It means that, for (lazy "foo"), we have
+                      forced_obj == obj
+                    and it is easy to wrongly print (lazy ) in such
+                    a case (PR#6669).
+
+                    Unfortunately, there is a corner-case that *is*
+                    a real cycle: using -rectypes one can define
+                      let rec x = lazy x
+                    which creates a Forward_tagged block that points to
+                    itself. For this reason, we still "nest"
+                    (detect head cycles) on forward tags.
+                  *)
+                 let v =
+                   if obj_tag = Obj.forward_tag
+                   then nest tree_of_val depth forced_obj ty_arg
+                   else      tree_of_val depth forced_obj ty_arg
+                 in
+                 Oval_constr (Oide_ident "lazy", [v])
+               end
+          | Tconstr(path, ty_list, _) -> begin
+              try
+                let decl = Env.find_type path env in
+                match decl with
+                | {type_kind = Type_abstract; type_manifest = None} ->
+                    Oval_stuff ""
+                | {type_kind = Type_abstract; type_manifest = Some body} ->
+                    tree_of_val depth obj
+                      (try Ctype.apply env decl.type_params body ty_list with
+                         Ctype.Cannot_apply -> abstract_type)
+                | {type_kind = Type_variant constr_list; type_unboxed} ->
+                    let unbx = type_unboxed.unboxed in
+                    let tag =
+                      if unbx then Cstr_unboxed
+                      else if O.is_block obj
+                      then Cstr_block(O.tag obj)
+                      else Cstr_constant(O.obj obj) in
+                    let {cd_id;cd_args;cd_res} =
+                      Datarepr.find_constr_by_tag tag constr_list in
+                    let type_params =
+                      match cd_res with
+                        Some t ->
+                          begin match (Ctype.repr t).desc with
+                            Tconstr (_,params,_) ->
+                              params
+                          | _ -> assert false end
+                      | None -> decl.type_params
+                    in
+                    begin
+                      match cd_args with
+                      | Cstr_tuple l ->
+                          let ty_args =
+                            List.map
+                              (function ty ->
+                                try Ctype.apply env type_params ty ty_list with
+                                  Ctype.Cannot_apply -> abstract_type)
+                              l
+                          in
+                          tree_of_constr_with_args (tree_of_constr env path)
+                            (Ident.name cd_id) false 0 depth obj
+                            ty_args unbx
+                      | Cstr_record lbls ->
+                          let r =
+                            tree_of_record_fields depth
+                              env path type_params ty_list
+                              lbls 0 obj unbx
+                          in
+                          Oval_constr(tree_of_constr env path
+                                        (Ident.name cd_id),
+                                      [ r ])
+                    end
+                | {type_kind = Type_record(lbl_list, rep)} ->
+                    begin match check_depth depth obj ty with
+                      Some x -> x
+                    | None ->
+                        let pos =
+                          match rep with
+                          | Record_extension -> 1
+                          | _ -> 0
+                        in
+                        let unbx =
+                          match rep with Record_unboxed _ -> true | _ -> false
+                        in
+                        tree_of_record_fields depth
+                          env path decl.type_params ty_list
+                          lbl_list pos obj unbx
+                    end
+                | {type_kind = Type_open} ->
+                    tree_of_extension path depth obj
+              with
+                Not_found ->                (* raised by Env.find_type *)
+                  Oval_stuff ""
+              | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
+                  Oval_stuff ""
+              end
+          | Tvariant row ->
+              let row = Btype.row_repr row in
+              if O.is_block obj then
+                let tag : int = O.obj (O.field obj 0) in
+                let rec find = function
+                  | (l, f) :: fields ->
+                      if Btype.hash_variant l = tag then
+                        match Btype.row_field_repr f with
+                        | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
+                            let args =
+                              nest tree_of_val (depth - 1) (O.field obj 1) ty
+                            in
+                              Oval_variant (l, Some args)
+                        | _ -> find fields
+                      else find fields
+                  | [] -> Oval_stuff "" in
+                find row.row_fields
+              else
+                let tag : int = O.obj obj in
+                let rec find = function
+                  | (l, _) :: fields ->
+                      if Btype.hash_variant l = tag then
+                        Oval_variant (l, None)
+                      else find fields
+                  | [] -> Oval_stuff "" in
+                find row.row_fields
+          | Tobject (_, _) ->
+              Oval_stuff ""
+          | Tsubst ty ->
+              tree_of_val (depth - 1) obj ty
+          | Tfield(_, _, _, _) | Tnil | Tlink _ ->
+              fatal_error "Printval.outval_of_value"
+          | Tpoly (ty, _) ->
+              tree_of_val (depth - 1) obj ty
+          | Tpackage _ ->
+              Oval_stuff ""
+        end
+
+      and tree_of_record_fields depth env path type_params ty_list
+          lbl_list pos obj unboxed =
+        let rec tree_of_fields pos = function
+          | [] -> []
+          | {ld_id; ld_type} :: remainder ->
+              let ty_arg =
+                try
+                  Ctype.apply env type_params ld_type
+                    ty_list
+                with
+                  Ctype.Cannot_apply -> abstract_type in
+              let name = Ident.name ld_id in
+              (* PR#5722: print full module path only
+                 for first record field *)
+              let lid =
+                if pos = 0 then tree_of_label env path name
+                else Oide_ident name
+              and v =
+                if unboxed
+                then tree_of_val (depth - 1) obj ty_arg
+                else nest tree_of_val (depth - 1) (O.field obj pos) ty_arg
+              in
+              (lid, v) :: tree_of_fields (pos + 1) remainder
+        in
+        Oval_record (tree_of_fields pos lbl_list)
+
+      and tree_of_val_list start depth obj ty_list =
+        let rec tree_list i = function
+          | [] -> []
+          | ty :: ty_list ->
+              let tree = nest tree_of_val (depth - 1) (O.field obj i) ty in
+              tree :: tree_list (i + 1) ty_list in
+      tree_list start ty_list
+
+      and tree_of_constr_with_args
+             tree_of_cstr cstr_name inlined start depth obj ty_args unboxed =
+        let lid = tree_of_cstr cstr_name in
+        let args =
+          if inlined || unboxed then
+            match ty_args with
+            | [ty] -> [ tree_of_val (depth - 1) obj ty ]
+            | _ -> assert false
+          else
+            tree_of_val_list start depth obj ty_args
+        in
+        Oval_constr (lid, args)
+
+    and tree_of_extension type_path depth bucket =
+      let slot =
+        if O.tag bucket <> 0 then bucket
+        else O.field bucket 0
+      in
+      let name = (O.obj(O.field slot 0) : string) in
+      let lid = Longident.parse name in
+      try
+        (* Attempt to recover the constructor description for the exn
+           from its name *)
+        let cstr = Env.lookup_constructor lid env in
+        let path =
+          match cstr.cstr_tag with
+            Cstr_extension(p, _) -> p
+            | _ -> raise Not_found
+        in
+        (* Make sure this is the right exception and not an homonym,
+           by evaluating the exception found and comparing with the
+           identifier contained in the exception bucket *)
+        if not (EVP.same_value slot (EVP.eval_path env path))
+        then raise Not_found;
+        tree_of_constr_with_args
+           (fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)
+           1 depth bucket
+           cstr.cstr_args false
+      with Not_found | EVP.Error ->
+        match check_depth depth bucket ty with
+          Some x -> x
+        | None when Path.same type_path Predef.path_exn->
+            outval_of_untyped_exception bucket
+        | None ->
+            Oval_stuff ""
+
+    and find_printer depth env ty =
+      let rec find = function
+      | [] -> raise Not_found
+      | (_name, Simple (sch, printer)) :: remainder ->
+          if Ctype.moregeneral env false sch ty
+          then printer
+          else find remainder
+      | (_name, Generic (path, fn)) :: remainder ->
+          begin match (Ctype.expand_head env ty).desc with
+          | Tconstr (p, args, _) when Path.same p path ->
+              begin try apply_generic_printer path (fn depth) args
+              with exn -> (fun _obj -> out_exn path exn) end
+          | _ -> find remainder end in
+      find !printers
+
+    and apply_generic_printer path printer args =
+      match (printer, args) with
+      | (Zero fn, []) -> (fun (obj : O.t)-> try fn obj with exn -> out_exn path exn)
+      | (Succ fn, arg :: args) ->
+          let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
+          apply_generic_printer path printer args
+      | _ ->
+          (fun _obj ->
+            let printer ppf =
+              fprintf ppf ""
+                Printtyp.path path in
+            Oval_printer printer)
+
+
+    in nest tree_of_val max_depth obj ty
+
+end
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
new file mode 100644
index 00000000..744aaaea
--- /dev/null
+++ b/toplevel/genprintval.mli
@@ -0,0 +1,70 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing of values *)
+
+open Types
+open Format
+
+module type OBJ =
+  sig
+    type t
+    val obj : t -> 'a
+    val is_block : t -> bool
+    val tag : t -> int
+    val size : t -> int
+    val field : t -> int -> t
+  end
+
+module type EVALPATH =
+  sig
+    type valu
+    val eval_path: Env.t -> Path.t -> valu
+    exception Error
+    val same_value: valu -> valu -> bool
+  end
+
+type ('a, 'b) gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
+module type S =
+  sig
+    type t
+    val install_printer :
+          Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
+    val install_generic_printer :
+          Path.t -> Path.t ->
+          (int -> (int -> t -> Outcometree.out_value,
+                   t -> Outcometree.out_value) gen_printer) ->
+          unit
+    val install_generic_printer' :
+           Path.t -> Path.t ->
+           (formatter -> t -> unit,
+            formatter -> t -> unit) gen_printer ->
+           unit
+    (** [install_generic_printer' function_path constructor_path printer]
+        function_path is used to remove the printer. *)
+
+    val remove_printer : Path.t -> unit
+    val outval_of_untyped_exception : t -> Outcometree.out_value
+    val outval_of_value :
+          int -> int ->
+          (int -> t -> Types.type_expr -> Outcometree.out_value option) ->
+          Env.t -> t -> type_expr -> Outcometree.out_value
+  end
+
+module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) :
+         (S with type t = O.t)
diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
new file mode 100644
index 00000000..795c7e48
--- /dev/null
+++ b/toplevel/opttopdirs.ml
@@ -0,0 +1,199 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Toplevel directives *)
+
+open Format
+open Misc
+open Longident
+open Types
+open Opttoploop
+
+(* The standard output formatter *)
+let std_out = std_formatter
+
+(* To quit *)
+
+let dir_quit () = exit 0
+
+let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit)
+
+(* To add a directory to the load path *)
+
+let dir_directory s =
+  let d = expand_directory Config.standard_library s in
+  Config.load_path := d :: !Config.load_path
+
+let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
+(* To remove a directory from the load path *)
+let dir_remove_directory s =
+  let d = expand_directory Config.standard_library s in
+  Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path
+
+let _ =
+  Hashtbl.add directive_table "remove_directory"
+    (Directive_string dir_remove_directory)
+
+let _ = Hashtbl.add directive_table "show_dirs"
+  (Directive_none
+     (fun () ->
+        List.iter print_endline !Config.load_path
+     ))
+
+(* To change the current directory *)
+
+let dir_cd s = Sys.chdir s
+
+let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
+
+(* Load in-core a .cmxs file *)
+
+let load_file ppf name0 =
+  let name =
+    try Some (find_in_path !Config.load_path name0)
+    with Not_found -> None
+  in
+  match name with
+  | None -> fprintf ppf "File not found: %s@." name0; false
+  | Some name ->
+    let fn,tmp =
+      if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa"
+      then
+        let cmxs = Filename.temp_file "caml" ".cmxs" in
+        Asmlink.link_shared ppf [name] cmxs;
+        cmxs,true
+      else
+        name,false
+    in
+    let success =
+      (* The Dynlink interface does not allow us to distinguish between
+          a Dynlink.Error exceptions raised in the loaded modules
+          or a genuine error during dynlink... *)
+      try Compdynlink.loadfile fn; true
+      with
+      | Compdynlink.Error err ->
+        fprintf ppf "Error while loading %s: %s.@."
+          name (Compdynlink.error_message err);
+        false
+      | exn ->
+        print_exception_outcome ppf exn;
+        false
+    in
+    if tmp then (try Sys.remove fn with Sys_error _ -> ());
+    success
+
+
+let dir_load ppf name = ignore (load_file ppf name)
+
+let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out))
+
+(* Load commands from a file *)
+
+let dir_use ppf name = ignore(Opttoploop.use_file ppf name)
+
+let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out))
+
+(* Install, remove a printer *)
+
+type 'a printer_type_new = Format.formatter -> 'a -> unit
+type 'a printer_type_old = 'a -> unit
+
+let match_printer_type ppf desc typename =
+  let printer_type =
+    try
+      Env.lookup_type (Ldot(Lident "Opttopdirs", typename)) !toplevel_env
+    with Not_found ->
+      fprintf ppf "Cannot find type Topdirs.%s.@." typename;
+      raise Exit in
+  Ctype.init_def(Ident.current_time());
+  Ctype.begin_def();
+  let ty_arg = Ctype.newvar() in
+  Ctype.unify !toplevel_env
+    (Ctype.newconstr printer_type [ty_arg])
+    (Ctype.instance_def desc.val_type);
+  Ctype.end_def();
+  Ctype.generalize ty_arg;
+  ty_arg
+
+let find_printer_type ppf lid =
+  try
+    let (path, desc) = Env.lookup_value lid !toplevel_env in
+    let (ty_arg, is_old_style) =
+      try
+        (match_printer_type ppf desc "printer_type_new", false)
+      with Ctype.Unify _ ->
+        (match_printer_type ppf desc "printer_type_old", true) in
+    (ty_arg, path, is_old_style)
+  with
+  | Not_found ->
+      fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
+      raise Exit
+  | Ctype.Unify _ ->
+      fprintf ppf "%a has a wrong type for a printing function.@."
+      Printtyp.longident lid;
+      raise Exit
+
+let dir_install_printer ppf lid =
+  try
+    let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+    let v = eval_path !toplevel_env path in
+    let print_function =
+      if is_old_style then
+        (fun _formatter repr -> Obj.obj v (Obj.obj repr))
+      else
+        (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
+    install_printer path ty_arg print_function
+  with Exit -> ()
+
+let dir_remove_printer ppf lid =
+  try
+    let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
+    begin try
+      remove_printer path
+    with Not_found ->
+      fprintf ppf "No printer named %a.@." Printtyp.longident lid
+    end
+  with Exit -> ()
+
+let _ = Hashtbl.add directive_table "install_printer"
+             (Directive_ident (dir_install_printer std_out))
+let _ = Hashtbl.add directive_table "remove_printer"
+             (Directive_ident (dir_remove_printer std_out))
+
+let parse_warnings ppf iserr s =
+  try Warnings.parse_options iserr s
+  with Arg.Bad err -> fprintf ppf "%s.@." err
+
+let _ =
+(* Control the printing of values *)
+
+  Hashtbl.add directive_table "print_depth"
+             (Directive_int(fun n -> max_printer_depth := n));
+  Hashtbl.add directive_table "print_length"
+             (Directive_int(fun n -> max_printer_steps := n));
+
+(* Set various compiler flags *)
+
+  Hashtbl.add directive_table "labels"
+             (Directive_bool(fun b -> Clflags.classic := not b));
+
+  Hashtbl.add directive_table "principal"
+             (Directive_bool(fun b -> Clflags.principal := b));
+
+  Hashtbl.add directive_table "warnings"
+             (Directive_string (parse_warnings std_out false));
+
+  Hashtbl.add directive_table "warn_error"
+             (Directive_string (parse_warnings std_out true))
diff --git a/toplevel/opttopdirs.mli b/toplevel/opttopdirs.mli
new file mode 100644
index 00000000..01d13569
--- /dev/null
+++ b/toplevel/opttopdirs.mli
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The toplevel directives. *)
+
+open Format
+
+val dir_quit : unit -> unit
+val dir_directory : string -> unit
+val dir_remove_directory : string -> unit
+val dir_cd : string -> unit
+val dir_load : formatter -> string -> unit
+val dir_use : formatter -> string -> unit
+val dir_install_printer : formatter -> Longident.t -> unit
+val dir_remove_printer : formatter -> Longident.t -> unit
+
+type 'a printer_type_new = Format.formatter -> 'a -> unit
+type 'a printer_type_old = 'a -> unit
+
+(* For topmain.ml. Maybe shouldn't be there *)
+val load_file : formatter -> string -> bool
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
new file mode 100644
index 00000000..6ca12efa
--- /dev/null
+++ b/toplevel/opttoploop.ml
@@ -0,0 +1,601 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The interactive toplevel loop *)
+
+open Path
+open Format
+open Config
+open Misc
+open Parsetree
+open Types
+open Typedtree
+open Outcometree
+open Ast_helper
+
+type res = Ok of Obj.t | Err of string
+type evaluation_outcome = Result of Obj.t | Exception of exn
+
+let _dummy = (Ok (Obj.magic 0), Err "")
+
+external ndl_run_toplevel: string -> string -> res
+  = "caml_natdynlink_run_toplevel"
+external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym"
+
+let global_symbol id =
+  let sym = Compilenv.symbol_for_global id in
+  try ndl_loadsym sym
+  with _ -> fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id))
+
+let need_symbol sym =
+  try ignore (ndl_loadsym sym); false
+  with _ -> true
+
+let dll_run dll entry =
+  match (try Result (Obj.magic (ndl_run_toplevel dll entry))
+         with exn -> Exception exn)
+  with
+    | Exception _ as r -> r
+    | Result r ->
+        match Obj.magic r with
+          | Ok x -> Result x
+          | Err s -> fatal_error ("Opttoploop.dll_run " ^ s)
+
+
+type directive_fun =
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
+
+
+(* Return the value referred to by a path *)
+
+let remembered = ref Ident.empty
+
+let rec remember phrase_name i = function
+  | [] -> ()
+  | Sig_value  (id, _) :: rest
+  | Sig_module (id, _, _) :: rest
+  | Sig_typext (id, _, _) :: rest
+  | Sig_class  (id, _, _) :: rest ->
+      remembered := Ident.add id (phrase_name, i) !remembered;
+      remember phrase_name (succ i) rest
+  | _ :: rest -> remember phrase_name i rest
+
+let toplevel_value id =
+  try Ident.find_same id !remembered
+  with _ -> Misc.fatal_error @@ "Unknown ident: " ^ Ident.unique_name id
+
+let close_phrase lam =
+  let open Lambda in
+  IdentSet.fold (fun id l ->
+    let glb, pos = toplevel_value id in
+    let glob =
+      Lprim (Pfield pos,
+             [Lprim (Pgetglobal glb, [], Location.none)],
+             Location.none)
+    in
+    Llet(Strict, Pgenval, id, glob, l)
+  ) (free_variables lam) lam
+
+let toplevel_value id =
+  let glob, pos =
+    if Config.flambda then toplevel_value id else Translmod.nat_toplevel_name id
+  in
+  (Obj.magic (global_symbol glob)).(pos)
+
+let rec eval_path = function
+  | Pident id ->
+      if Ident.persistent id || Ident.global id
+      then global_symbol id
+      else toplevel_value id
+  | Pdot(p, _s, pos) ->
+      Obj.field (eval_path p) pos
+  | Papply _ ->
+      fatal_error "Toploop.eval_path"
+
+let eval_path env path =
+  eval_path (Env.normalize_path (Some Location.none) env path)
+
+(* To print values *)
+
+module EvalPath = struct
+  type valu = Obj.t
+  exception Error
+  let eval_path env p = try eval_path env p with _ -> raise Error
+  let same_value v1 v2 = (v1 == v2)
+end
+
+module Printer = Genprintval.Make(Obj)(EvalPath)
+
+let max_printer_depth = ref 100
+let max_printer_steps = ref 300
+
+let print_out_value = Oprint.out_value
+let print_out_type = Oprint.out_type
+let print_out_class_type = Oprint.out_class_type
+let print_out_module_type = Oprint.out_module_type
+let print_out_type_extension = Oprint.out_type_extension
+let print_out_sig_item = Oprint.out_sig_item
+let print_out_signature = Oprint.out_signature
+let print_out_phrase = Oprint.out_phrase
+
+let print_untyped_exception ppf obj =
+  !print_out_value ppf (Printer.outval_of_untyped_exception obj)
+let outval_of_value env obj ty =
+  Printer.outval_of_value !max_printer_steps !max_printer_depth
+    (fun _ _ _ -> None) env obj ty
+let print_value env obj ppf ty =
+  !print_out_value ppf (outval_of_value env obj ty)
+
+type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
+let install_printer = Printer.install_printer
+let install_generic_printer = Printer.install_generic_printer
+let install_generic_printer' = Printer.install_generic_printer'
+let remove_printer = Printer.remove_printer
+
+(* Hooks for parsing functions *)
+
+let parse_toplevel_phrase = ref Parse.toplevel_phrase
+let parse_use_file = ref Parse.use_file
+let print_location = Location.print_error (* FIXME change back to print *)
+let print_error = Location.print_error
+let print_warning = Location.print_warning
+let input_name = Location.input_name
+
+let parse_mod_use_file name lb =
+  let modname =
+    String.capitalize_ascii (Filename.chop_extension (Filename.basename name))
+  in
+  let items =
+    List.concat
+      (List.map
+         (function Ptop_def s -> s | Ptop_dir _ -> [])
+         (!parse_use_file lb))
+  in
+  [ Ptop_def
+      [ Str.module_
+          (Mb.mk
+             (Location.mknoloc modname)
+             (Mod.structure items)
+          )
+       ]
+   ]
+
+(* Hooks for initialization *)
+
+let toplevel_startup_hook = ref (fun () -> ())
+
+(* Load in-core and execute a lambda term *)
+
+let phrase_seqid = ref 0
+let phrase_name = ref "TOP"
+
+(* CR-soon trefis for mshinwell: copy/pasted from Optmain. Should it be shared
+   or?
+   mshinwell: It should be shared, but after 4.03. *)
+module Backend = struct
+  (* See backend_intf.mli. *)
+
+  let symbol_for_global' = Compilenv.symbol_for_global'
+  let closure_symbol = Compilenv.closure_symbol
+
+  let really_import_approx = Import_approx.really_import_approx
+  let import_symbol = Import_approx.import_symbol
+
+  let size_int = Arch.size_int
+  let big_endian = Arch.big_endian
+
+  let max_sensible_number_of_arguments =
+    (* The "-1" is to allow for a potential closure environment parameter. *)
+    Proc.max_arguments_for_tailcalls - 1
+end
+let backend = (module Backend : Backend_intf.S)
+
+let load_lambda ppf ~module_ident ~required_globals lam size =
+  if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
+  let slam = Simplif.simplify_lambda "//toplevel//" lam in
+  if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
+
+  let dll =
+    if !Clflags.keep_asm_file then !phrase_name ^ ext_dll
+    else Filename.temp_file ("caml" ^ !phrase_name) ext_dll
+  in
+  let fn = Filename.chop_extension dll in
+  if not Config.flambda then
+    Asmgen.compile_implementation_clambda ~source_provenance:Timings.Toplevel
+      ~toplevel:need_symbol fn ppf
+      { Lambda.code=slam ; main_module_block_size=size;
+        module_ident; required_globals }
+  else
+    Asmgen.compile_implementation_flambda ~source_provenance:Timings.Toplevel
+      ~required_globals ~backend ~toplevel:need_symbol fn ppf
+      (Middle_end.middle_end ppf
+         ~source_provenance:Timings.Toplevel ~prefixname:"" ~backend ~size
+         ~module_ident ~module_initializer:slam ~filename:"toplevel");
+  Asmlink.call_linker_shared [fn ^ ext_obj] dll;
+  Sys.remove (fn ^ ext_obj);
+
+  let dll =
+    if Filename.is_implicit dll
+    then Filename.concat (Sys.getcwd ()) dll
+    else dll in
+  let res = dll_run dll !phrase_name in
+  (try Sys.remove dll with Sys_error _ -> ());
+  (* note: under windows, cannot remove a loaded dll
+     (should remember the handles, close them in at_exit, and then remove
+     files) *)
+  res
+
+(* Print the outcome of an evaluation *)
+
+let pr_item =
+  Printtyp.print_items
+    (fun env -> function
+      | Sig_value(id, {val_kind = Val_reg; val_type}) ->
+          Some (outval_of_value env (toplevel_value id) val_type)
+      | _ -> None
+    )
+
+(* The current typing environment for the toplevel *)
+
+let toplevel_env = ref Env.empty
+
+(* Print an exception produced by an evaluation *)
+
+let print_out_exception ppf exn outv =
+  !print_out_phrase ppf (Ophr_exception (exn, outv))
+
+let print_exception_outcome ppf exn =
+  if exn = Out_of_memory then Gc.full_major ();
+  let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
+  print_out_exception ppf exn outv
+
+(* The table of toplevel directives.
+   Filled by functions from module topdirs. *)
+
+let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
+
+(* Execute a toplevel phrase *)
+
+let execute_phrase print_outcome ppf phr =
+  match phr with
+  | Ptop_def sstr ->
+      let oldenv = !toplevel_env in
+      incr phrase_seqid;
+      phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
+      Compilenv.reset ~source_provenance:Timings.Toplevel
+        ?packname:None !phrase_name;
+      Typecore.reset_delayed_checks ();
+      let sstr, rewritten =
+        match sstr with
+        | [ { pstr_desc = Pstr_eval (e, attrs) ; pstr_loc = loc } ]
+        | [ { pstr_desc = Pstr_value (Asttypes.Nonrecursive,
+                                      [{ pvb_expr = e
+                                       ; pvb_pat = { ppat_desc = Ppat_any ; _ }
+                                       ; pvb_attributes = attrs
+                                       ; _ }])
+            ; pstr_loc = loc }
+          ] ->
+            let pat = Ast_helper.Pat.var (Location.mknoloc "_$") in
+            let vb = Ast_helper.Vb.mk ~loc ~attrs pat e in
+            [ Ast_helper.Str.value ~loc Asttypes.Nonrecursive [vb] ], true
+        | _ -> sstr, false
+      in
+      let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
+      if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
+      let sg' = Typemod.simplify_signature sg in
+      (* Why is this done? *)
+      ignore (Includemod.signatures oldenv sg sg');
+      Typecore.force_delayed_checks ();
+      let module_ident, res, required_globals, size =
+        if Config.flambda then
+          let { Lambda.module_ident; main_module_block_size = size;
+                required_globals; code = res } =
+            Translmod.transl_implementation_flambda !phrase_name
+              (str, Tcoerce_none)
+          in
+          remember module_ident 0 sg';
+          module_ident, close_phrase res, required_globals, size
+        else
+          let size, res = Translmod.transl_store_phrases !phrase_name str in
+          Ident.create_persistent !phrase_name, res, Ident.Set.empty, size
+      in
+      Warnings.check_fatal ();
+      begin try
+        toplevel_env := newenv;
+        let res = load_lambda ppf ~required_globals ~module_ident res size in
+        let out_phr =
+          match res with
+          | Result _ ->
+              if Config.flambda then
+                (* CR-someday trefis: *)
+                ()
+              else
+                Compilenv.record_global_approx_toplevel ();
+              if print_outcome then
+                Printtyp.wrap_printing_env oldenv (fun () ->
+                match str.str_items with
+                | [] -> Ophr_signature []
+                | _ ->
+                    if rewritten then
+                      match sg' with
+                      | [ Sig_value (id, vd) ] ->
+                          let outv =
+                            outval_of_value newenv (toplevel_value id)
+                              vd.val_type
+                          in
+                          let ty = Printtyp.tree_of_type_scheme vd.val_type in
+                          Ophr_eval (outv, ty)
+                      | _ -> assert false
+                    else
+                      Ophr_signature (pr_item newenv sg'))
+              else Ophr_signature []
+          | Exception exn ->
+              toplevel_env := oldenv;
+              if exn = Out_of_memory then Gc.full_major();
+              let outv =
+                outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
+              in
+              Ophr_exception (exn, outv)
+        in
+        !print_out_phrase ppf out_phr;
+        begin match out_phr with
+        | Ophr_eval (_, _) | Ophr_signature _ -> true
+        | Ophr_exception _ -> false
+        end
+      with x ->
+        toplevel_env := oldenv; raise x
+      end
+  | Ptop_dir(dir_name, dir_arg) ->
+      let d =
+        try Some (Hashtbl.find directive_table dir_name)
+        with Not_found -> None
+      in
+      begin match d with
+      | None ->
+          fprintf ppf "Unknown directive `%s'.@." dir_name;
+          false
+      | Some d ->
+          match d, dir_arg with
+          | Directive_none f, Pdir_none -> f (); true
+          | Directive_string f, Pdir_string s -> f s; true
+          | Directive_int f, Pdir_int (n,None) ->
+             begin match Int_literal_converter.int n with
+             | n -> f n; true
+             | exception _ ->
+               fprintf ppf "Integer literal exceeds the range of \
+                            representable integers for directive `%s'.@."
+                       dir_name;
+               false
+             end
+          | Directive_int _, Pdir_int (_, Some _) ->
+              fprintf ppf "Wrong integer literal for directive `%s'.@."
+                dir_name;
+              false
+          | Directive_ident f, Pdir_ident lid -> f lid; true
+          | Directive_bool f, Pdir_bool b -> f b; true
+          | _ ->
+              fprintf ppf "Wrong type of argument for directive `%s'.@."
+                dir_name;
+              false
+      end
+
+(* Read and execute commands from a file, or from stdin if [name] is "". *)
+
+let use_print_results = ref true
+
+let preprocess_phrase ppf phr =
+  let phr =
+    match phr with
+    | Ptop_def str ->
+        let str =
+          Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
+        in
+        let str =
+          Pparse.ImplementationHooks.apply_hooks
+            { Misc.sourcefile = "//toplevel//" } str in
+        Ptop_def str
+    | phr -> phr
+  in
+  if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+  if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+  phr
+
+let use_file ppf wrap_mod name =
+  try
+    let (filename, ic, must_close) =
+      if name = "" then
+        ("(stdin)", stdin, false)
+      else begin
+        let filename = find_in_path !Config.load_path name in
+        let ic = open_in_bin filename in
+        (filename, ic, true)
+      end
+    in
+    let lb = Lexing.from_channel ic in
+    Location.init lb filename;
+    (* Skip initial #! line if any *)
+    Lexer.skip_hash_bang lb;
+    let success =
+      protect_refs [ R (Location.input_name, filename) ] (fun () ->
+        try
+          List.iter
+            (fun ph ->
+              let ph = preprocess_phrase ppf ph in
+              if not (execute_phrase !use_print_results ppf ph) then raise Exit)
+            (if wrap_mod then
+               parse_mod_use_file name lb
+             else
+               !parse_use_file lb);
+          true
+        with
+        | Exit -> false
+        | Sys.Break -> fprintf ppf "Interrupted.@."; false
+        | x -> Location.report_exception ppf x; false) in
+    if must_close then close_in ic;
+    success
+  with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
+
+let mod_use_file ppf name = use_file ppf true name
+let use_file ppf name = use_file ppf false name
+
+let use_silently ppf name =
+  protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
+
+(* Reading function for interactive use *)
+
+let first_line = ref true
+let got_eof = ref false;;
+
+let read_input_default prompt buffer len =
+  output_string Pervasives.stdout prompt; flush Pervasives.stdout;
+  let i = ref 0 in
+  try
+    while true do
+      if !i >= len then raise Exit;
+      let c = input_char Pervasives.stdin in
+      Bytes.set 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 =
+      if !Clflags.noprompt then ""
+      else if !first_line then "# "
+      else if !Clflags.nopromptcont then ""
+      else if Lexer.in_comment () then "* "
+      else "  "
+    in
+    first_line := false;
+    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
+   beginning of loop() so that user code linked in with ocamlmktop
+   can call directives from Topdirs. *)
+
+let _ =
+  Sys.interactive := true;
+  Compdynlink.init ();
+  Compmisc.init_path true;
+  Clflags.dlcode := true;
+  ()
+
+let load_ocamlinit ppf =
+  if !Clflags.noinit then ()
+  else match !Clflags.init_file with
+  | Some f -> if Sys.file_exists f then ignore (use_silently ppf f)
+              else fprintf ppf "Init file not found: \"%s\".@." f
+  | None ->
+     if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit")
+     else try
+       let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in
+       if Sys.file_exists home_init then ignore (use_silently ppf home_init)
+     with Not_found -> ()
+;;
+
+let set_paths () =
+  (* Add whatever -I options have been specified on the command line,
+     but keep the directories that user code linked in with ocamlmktop
+     may have added to load_path. *)
+  load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"];
+  load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path);
+  ()
+
+let initialize_toplevel_env () =
+  toplevel_env := Compmisc.initial_env()
+
+(* The interactive loop *)
+
+exception PPerror
+
+let loop ppf =
+  Location.formatter_for_warnings := ppf;
+  if not !Clflags.noversion then
+    fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
+  initialize_toplevel_env ();
+  let lb = Lexing.from_function refill_lexbuf in
+  Location.init lb "//toplevel//";
+  Location.input_name := "//toplevel//";
+  Location.input_lexbuf := Some lb;
+  Sys.catch_break true;
+  load_ocamlinit ppf;
+  while true do
+    let snap = Btype.snapshot () in
+    try
+      Lexing.flush_input lb;
+      Location.reset();
+      first_line := true;
+      let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
+      let phr = preprocess_phrase ppf phr  in
+      Env.reset_cache_toplevel ();
+      if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+      ignore(execute_phrase true ppf phr)
+    with
+    | End_of_file -> exit 0
+    | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
+    | PPerror -> ()
+    | x -> Location.report_exception ppf x; Btype.backtrack snap
+  done
+
+(* Execute a script.  If [name] is "", read the script from stdin. *)
+
+let override_sys_argv args =
+  let len = Array.length args in
+  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
+  Array.blit args 0 Sys.argv 0 len;
+  Obj.truncate (Obj.repr Sys.argv) len;
+  Arg.current := 0
+
+let run_script ppf name args =
+  let len = Array.length args in
+  if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
+  Array.blit args 0 Sys.argv 0 len;
+  Obj.truncate (Obj.repr Sys.argv) len;
+  Arg.current := 0;
+  Compmisc.init_path ~dir:(Filename.dirname name) true;
+                   (* Note: would use [Filename.abspath] here, if we had it. *)
+  toplevel_env := Compmisc.initial_env();
+  Sys.interactive := false;
+  let explicit_name =
+    (* Prevent use_silently from searching in the path. *)
+    if Filename.is_implicit name
+    then Filename.concat Filename.current_dir_name name
+    else name
+  in
+  use_silently ppf explicit_name
diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
new file mode 100644
index 00000000..f234b4f4
--- /dev/null
+++ b/toplevel/opttoploop.mli
@@ -0,0 +1,132 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+(* Set the load paths, before running anything *)
+
+val set_paths : unit -> unit
+
+(* The interactive toplevel loop *)
+
+val loop : formatter -> unit
+
+(* Read and execute a script from the given file *)
+
+val run_script : formatter -> string -> string array -> bool
+        (* true if successful, false if error *)
+
+(* Interface with toplevel directives *)
+
+type directive_fun =
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
+
+val directive_table : (string, directive_fun) Hashtbl.t
+        (* Table of known directives, with their execution function *)
+val toplevel_env : Env.t ref
+        (* Typing environment for the toplevel *)
+val initialize_toplevel_env : unit -> unit
+        (* Initialize the typing environment for the toplevel *)
+val print_exception_outcome : formatter -> exn -> unit
+        (* Print an exception resulting from the evaluation of user code. *)
+val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool
+        (* Execute the given toplevel phrase. Return [true] if the
+           phrase executed with no errors and [false] otherwise.
+           First bool says whether the values and types of the results
+           should be printed. Uncaught exceptions are always printed. *)
+val preprocess_phrase :
+      formatter -> Parsetree.toplevel_phrase ->  Parsetree.toplevel_phrase
+        (* Preprocess the given toplevel phrase using regular and ppx
+           preprocessors. Return the updated phrase. *)
+val use_file : formatter -> string -> bool
+val use_silently : formatter -> string -> bool
+val mod_use_file : formatter -> string -> bool
+        (* Read and execute commands from a file.
+           [use_file] prints the types and values of the results.
+           [use_silently] does not print them.
+           [mod_use_file] wrap the file contents into a module. *)
+val eval_path: Env.t -> Path.t -> Obj.t
+        (* Return the toplevel object referred to by the given path *)
+
+(* Printing of values *)
+
+val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit
+val print_untyped_exception: formatter -> Obj.t -> unit
+
+type ('a, 'b) gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
+val install_printer :
+  Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit
+val install_generic_printer :
+  Path.t -> Path.t ->
+  (int -> (int -> Obj.t -> Outcometree.out_value,
+           Obj.t -> Outcometree.out_value) gen_printer) -> unit
+val install_generic_printer' :
+  Path.t -> Path.t -> (formatter -> Obj.t -> unit,
+                       formatter -> Obj.t -> unit) gen_printer -> unit
+val remove_printer : Path.t -> unit
+
+val max_printer_depth: int ref
+val max_printer_steps: int ref
+
+(* Hooks for external parsers and printers *)
+
+val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
+val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
+val print_location : formatter -> Location.t -> unit
+val print_error : formatter -> Location.t -> unit
+val print_warning : Location.t -> formatter -> Warnings.t -> unit
+val input_name : string ref
+
+val print_out_value :
+  (formatter -> Outcometree.out_value -> unit) ref
+val print_out_type :
+  (formatter -> Outcometree.out_type -> unit) ref
+val print_out_class_type :
+  (formatter -> Outcometree.out_class_type -> unit) ref
+val print_out_module_type :
+  (formatter -> Outcometree.out_module_type -> unit) ref
+val print_out_type_extension :
+  (formatter -> Outcometree.out_type_extension -> unit) ref
+val print_out_sig_item :
+  (formatter -> Outcometree.out_sig_item -> unit) ref
+val print_out_signature :
+  (formatter -> Outcometree.out_sig_item list -> unit) ref
+val print_out_phrase :
+  (formatter -> Outcometree.out_phrase -> unit) ref
+
+(* Hooks for external line editor *)
+
+val read_interactive_input : (string -> bytes -> int -> int * bool) ref
+
+(* Hooks for initialization *)
+
+val toplevel_startup_hook : (unit -> unit) ref
+
+(* Misc *)
+
+val override_sys_argv : string array -> unit
+(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
+   and reset [Arg.current] to [0].
+
+   This is called by [run_script] so that [Sys.argv] represents
+   "script.ml args..." instead of the full command line:
+   "ocamlrun unix.cma ... script.ml args...". *)
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
new file mode 100644
index 00000000..96d22185
--- /dev/null
+++ b/toplevel/opttopmain.ml
@@ -0,0 +1,255 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Clflags
+
+let usage =
+   "Usage: ocamlnat   [script-file]\noptions are:"
+
+let preload_objects = ref []
+
+(* Position of the first non expanded argument *)
+let first_nonexpanded_pos = ref 0
+
+let current = ref (!Arg.current)
+
+let argv = ref Sys.argv
+
+(* Test whether the option is part of a responsefile *)
+let is_expanded pos = pos < !first_nonexpanded_pos
+
+let expand_position pos len =
+  if pos < !first_nonexpanded_pos then
+    first_nonexpanded_pos := !first_nonexpanded_pos + len (* Shift the position *)
+  else
+    first_nonexpanded_pos :=  pos + len + 2 (* New last position *)
+
+
+let prepare ppf =
+  Opttoploop.set_paths ();
+  try
+    let res =
+      List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects)
+    in
+    !Opttoploop.toplevel_startup_hook ();
+    res
+  with x ->
+    try Location.report_exception ppf x; false
+    with x ->
+      Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
+      false
+
+let file_argument name =
+  let ppf = Format.err_formatter in
+  if Filename.check_suffix name ".cmxs"
+    || Filename.check_suffix name ".cmx"
+    || Filename.check_suffix name ".cmxa"
+  then preload_objects := name :: !preload_objects
+  else if is_expanded !current then begin
+    (* Script files are not allowed in expand options because otherwise the
+       check in override arguments may fail since the new argv can be larger
+       than the original argv.
+    *)
+    Printf.eprintf "For implementation reasons, the toplevel does not support\
+    \ having script files (here %S) inside expanded arguments passed through the\
+    \ -args{,0} command-line option.\n" name;
+    exit 2
+  end else begin
+    let newargs = Array.sub !argv !Arg.current
+                              (Array.length !argv - !Arg.current)
+      in
+      if prepare ppf && Opttoploop.run_script ppf name newargs
+      then exit 0
+      else exit 2
+    end
+
+let print_version () =
+  Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
+  exit 0;
+;;
+
+let print_version_num () =
+  Printf.printf "%s\n" Sys.ocaml_version;
+  exit 0;
+;;
+
+let wrap_expand f s =
+  let start = !current in
+  let arr = f s in
+  expand_position start (Array.length arr);
+  arr
+
+module Options = Main_args.Make_opttop_options (struct
+  let set r () = r := true
+  let clear r () = r := false
+
+  let _absname = set Location.absname
+  let _compact = clear optimize_for_speed
+  let _I dir =
+    let dir = Misc.expand_directory Config.standard_library dir in
+    include_dirs := dir :: !include_dirs
+  let _init s = init_file := Some s
+  let _noinit = set noinit
+  let _clambda_checks () = clambda_checks := true
+  let _inline spec =
+    Float_arg_helper.parse spec
+      "Syntax: -inline  | =[,...]"
+      inline_threshold
+  let _inline_indirect_cost spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-indirect-cost  | =[,...]"
+      inline_indirect_cost
+  let _inline_toplevel spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-toplevel  | =[,...]"
+      inline_toplevel_threshold
+  let _inlining_report () = inlining_report := true
+  let _dump_pass pass = set_dumped_pass pass true
+  let _rounds n = simplify_rounds := Some n
+  let _inline_max_unroll spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-unroll  | =[,...]"
+      inline_max_unroll
+  let _classic_inlining () = classic_inlining := true
+  let _inline_call_cost spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-call-cost  | =[,...]"
+       inline_call_cost
+  let _inline_alloc_cost spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-alloc-cost  | =[,...]"
+      inline_alloc_cost
+  let _inline_prim_cost spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-prim-cost  | =[,...]"
+       inline_prim_cost
+  let _inline_branch_cost spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-branch-cost  | =[,...]"
+      inline_branch_cost
+  let _inline_lifting_benefit spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-lifting-benefit  | =[,...]"
+      inline_lifting_benefit
+  let _inline_branch_factor spec =
+    Float_arg_helper.parse spec
+      "Syntax: -inline-branch-factor  | =[,...]"
+      inline_branch_factor
+  let _inline_max_depth spec =
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-depth  | =[,...]"
+      inline_max_depth
+  let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures
+  let _no_unbox_specialised_args = clear unbox_specialised_args
+  let _o s = output_name := Some s
+  let _o2 () =
+    default_simplify_rounds := 2;
+    use_inlining_arguments_set o2_arguments;
+    use_inlining_arguments_set ~round:0 o1_arguments
+  let _o3 () =
+    default_simplify_rounds := 3;
+    use_inlining_arguments_set o3_arguments;
+    use_inlining_arguments_set ~round:1 o2_arguments;
+    use_inlining_arguments_set ~round:0 o1_arguments
+  let _remove_unused_arguments = set remove_unused_arguments
+  let _unbox_closures = set unbox_closures
+  let _unbox_closures_factor f = unbox_closures_factor := f
+  let _drawclambda = set dump_rawclambda
+  let _dclambda = set dump_clambda
+  let _drawflambda = set dump_rawflambda
+  let _dflambda = set dump_flambda
+  let _dflambda_let stamp = dump_flambda_let := Some stamp
+  let _dflambda_verbose () =
+    set dump_flambda ();
+    set dump_flambda_verbose ()
+  let _dflambda_no_invariants = clear flambda_invariant_checks
+  let _labels = clear classic
+  let _alias_deps = clear transparent_modules
+  let _no_alias_deps = set transparent_modules
+  let _app_funct = set applicative_functors
+  let _no_app_funct = clear applicative_functors
+  let _noassert = set noassert
+  let _nolabels = set classic
+  let _noprompt = set noprompt
+  let _nopromptcont = set nopromptcont
+  let _nostdlib = set no_std_include
+  let _ppx s = Compenv.first_ppx := s :: !Compenv.first_ppx
+  let _principal = set principal
+  let _no_principal = clear principal
+  let _real_paths = set real_paths
+  let _rectypes = set recursive_types
+  let _no_rectypes = clear recursive_types
+  let _strict_sequence = set strict_sequence
+  let _no_strict_sequence = clear strict_sequence
+  let _strict_formats = set strict_formats
+  let _no_strict_formats = clear strict_formats
+  let _S = set keep_asm_file
+  let _short_paths = clear real_paths
+  let _stdin () = file_argument ""
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
+  let _unsafe = set fast
+  let _verbose = set verbose
+  let _version () = print_version ()
+  let _vnum () = print_version_num ()
+  let _no_version = set noversion
+  let _w s = Warnings.parse_options false s
+  let _warn_error s = Warnings.parse_options true s
+  let _warn_help = Warnings.help_warnings
+
+  let _dsource = set dump_source
+  let _dparsetree = set dump_parsetree
+  let _dtypedtree = set dump_typedtree
+  let _drawlambda = set dump_rawlambda
+  let _dlambda = set dump_lambda
+  let _drawclambda = set dump_rawclambda
+  let _dclambda = set dump_clambda
+  let _dcmm = set dump_cmm
+  let _dsel = set dump_selection
+  let _dcombine = set dump_combine
+  let _dcse = set dump_cse
+  let _dlive () = dump_live := true; Printmach.print_live := true
+  let _dspill = set dump_spill
+  let _dsplit = set dump_split
+  let _dinterf = set dump_interf
+  let _dprefer = set dump_prefer
+  let _dalloc = set dump_regalloc
+  let _dreload = set dump_reload
+  let _dscheduling = set dump_scheduling
+  let _dlinear = set dump_linear
+  let _dstartup = set keep_startup_file
+  let _safe_string = clear unsafe_string
+  let _unsafe_string = set unsafe_string
+  let _open s = open_modules := s :: !open_modules
+  let _plugin p = Compplugin.load p
+
+  let _args = wrap_expand Arg.read_arg
+  let _args0 = wrap_expand Arg.read_arg0
+
+  let anonymous = file_argument
+end);;
+
+let main () =
+  native_code := true;
+  let list = ref Options.list in
+  begin
+    try
+      Arg.parse_and_expand_argv_dynamic current argv list file_argument usage;
+    with
+    | Arg.Bad msg -> Format.fprintf Format.err_formatter "%s%!" msg; exit 2
+    | Arg.Help msg -> Format.fprintf Format.std_formatter "%s%!" msg; exit 0
+  end;
+  if not (prepare Format.err_formatter) then exit 2;
+  Opttoploop.loop Format.std_formatter
diff --git a/toplevel/opttopmain.mli b/toplevel/opttopmain.mli
new file mode 100644
index 00000000..93fea4c7
--- /dev/null
+++ b/toplevel/opttopmain.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Start the [ocaml] toplevel loop *)
+
+val main: unit -> unit
diff --git a/toplevel/opttopstart.ml b/toplevel/opttopstart.ml
new file mode 100644
index 00000000..a8127208
--- /dev/null
+++ b/toplevel/opttopstart.ml
@@ -0,0 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let _ = Opttopmain.main()
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
new file mode 100644
index 00000000..a28ee990
--- /dev/null
+++ b/toplevel/topdirs.ml
@@ -0,0 +1,774 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Toplevel directives *)
+
+open Format
+open Misc
+open Longident
+open Types
+open Cmo_format
+open Trace
+open Toploop
+
+(* The standard output formatter *)
+let std_out = std_formatter
+
+(* Directive sections (used in #help) *)
+let section_general = "General"
+let section_run = "Loading code"
+let section_env = "Environment queries"
+
+let section_print = "Pretty-printing"
+let section_trace = "Tracing"
+let section_options = "Compiler options"
+
+let section_undocumented = "Undocumented"
+
+(* we will print the sections in the first list,
+   then all user-defined sections,
+   then the sections in the second list,
+   then all undocumented directives *)
+let order_of_sections =
+  ([
+    section_general;
+    section_run;
+    section_env;
+  ], [
+    section_print;
+    section_trace;
+    section_options;
+
+    section_undocumented;
+  ])
+(* Do not forget to keep the directives synchronized with the manual in
+   manual/manual/cmds/top.etex *)
+
+(* To quit *)
+
+let dir_quit () = exit 0
+
+let _ = add_directive "quit" (Directive_none dir_quit)
+    {
+      section = section_general;
+      doc = "Exit the toplevel.";
+    }
+
+(* To add a directory to the load path *)
+
+let dir_directory s =
+  let d = expand_directory Config.standard_library s in
+  Config.load_path := d :: !Config.load_path;
+  Dll.add_path [d]
+
+let _ = add_directive "directory" (Directive_string dir_directory)
+    {
+      section = section_run;
+      doc = "Add the given directory to search path for source and compiled \
+             files.";
+    }
+
+(* To remove a directory from the load path *)
+let dir_remove_directory s =
+  let d = expand_directory Config.standard_library s in
+  Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path;
+  Dll.remove_path [d]
+
+let _ = add_directive "remove_directory" (Directive_string dir_remove_directory)
+    {
+      section = section_run;
+      doc = "Remove the given directory from the search path.";
+    }
+(* To change the current directory *)
+
+let dir_cd s = Sys.chdir s
+
+let _ = add_directive "cd" (Directive_string dir_cd)
+    {
+      section = section_run;
+      doc = "Change the current working directory.";
+    }
+(* Load in-core a .cmo file *)
+
+exception Load_failed
+
+let check_consistency ppf filename cu =
+  try
+    List.iter
+      (fun (name, crco) ->
+       Env.add_import name;
+       match crco with
+         None -> ()
+       | Some crc->
+           Consistbl.check Env.crc_units name crc filename)
+      cu.cu_imports
+  with Consistbl.Inconsistency(name, user, auth) ->
+    fprintf ppf "@[The files %s@ and %s@ \
+                 disagree over interface %s@]@."
+            user auth name;
+    raise Load_failed
+
+let load_compunit ic filename ppf compunit =
+  check_consistency ppf filename compunit;
+  seek_in ic compunit.cu_pos;
+  let code_size = compunit.cu_codesize + 8 in
+  let code = Meta.static_alloc code_size in
+  unsafe_really_input ic code 0 compunit.cu_codesize;
+  Bytes.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
+  String.unsafe_blit "\000\000\000\001\000\000\000" 0
+                     code (compunit.cu_codesize + 1) 7;
+  let initial_symtable = Symtable.current_state() in
+  Symtable.patch_object code compunit.cu_reloc;
+  Symtable.update_global_table();
+  let events =
+    if compunit.cu_debug = 0 then [| |]
+    else begin
+      seek_in ic compunit.cu_debug;
+      [| input_value ic |]
+    end in
+  Meta.add_debug_info code code_size events;
+  begin try
+    may_trace := true;
+    ignore((Meta.reify_bytecode code code_size) ());
+    may_trace := false;
+  with exn ->
+    record_backtrace ();
+    may_trace := false;
+    Symtable.restore_state initial_symtable;
+    print_exception_outcome ppf exn;
+    raise Load_failed
+  end
+
+let rec load_file recursive ppf name =
+  let filename =
+    try Some (find_in_path !Config.load_path name) with Not_found -> None
+  in
+  match filename with
+  | None -> fprintf ppf "Cannot find file %s.@." name; false
+  | Some filename ->
+      let ic = open_in_bin filename in
+      try
+        let success = really_load_file recursive ppf name filename ic in
+        close_in ic;
+        success
+      with exn ->
+        close_in ic;
+        raise exn
+
+and really_load_file recursive ppf name filename ic =
+  let buffer = really_input_string ic (String.length Config.cmo_magic_number) in
+  try
+    if buffer = Config.cmo_magic_number then begin
+      let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
+      seek_in ic compunit_pos;
+      let cu : compilation_unit = input_value ic in
+      if recursive then
+        List.iter
+          (function
+            | (Reloc_getglobal id, _)
+              when not (Symtable.is_global_defined id) ->
+                let file = Ident.name id ^ ".cmo" in
+                begin match try Some (Misc.find_in_path_uncap !Config.load_path
+                                        file)
+                      with Not_found -> None
+                with
+                | None -> ()
+                | Some file ->
+                    if not (load_file recursive ppf file) then raise Load_failed
+                end
+            | _ -> ()
+          )
+          cu.cu_reloc;
+      load_compunit ic filename ppf cu;
+      true
+    end else
+      if buffer = Config.cma_magic_number then begin
+        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
+        List.iter
+          (fun dllib ->
+            let name = Dll.extract_dll_name dllib in
+            try Dll.open_dlls Dll.For_execution [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
+        fprintf ppf "File %s is not a bytecode object file.@." name;
+        false
+      end
+  with Load_failed -> false
+
+let dir_load ppf name = ignore (load_file false ppf name)
+
+let _ = add_directive "load" (Directive_string (dir_load std_out))
+    {
+      section = section_run;
+      doc = "Load in memory a bytecode object, produced by ocamlc.";
+    }
+
+let dir_load_rec ppf name = ignore (load_file true ppf name)
+
+let _ = add_directive "load_rec"
+    (Directive_string (dir_load_rec std_out))
+    {
+      section = section_run;
+      doc = "As #load, but loads dependencies recursively.";
+    }
+
+let load_file = load_file false
+
+(* Load commands from a file *)
+
+let dir_use ppf name = ignore(Toploop.use_file ppf name)
+let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name)
+
+let _ = add_directive "use" (Directive_string (dir_use std_out))
+    {
+      section = section_run;
+      doc = "Read, compile and execute source phrases from the given file.";
+    }
+
+let _ = add_directive "mod_use" (Directive_string (dir_mod_use std_out))
+    {
+      section = section_run;
+      doc = "Usage is identical to #use but #mod_use \
+             wraps the contents in a module.";
+    }
+
+
+(* Install, remove a printer *)
+
+let filter_arrow ty =
+  let ty = Ctype.expand_head !toplevel_env ty in
+  match ty.desc with
+  | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> Some (l, r)
+  | _ -> None
+
+let rec extract_last_arrow desc =
+  match filter_arrow desc with
+  | None -> raise (Ctype.Unify [])
+  | Some (_, r as res) ->
+      try extract_last_arrow r
+      with Ctype.Unify _ -> res
+
+let extract_target_type ty = fst (extract_last_arrow ty)
+let extract_target_parameters ty =
+  let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in
+  match ty.desc with
+  | Tconstr (path, (_ :: _ as args), _)
+      when Ctype.all_distinct_vars !toplevel_env args -> Some (path, args)
+  | _ -> None
+
+type 'a printer_type_new = Format.formatter -> 'a -> unit
+type 'a printer_type_old = 'a -> unit
+
+let printer_type ppf typename =
+  let printer_type =
+    try
+      Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env
+    with Not_found ->
+      fprintf ppf "Cannot find type Topdirs.%s.@." typename;
+      raise Exit in
+  printer_type
+
+let match_simple_printer_type desc printer_type =
+  Ctype.begin_def();
+  let ty_arg = Ctype.newvar() in
+  Ctype.unify !toplevel_env
+    (Ctype.newconstr printer_type [ty_arg])
+    (Ctype.instance_def desc.val_type);
+  Ctype.end_def();
+  Ctype.generalize ty_arg;
+  (ty_arg, None)
+
+let match_generic_printer_type desc path args printer_type =
+  Ctype.begin_def();
+  let args = List.map (fun _ -> Ctype.newvar ()) args in
+  let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in
+  let ty_args =
+    List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in
+  let ty_expected =
+    List.fold_right
+      (fun ty_arg ty -> Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty,
+                                             Cunknown)))
+      ty_args (Ctype.newconstr printer_type [ty_target]) in
+  Ctype.unify !toplevel_env
+    ty_expected
+    (Ctype.instance_def desc.val_type);
+  Ctype.end_def();
+  Ctype.generalize ty_expected;
+  if not (Ctype.all_distinct_vars !toplevel_env args) then
+    raise (Ctype.Unify []);
+  (ty_expected, Some (path, ty_args))
+
+let match_printer_type ppf desc =
+  let printer_type_new = printer_type ppf "printer_type_new" in
+  let printer_type_old = printer_type ppf "printer_type_old" in
+  Ctype.init_def(Ident.current_time());
+  try
+    (match_simple_printer_type desc printer_type_new, false)
+  with Ctype.Unify _ ->
+    try
+      (match_simple_printer_type desc printer_type_old, true)
+    with Ctype.Unify _ as exn ->
+      match extract_target_parameters desc.val_type with
+      | None -> raise exn
+      | Some (path, args) ->
+          (match_generic_printer_type desc path args printer_type_new,
+           false)
+
+let find_printer_type ppf lid =
+  try
+    let (path, desc) = Env.lookup_value lid !toplevel_env in
+    let (ty_arg, is_old_style) = match_printer_type ppf desc in
+    (ty_arg, path, is_old_style)
+  with
+  | Not_found ->
+      fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
+      raise Exit
+  | Ctype.Unify _ ->
+      fprintf ppf "%a has a wrong type for a printing function.@."
+      Printtyp.longident lid;
+      raise Exit
+
+let dir_install_printer ppf lid =
+  try
+    let ((ty_arg, ty), path, is_old_style) =
+      find_printer_type ppf lid in
+    let v = eval_path !toplevel_env path in
+    match ty with
+    | None ->
+       let print_function =
+         if is_old_style then
+           (fun _formatter repr -> Obj.obj v (Obj.obj repr))
+         else
+           (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
+       install_printer path ty_arg print_function
+    | Some (ty_path, ty_args) ->
+       let rec build v = function
+         | [] ->
+            let print_function =
+              if is_old_style then
+                (fun _formatter repr -> Obj.obj v (Obj.obj repr))
+              else
+                (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
+            Zero print_function
+         | _ :: args ->
+            Succ
+              (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) in
+       install_generic_printer' path ty_path (build v ty_args)
+  with Exit -> ()
+
+let dir_remove_printer ppf lid =
+  try
+    let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
+    begin try
+      remove_printer path
+    with Not_found ->
+      fprintf ppf "No printer named %a.@." Printtyp.longident lid
+    end
+  with Exit -> ()
+
+let _ = add_directive "install_printer"
+    (Directive_ident (dir_install_printer std_out))
+    {
+      section = section_print;
+      doc = "Registers a printer for values of a certain type.";
+    }
+
+let _ = add_directive "remove_printer"
+    (Directive_ident (dir_remove_printer std_out))
+    {
+      section = section_print;
+      doc = "Remove the named function from the table of toplevel printers.";
+    }
+
+(* The trace *)
+
+external current_environment: unit -> Obj.t = "caml_get_current_environment"
+
+let tracing_function_ptr =
+  get_code_pointer
+    (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
+
+let dir_trace ppf lid =
+  try
+    let (path, desc) = Env.lookup_value lid !toplevel_env in
+    (* Check if this is a primitive *)
+    match desc.val_kind with
+    | Val_prim _ ->
+        fprintf ppf "%a is an external function and cannot be traced.@."
+        Printtyp.longident lid
+    | _ ->
+        let clos = eval_path !toplevel_env path in
+        (* Nothing to do if it's not a closure *)
+        if Obj.is_block clos
+        && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
+        && (match Ctype.(repr (expand_head !toplevel_env desc.val_type))
+            with {desc=Tarrow _} -> true | _ -> false)
+        then begin
+        match is_traced clos with
+        | Some opath ->
+            fprintf ppf "%a is already traced (under the name %a).@."
+            Printtyp.path path
+            Printtyp.path opath
+        | None ->
+            (* Instrument the old closure *)
+            traced_functions :=
+              { path = path;
+                closure = clos;
+                actual_code = get_code_pointer clos;
+                instrumented_fun =
+                  instrument_closure !toplevel_env lid ppf desc.val_type }
+              :: !traced_functions;
+            (* Redirect the code field of the closure to point
+               to the instrumentation function *)
+            set_code_pointer clos tracing_function_ptr;
+            fprintf ppf "%a is now traced.@." Printtyp.longident lid
+        end else fprintf ppf "%a is not a function.@." Printtyp.longident lid
+  with
+  | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
+
+let dir_untrace ppf lid =
+  try
+    let (path, _desc) = Env.lookup_value lid !toplevel_env in
+    let rec remove = function
+    | [] ->
+        fprintf ppf "%a was not traced.@." Printtyp.longident lid;
+        []
+    | f :: rem ->
+        if Path.same f.path path then begin
+          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
+    traced_functions := remove !traced_functions
+  with
+  | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
+
+let dir_untrace_all ppf () =
+  List.iter
+    (fun f ->
+      set_code_pointer f.closure f.actual_code;
+      fprintf ppf "%a is no longer traced.@." Printtyp.path f.path)
+    !traced_functions;
+  traced_functions := []
+
+let parse_warnings ppf iserr s =
+  try Warnings.parse_options iserr s
+  with Arg.Bad err -> fprintf ppf "%s.@." err
+
+(* Typing information *)
+
+let trim_signature = function
+    Mty_signature sg ->
+      Mty_signature
+        (List.map
+           (function
+               Sig_module (id, md, rs) ->
+                 Sig_module (id, {md with md_attributes =
+                                    (Location.mknoloc "...", Parsetree.PStr [])
+                                    :: md.md_attributes},
+                             rs)
+             (*| Sig_modtype (id, Modtype_manifest mty) ->
+                 Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)
+             | item -> item)
+           sg)
+  | mty -> mty
+
+let show_prim to_sig ppf lid =
+  let env = !Toploop.toplevel_env in
+  let loc = Location.none in
+  try
+    let s =
+      match lid with
+      | Longident.Lident s -> s
+      | Longident.Ldot (_,s) -> s
+      | Longident.Lapply _ ->
+          fprintf ppf "Invalid path %a@." Printtyp.longident lid;
+          raise Exit
+    in
+    let id = Ident.create_persistent s in
+    let sg = to_sig env loc id lid in
+    Printtyp.wrap_printing_env env
+      (fun () -> fprintf ppf "@[%a@]@." Printtyp.signature sg)
+  with
+  | Not_found ->
+      fprintf ppf "@[Unknown element.@]@."
+  | Exit -> ()
+
+let all_show_funs = ref []
+
+let reg_show_prim name to_sig doc =
+  all_show_funs := to_sig :: !all_show_funs;
+  add_directive
+    name
+    (Directive_ident (show_prim to_sig std_out))
+    {
+      section = section_env;
+      doc;
+    }
+
+let () =
+  reg_show_prim "show_val"
+    (fun env loc id lid ->
+       let _path, desc = Typetexp.find_value env loc lid in
+       [ Sig_value (id, desc) ]
+    )
+    "Print the signature of the corresponding value."
+
+let () =
+  reg_show_prim "show_type"
+    (fun env loc id lid ->
+       let _path, desc = Typetexp.find_type env loc lid in
+       [ Sig_type (id, desc, Trec_not) ]
+    )
+    "Print the signature of the corresponding type constructor."
+
+let () =
+  reg_show_prim "show_exception"
+    (fun env loc id lid ->
+       let desc = Typetexp.find_constructor env loc lid in
+       if not (Ctype.equal env true [desc.cstr_res] [Predef.type_exn]) then
+         raise Not_found;
+       let ret_type =
+         if desc.cstr_generalized then Some Predef.type_exn
+         else None
+       in
+       let ext =
+         { ext_type_path = Predef.path_exn;
+           ext_type_params = [];
+           ext_args = Cstr_tuple desc.cstr_args;
+           ext_ret_type = ret_type;
+           ext_private = Asttypes.Public;
+           Types.ext_loc = desc.cstr_loc;
+           Types.ext_attributes = desc.cstr_attributes; }
+       in
+         [Sig_typext (id, ext, Text_exception)]
+    )
+    "Print the signature of the corresponding exception."
+
+let () =
+  reg_show_prim "show_module"
+    (fun env loc id lid ->
+       let rec accum_aliases path acc =
+         let md = Env.find_module path env in
+         let acc =
+           Sig_module (id, {md with md_type = trim_signature md.md_type},
+                       Trec_not) :: acc in
+         match md.md_type with
+         | Mty_alias(_, path) -> accum_aliases path acc
+         | Mty_ident _ | Mty_signature _ | Mty_functor _ ->
+             List.rev acc
+       in
+       let path, _ = Typetexp.find_module env loc lid in
+       accum_aliases path []
+    )
+    "Print the signature of the corresponding module."
+
+let () =
+  reg_show_prim "show_module_type"
+    (fun env loc id lid ->
+       let _path, desc = Typetexp.find_modtype env loc lid in
+       [ Sig_modtype (id, desc) ]
+    )
+    "Print the signature of the corresponding module type."
+
+let () =
+  reg_show_prim "show_class"
+    (fun env loc id lid ->
+       let _path, desc = Typetexp.find_class env loc lid in
+       [ Sig_class (id, desc, Trec_not) ]
+    )
+    "Print the signature of the corresponding class."
+
+let () =
+  reg_show_prim "show_class_type"
+    (fun env loc id lid ->
+       let _path, desc = Typetexp.find_class_type env loc lid in
+       [ Sig_class_type (id, desc, Trec_not) ]
+    )
+    "Print the signature of the corresponding class type."
+
+let show env loc id lid =
+  let sg =
+    List.fold_left
+      (fun sg f -> try (f env loc id lid) @ sg with _ -> sg)
+      [] !all_show_funs
+  in
+  if sg = [] then raise Not_found else sg
+
+let () =
+  add_directive "show" (Directive_ident (show_prim show std_out))
+    {
+      section = section_env;
+      doc = "Print the signatures of components \
+             from any of the above categories.";
+    }
+
+let _ = add_directive "trace"
+    (Directive_ident (dir_trace std_out))
+    {
+      section = section_trace;
+      doc = "All calls to the function \
+          named function-name will be traced.";
+    }
+
+let _ = add_directive "untrace"
+    (Directive_ident (dir_untrace std_out))
+    {
+      section = section_trace;
+      doc = "Stop tracing the given function.";
+    }
+
+let _ = add_directive "untrace_all"
+    (Directive_none (dir_untrace_all std_out))
+    {
+      section = section_trace;
+      doc = "Stop tracing all functions traced so far.";
+    }
+
+(* Control the printing of values *)
+
+let _ = add_directive "print_depth"
+    (Directive_int(fun n -> max_printer_depth := n))
+    {
+      section = section_print;
+      doc = "Limit the printing of values to a maximal depth of n.";
+    }
+
+let _ = add_directive "print_length"
+    (Directive_int(fun n -> max_printer_steps := n))
+    {
+      section = section_print;
+      doc = "Limit the number of value nodes printed to at most n.";
+    }
+
+(* Set various compiler flags *)
+
+let _ = add_directive "labels"
+    (Directive_bool(fun b -> Clflags.classic := not b))
+    {
+      section = section_options;
+      doc = "Choose whether to ignore labels in function types.";
+    }
+
+let _ = add_directive "principal"
+    (Directive_bool(fun b -> Clflags.principal := b))
+    {
+      section = section_options;
+      doc = "Make sure that all types are derived in a principal way.";
+    }
+
+let _ = add_directive "rectypes"
+    (Directive_none(fun () -> Clflags.recursive_types := true))
+    {
+      section = section_options;
+      doc = "Allow arbitrary recursive types during type-checking.";
+    }
+
+let _ = add_directive "ppx"
+    (Directive_string(fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx))
+    {
+      section = section_options;
+      doc = "After parsing, pipe the abstract \
+          syntax tree through the preprocessor command.";
+    }
+
+let _ = add_directive "warnings"
+    (Directive_string (parse_warnings std_out false))
+    {
+      section = section_options;
+      doc = "Enable or disable warnings according to the argument.";
+    }
+
+let _ = add_directive "warn_error"
+    (Directive_string (parse_warnings std_out true))
+    {
+      section = section_options;
+      doc = "Treat as errors the warnings enabled by the argument.";
+    }
+
+(* #help directive *)
+
+let directive_sections () =
+  let sections = Hashtbl.create 10 in
+  let add_dir name dir =
+    let section, doc =
+      match Hashtbl.find directive_info_table name with
+      | { section; doc } -> section, Some doc
+      | exception Not_found -> "Undocumented", None
+    in
+    Hashtbl.replace sections section
+      ((name, dir, doc)
+       :: (try Hashtbl.find sections section with Not_found -> []))
+  in
+  Hashtbl.iter add_dir directive_table;
+  let take_section section =
+    if not (Hashtbl.mem sections section) then (section, [])
+    else begin
+      let section_dirs =
+        Hashtbl.find sections section
+        |> List.sort (fun (n1, _, _) (n2, _, _) -> String.compare n1 n2) in
+      Hashtbl.remove sections section;
+      (section, section_dirs)
+    end
+  in
+  let before, after = order_of_sections in
+  let sections_before = List.map take_section before in
+  let sections_after = List.map take_section after in
+  let sections_user =
+    Hashtbl.fold (fun section _ acc -> section::acc) sections []
+    |> List.sort String.compare
+    |> List.map take_section in
+  sections_before @ sections_user @ sections_after
+
+let print_directive ppf (name, directive, doc) =
+  let param = match directive with
+    | Directive_none _ -> ""
+    | Directive_string _ -> " "
+    | Directive_int _ -> " "
+    | Directive_bool _ -> " "
+    | Directive_ident _ -> " " in
+  match doc with
+  | None -> fprintf ppf "#%s%s@." name param
+  | Some doc ->
+      fprintf ppf "@[#%s%s@\n%a@]@."
+        name param
+        Format.pp_print_text doc
+
+let print_section ppf (section, directives) =
+  if directives <> [] then begin
+    fprintf ppf "%30s%s@." "" section;
+    List.iter (print_directive ppf) directives;
+    fprintf ppf "@.";
+  end
+
+let print_directives ppf () =
+  List.iter (print_section ppf) (directive_sections ())
+
+let _ = add_directive "help"
+    (Directive_none (print_directives std_out))
+    {
+      section = section_general;
+      doc = "Prints a list of all available directives, with \
+          corresponding argument type if appropriate.";
+    }
diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli
new file mode 100644
index 00000000..1cdc2fa2
--- /dev/null
+++ b/toplevel/topdirs.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The toplevel directives. *)
+
+open Format
+
+val dir_quit : unit -> unit
+val dir_directory : string -> unit
+val dir_remove_directory : string -> unit
+val dir_cd : string -> unit
+val dir_load : formatter -> string -> unit
+val dir_use : formatter -> string -> unit
+val dir_install_printer : formatter -> Longident.t -> unit
+val dir_remove_printer : formatter -> Longident.t -> unit
+val dir_trace : formatter -> Longident.t -> unit
+val dir_untrace : formatter -> Longident.t -> unit
+val dir_untrace_all : formatter -> unit -> unit
+
+type 'a printer_type_new = Format.formatter -> 'a -> unit
+type 'a printer_type_old = 'a -> unit
+
+(* For topmain.ml. Maybe shouldn't be there *)
+val load_file : formatter -> string -> bool
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
new file mode 100644
index 00000000..e832fde5
--- /dev/null
+++ b/toplevel/toploop.ml
@@ -0,0 +1,571 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The interactive toplevel loop *)
+
+open Path
+open Format
+open Config
+open Misc
+open Parsetree
+open Types
+open Typedtree
+open Outcometree
+open Ast_helper
+
+type directive_fun =
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
+
+type directive_info = {
+  section: string;
+  doc: string;
+}
+
+(* The table of toplevel value bindings and its accessors *)
+
+module StringMap = Map.Make(String)
+
+let toplevel_value_bindings : Obj.t StringMap.t ref = ref StringMap.empty
+
+let getvalue name =
+  try
+    StringMap.find name !toplevel_value_bindings
+  with Not_found ->
+    fatal_error (name ^ " unbound at toplevel")
+
+let setvalue name v =
+  toplevel_value_bindings := StringMap.add name v !toplevel_value_bindings
+
+(* Return the value referred to by a path *)
+
+let rec eval_path = function
+  | Pident id ->
+      if Ident.persistent id || Ident.global id then
+        Symtable.get_global_value id
+      else begin
+        let name = Translmod.toplevel_name id in
+        try
+          StringMap.find name !toplevel_value_bindings
+        with Not_found ->
+          raise (Symtable.Error(Symtable.Undefined_global name))
+      end
+  | Pdot(p, _s, pos) ->
+      Obj.field (eval_path p) pos
+  | Papply _ ->
+      fatal_error "Toploop.eval_path"
+
+let eval_path env path =
+  eval_path (Env.normalize_path (Some Location.none) env path)
+
+(* To print values *)
+
+module EvalPath = struct
+  type valu = Obj.t
+  exception Error
+  let eval_path env p = try eval_path env p with Symtable.Error _ -> raise Error
+  let same_value v1 v2 = (v1 == v2)
+end
+
+module Printer = Genprintval.Make(Obj)(EvalPath)
+
+let max_printer_depth = ref 100
+let max_printer_steps = ref 300
+
+let print_out_value = Oprint.out_value
+let print_out_type = Oprint.out_type
+let print_out_class_type = Oprint.out_class_type
+let print_out_module_type = Oprint.out_module_type
+let print_out_type_extension = Oprint.out_type_extension
+let print_out_sig_item = Oprint.out_sig_item
+let print_out_signature = Oprint.out_signature
+let print_out_phrase = Oprint.out_phrase
+
+let print_untyped_exception ppf obj =
+  !print_out_value ppf (Printer.outval_of_untyped_exception obj)
+let outval_of_value env obj ty =
+  Printer.outval_of_value !max_printer_steps !max_printer_depth
+    (fun _ _ _ -> None) env obj ty
+let print_value env obj ppf ty =
+  !print_out_value ppf (outval_of_value env obj ty)
+
+type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
+let install_printer = Printer.install_printer
+let install_generic_printer = Printer.install_generic_printer
+let install_generic_printer' = Printer.install_generic_printer'
+let remove_printer = Printer.remove_printer
+
+(* Hooks for parsing functions *)
+
+let parse_toplevel_phrase = ref Parse.toplevel_phrase
+let parse_use_file = ref Parse.use_file
+let print_location = Location.print_error (* FIXME change back to print *)
+let print_error = Location.print_error
+let print_warning = Location.print_warning
+let input_name = Location.input_name
+
+let parse_mod_use_file name lb =
+  let modname =
+    String.capitalize_ascii (Filename.chop_extension (Filename.basename name))
+  in
+  let items =
+    List.concat
+      (List.map
+         (function Ptop_def s -> s | Ptop_dir _ -> [])
+         (!parse_use_file lb))
+  in
+  [ Ptop_def
+      [ Str.module_
+          (Mb.mk
+             (Location.mknoloc modname)
+             (Mod.structure items)
+          )
+       ]
+   ]
+
+(* Hooks for initialization *)
+
+let toplevel_startup_hook = ref (fun () -> ())
+
+(* Load in-core and execute a lambda term *)
+
+let may_trace = ref false (* Global lock on tracing *)
+type evaluation_outcome = Result of Obj.t | Exception of exn
+
+let backtrace = ref None
+
+let record_backtrace () =
+  if Printexc.backtrace_status ()
+  then backtrace := Some (Printexc.get_backtrace ())
+
+let load_lambda ppf lam =
+  if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
+  let slam = Simplif.simplify_lambda "//toplevel//" lam in
+  if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
+  let (init_code, fun_code) = Bytegen.compile_phrase slam in
+  if !Clflags.dump_instr then
+    fprintf ppf "%a%a@."
+    Printinstr.instrlist init_code
+    Printinstr.instrlist fun_code;
+  let (code, code_size, reloc, events) =
+    Emitcode.to_memory init_code fun_code
+  in
+  Meta.add_debug_info code code_size [| events |];
+  let can_free = (fun_code = []) in
+  let initial_symtable = Symtable.current_state() in
+  Symtable.patch_object code reloc;
+  Symtable.check_global_initialized reloc;
+  Symtable.update_global_table();
+  let initial_bindings = !toplevel_value_bindings in
+  try
+    may_trace := true;
+    let retval = (Meta.reify_bytecode code code_size) () in
+    may_trace := false;
+    if can_free then begin
+      Meta.remove_debug_info code;
+      Meta.static_release_bytecode code code_size;
+      Meta.static_free code;
+    end;
+    Result retval
+  with x ->
+    may_trace := false;
+    record_backtrace ();
+    if can_free then begin
+      Meta.remove_debug_info code;
+      Meta.static_release_bytecode code code_size;
+      Meta.static_free code;
+    end;
+    toplevel_value_bindings := initial_bindings; (* PR#6211 *)
+    Symtable.restore_state initial_symtable;
+    Exception x
+
+(* Print the outcome of an evaluation *)
+
+let pr_item =
+  Printtyp.print_items
+    (fun env -> function
+      | Sig_value(id, {val_kind = Val_reg; val_type}) ->
+          Some (outval_of_value env (getvalue (Translmod.toplevel_name id))
+                  val_type)
+      | _ -> None
+    )
+
+(* The current typing environment for the toplevel *)
+
+let toplevel_env = ref Env.empty
+
+(* Print an exception produced by an evaluation *)
+
+let print_out_exception ppf exn outv =
+  !print_out_phrase ppf (Ophr_exception (exn, outv))
+
+let print_exception_outcome ppf exn =
+  if exn = Out_of_memory then Gc.full_major ();
+  let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
+  print_out_exception ppf exn outv;
+  if Printexc.backtrace_status ()
+  then
+    match !backtrace with
+      | None -> ()
+      | Some b ->
+          print_string b;
+          backtrace := None
+
+
+(* Inserting new toplevel directives *)
+
+let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t)
+
+let directive_info_table =
+  (Hashtbl.create 23 : (string, directive_info) Hashtbl.t)
+
+let add_directive name dir_fun dir_info =
+  Hashtbl.add directive_table name dir_fun;
+  Hashtbl.add directive_info_table name dir_info
+
+(* Execute a toplevel phrase *)
+
+let execute_phrase print_outcome ppf phr =
+  match phr with
+  | Ptop_def sstr ->
+      let oldenv = !toplevel_env in
+      Typecore.reset_delayed_checks ();
+      let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
+      if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
+      let sg' = Typemod.simplify_signature sg in
+      ignore (Includemod.signatures oldenv sg sg');
+      Typecore.force_delayed_checks ();
+      let lam = Translmod.transl_toplevel_definition str in
+      Warnings.check_fatal ();
+      begin try
+        toplevel_env := newenv;
+        let res = load_lambda ppf lam in
+        let out_phr =
+          match res with
+          | Result v ->
+              if print_outcome then
+                Printtyp.wrap_printing_env oldenv (fun () ->
+                  match str.str_items with
+                  | [ { str_desc =
+                          (Tstr_eval (exp, _)
+                          |Tstr_value
+                              (Asttypes.Nonrecursive,
+                               [{vb_pat = {pat_desc=Tpat_any};
+                                 vb_expr = exp}
+                               ]
+                              )
+                          )
+                      }
+                    ] ->
+                      let outv = outval_of_value newenv v exp.exp_type in
+                      let ty = Printtyp.tree_of_type_scheme exp.exp_type in
+                      Ophr_eval (outv, ty)
+
+                  | [] -> Ophr_signature []
+                  | _ -> Ophr_signature (pr_item newenv sg'))
+              else Ophr_signature []
+          | Exception exn ->
+              toplevel_env := oldenv;
+              if exn = Out_of_memory then Gc.full_major();
+              let outv =
+                outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
+              in
+              Ophr_exception (exn, outv)
+        in
+        !print_out_phrase ppf out_phr;
+        if Printexc.backtrace_status ()
+        then begin
+          match !backtrace with
+            | None -> ()
+            | Some b ->
+                pp_print_string ppf b;
+                pp_print_flush ppf ();
+                backtrace := None;
+        end;
+        begin match out_phr with
+        | Ophr_eval (_, _) | Ophr_signature _ -> true
+        | Ophr_exception _ -> false
+        end
+      with x ->
+        toplevel_env := oldenv; raise x
+      end
+  | Ptop_dir(dir_name, dir_arg) ->
+      let d =
+        try Some (Hashtbl.find directive_table dir_name)
+        with Not_found -> None
+      in
+      begin match d with
+      | None ->
+          fprintf ppf "Unknown directive `%s'." dir_name;
+          let directives =
+            Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table [] in
+          Misc.did_you_mean ppf
+            (fun () -> Misc.spellcheck directives dir_name);
+          fprintf ppf "@.";
+          false
+      | Some d ->
+          match d, dir_arg with
+          | Directive_none f, Pdir_none -> f (); true
+          | Directive_string f, Pdir_string s -> f s; true
+          | Directive_int f, Pdir_int (n,None) ->
+             begin match Int_literal_converter.int n with
+             | n -> f n; true
+             | exception _ ->
+               fprintf ppf "Integer literal exceeds the range of \
+                            representable integers for directive `%s'.@."
+                       dir_name;
+               false
+             end
+          | Directive_int _, Pdir_int (_, Some _) ->
+              fprintf ppf "Wrong integer literal for directive `%s'.@."
+                dir_name;
+              false
+          | Directive_ident f, Pdir_ident lid -> f lid; true
+          | Directive_bool f, Pdir_bool b -> f b; true
+          | _ ->
+              fprintf ppf "Wrong type of argument for directive `%s'.@."
+                dir_name;
+              false
+      end
+
+let execute_phrase print_outcome ppf phr =
+  try execute_phrase print_outcome ppf phr
+  with exn ->
+    Warnings.reset_fatal ();
+    raise exn
+
+(* Read and execute commands from a file, or from stdin if [name] is "". *)
+
+let use_print_results = ref true
+
+let preprocess_phrase ppf phr =
+  let phr =
+    match phr with
+    | Ptop_def str ->
+        let str =
+          Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
+        in
+        let str =
+          Pparse.ImplementationHooks.apply_hooks
+            { Misc.sourcefile = "//toplevel//" } str in
+        Ptop_def str
+    | phr -> phr
+  in
+  if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+  if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+  phr
+
+let use_file ppf wrap_mod name =
+  try
+    let (filename, ic, must_close) =
+      if name = "" then
+        ("(stdin)", stdin, false)
+      else begin
+        let filename = find_in_path !Config.load_path name in
+        let ic = open_in_bin filename in
+        (filename, ic, true)
+      end
+    in
+    let lb = Lexing.from_channel ic in
+    Warnings.reset_fatal ();
+    Location.init lb filename;
+    (* Skip initial #! line if any *)
+    Lexer.skip_hash_bang lb;
+    let success =
+      protect_refs [ R (Location.input_name, filename) ] (fun () ->
+        try
+          List.iter
+            (fun ph ->
+              let ph = preprocess_phrase ppf ph in
+              if not (execute_phrase !use_print_results ppf ph) then raise Exit)
+            (if wrap_mod then
+               parse_mod_use_file name lb
+             else
+               !parse_use_file lb);
+          true
+        with
+        | Exit -> false
+        | Sys.Break -> fprintf ppf "Interrupted.@."; false
+        | x -> Location.report_exception ppf x; false) in
+    if must_close then close_in ic;
+    success
+  with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
+
+let mod_use_file ppf name = use_file ppf true name
+let use_file ppf name = use_file ppf false name
+
+let use_silently ppf name =
+  protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
+
+(* Reading function for interactive use *)
+
+let first_line = ref true
+let got_eof = ref false;;
+
+let read_input_default prompt buffer len =
+  output_string Pervasives.stdout prompt; flush Pervasives.stdout;
+  let i = ref 0 in
+  try
+    while true do
+      if !i >= len then raise Exit;
+      let c = input_char Pervasives.stdin in
+      Bytes.set 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 =
+      if !Clflags.noprompt then ""
+      else if !first_line then "# "
+      else if !Clflags.nopromptcont then ""
+      else if Lexer.in_comment () then "* "
+      else "  "
+    in
+    first_line := false;
+    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
+   beginning of loop() so that user code linked in with ocamlmktop
+   can call directives from Topdirs. *)
+
+let _ =
+  if !Sys.interactive then (* PR#6108 *)
+    invalid_arg "The ocamltoplevel.cma library from compiler-libs \
+                 cannot be loaded inside the OCaml toplevel";
+  Clflags.debug := true;
+  Sys.interactive := true;
+  let crc_intfs = Symtable.init_toplevel() in
+  Compmisc.init_path false;
+  List.iter
+    (fun (name, crco) ->
+      Env.add_import name;
+      match crco with
+        None -> ()
+      | Some crc->
+          Consistbl.set Env.crc_units name crc Sys.executable_name)
+    crc_intfs
+
+let load_ocamlinit ppf =
+  if !Clflags.noinit then ()
+  else match !Clflags.init_file with
+  | Some f -> if Sys.file_exists f then ignore (use_silently ppf f)
+              else fprintf ppf "Init file not found: \"%s\".@." f
+  | None ->
+     if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit")
+     else try
+       let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in
+       if Sys.file_exists home_init then ignore (use_silently ppf home_init)
+     with Not_found -> ()
+;;
+
+let set_paths () =
+  (* Add whatever -I options have been specified on the command line,
+     but keep the directories that user code linked in with ocamlmktop
+     may have added to load_path. *)
+  load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"];
+  load_path := "" :: List.rev (!Compenv.last_include_dirs @
+                               !Clflags.include_dirs @
+                               !Compenv.first_include_dirs) @ !load_path;
+  Dll.add_path !load_path
+
+let initialize_toplevel_env () =
+  toplevel_env := Compmisc.initial_env()
+
+(* The interactive loop *)
+
+exception PPerror
+
+let loop ppf =
+  Location.formatter_for_warnings := ppf;
+  if not !Clflags.noversion then
+    fprintf ppf "        OCaml version %s@.@." Config.version;
+  begin
+    try initialize_toplevel_env ()
+    with Env.Error _ | Typetexp.Error _ as exn ->
+      Location.report_exception ppf exn; exit 2
+  end;
+  let lb = Lexing.from_function refill_lexbuf in
+  Location.init lb "//toplevel//";
+  Location.input_name := "//toplevel//";
+  Location.input_lexbuf := Some lb;
+  Sys.catch_break true;
+  load_ocamlinit ppf;
+  while true do
+    let snap = Btype.snapshot () in
+    try
+      Lexing.flush_input lb;
+      Location.reset();
+      Warnings.reset_fatal ();
+      first_line := true;
+      let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
+      let phr = preprocess_phrase ppf phr  in
+      Env.reset_cache_toplevel ();
+      ignore(execute_phrase true ppf phr)
+    with
+    | End_of_file -> exit 0
+    | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
+    | PPerror -> ()
+    | x -> Location.report_exception ppf x; Btype.backtrack snap
+  done
+
+(* Execute a script.  If [name] is "", read the script from stdin. *)
+
+let override_sys_argv args =
+  let len = Array.length args in
+  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
+  Array.blit args 0 Sys.argv 0 len;
+  Obj.truncate (Obj.repr Sys.argv) len;
+  Arg.current := 0
+
+let run_script ppf name args =
+  override_sys_argv args;
+  Compmisc.init_path ~dir:(Filename.dirname name) true;
+                   (* Note: would use [Filename.abspath] here, if we had it. *)
+  begin
+    try toplevel_env := Compmisc.initial_env()
+    with Env.Error _ | Typetexp.Error _ as exn ->
+      Location.report_exception ppf exn; exit 2
+  end;
+  Sys.interactive := false;
+  let explicit_name =
+    (* Prevent use_silently from searching in the path. *)
+    if name <> "" && Filename.is_implicit name
+    then Filename.concat Filename.current_dir_name name
+    else name
+  in
+  use_silently ppf explicit_name
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
new file mode 100644
index 00000000..7a478b3c
--- /dev/null
+++ b/toplevel/toploop.mli
@@ -0,0 +1,157 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+(* Accessors for the table of toplevel value bindings.  These functions
+   must appear as first and second exported functions in this module.
+   (See module Translmod.) *)
+val getvalue : string -> Obj.t
+val setvalue : string -> Obj.t -> unit
+
+(* Set the load paths, before running anything *)
+
+val set_paths : unit -> unit
+
+(* The interactive toplevel loop *)
+
+val loop : formatter -> unit
+
+(* Read and execute a script from the given file *)
+
+val run_script : formatter -> string -> string array -> bool
+        (* true if successful, false if error *)
+
+(* Interface with toplevel directives *)
+
+type directive_fun =
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
+
+type directive_info = {
+  section: string;
+  doc: string;
+}
+
+val add_directive : string -> directive_fun -> directive_info -> unit
+        (* Add toplevel directive and its documentation.
+
+           @since 4.03 *)
+
+val directive_table : (string, directive_fun) Hashtbl.t
+  (* Deprecated: please use [add_directive] instead of inserting
+     in this table directly. *)
+
+val directive_info_table : (string, directive_info) Hashtbl.t
+
+val toplevel_env : Env.t ref
+        (* Typing environment for the toplevel *)
+val initialize_toplevel_env : unit -> unit
+        (* Initialize the typing environment for the toplevel *)
+val print_exception_outcome : formatter -> exn -> unit
+        (* Print an exception resulting from the evaluation of user code. *)
+val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool
+        (* Execute the given toplevel phrase. Return [true] if the
+           phrase executed with no errors and [false] otherwise.
+           First bool says whether the values and types of the results
+           should be printed. Uncaught exceptions are always printed. *)
+val preprocess_phrase :
+    formatter -> Parsetree.toplevel_phrase ->  Parsetree.toplevel_phrase
+        (* Preprocess the given toplevel phrase using regular and ppx
+           preprocessors. Return the updated phrase. *)
+val use_file : formatter -> string -> bool
+val use_silently : formatter -> string -> bool
+val mod_use_file : formatter -> string -> bool
+        (* Read and execute commands from a file.
+           [use_file] prints the types and values of the results.
+           [use_silently] does not print them.
+           [mod_use_file] wrap the file contents into a module. *)
+val eval_path: Env.t -> Path.t -> Obj.t
+        (* Return the toplevel object referred to by the given path *)
+val record_backtrace : unit -> unit
+
+(* Printing of values *)
+
+val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit
+val print_untyped_exception: formatter -> Obj.t -> unit
+
+type ('a, 'b) gen_printer =
+  | Zero of 'b
+  | Succ of ('a -> ('a, 'b) gen_printer)
+
+val install_printer :
+  Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit
+val install_generic_printer :
+  Path.t -> Path.t ->
+  (int -> (int -> Obj.t -> Outcometree.out_value,
+           Obj.t -> Outcometree.out_value) gen_printer) -> unit
+val install_generic_printer' :
+  Path.t -> Path.t -> (formatter -> Obj.t -> unit,
+                       formatter -> Obj.t -> unit) gen_printer -> unit
+val remove_printer : Path.t -> unit
+
+val max_printer_depth: int ref
+val max_printer_steps: int ref
+
+(* Hooks for external parsers and printers *)
+
+val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
+val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
+val print_location : formatter -> Location.t -> unit
+val print_error : formatter -> Location.t -> unit
+val print_warning : Location.t -> formatter -> Warnings.t -> unit
+val input_name : string ref
+
+val print_out_value :
+  (formatter -> Outcometree.out_value -> unit) ref
+val print_out_type :
+  (formatter -> Outcometree.out_type -> unit) ref
+val print_out_class_type :
+  (formatter -> Outcometree.out_class_type -> unit) ref
+val print_out_module_type :
+  (formatter -> Outcometree.out_module_type -> unit) ref
+val print_out_type_extension :
+  (formatter -> Outcometree.out_type_extension -> unit) ref
+val print_out_sig_item :
+  (formatter -> Outcometree.out_sig_item -> unit) ref
+val print_out_signature :
+  (formatter -> Outcometree.out_sig_item list -> unit) ref
+val print_out_phrase :
+  (formatter -> Outcometree.out_phrase -> unit) ref
+
+(* Hooks for external line editor *)
+
+val read_interactive_input : (string -> bytes -> int -> int * bool) ref
+
+(* Hooks for initialization *)
+
+val toplevel_startup_hook : (unit -> unit) ref
+
+(* Used by Trace module *)
+
+val may_trace : bool ref
+
+(* Misc *)
+
+val override_sys_argv : string array -> unit
+(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
+   and reset [Arg.current] to [0].
+
+   This is called by [run_script] so that [Sys.argv] represents
+   "script.ml args..." instead of the full command line:
+   "ocamlrun unix.cma ... script.ml args...". *)
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
new file mode 100644
index 00000000..1a8757b3
--- /dev/null
+++ b/toplevel/topmain.ml
@@ -0,0 +1,170 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Clflags
+open Compenv
+
+let usage = "Usage: ocaml   [script-file [arguments]]\n\
+             options are:"
+
+let preload_objects = ref []
+
+(* Position of the first non expanded argument *)
+let first_nonexpanded_pos = ref 0
+
+let current = ref (!Arg.current)
+
+let argv = ref Sys.argv
+
+(* Test whether the option is part of a responsefile *)
+let is_expanded pos = pos < !first_nonexpanded_pos
+
+let expand_position pos len =
+  if pos < !first_nonexpanded_pos then
+    first_nonexpanded_pos := !first_nonexpanded_pos + len (* Shift the position *)
+  else
+    first_nonexpanded_pos :=  pos + len + 2 (* New last position *)
+
+let prepare ppf =
+  Toploop.set_paths ();
+  try
+    let res =
+      let objects =
+        List.rev (!preload_objects @ !first_objfiles)
+      in
+      List.for_all (Topdirs.load_file ppf) objects
+    in
+    !Toploop.toplevel_startup_hook ();
+    res
+  with x ->
+    try Location.report_exception ppf x; false
+    with x ->
+      Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
+      false
+
+(* If [name] is "", then the "file" is stdin treated as a script file. *)
+let file_argument name =
+  let ppf = Format.err_formatter in
+  if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
+  then preload_objects := name :: !preload_objects
+  else if is_expanded !current then begin
+    (* Script files are not allowed in expand options because otherwise the
+       check in override arguments may fail since the new argv can be larger
+       than the original argv.
+    *)
+    Printf.eprintf "For implementation reasons, the toplevel does not support\
+   \ having script files (here %S) inside expanded arguments passed through the\
+   \ -args{,0} command-line option.\n" name;
+    exit 2
+  end else begin
+      let newargs = Array.sub !argv !current
+                              (Array.length !argv - !current)
+      in
+      Compenv.readenv ppf Before_link;
+      if prepare ppf && Toploop.run_script ppf name newargs
+      then exit 0
+      else exit 2
+    end
+
+let print_version () =
+  Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
+  exit 0;
+;;
+
+let print_version_num () =
+  Printf.printf "%s\n" Sys.ocaml_version;
+  exit 0;
+;;
+
+let wrap_expand f s =
+  let start = !current in
+  let arr = f s in
+  expand_position start (Array.length arr);
+  arr
+
+module Options = Main_args.Make_bytetop_options (struct
+  let set r () = r := true
+  let clear r () = r := false
+
+  let _absname = set Location.absname
+  let _I dir =
+    let dir = Misc.expand_directory Config.standard_library dir in
+    include_dirs := dir :: !include_dirs
+  let _init s = init_file := Some s
+  let _noinit = set noinit
+  let _labels = clear classic
+  let _alias_deps = clear transparent_modules
+  let _no_alias_deps = set transparent_modules
+  let _app_funct = set applicative_functors
+  let _no_app_funct = clear applicative_functors
+  let _noassert = set noassert
+  let _nolabels = set classic
+  let _noprompt = set noprompt
+  let _nopromptcont = set nopromptcont
+  let _nostdlib = set no_std_include
+  let _open s = open_modules := s :: !open_modules
+  let _plugin p = Compplugin.load p
+  let _ppx s = first_ppx := s :: !first_ppx
+  let _principal = set principal
+  let _no_principal = clear principal
+  let _rectypes = set recursive_types
+  let _no_rectypes = clear recursive_types
+  let _safe_string = clear unsafe_string
+  let _short_paths = clear real_paths
+  let _stdin () = file_argument ""
+  let _strict_sequence = set strict_sequence
+  let _no_strict_sequence = clear strict_sequence
+  let _strict_formats = set strict_formats
+  let _no_strict_formats = clear strict_formats
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
+  let _unsafe = set fast
+  let _unsafe_string = set unsafe_string
+  let _version () = print_version ()
+  let _vnum () = print_version_num ()
+  let _no_version = set noversion
+  let _w s = Warnings.parse_options false s
+  let _warn_error s = Warnings.parse_options true s
+  let _warn_help = Warnings.help_warnings
+  let _dparsetree = set dump_parsetree
+  let _dtypedtree = set dump_typedtree
+  let _dsource = set dump_source
+  let _drawlambda = set dump_rawlambda
+  let _dlambda = set dump_lambda
+  let _dflambda = set dump_flambda
+  let _dtimings = set print_timings
+  let _dinstr = set dump_instr
+
+  let _args = wrap_expand Arg.read_arg
+  let _args0 = wrap_expand Arg.read_arg0
+
+  let anonymous s = file_argument s
+end);;
+
+
+let main () =
+  let ppf = Format.err_formatter in
+  Compenv.readenv ppf Before_args;
+  let list = ref Options.list in
+  begin
+    try
+      Arg.parse_and_expand_argv_dynamic current argv list file_argument usage;
+    with
+    | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
+    | Arg.Help msg -> Printf.printf "%s" msg; exit 0
+  end;
+  Compenv.readenv ppf Before_link;
+  if not (prepare ppf) then exit 2;
+  Toploop.loop Format.std_formatter
diff --git a/toplevel/topmain.mli b/toplevel/topmain.mli
new file mode 100644
index 00000000..93fea4c7
--- /dev/null
+++ b/toplevel/topmain.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Start the [ocaml] toplevel loop *)
+
+val main: unit -> unit
diff --git a/toplevel/topstart.ml b/toplevel/topstart.ml
new file mode 100644
index 00000000..e3dd62c9
--- /dev/null
+++ b/toplevel/topstart.ml
@@ -0,0 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let _ = Topmain.main()
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
new file mode 100644
index 00000000..cc732a61
--- /dev/null
+++ b/toplevel/trace.ml
@@ -0,0 +1,150 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The "trace" facility *)
+
+open Format
+open Misc
+open Longident
+open Types
+open Toploop
+
+type codeptr = Obj.t
+
+type traced_function =
+  { path: Path.t;                       (* Name under which it is traced *)
+    closure: Obj.t;                     (* Its function closure (patched) *)
+    actual_code: codeptr;               (* Its original code pointer *)
+    instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t }
+                                        (* Printing function *)
+
+let traced_functions = ref ([] : traced_function list)
+
+(* Check if a function is already traced *)
+
+let is_traced clos =
+  let rec is_traced = function
+      [] -> None
+    | tf :: rem -> if tf.closure == clos then Some tf.path else is_traced rem
+  in is_traced !traced_functions
+
+(* Get or overwrite the code pointer of a closure *)
+
+let get_code_pointer cls = Obj.field cls 0
+
+let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
+
+(* Call a traced function (use old code pointer, but new closure as
+   environment so that recursive calls are also traced).
+   It is necessary to wrap Meta.invoke_traced_function in an ML function
+   so that the RETURN at the end of the ML wrapper takes us to the
+   code of the function. *)
+
+let invoke_traced_function codeptr env arg =
+  Meta.invoke_traced_function codeptr env arg
+
+let print_label ppf l =
+  if l <> Asttypes.Nolabel then fprintf ppf "%s:" (Printtyp.string_of_label l)
+
+(* If a function returns a functional value, wrap it into a trace code *)
+
+let rec instrument_result env name ppf clos_typ =
+  match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
+  | Tarrow(l, t1, t2, _) ->
+      let starred_name =
+        match name with
+        | Lident s -> Lident(s ^ "*")
+        | Ldot(lid, s) -> Ldot(lid, s ^ "*")
+        | Lapply _ -> fatal_error "Trace.instrument_result" in
+      let trace_res = instrument_result env starred_name ppf t2 in
+      (fun clos_val ->
+        Obj.repr (fun arg ->
+          if not !may_trace then
+            (Obj.magic clos_val : Obj.t -> Obj.t) arg
+          else begin
+            may_trace := false;
+            try
+              fprintf ppf "@[<2>%a <--@ %a%a@]@."
+                Printtyp.longident starred_name
+                print_label l
+                (print_value !toplevel_env arg) t1;
+              may_trace := true;
+              let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in
+              may_trace := false;
+              fprintf ppf "@[<2>%a -->@ %a@]@."
+                Printtyp.longident starred_name
+                (print_value !toplevel_env res) t2;
+              may_trace := true;
+              trace_res res
+            with exn ->
+              may_trace := false;
+              fprintf ppf "@[<2>%a raises@ %a@]@."
+                Printtyp.longident starred_name
+                (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
+              may_trace := true;
+              raise exn
+          end))
+  | _ -> (fun v -> v)
+
+(* Same as instrument_result, but for a toplevel closure (modified in place) *)
+
+exception Dummy
+let _ = Dummy
+
+let instrument_closure env name ppf clos_typ =
+  match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
+  | Tarrow(l, t1, t2, _) ->
+      let trace_res = instrument_result env name ppf t2 in
+      (fun actual_code closure arg ->
+        if not !may_trace then begin
+          try invoke_traced_function actual_code closure arg
+          with Dummy -> assert false
+          (* do not remove handler, prevents tail-call to invoke_traced_ *)
+        end else begin
+          may_trace := false;
+          try
+            fprintf ppf "@[<2>%a <--@ %a%a@]@."
+              Printtyp.longident name
+              print_label l
+              (print_value !toplevel_env arg) t1;
+            may_trace := true;
+            let res = invoke_traced_function actual_code closure arg in
+            may_trace := false;
+            fprintf ppf "@[<2>%a -->@ %a@]@."
+              Printtyp.longident name
+              (print_value !toplevel_env res) t2;
+            may_trace := true;
+            trace_res res
+          with exn ->
+            may_trace := false;
+            fprintf ppf "@[<2>%a raises@ %a@]@."
+              Printtyp.longident name
+              (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
+            may_trace := true;
+            raise exn
+        end)
+  | _ -> assert false
+
+(* Given the address of a closure, find its tracing info *)
+
+let rec find_traced_closure clos = function
+  | [] -> fatal_error "Trace.find_traced_closure"
+  | f :: rem -> if f.closure == clos then f else find_traced_closure clos rem
+
+(* Trace the application of an (instrumented) closure to an argument *)
+
+let print_trace clos arg =
+  let f = find_traced_closure clos !traced_functions in
+  f.instrumented_fun f.actual_code clos arg
diff --git a/toplevel/trace.mli b/toplevel/trace.mli
new file mode 100644
index 00000000..ab9d217e
--- /dev/null
+++ b/toplevel/trace.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The "trace" facility *)
+
+open Format
+
+type codeptr
+
+type traced_function =
+  { path: Path.t;                       (* Name under which it is traced *)
+    closure: Obj.t;                     (* Its function closure (patched) *)
+    actual_code: codeptr;               (* Its original code pointer *)
+    instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t }
+                                        (* Printing function *)
+
+val traced_functions: traced_function list ref
+val is_traced: Obj.t -> Path.t option
+val get_code_pointer: Obj.t -> codeptr
+val set_code_pointer: Obj.t -> codeptr -> unit
+val instrument_closure:
+        Env.t -> Longident.t -> formatter -> Types.type_expr ->
+        codeptr -> Obj.t -> Obj.t -> Obj.t
+val print_trace: Obj.t -> Obj.t -> Obj.t
diff --git a/typing/HACKING.adoc b/typing/HACKING.adoc
new file mode 100644
index 00000000..101bf8ed
--- /dev/null
+++ b/typing/HACKING.adoc
@@ -0,0 +1,58 @@
+The implementation of the OCaml typechecker is complex. Modifying it
+will need a good understanding of the OCaml type system and type
+inference. Here is a reading list to ease your discovery of the
+typechecker:
+
+http://caml.inria.fr/pub/docs/u3-ocaml/index.html[Using, Understanding, and Unraveling the OCaml Language by Didier Rémy] ::
+This book provides (among other things) a formal description of parts
+of the core OCaml language, starting with a simple Core ML.
+
+http://okmij.org/ftp/ML/generalization.html[Efficient and Insightful Generalization by Oleg Kiselyov] ::
+This article describes the basis of the type inference algorithm used
+by the OCaml type checker. It is a recommended read if you want to
+understand the type-checker codebase, in particular its handling of
+polymorphism/generalization.
+
+After that, it is best to dive right in. There is no real "entry
+point", but an understanding of both the parsetree and the typedtree
+is necessary.
+
+The datastructures ::
+link:types.mli[Types] and link:typedtree.mli[Typedtree]
+are the two main datastructures in the typechecker. They correspond to
+the source code annotated with all the information needed for type
+checking and type inference. link:env.mli[Env] contains all the
+environments that are used in the typechecker. Each node in the
+typedtree is annotated with the local environment in which it was
+type-checked.
+
+Core utilities ::
+link:btype.mli[Btype] and link:ctype.mli[Ctype] contain
+the various low-level function needed for typing, in particular
+related to levels, unification and
+backtracking. link:mtype.mli[Mtype] contains utilities related
+to modules.
+
+Inference and checking::
+The `Type..` modules are related to inference and typechecking, each
+for a different part of the language:
+link:typetexp.mli[Typetexp] for type expressions,
+link:typecore.mli[Typecore] for the core language,
+link:typemod.mli[Typemod] for modules,
+link:typedecl.mli[Typedecl] for type declarations and finally
+link:typeclass.mli[Typeclass] for the object system.
+
+Inclusion/Module subtyping::
+Handling of inclusion relations are separated in the `Include...`
+modules: link:includecore.ml[Includecore] for the type and
+value declarations, link:includemod.mli[Includemod] for modules
+and finally link:includeclass.mli[Includeclass] for the object
+system.
+
+Dependencies between modules::
+Most of the modules presented above are inter-dependent. Since OCaml
+does not permit circular dependencies between files, the
+implementation uses forward declarations, implemented with references
+to functions that are filled later on. An example can be seen in
+link:typecore.ml[Typecore.type_module], which is filled in
+link:typemod.ml[Typemod].
diff --git a/typing/annot.mli b/typing/annot.mli
new file mode 100644
index 00000000..3cae8f27
--- /dev/null
+++ b/typing/annot.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Data types for annotations (Stypes.ml) *)
+
+type call = Tail | Stack | Inline;;
+
+type ident =
+  | Iref_internal of Location.t (* defining occurrence *)
+  | Iref_external
+  | Idef of Location.t          (* scope *)
+;;
diff --git a/typing/btype.ml b/typing/btype.ml
new file mode 100644
index 00000000..d94693b1
--- /dev/null
+++ b/typing/btype.ml
@@ -0,0 +1,737 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Misc
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
+(**** Type level management ****)
+
+let generic_level = 100000000
+
+(* Used to mark a type during a traversal. *)
+let lowest_level = 0
+let pivot_level = 2 * lowest_level - 1
+    (* pivot_level - lowest_level < lowest_level *)
+
+(**** Some type creators ****)
+
+let new_id = ref (-1)
+
+let newty2 level desc  =
+  incr new_id; { desc; level; id = !new_id }
+let newgenty desc      = newty2 generic_level desc
+let newgenvar ?name () = newgenty (Tvar name)
+(*
+let newmarkedvar level =
+  incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
+let newmarkedgenvar () =
+  incr new_id;
+  { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
+*)
+
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
+
+let dummy_method = "*dummy method*"
+let default_mty = function
+    Some mty -> mty
+  | None -> Mty_signature []
+
+(**** Definitions for backtracking ****)
+
+type change =
+    Ctype of type_expr * type_desc
+  | Ccompress of type_expr * type_desc * type_desc
+  | Clevel of type_expr * int
+  | Cname of
+      (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
+  | Crow of row_field option ref * row_field option
+  | Ckind of field_kind option ref * field_kind option
+  | Ccommu of commutable ref * commutable
+  | Cuniv of type_expr option ref * type_expr option
+  | Ctypeset of TypeSet.t ref * TypeSet.t
+
+type changes =
+    Change of change * changes ref
+  | Unchanged
+  | Invalid
+
+let trail = Weak.create 1
+
+let log_change ch =
+  match Weak.get trail 0 with None -> ()
+  | Some r ->
+      let r' = ref Unchanged in
+      r := Change (ch, r');
+      Weak.set trail 0 (Some r')
+
+(**** Representative of a type ****)
+
+let rec field_kind_repr =
+  function
+    Fvar {contents = Some kind} -> field_kind_repr kind
+  | kind                        -> kind
+
+let rec repr_link compress t d =
+ function
+   {desc = Tlink t' as d'} ->
+     repr_link true t d' t'
+ | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+     repr_link true t d' t'
+ | t' ->
+     if compress then begin
+       log_change (Ccompress (t, t.desc, d)); t.desc <- d
+     end;
+     t'
+
+let repr t =
+  match t.desc with
+   Tlink t' as d ->
+     repr_link false t d t'
+ | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent ->
+     repr_link false t d t'
+ | _ -> t
+
+let rec commu_repr = function
+    Clink r when !r <> Cunknown -> commu_repr !r
+  | c -> c
+
+let rec row_field_repr_aux tl = function
+    Reither(_, tl', _, {contents = Some fi}) ->
+      row_field_repr_aux (tl@tl') fi
+  | Reither(c, tl', m, r) ->
+      Reither(c, tl@tl', m, r)
+  | Rpresent (Some _) when tl <> [] ->
+      Rpresent (Some (List.hd tl))
+  | fi -> fi
+
+let row_field_repr fi = row_field_repr_aux [] fi
+
+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' ->
+      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
+  | {desc=Tvariant row'} -> row_more row'
+  | ty -> ty
+
+let row_fixed row =
+  let row = row_repr row in
+  row.row_fixed ||
+  match (repr row.row_more).desc with
+    Tvar _ | Tnil -> false
+  | Tunivar _ | Tconstr _ -> true
+  | _ -> assert false
+
+let static_row row =
+  let row = row_repr row in
+  row.row_closed &&
+  List.for_all
+    (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
+    row.row_fields
+
+let hash_variant s =
+  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 *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+let proxy ty =
+  let ty0 = repr ty in
+  match ty0.desc with
+  | Tvariant row when not (static_row row) ->
+      row_more row
+  | Tobject (ty, _) ->
+      let rec proxy_obj ty =
+        match ty.desc with
+          Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
+        | Tnil -> ty0
+        | _ -> assert false
+      in proxy_obj ty
+  | _ -> ty0
+
+(**** Utilities for fixed row private types ****)
+
+let row_of_type t = 
+  match (repr t).desc with
+    Tobject(t,_) ->
+      let rec get_row t =
+        let t = repr t in
+        match t.desc with
+          Tfield(_,_,_,t) -> get_row t
+        | _ -> t
+      in get_row t
+  | Tvariant row ->
+      row_more row
+  | _ ->
+      t
+
+let has_constr_row t =
+  not (is_Tconstr t) && is_Tconstr (row_of_type t)
+
+let is_row_name s =
+  let l = String.length s in
+  if l < 4 then false else String.sub s (l-4) 4 = "#row"
+
+let is_constr_row ~allow_ident t =
+  match t.desc with
+    Tconstr (Path.Pident id, _, _) when allow_ident ->
+      is_row_name (Ident.name id)
+  | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
+  | _ -> false
+
+
+                  (**********************************)
+                  (*  Utilities for type traversal  *)
+                  (**********************************)
+
+let rec iter_row f row =
+  List.iter
+    (fun (_, fi) ->
+      match row_field_repr fi with
+      | Rpresent(Some ty) -> f ty
+      | Reither(_, tl, _, _) -> List.iter f tl
+      | _ -> ())
+    row.row_fields;
+  match (repr row.row_more).desc with
+    Tvariant row -> iter_row f row
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
+      Misc.may (fun (_,l) -> List.iter f l) row.row_name
+  | _ -> assert false
+
+let iter_type_expr f ty =
+  match ty.desc with
+    Tvar _              -> ()
+  | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
+  | Ttuple l            -> List.iter f l
+  | Tconstr (_, l, _)   -> List.iter f l
+  | Tobject(ty, {contents = Some (_, p)})
+                        -> f ty; List.iter f p
+  | Tobject (ty, _)     -> f ty
+  | Tvariant row        -> iter_row f row; f (row_more row)
+  | Tfield (_, _, ty1, ty2) -> f ty1; f ty2
+  | Tnil                -> ()
+  | Tlink ty            -> f ty
+  | Tsubst ty           -> f ty
+  | Tunivar _           -> ()
+  | Tpoly (ty, tyl)     -> f ty; List.iter f tyl
+  | Tpackage (_, _, l)  -> List.iter f l
+
+let rec iter_abbrev f = function
+    Mnil                   -> ()
+  | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem
+  | Mlink rem              -> iter_abbrev f !rem
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+
+let iter_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> List.iter f tl
+  | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
+
+let map_type_expr_cstr_args f = function
+  | Cstr_tuple tl -> Cstr_tuple (List.map f tl)
+  | Cstr_record lbls ->
+      Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
+
+let iter_type_expr_kind f = function
+  | Type_abstract -> ()
+  | Type_variant cstrs ->
+      List.iter
+        (fun cd ->
+           iter_type_expr_cstr_args f cd.cd_args;
+           Misc.may f cd.cd_res
+        )
+        cstrs
+  | Type_record(lbls, _) ->
+      List.iter (fun d -> f d.ld_type) lbls
+  | Type_open ->
+      ()
+
+
+let type_iterators =
+  let it_signature it =
+    List.iter (it.it_signature_item it)
+  and it_signature_item it = function
+      Sig_value (_, vd)     -> it.it_value_description it vd
+    | Sig_type (_, td, _)   -> it.it_type_declaration it td
+    | Sig_typext (_, td, _) -> it.it_extension_constructor it td
+    | Sig_module (_, md, _) -> it.it_module_declaration it md
+    | Sig_modtype (_, mtd)  -> it.it_modtype_declaration it mtd
+    | Sig_class (_, cd, _)  -> it.it_class_declaration it cd
+    | Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd
+  and it_value_description it vd =
+    it.it_type_expr it vd.val_type
+  and it_type_declaration it td =
+    List.iter (it.it_type_expr it) td.type_params;
+    may (it.it_type_expr it) td.type_manifest;
+    it.it_type_kind it td.type_kind
+  and it_extension_constructor it td =
+    it.it_path td.ext_type_path;
+    List.iter (it.it_type_expr it) td.ext_type_params;
+    iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args;
+    may (it.it_type_expr it) td.ext_ret_type
+  and it_module_declaration it md =
+    it.it_module_type it md.md_type
+  and it_modtype_declaration it mtd =
+    may (it.it_module_type it) mtd.mtd_type
+  and it_class_declaration it cd =
+    List.iter (it.it_type_expr it) cd.cty_params;
+    it.it_class_type it cd.cty_type;
+    may (it.it_type_expr it) cd.cty_new;
+    it.it_path cd.cty_path
+  and it_class_type_declaration it ctd =
+    List.iter (it.it_type_expr it) ctd.clty_params;
+    it.it_class_type it ctd.clty_type;
+    it.it_path ctd.clty_path
+  and it_module_type it = function
+      Mty_ident p
+    | Mty_alias(_, p) -> it.it_path p
+    | Mty_signature sg -> it.it_signature it sg
+    | Mty_functor (_, mto, mt) ->
+        may (it.it_module_type it) mto;
+        it.it_module_type it mt
+  and it_class_type it = function
+      Cty_constr (p, tyl, cty) ->
+        it.it_path p;
+        List.iter (it.it_type_expr it) tyl;
+        it.it_class_type it cty
+    | Cty_signature cs ->
+        it.it_type_expr it cs.csig_self;
+        Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
+        List.iter
+          (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
+          cs.csig_inher
+    | Cty_arrow  (_, ty, cty) ->
+        it.it_type_expr it ty;
+        it.it_class_type it cty
+  and it_type_kind it kind =
+    iter_type_expr_kind (it.it_type_expr it) kind
+  and it_do_type_expr it ty =
+    iter_type_expr (it.it_type_expr it) ty;
+    match ty.desc with
+      Tconstr (p, _, _)
+    | Tobject (_, {contents=Some (p, _)})
+    | Tpackage (p, _, _) ->
+        it.it_path p
+    | Tvariant row ->
+        may (fun (p,_) -> it.it_path p) (row_repr row).row_name
+    | _ -> ()
+  and it_path _p = ()
+  in
+  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
+    it_type_kind; it_class_type; it_module_type;
+    it_signature; it_class_type_declaration; it_class_declaration;
+    it_modtype_declaration; it_module_declaration; it_extension_constructor;
+    it_type_declaration; it_value_description; it_signature_item; }
+
+let copy_row f fixed row keep more =
+  let fields = List.map
+      (fun (l, fi) -> l,
+        match row_field_repr fi with
+        | Rpresent(Some ty) -> Rpresent(Some(f ty))
+        | Reither(c, tl, m, e) ->
+            let e = if keep then e else ref None in
+            let m = if row.row_fixed then fixed else m in
+            let tl = List.map f tl in
+            Reither(c, tl, m, e)
+        | _ -> fi)
+      row.row_fields in
+  let name =
+    match row.row_name with None -> None
+    | Some (path, tl) -> Some (path, List.map f tl) in
+  { row_fields = fields; row_more = more;
+    row_bound = (); row_fixed = row.row_fixed && fixed;
+    row_closed = row.row_closed; row_name = name; }
+
+let rec copy_kind = function
+    Fvar{contents = Some k} -> copy_kind k
+  | Fvar _   -> Fvar (ref None)
+  | Fpresent -> Fpresent
+  | Fabsent  -> assert false
+
+let copy_commu c =
+  if commu_repr c = Cok then Cok else Clink (ref Cunknown)
+
+(* Since univars may be used as row variables, we need to do some
+   encoding during substitution *)
+let rec norm_univar ty =
+  match ty.desc with
+    Tunivar _ | Tsubst _ -> ty
+  | Tlink ty           -> norm_univar ty
+  | Ttuple (ty :: _)   -> norm_univar ty
+  | _                  -> assert false
+
+let rec copy_type_desc ?(keep_names=false) f = function
+    Tvar _ as ty        -> if keep_names then ty else Tvar None
+  | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
+  | Ttuple l            -> Ttuple (List.map f l)
+  | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
+  | Tobject(ty, {contents = Some (p, tl)})
+                        -> Tobject (f ty, ref (Some(p, List.map f tl)))
+  | Tobject (ty, _)     -> Tobject (f ty, ref None)
+  | Tvariant _          -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
+  | Tnil                -> Tnil
+  | Tlink ty            -> copy_type_desc f ty.desc
+  | Tsubst _            -> assert false
+  | Tunivar _ as ty     -> ty (* always keep the name *)
+  | Tpoly (ty, tyl)     ->
+      let tyl = List.map (fun x -> norm_univar (f x)) tyl in
+      Tpoly (f ty, tyl)
+  | Tpackage (p, n, l)  -> Tpackage (p, n, List.map f l)
+
+(* Utilities for copying *)
+
+let saved_desc = ref []
+  (* Saved association of generic nodes with their description. *)
+
+let save_desc ty desc =
+  saved_desc := (ty, desc)::!saved_desc
+
+let saved_kinds = ref [] (* duplicated kind variables *)
+let new_kinds = ref []   (* new kind variables *)
+let dup_kind r =
+  (match !r with None -> () | Some _ -> assert false);
+  if not (List.memq r !new_kinds) then begin
+    saved_kinds := r :: !saved_kinds;
+    let r' = ref None in
+    new_kinds := r' :: !new_kinds;
+    r := Some (Fvar r')
+  end
+
+(* Restored type descriptions. *)
+let cleanup_types () =
+  List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc;
+  List.iter (fun r -> r := None) !saved_kinds;
+  saved_desc := []; saved_kinds := []; new_kinds := []
+
+(* Mark a type. *)
+let rec mark_type ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    iter_type_expr mark_type ty
+  end
+
+let mark_type_node ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+  end
+
+let mark_type_params ty =
+  iter_type_expr mark_type ty
+
+let type_iterators =
+  let it_type_expr it ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      it.it_do_type_expr it ty;
+    end
+  in
+  {type_iterators with it_type_expr}
+
+
+(* Remove marks from a type. *)
+let rec unmark_type ty =
+  let ty = repr ty in
+  if ty.level < lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    iter_type_expr unmark_type ty
+  end
+
+let unmark_iterators =
+  let it_type_expr _it ty = unmark_type ty in
+  {type_iterators with it_type_expr}
+
+let unmark_type_decl decl =
+  unmark_iterators.it_type_declaration unmark_iterators decl
+
+let unmark_extension_constructor ext =
+  List.iter unmark_type ext.ext_type_params;
+  iter_type_expr_cstr_args unmark_type ext.ext_args;
+  Misc.may unmark_type ext.ext_ret_type
+
+let unmark_class_signature sign =
+  unmark_type sign.csig_self;
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
+
+let unmark_class_type cty =
+  unmark_iterators.it_class_type unmark_iterators cty
+
+
+                  (*******************************************)
+                  (*  Memorization of abbreviation expansion *)
+                  (*******************************************)
+
+(* Search whether the expansion has been memorized. *)
+
+let lte_public p1 p2 =  (* Private <= Public *)
+  match p1, p2 with
+  | Private, _ | _, Public -> true
+  | Public, Private -> false
+
+let rec find_expans priv p1 = function
+    Mnil -> None
+  | Mcons (priv', p2, _ty0, ty, _)
+    when lte_public priv priv' && Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
+  | Mlink {contents = rem} -> find_expans priv 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. *)
+
+let cleanup_abbrev () =
+        (* Remove all memorized abbreviation expansions. *)
+  List.iter (fun abbr -> abbr := Mnil) !memo;
+  memo := []
+
+let memorize_abbrev mem priv path v v' =
+        (* Memorize the expansion of an abbreviation. *)
+  mem := Mcons (priv, path, v, v', !mem);
+  (* check_expans [] v; *)
+  memo := mem :: !memo
+
+let rec forget_abbrev_rec mem path =
+  match mem with
+    Mnil ->
+      assert false
+  | Mcons (_, path', _, _, rem) when Path.same path path' ->
+      rem
+  | Mcons (priv, path', v, v', rem) ->
+      Mcons (priv, path', v, v', forget_abbrev_rec rem path)
+  | Mlink mem' ->
+      mem' := forget_abbrev_rec !mem' path;
+      raise Exit
+
+let forget_abbrev mem path =
+  try mem := forget_abbrev_rec !mem path with Exit -> ()
+
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
+    Mnil -> true
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
+  | Mlink mem' ->
+      check_abbrev_rec !mem'
+
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
+
+                  (**********************************)
+                  (*  Utilities for labels          *)
+                  (**********************************)
+
+let is_optional = function Optional _ -> true | _ -> false
+
+let label_name = function
+    Nolabel -> ""
+  | Labelled s
+  | Optional s -> s
+
+let prefixed_label_name = function
+    Nolabel -> ""
+  | Labelled s -> "~" ^ s
+  | Optional s -> "?" ^ s
+
+let rec extract_label_aux hd l = function
+    [] -> raise Not_found
+  | (l',t as p) :: ls ->
+      if label_name l' = l then (l', t, List.rev hd, ls)
+      else extract_label_aux (p::hd) l ls
+
+let extract_label l ls = extract_label_aux [] l ls
+
+
+                  (**********************************)
+                  (*  Utilities for backtracking    *)
+                  (**********************************)
+
+let undo_change = function
+    Ctype  (ty, desc) -> ty.desc <- desc
+  | Ccompress  (ty, desc, _) -> ty.desc <- desc
+  | Clevel (ty, level) -> ty.level <- level
+  | Cname  (r, v) -> r := v
+  | Crow   (r, v) -> r := v
+  | Ckind  (r, v) -> r := v
+  | Ccommu (r, v) -> r := v
+  | Cuniv  (r, v) -> r := v
+  | Ctypeset (r, v) -> r := v
+
+type snapshot = changes ref * int
+let last_snapshot = ref 0
+
+let log_type ty =
+  if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  ty.desc <- Tlink ty';
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
+      | None, Some _ ->  ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
+      | None, None   ->  ()
+      end
+  | _ -> ()
+  (* ; 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
+let set_univar rty ty =
+  log_change (Cuniv (rty, !rty)); rty := Some ty
+let set_name nm v =
+  log_change (Cname (nm, !nm)); nm := v
+let set_row_field e v =
+  log_change (Crow (e, !e)); e := Some v
+let set_kind rk k =
+  log_change (Ckind (rk, !rk)); rk := Some k
+let set_commu rc c =
+  log_change (Ccommu (rc, !rc)); rc := c
+let set_typeset rs s =
+  log_change (Ctypeset (rs, !rs)); rs := s
+
+let snapshot () =
+  let old = !last_snapshot in
+  last_snapshot := !new_id;
+  match Weak.get trail 0 with Some r -> (r, old)
+  | None ->
+      let r = ref Unchanged in
+      Weak.set trail 0 (Some r);
+      (r, old)
+
+let rec rev_log accu = function
+    Unchanged -> accu
+  | Invalid -> assert false
+  | Change (ch, next) ->
+      let d = !next in
+      next := Invalid;
+      rev_log (ch::accu) d
+
+let backtrack (changes, old) =
+  match !changes with
+    Unchanged -> last_snapshot := old
+  | Invalid -> failwith "Btype.backtrack"
+  | Change _ as change ->
+      cleanup_abbrev ();
+      let backlog = rev_log [] change in
+      List.iter undo_change backlog;
+      changes := Unchanged;
+      last_snapshot := old;
+      Weak.set trail 0 (Some changes)
+
+let rec rev_compress_log log r =
+  match !r with
+    Unchanged | Invalid ->
+      log
+  | Change (Ccompress _, next) ->
+      rev_compress_log (r::log) next
+  | Change (_, next) ->
+      rev_compress_log log next
+
+let undo_compress (changes, _old) =
+  match !changes with
+    Unchanged
+  | Invalid -> ()
+  | Change _ ->
+      let log = rev_compress_log [] changes in
+      List.iter
+        (fun r -> match !r with
+          Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
+            ty.desc <- desc; r := !next
+        | _ -> ())
+        log
diff --git a/typing/btype.mli b/typing/btype.mli
new file mode 100644
index 00000000..aaa426a8
--- /dev/null
+++ b/typing/btype.mli
@@ -0,0 +1,221 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic operations on core types *)
+
+open Asttypes
+open Types
+
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
+val generic_level: int
+
+val newty2: int -> type_desc -> type_expr
+        (* Create a type *)
+val newgenty: type_desc -> type_expr
+        (* Create a generic type *)
+val newgenvar: ?name:string -> unit -> type_expr
+        (* Return a fresh generic variable *)
+
+(* Use Tsubst instead
+val newmarkedvar: int -> type_expr
+        (* Return a fresh marked variable *)
+val newmarkedgenvar: unit -> type_expr
+        (* Return a fresh marked generic variable *)
+*)
+
+(**** Types ****)
+
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
+val dummy_method: label
+val default_mty: module_type option -> module_type
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val field_kind_repr: field_kind -> field_kind
+        (* Return the canonical representative of an object field
+           kind. *)
+
+val commu_repr: commutable -> commutable
+        (* Return the canonical representative of a commutation lock *)
+
+(**** polymorphic variants ****)
+
+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 *)
+val row_fixed: row_desc -> bool
+        (* Return whether the row should be treated as fixed or not *)
+val static_row: row_desc -> bool
+        (* Return whether the row is static or not *)
+val hash_variant: label -> int
+        (* Hash function for variant tags *)
+
+val proxy: type_expr -> type_expr
+        (* Return the proxy representative of the type: either itself
+           or a row variable *)
+
+(**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
+
+(**** Utilities for type traversal ****)
+
+val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
+        (* Iteration on types *)
+val iter_row: (type_expr -> unit) -> row_desc -> unit
+        (* Iteration on types in a row *)
+val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
+        (* Iteration on types in an abbreviation list *)
+
+type type_iterators =
+  { it_signature: type_iterators -> signature -> unit;
+    it_signature_item: type_iterators -> signature_item -> unit;
+    it_value_description: type_iterators -> value_description -> unit;
+    it_type_declaration: type_iterators -> type_declaration -> unit;
+    it_extension_constructor: type_iterators -> extension_constructor -> unit;
+    it_module_declaration: type_iterators -> module_declaration -> unit;
+    it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
+    it_class_declaration: type_iterators -> class_declaration -> unit;
+    it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
+    it_module_type: type_iterators -> module_type -> unit;
+    it_class_type: type_iterators -> class_type -> unit;
+    it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
+    it_type_expr: type_iterators -> type_expr -> unit;
+    it_path: Path.t -> unit; }
+val type_iterators: type_iterators
+        (* Iteration on arbitrary type information.
+           [it_type_expr] calls [mark_type_node] to avoid loops. *)
+val unmark_iterators: type_iterators
+        (* Unmark any structure containing types. See [unmark_type] below. *)
+
+val copy_type_desc:
+    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
+        (* Copy on types *)
+val copy_row:
+    (type_expr -> type_expr) ->
+    bool -> row_desc -> bool -> type_expr -> row_desc
+val copy_kind: field_kind -> field_kind
+
+val save_desc: type_expr -> type_desc -> unit
+        (* Save a type description *)
+val dup_kind: field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
+val cleanup_types: unit -> unit
+        (* Restore type descriptions *)
+
+val lowest_level: int
+        (* Marked type: ty.level < lowest_level *)
+val pivot_level: int
+        (* Type marking: ty.level <- pivot_level - ty.level *)
+val mark_type: type_expr -> unit
+        (* Mark a type *)
+val mark_type_node: type_expr -> unit
+        (* Mark a type node (but not its sons) *)
+val mark_type_params: type_expr -> unit
+        (* Mark the sons of a type node *)
+val unmark_type: type_expr -> unit
+val unmark_type_decl: type_declaration -> unit
+val unmark_extension_constructor: extension_constructor -> unit
+val unmark_class_type: class_type -> unit
+val unmark_class_signature: class_signature -> unit
+        (* Remove marks from a type *)
+
+(**** Memorization of abbreviation expansion ****)
+
+val find_expans: private_flag -> 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
+           function MUST be called just before. *)
+val memorize_abbrev:
+        abbrev_memo ref ->
+        private_flag -> Path.t -> type_expr -> type_expr -> unit
+        (* Add an expansion in the cache *)
+val forget_abbrev:
+        abbrev_memo ref -> Path.t -> unit
+        (* Remove an abbreviation from the cache *)
+
+(**** Utilities for labels ****)
+
+val is_optional : arg_label -> bool
+val label_name : arg_label -> label
+
+(* Returns the label name with first character '?' or '~' as appropriate. *)
+val prefixed_label_name : arg_label -> label
+
+val extract_label :
+    label -> (arg_label * 'a) list ->
+    arg_label * 'a * (arg_label * 'a) list * (arg_label * 'a) list
+    (* actual label, value, before list, after list *)
+
+(**** Utilities for backtracking ****)
+
+type snapshot
+        (* A snapshot for backtracking *)
+val snapshot: unit -> snapshot
+        (* Make a snapshot for later backtracking. Costs nothing *)
+val backtrack: snapshot -> unit
+        (* Backtrack to a given snapshot. Only possible if you have
+           not already backtracked to a previous snapshot.
+           Calls [cleanup_abbrev] internally *)
+val undo_compress: snapshot -> unit
+        (* Backtrack only path compression. Only meaningful if you have
+           not already backtracked to a previous snapshot.
+           Does not call [cleanup_abbrev] *)
+
+(* Functions to use when modifying a type (only Ctype?) *)
+val link_type: type_expr -> type_expr -> unit
+        (* Set the desc field of [t1] to [Tlink t2], logging the old
+           value if there is an active snapshot *)
+val set_level: type_expr -> int -> unit
+val set_name:
+    (Path.t * type_expr list) option ref ->
+    (Path.t * type_expr list) option -> unit
+val set_row_field: row_field option ref -> row_field -> unit
+val set_univar: type_expr option ref -> type_expr -> unit
+val set_kind: field_kind option ref -> field_kind -> unit
+val set_commu: commutable ref -> commutable -> unit
+val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
+        (* Set references, logging the old value *)
+val log_type: type_expr -> unit
+        (* Log the old value of a type, before modifying it by hand *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref
+
+val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit)
+
+val iter_type_expr_cstr_args: (type_expr -> unit) ->
+  (constructor_arguments -> unit)
+val map_type_expr_cstr_args: (type_expr -> type_expr) ->
+  (constructor_arguments -> constructor_arguments)
diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml
new file mode 100644
index 00000000..67795219
--- /dev/null
+++ b/typing/cmi_format.ml
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type pers_flags =
+  | Rectypes
+  | Deprecated of string
+  | Opaque
+  | Unsafe_string
+
+type error =
+    Not_an_interface of string
+  | Wrong_version_interface of string * string
+  | Corrupted_interface of string
+
+exception Error of error
+
+type cmi_infos = {
+    cmi_name : string;
+    cmi_sign : Types.signature_item list;
+    cmi_crcs : (string * Digest.t option) list;
+    cmi_flags : pers_flags list;
+}
+
+let input_cmi ic =
+  let (name, sign) = input_value ic in
+  let crcs = input_value ic in
+  let flags = input_value ic in
+  {
+      cmi_name = name;
+      cmi_sign = sign;
+      cmi_crcs = crcs;
+      cmi_flags = flags;
+    }
+
+let read_cmi filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer =
+      really_input_string ic (String.length Config.cmi_magic_number)
+    in
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      let pre_len = String.length Config.cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len
+          = String.sub Config.cmi_magic_number 0 pre_len then
+      begin
+        let msg =
+          if buffer < Config.cmi_magic_number then "an older" else "a newer" in
+        raise (Error (Wrong_version_interface (filename, msg)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
+    end;
+    let cmi = input_cmi ic in
+    close_in ic;
+    cmi
+  with End_of_file | Failure _ ->
+      close_in ic;
+      raise(Error(Corrupted_interface(filename)))
+    | Error e ->
+      close_in ic;
+      raise (Error e)
+
+let output_cmi filename oc cmi =
+(* beware: the provided signature must have been substituted for saving *)
+  output_string oc Config.cmi_magic_number;
+  output_value oc (cmi.cmi_name, cmi.cmi_sign);
+  flush oc;
+  let crc = Digest.file filename in
+  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
+  output_value oc crcs;
+  output_value oc cmi.cmi_flags;
+  crc
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Not_an_interface filename ->
+      fprintf ppf "%a@ is not a compiled interface"
+        Location.print_filename filename
+  | Wrong_version_interface (filename, older_newer) ->
+      fprintf ppf
+        "%a@ is not a compiled interface for this version of OCaml.@.\
+         It seems to be for %s version of OCaml."
+        Location.print_filename filename older_newer
+  | Corrupted_interface filename ->
+      fprintf ppf "Corrupted compiled interface@ %a"
+        Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli
new file mode 100644
index 00000000..d36612b1
--- /dev/null
+++ b/typing/cmi_format.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type pers_flags =
+  | Rectypes
+  | Deprecated of string
+  | Opaque
+  | Unsafe_string
+
+type cmi_infos = {
+    cmi_name : string;
+    cmi_sign : Types.signature_item list;
+    cmi_crcs : (string * Digest.t option) list;
+    cmi_flags : pers_flags list;
+}
+
+(* write the magic + the cmi information *)
+val output_cmi : string -> out_channel -> cmi_infos -> Digest.t
+
+(* read the cmi information (the magic is supposed to have already been read) *)
+val input_cmi : in_channel -> cmi_infos
+
+(* read a cmi from a filename, checking the magic *)
+val read_cmi : string -> cmi_infos
+
+(* Error report *)
+
+type error =
+    Not_an_interface of string
+  | Wrong_version_interface of string * string
+  | Corrupted_interface of string
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml
new file mode 100644
index 00000000..56cfba39
--- /dev/null
+++ b/typing/cmt_format.ml
@@ -0,0 +1,195 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cmi_format
+open Typedtree
+
+(* Note that in Typerex, there is an awful hack to save a cmt file
+   together with the interface file that was generated by ocaml (this
+   is because the installed version of ocaml might differ from the one
+   integrated in Typerex).
+*)
+
+
+
+let read_magic_number ic =
+  let len_magic_number = String.length Config.cmt_magic_number in
+  really_input_string ic len_magic_number
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+| Partial_structure of structure
+| Partial_structure_item of structure_item
+| Partial_expression of expression
+| Partial_pattern of pattern
+| Partial_class_expr of class_expr
+| Partial_signature of signature
+| Partial_signature_item of signature_item
+| Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : string;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : Digest.t option;
+  cmt_initial_env : Env.t;
+  cmt_imports : (string * Digest.t option) list;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+let need_to_clear_env =
+  try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
+  with Not_found -> true
+
+let keep_only_summary = Env.keep_only_summary
+
+open Tast_mapper
+
+let cenv =
+  {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
+
+let clear_part = function
+  | Partial_structure s -> Partial_structure (cenv.structure cenv s)
+  | Partial_structure_item s ->
+      Partial_structure_item (cenv.structure_item cenv s)
+  | Partial_expression e -> Partial_expression (cenv.expr cenv e)
+  | Partial_pattern p -> Partial_pattern (cenv.pat cenv p)
+  | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
+  | Partial_signature s -> Partial_signature (cenv.signature cenv s)
+  | Partial_signature_item s ->
+      Partial_signature_item (cenv.signature_item cenv s)
+  | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s)
+
+let clear_env binary_annots =
+  if need_to_clear_env then
+    match binary_annots with
+    | Implementation s -> Implementation (cenv.structure cenv s)
+    | Interface s -> Interface (cenv.signature cenv s)
+    | Packed _ -> binary_annots
+    | Partial_implementation array ->
+        Partial_implementation (Array.map clear_part array)
+    | Partial_interface array ->
+        Partial_interface (Array.map clear_part array)
+
+  else binary_annots
+
+exception Error of error
+
+let input_cmt ic = (input_value ic : cmt_infos)
+
+let output_cmt oc cmt =
+  output_string oc Config.cmt_magic_number;
+  output_value oc (cmt : cmt_infos)
+
+let read filename =
+(*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
+  let ic = open_in_bin filename in
+  try
+    let magic_number = read_magic_number ic in
+    let cmi, cmt =
+      if magic_number = Config.cmt_magic_number then
+        None, Some (input_cmt ic)
+      else if magic_number = Config.cmi_magic_number then
+        let cmi = Cmi_format.input_cmi ic in
+        let cmt = try
+                    let magic_number = read_magic_number ic in
+                    if magic_number = Config.cmt_magic_number then
+                      let cmt = input_cmt ic in
+                      Some cmt
+                    else None
+          with _ -> None
+        in
+        Some cmi, cmt
+      else
+        raise(Cmi_format.Error(Cmi_format.Not_an_interface filename))
+    in
+    close_in ic;
+(*    Printf.fprintf stderr "Cmt_format.read done\n%!"; *)
+    cmi, cmt
+  with e ->
+    close_in ic;
+    raise e
+
+let read_cmt filename =
+  match read filename with
+      _, None -> raise (Error (Not_a_typedtree filename))
+    | _, Some cmt -> cmt
+
+let read_cmi filename =
+  match read filename with
+      None, _ ->
+        raise (Cmi_format.Error (Cmi_format.Not_an_interface filename))
+    | Some cmi, _ -> cmi
+
+let saved_types = ref []
+let value_deps = ref []
+
+let clear () =
+  saved_types := [];
+  value_deps := []
+
+let add_saved_type b = saved_types := b :: !saved_types
+let get_saved_types () = !saved_types
+let set_saved_types l = saved_types := l
+
+let record_value_dependency vd1 vd2 =
+  if vd1.Types.val_loc <> vd2.Types.val_loc then
+    value_deps := (vd1, vd2) :: !value_deps
+
+let save_cmt filename modname binary_annots sourcefile initial_env cmi =
+  if !Clflags.binary_annotations && not !Clflags.print_types then begin
+    let oc = open_out_bin filename in
+    let this_crc =
+      match cmi with
+      | None -> None
+      | Some cmi -> Some (output_cmi filename oc cmi)
+    in
+    let source_digest = Misc.may_map Digest.file sourcefile in
+    let cmt = {
+      cmt_modname = modname;
+      cmt_annots = clear_env binary_annots;
+      cmt_value_dependencies = !value_deps;
+      cmt_comments = Lexer.comments ();
+      cmt_args = Sys.argv;
+      cmt_sourcefile = sourcefile;
+      cmt_builddir =  Sys.getcwd ();
+      cmt_loadpath = !Config.load_path;
+      cmt_source_digest = source_digest;
+      cmt_initial_env = if need_to_clear_env then
+          keep_only_summary initial_env else initial_env;
+      cmt_imports = List.sort compare (Env.imports ());
+      cmt_interface_digest = this_crc;
+      cmt_use_summaries = need_to_clear_env;
+    } in
+    output_cmt oc cmt;
+    close_out oc;
+  end;
+  clear ()
diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli
new file mode 100644
index 00000000..617bc1ed
--- /dev/null
+++ b/typing/cmt_format.mli
@@ -0,0 +1,121 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** cmt and cmti files format. *)
+
+(** The layout of a cmt file is as follows:
+       := \{\}  \{cmt infos\} \{\}
+    where  is the cmi file format:
+       :=  .
+    More precisely, the optional  part must be present if and only if
+    the file is:
+    - a cmti, or
+    - a cmt, for a ml file which has no corresponding mli (hence no
+    corresponding cmti).
+
+    Thus, we provide a common reading function for cmi and cmt(i)
+    files which returns an option for each of the three parts: cmi
+    info, cmt info, source info. *)
+
+open Typedtree
+
+type binary_annots =
+  | Packed of Types.signature * string list
+  | Implementation of structure
+  | Interface of signature
+  | Partial_implementation of binary_part array
+  | Partial_interface of binary_part array
+
+and binary_part =
+  | Partial_structure of structure
+  | Partial_structure_item of structure_item
+  | Partial_expression of expression
+  | Partial_pattern of pattern
+  | Partial_class_expr of class_expr
+  | Partial_signature of signature
+  | Partial_signature_item of signature_item
+  | Partial_module_type of module_type
+
+type cmt_infos = {
+  cmt_modname : string;
+  cmt_annots : binary_annots;
+  cmt_value_dependencies :
+    (Types.value_description * Types.value_description) list;
+  cmt_comments : (string * Location.t) list;
+  cmt_args : string array;
+  cmt_sourcefile : string option;
+  cmt_builddir : string;
+  cmt_loadpath : string list;
+  cmt_source_digest : string option;
+  cmt_initial_env : Env.t;
+  cmt_imports : (string * Digest.t option) list;
+  cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
+}
+
+type error =
+    Not_a_typedtree of string
+
+exception Error of error
+
+(** [read filename] opens filename, and extract both the cmi_infos, if
+    it exists, and the cmt_infos, if it exists. Thus, it can be used
+    with .cmi, .cmt and .cmti files.
+
+    .cmti files always contain a cmi_infos at the beginning. .cmt files
+    only contain a cmi_infos at the beginning if there is no associated
+    .cmti file.
+*)
+val read : string -> Cmi_format.cmi_infos option * cmt_infos option
+
+val read_cmt : string -> cmt_infos
+val read_cmi : string -> Cmi_format.cmi_infos
+
+(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
+    writes a cmt(i) file.  *)
+val save_cmt :
+  string ->  (* filename.cmt to generate *)
+  string ->  (* module name *)
+  binary_annots ->
+  string option ->  (* source file *)
+  Env.t -> (* initial env *)
+  Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
+  unit
+
+(* Miscellaneous functions *)
+
+val read_magic_number : in_channel -> string
+
+val clear: unit -> unit
+
+val add_saved_type : binary_part -> unit
+val get_saved_types : unit -> binary_part list
+val set_saved_types : binary_part list -> unit
+
+val record_value_dependency:
+  Types.value_description -> Types.value_description -> unit
+
+
+(*
+
+  val is_magic_number : string -> bool
+  val read : in_channel -> Env.cmi_infos option * t
+  val write_magic_number : out_channel -> unit
+  val write : out_channel -> t -> unit
+
+  val find : string list -> string -> string
+  val read_signature : 'a -> string -> Types.signature * 'b list * 'c list
+
+*)
diff --git a/typing/ctype.ml b/typing/ctype.ml
new file mode 100644
index 00000000..3135e4a2
--- /dev/null
+++ b/typing/ctype.ml
@@ -0,0 +1,4549 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Misc
+open Asttypes
+open Types
+open Btype
+
+(*
+   Type manipulation after type inference
+   ======================================
+   If one wants to manipulate a type after type inference (for
+   instance, during code generation or in the debugger), one must
+   first make sure that the type levels are correct, using the
+   function [correct_levels]. Then, this type can be correctely
+   manipulated by [apply], [expand_head] and [moregeneral].
+*)
+
+(*
+   General notes
+   =============
+   - As much sharing as possible should be kept : it makes types
+     smaller and better abbreviated.
+     When necessary, some sharing can be lost. Types will still be
+     printed correctly (+++ TO DO...), and abbreviations defined by a
+     class do not depend on sharing thanks to constrained
+     abbreviations. (Of course, even if some sharing is lost, typing
+     will still be correct.)
+   - All nodes of a type have a level : that way, one know whether a
+     node need to be duplicated or not when instantiating a type.
+   - Levels of a type are decreasing (generic level being considered
+     as greatest).
+   - The level of a type constructor is superior to the binding
+     time of its path.
+   - Recursive types without limitation should be handled (even if
+     there is still an occur check). This avoid treating specially the
+     case for objects, for instance. Furthermore, the occur check
+     policy can then be easily changed.
+*)
+
+(**** Errors ****)
+
+exception Unify of (type_expr * type_expr) list
+
+exception Tags of label * label
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Tags (l, l') ->
+          Some
+            Location.
+              (errorf ~loc:(in_file !input_name)
+                 "In this program,@ variant constructors@ `%s and `%s@ \
+                  have the same hash value.@ Change one of them." l l'
+              )
+      | _ -> None
+    )
+
+exception Subtype of
+        (type_expr * type_expr) list * (type_expr * type_expr) list
+
+exception Cannot_expand
+
+exception Cannot_apply
+
+exception Recursive_abbrev
+
+(* GADT: recursive abbrevs can appear as a result of local constraints *)
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
+
+(**** Type level management ****)
+
+let current_level = ref 0
+let nongen_level = ref 0
+let global_level = ref 1
+let saved_level = ref []
+
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+let save_levels () =
+  { current_level = !current_level;
+    nongen_level = !nongen_level;
+    global_level = !global_level;
+    saved_level = !saved_level }
+let set_levels l =
+  current_level := l.current_level;
+  nongen_level := l.nongen_level;
+  global_level := l.global_level;
+  saved_level := l.saved_level
+
+let get_current_level () = !current_level
+let init_def level = current_level := level; nongen_level := level
+let begin_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level; nongen_level := !current_level
+let begin_class_def () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  incr current_level
+let raise_nongen_level () =
+  saved_level := (!current_level, !nongen_level) :: !saved_level;
+  nongen_level := !current_level
+let end_def () =
+  let (cl, nl) = List.hd !saved_level in
+  saved_level := List.tl !saved_level;
+  current_level := cl; nongen_level := nl
+
+let reset_global_level () =
+  global_level := !current_level + 1
+let increase_global_level () =
+  let gl = !global_level in
+  global_level := !current_level;
+  gl
+let restore_global_level gl =
+  global_level := gl
+
+(**** Whether a path points to an object type (with hidden row variable) ****)
+let is_object_type path =
+  let name =
+    match path with Path.Pident id -> Ident.name id
+    | Path.Pdot(_, s,_) -> s
+    | Path.Papply _ -> assert false
+  in name.[0] = '#'
+
+(**** Control tracing of GADT instances *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
+let reset_trace_gadt_instances b =
+  if b then trace_gadt_instances := false
+
+let wrap_trace_gadt_instances env f x =
+  let b = check_trace_gadt_instances env in
+  let y = f x in
+  reset_trace_gadt_instances b;
+  y
+
+(**** Abbreviations without parameters ****)
+(* Shall reset after generalizing *)
+
+let simple_abbrevs = ref Mnil
+
+let proper_abbrevs path tl abbrev =
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
+  else simple_abbrevs
+
+(**** Some type creators ****)
+
+(* Re-export generic type creators *)
+
+let newty2             = Btype.newty2
+let newty desc         = newty2 !current_level desc
+
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
+
+let newobj fields      = newty (Tobject (fields, ref None))
+
+let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+
+let none = newty (Ttuple [])                (* Clearly ill-formed type *)
+
+(**** Representative of a type ****)
+
+(* Re-export repr *)
+let repr = repr
+
+(**** Type maps ****)
+
+module TypePairs =
+  Hashtbl.Make (struct
+    type t = type_expr * type_expr
+    let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2')
+    let hash (t, t') = t.id + 93 * t'.id
+ end)
+
+
+(**** unification mode ****)
+
+type unification_mode =
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+let umode = ref Expression
+let generate_equations = ref false
+let assume_injective = ref false
+
+let set_mode_pattern ~generate ~injective f =
+  let old_unification_mode = !umode
+  and old_gen = !generate_equations
+  and old_inj = !assume_injective in
+  try
+    umode := Pattern;
+    generate_equations := generate;
+    assume_injective := injective;
+    let ret = f () in
+    umode := old_unification_mode;
+    generate_equations := old_gen;
+    assume_injective := old_inj;
+    ret
+  with e ->
+    umode := old_unification_mode;
+    generate_equations := old_gen;
+    assume_injective := old_inj;
+    raise e
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p =
+  in_current_module p &&
+  try ignore (Env.find_type p Env.initial_safe_string); true
+  with Not_found -> false
+
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ | Type_open -> true
+  | Type_abstract -> false
+
+
+                  (**********************************************)
+                  (*  Miscellaneous operations on object types  *)
+                  (**********************************************)
+
+(* Note:
+   We need to maintain some invariants:
+   * cty_self must be a Tobject
+   * ...
+*)
+
+(**** Object field manipulation. ****)
+
+let object_fields ty =
+  match (repr ty).desc with
+    Tobject (fields, _) -> fields
+  | _                   -> assert false
+
+let flatten_fields ty =
+  let rec flatten l ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield(s, k, ty1, ty2) ->
+        flatten ((s, k, ty1)::l) ty2
+    | _ ->
+        (l, ty)
+  in
+    let (l, r) = flatten [] ty in
+    (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r)
+
+let build_fields level =
+  List.fold_right
+    (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2)))
+
+let associate_fields fields1 fields2 =
+  let rec associate p s s' =
+    function
+      (l, []) ->
+        (List.rev p, (List.rev s) @ l, List.rev s')
+    | ([], l') ->
+        (List.rev p, List.rev s, (List.rev s') @ l')
+    | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
+        associate ((n, k, t, k', t')::p) s s' (r, r')
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
+        associate p ((n, k, t)::s) s' (r, l')
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
+        associate p s ((n', k', t')::s') (l, r')
+  in
+  associate [] [] [] (fields1, fields2)
+
+(**** Check whether an object is open ****)
+
+(* +++ The abbreviation should eventually be expanded *)
+let rec object_row ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tobject (t, _)     -> object_row t
+  | Tfield(_, _, _, t) -> object_row t
+  | _ -> ty
+
+let opened_object ty =
+  match (object_row ty).desc with
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
+
+(**** Close an object ****)
+
+let close_object ty =
+  let rec close ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tvar _ ->
+        link_type ty (newty2 ty.level Tnil)
+    | Tfield(_, _, _, ty') -> close ty'
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (ty, _)   -> close ty
+  | _                 -> assert false
+
+(**** Row variable of an object type ****)
+
+let row_variable ty =
+  let rec find ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tfield (_, _, _, ty) -> find ty
+    | Tvar _               -> ty
+    | _                    -> assert false
+  in
+  match (repr ty).desc with
+    Tobject (fi, _) -> find fi
+  | _               -> assert false
+
+(**** Object name manipulation ****)
+(* +++ Bientot obsolete *)
+
+let set_object_name id rv params ty =
+  match (repr ty).desc with
+    Tobject (_fi, nm) ->
+      set_name nm (Some (Path.Pident id, rv::params))
+  | _ ->
+      assert false
+
+let remove_object_name ty =
+  match (repr ty).desc with
+    Tobject (_, nm)   -> set_name nm None
+  | Tconstr (_, _, _) -> ()
+  | _                 -> fatal_error "Ctype.remove_object_name"
+
+(**** Hiding of private methods ****)
+
+let hide_private_methods ty =
+  match (repr ty).desc with
+    Tobject (fi, nm) ->
+      nm := None;
+      let (fl, _) = flatten_fields fi in
+      List.iter
+        (function (_, k, _) ->
+          match field_kind_repr k with
+            Fvar r -> set_kind r Fabsent
+          | _      -> ())
+        fl
+  | _ ->
+      assert false
+
+
+                              (*******************************)
+                              (*  Operations on class types  *)
+                              (*******************************)
+
+
+let rec signature_of_class_type =
+  function
+    Cty_constr (_, _, cty) -> signature_of_class_type cty
+  | Cty_signature sign     -> sign
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
+
+let self_type cty =
+  repr (signature_of_class_type cty).csig_self
+
+let rec class_type_arity =
+  function
+    Cty_constr (_, _, cty) ->  class_type_arity cty
+  | Cty_signature _        ->  0
+  | Cty_arrow (_, _, cty)    ->  1 + class_type_arity cty
+
+
+                  (*******************************************)
+                  (*  Miscellaneous operations on row types  *)
+                  (*******************************************)
+
+let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q)
+
+let rec merge_rf r1 r2 pairs fi1 fi2 =
+  match fi1, fi2 with
+    (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
+      if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
+      if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else
+      merge_rf r1 (p2::r2) pairs fi1 fi2'
+  | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
+  | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
+
+let merge_row_fields fi1 fi2 =
+  match fi1, fi2 with
+    [], _ | _, [] -> (fi1, fi2, [])
+  | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, [])
+  | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, [])
+  | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)
+
+let rec filter_row_fields erase = function
+    [] -> []
+  | (_l,f as p)::fi ->
+      let fi = filter_row_fields erase fi in
+      match row_field_repr f with
+        Rabsent -> fi
+      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
+      | _ -> p :: fi
+
+                    (**************************************)
+                    (*  Check genericity of type schemes  *)
+                    (**************************************)
+
+
+exception Non_closed of type_expr * bool
+
+let free_variables = ref []
+let really_closed = ref None
+
+let rec free_vars_rec real ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    begin match ty.desc, !really_closed with
+      Tvar _, _ ->
+        free_variables := (ty, real) :: !free_variables
+    | Tconstr (path, tl, _), Some env ->
+        begin try
+          let (_, body, _) = Env.find_type_expansion path env in
+          if (repr body).level <> generic_level then
+            free_variables := (ty, real) :: !free_variables
+        with Not_found -> ()
+        end;
+        List.iter (free_vars_rec true) tl
+(* Do not count "virtual" free variables
+    | Tobject(ty, {contents = Some (_, p)}) ->
+        free_vars_rec false ty; List.iter (free_vars_rec true) p
+*)
+    | Tobject (ty, _), _ ->
+        free_vars_rec false ty
+    | Tfield (_, _, ty1, ty2), _ ->
+        free_vars_rec true ty1; free_vars_rec false ty2
+    | Tvariant row, _ ->
+        let row = row_repr row in
+        iter_row (free_vars_rec true) row;
+        if not (static_row row) then free_vars_rec false row.row_more
+    | _    ->
+        iter_type_expr (free_vars_rec true) ty
+    end;
+  end
+
+let free_vars ?env ty =
+  free_variables := [];
+  really_closed := env;
+  free_vars_rec true ty;
+  let res = !free_variables in
+  free_variables := [];
+  really_closed := None;
+  res
+
+let free_variables ?env ty =
+  let tl = List.map fst (free_vars ?env ty) in
+  unmark_type ty;
+  tl
+
+let closed_type ty =
+  match free_vars ty with
+      []           -> ()
+  | (v, real) :: _ -> raise (Non_closed (v, real))
+
+let closed_parameterized_type params ty =
+  List.iter mark_type params;
+  let ok =
+    try closed_type ty; true with Non_closed _ -> false in
+  List.iter unmark_type params;
+  unmark_type ty;
+  ok
+
+let closed_type_decl decl =
+  try
+    List.iter mark_type decl.type_params;
+    begin match decl.type_kind with
+      Type_abstract ->
+        ()
+    | Type_variant v ->
+        List.iter
+          (fun {cd_args; cd_res; _} ->
+            match cd_res with
+            | Some _ -> ()
+            | None ->
+                match cd_args with
+                | Cstr_tuple l ->  List.iter closed_type l
+                | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
+          )
+          v
+    | Type_record(r, _rep) ->
+        List.iter (fun l -> closed_type l.ld_type) r
+    | Type_open -> ()
+    end;
+    begin match decl.type_manifest with
+      None    -> ()
+    | Some ty -> closed_type ty
+    end;
+    unmark_type_decl decl;
+    None
+  with Non_closed (ty, _) ->
+    unmark_type_decl decl;
+    Some ty
+
+let closed_extension_constructor ext =
+  try
+    List.iter mark_type ext.ext_type_params;
+    begin match ext.ext_ret_type with
+    | Some _ -> ()
+    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
+    end;
+    unmark_extension_constructor ext;
+    None
+  with Non_closed (ty, _) ->
+    unmark_extension_constructor ext;
+    Some ty
+
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+
+exception CCFailure of closed_class_failure
+
+let closed_class params sign =
+  let ty = object_fields (repr sign.csig_self) in
+  let (fields, rest) = flatten_fields ty in
+  List.iter mark_type params;
+  mark_type rest;
+  List.iter
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
+    fields;
+  try
+    mark_type_node (repr sign.csig_self);
+    List.iter
+      (fun (lab, kind, ty) ->
+        if field_kind_repr kind = Fpresent then
+        try closed_type ty with Non_closed (ty0, real) ->
+          raise (CCFailure (CC_Method (ty0, real, lab, ty))))
+      fields;
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    None
+  with CCFailure reason ->
+    mark_type_params (repr sign.csig_self);
+    List.iter unmark_type params;
+    unmark_class_signature sign;
+    Some reason
+
+
+                            (**********************)
+                            (*  Type duplication  *)
+                            (**********************)
+
+
+(* Duplicate a type, preserving only type variables *)
+let duplicate_type ty =
+  Subst.type_expr Subst.identity ty
+
+(* Same, for class types *)
+let duplicate_class_type ty =
+  Subst.class_type Subst.identity ty
+
+
+                         (*****************************)
+                         (*  Type level manipulation  *)
+                         (*****************************)
+
+(*
+   It would be a bit more efficient to remove abbreviation expansions
+   rather than generalizing them: these expansions will usually not be
+   used anymore. However, this is not possible in the general case, as
+   [expand_abbrev] (via [subst]) requires these expansions to be
+   preserved. Does it worth duplicating this code ?
+*)
+let rec generalize ty =
+  let ty = repr ty in
+  if (ty.level > !current_level) && (ty.level <> generic_level) then begin
+    set_level ty generic_level;
+    begin match ty.desc with
+      Tconstr (_, _, abbrev) ->
+        iter_abbrev generalize !abbrev
+    | _ -> ()
+    end;
+    iter_type_expr generalize ty
+  end
+
+let generalize ty =
+  simple_abbrevs := Mnil;
+  generalize ty
+
+(* Generalize the structure and lower the variables *)
+
+let rec generalize_structure var_level ty =
+  let ty = repr ty in
+  if ty.level <> generic_level then begin
+    if is_Tvar ty && ty.level > var_level then
+      set_level ty var_level
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
+      set_level ty generic_level;
+      iter_type_expr (generalize_structure var_level) ty
+    end
+  end
+
+let generalize_structure var_level ty =
+  simple_abbrevs := Mnil;
+  generalize_structure var_level ty
+
+(* Generalize the spine of a function, if the level >= !current_level *)
+
+let rec generalize_spine ty =
+  let ty = repr ty in
+  if ty.level < !current_level || ty.level = generic_level then () else
+  match ty.desc with
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
+      set_level ty generic_level;
+      generalize_spine ty'
+  | Ttuple tyl
+  | Tpackage (_, _, tyl) ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
+  | _ -> ()
+
+let forward_try_expand_once = (* Forward declaration *)
+  ref (fun _env _ty -> raise Cannot_expand)
+
+(*
+   Lower the levels of a type (assume [level] is not
+   [generic_level]).
+*)
+(*
+    The level of a type constructor must be greater than its binding
+    time. That way, a type constructor cannot escape the scope of its
+    definition, as would be the case in
+      let x = ref []
+      module M = struct type t let _ = (x : t list ref) end
+    (without this constraint, the type system would actually be unsound.)
+*)
+let get_level env p =
+  try
+    match (Env.find_type p env).type_newtype_level with
+      | None -> Path.binding_time p
+      | Some (x, _) -> x
+  with
+    | Not_found ->
+      (* no newtypes in predef *)
+      Path.binding_time p
+
+let rec normalize_package_path env p =
+  let t =
+    try (Env.find_modtype p env).mtd_type
+    with Not_found -> None
+  in
+  match t with
+  | Some (Mty_ident p) -> normalize_package_path env p
+  | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None ->
+      match p with
+        Path.Pdot (p1, s, n) ->
+          (* For module aliases *)
+          let p1' = Env.normalize_path None env p1 in
+          if Path.same p1 p1' then p else
+          normalize_package_path env (Path.Pdot (p1', s, n))
+      | _ -> p
+
+let rec update_level env level ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    begin match Env.gadt_instance_level env ty with
+      Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
+    | None -> ()
+    end;
+    match ty.desc with
+      Tconstr(p, _tl, _abbrev) when level < get_level env p ->
+        (* Try first to replace an abbreviation by its expansion. *)
+        begin try
+          (* if is_newtype env p then raise Cannot_expand; *)
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level ty
+        with Cannot_expand ->
+          (* +++ Levels should be restored... *)
+          (* Format.printf "update_level: %i < %i@." level (get_level env p); *)
+          if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
+          iter_type_expr (update_level env level) ty
+        end
+    | Tpackage (p, nl, tl) when level < Path.binding_time p ->
+        let p' = normalize_package_path env p in
+        if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
+        log_type ty; ty.desc <- Tpackage (p', nl, tl);
+        update_level env level ty
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
+      when level < get_level env p ->
+        set_name nm None;
+        update_level env level ty
+    | Tvariant row ->
+        let row = row_repr row in
+        begin match row.row_name with
+        | Some (p, _tl) when level < get_level env p ->
+            log_type ty;
+            ty.desc <- Tvariant {row with row_name = None}
+        | _ -> ()
+        end;
+        set_level ty level;
+        iter_type_expr (update_level env level) ty
+    | Tfield(lab, _, ty1, _)
+      when lab = dummy_method && (repr ty1).level > level ->
+        raise (Unify [(ty1, newvar2 level)])
+    | _ ->
+        set_level ty level;
+        (* XXX what about abbreviations in Tconstr ? *)
+        iter_type_expr (update_level env level) ty
+  end
+
+(* Generalize and lower levels of contravariant branches simultaneously *)
+
+let rec generalize_expansive env var_level visited ty =
+  let ty = repr ty in
+  if ty.level = generic_level || ty.level <= var_level then () else
+  if not (Hashtbl.mem visited ty.id) then begin
+    Hashtbl.add visited ty.id ();
+    match ty.desc with
+      Tconstr (path, tyl, abbrev) ->
+        let variance =
+          try (Env.find_type path env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
+        abbrev := Mnil;
+        List.iter2
+          (fun v t ->
+            if Variance.(mem May_weak v)
+            then generalize_structure var_level t
+            else generalize_expansive env var_level visited t)
+          variance tyl
+    | Tpackage (_, _, tyl) ->
+        List.iter (generalize_structure var_level) tyl
+    | Tarrow (_, t1, t2, _) ->
+        generalize_structure var_level t1;
+        generalize_expansive env var_level visited t2
+    | _ ->
+        iter_type_expr (generalize_expansive env var_level visited) ty
+  end
+
+let generalize_expansive env ty =
+  simple_abbrevs := Mnil;
+  try
+    generalize_expansive env !nongen_level (Hashtbl.create 7) ty
+  with Unify ([_, ty'] as tr) ->
+    raise (Unify ((ty, ty') :: tr))
+
+let generalize_global ty = generalize_structure !global_level ty
+let generalize_structure ty = generalize_structure !current_level ty
+
+(* Correct the levels of type [ty]. *)
+let correct_levels ty =
+  duplicate_type ty
+
+(* Only generalize the type ty0 in ty *)
+let limited_generalize ty0 ty =
+  let ty0 = repr ty0 in
+
+  let graph = Hashtbl.create 17 in
+  let idx = ref lowest_level in
+  let roots = ref [] in
+
+  let rec inverse pty ty =
+    let ty = repr ty in
+    if (ty.level > !current_level) || (ty.level = generic_level) then begin
+      decr idx;
+      Hashtbl.add graph !idx (ty, ref pty);
+      if (ty.level = generic_level) || (ty == ty0) then
+        roots := ty :: !roots;
+      set_level ty !idx;
+      iter_type_expr (inverse [ty]) ty
+    end else if ty.level < lowest_level then begin
+      let (_, parents) = Hashtbl.find graph ty.level in
+      parents := pty @ !parents
+    end
+
+  and generalize_parents ty =
+    let idx = ty.level in
+    if idx <> generic_level then begin
+      set_level ty generic_level;
+      List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+      (* Special case for rows: must generalize the row variable *)
+      match ty.desc with
+        Tvariant row ->
+          let more = row_more row in
+          let lv = more.level in
+          if (lv < lowest_level || lv > !current_level)
+          && lv <> generic_level then set_level more generic_level
+      | _ -> ()
+    end
+  in
+
+  inverse [] ty;
+  if ty0.level < lowest_level then
+    iter_type_expr (inverse []) ty0;
+  List.iter generalize_parents !roots;
+  Hashtbl.iter
+    (fun _ (ty, _) ->
+       if ty.level <> generic_level then set_level ty !current_level)
+    graph
+
+
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
+                              (*******************)
+                              (*  Instantiation  *)
+                              (*******************)
+
+
+let rec find_repr p1 =
+  function
+    Mnil ->
+      None
+  | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 ->
+      Some ty
+  | Mcons (_, _, _, _, rem) ->
+      find_repr p1 rem
+  | Mlink {contents = rem} ->
+      find_repr p1 rem
+
+(*
+   Generic nodes are duplicated, while non-generic nodes are left
+   as-is.
+   During instantiation, the description of a generic node is first
+   replaced by a link to a stub ([Tsubst (newvar ())]). Once the
+   copy is made, it replaces the stub.
+   After instantiation, the description of generic node, which was
+   stored by [save_desc], must be put back, using [cleanup_types].
+*)
+
+let abbreviations = ref (ref Mnil)
+  (* Abbreviation memorized. *)
+
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?env ?partial ?keep_names ty =
+  let copy = copy ?env ?partial ?keep_names in
+  let ty = repr ty in
+  match ty.desc with
+    Tsubst ty -> ty
+  | _ ->
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
+    let desc = ty.desc in
+    save_desc ty desc;
+    let t = newvar() in          (* Stub *)
+    begin match env with
+      Some env when Env.has_local_constraints env ->
+        begin match Env.gadt_instance_level env ty with
+          Some lv -> Env.add_gadt_instances env lv [t]
+        | None -> ()
+        end
+    | _ -> ()
+    end;
+    ty.desc <- Tsubst t;
+    t.desc <-
+      begin match desc with
+      | Tconstr (p, tl, _) ->
+          let abbrevs = proper_abbrevs p tl !abbreviations in
+          begin match find_repr p !abbrevs with
+            Some ty when repr ty != t ->
+              Tlink ty
+          | _ ->
+          (*
+             One must allocate a new reference, so that abbrevia-
+             tions belonging to different branches of a type are
+             independent.
+             Moreover, a reference containing a [Mcons] must be
+             shared, so that the memorized expansion of an abbrevi-
+             ation can be released by changing the content of just
+             one reference.
+          *)
+              Tconstr (p, List.map copy tl,
+                       ref (match !(!abbreviations) with
+                              Mcons _ -> Mlink !abbreviations
+                            | abbrev  -> abbrev))
+          end
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst {desc = Ttuple [_;ty2]} ->
+              (* This variant type has been already copied *)
+              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              (* If the row variable is not generic, we must keep it *)
+              let keep = more.level <> generic_level in
+              let more' =
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ | Tnil ->
+                    if keep then save_desc more more.desc;
+                    copy more
+                | Tvar _ | Tunivar _ ->
+                    save_desc more more.desc;
+                    if keep then more else newty more.desc
+                |  _ -> assert false
+              in
+              let row =
+                match repr more' with (* PR#6163 *)
+                  {desc=Tconstr _} when not row.row_fixed ->
+                    {row with row_fixed = true}
+                | _ -> row
+              in
+              (* Open row if partial for pattern and contains Reither *)
+              let more', row =
+                match partial with
+                  Some (free_univars, false) ->
+                    let more' =
+                      if more.id != more'.id then more' else
+                      let lv = if keep then more.level else !current_level in
+                      newty2 lv (Tvar None)
+                    in
+                    let not_reither (_, f) =
+                      match row_field_repr f with
+                        Reither _ -> false
+                      | _ -> true
+                    in
+                    if row.row_closed && not row.row_fixed
+                    && TypeSet.is_empty (free_univars ty)
+                    && not (List.for_all not_reither row.row_fields) then
+                      (more',
+                       {row_fields = List.filter not_reither row.row_fields;
+                        row_more = more'; row_bound = ();
+                        row_closed = false; row_fixed = false; row_name = None})
+                    else (more', row)
+                | _ -> (more', row)
+              in
+              (* Register new type first for recursion *)
+              more.desc <- Tsubst(newgenty(Ttuple[more';t]));
+              (* Return a new copy *)
+              Tvariant (copy_row copy true row keep more')
+          end
+      | Tfield (_p, k, _ty1, ty2) ->
+          begin match field_kind_repr k with
+            Fabsent  -> Tlink (copy ty2)
+          | Fpresent -> copy_type_desc copy desc
+          | Fvar r ->
+              dup_kind r;
+              copy_type_desc copy desc
+          end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
+      | _ -> copy_type_desc ?keep_names copy desc
+      end;
+    t
+
+let simple_copy t = copy t
+
+(**** Variants of instantiations ****)
+
+let gadt_env env =
+  if Env.has_local_constraints env
+  then Some env
+  else None
+
+let instance ?partial env sch =
+  let env = gadt_env env in
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  let ty = copy ?env ?partial sch in
+  cleanup_types ();
+  ty
+
+let instance_def sch =
+  let ty = copy sch in
+  cleanup_types ();
+  ty
+
+let generic_instance env sch =
+  let old = !current_level in
+  current_level := generic_level;
+  let ty = instance env sch in
+  current_level := old;
+  ty
+
+let instance_list env schl =
+  let env = gadt_env env in
+  let tyl = List.map (fun t -> copy ?env t) schl in
+  cleanup_types ();
+  tyl
+
+let reified_var_counter = ref Vars.empty
+let reset_reified_var_counter () =
+  reified_var_counter := Vars.empty
+
+(* names given to new type constructors.
+   Used for existential types and
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
+  Printf.sprintf "%s%d" s index
+
+let new_declaration newtype manifest =
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_newtype_level = newtype;
+    type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = false;
+    type_unboxed = unboxed_false_default_false;
+  }
+
+let instance_constructor ?in_pattern cstr =
+  begin match in_pattern with
+  | None -> ()
+  | Some (env, newtype_lev) ->
+      let process existential =
+        let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
+        let name =
+          match repr existential with
+            {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
+          | _ -> "$" ^ cstr.cstr_name
+        in
+        let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+        let new_env = Env.add_local_type path decl !env in
+        env := new_env;
+        let to_unify = newty (Tconstr (path,[],ref Mnil)) in
+        let tv = copy existential in
+        assert (is_Tvar tv);
+        link_type tv to_unify
+      in
+      List.iter process cstr.cstr_existentials
+  end;
+  let ty_res = copy cstr.cstr_res in
+  let ty_args = List.map simple_copy  cstr.cstr_args in
+  cleanup_types ();
+  (ty_args, ty_res)
+
+let instance_parameterized_type ?keep_names sch_args sch =
+  let ty_args = List.map (fun t -> copy ?keep_names t) sch_args in
+  let ty = copy sch in
+  cleanup_types ();
+  (ty_args, ty)
+
+let instance_parameterized_type_2 sch_args sch_lst sch =
+  let ty_args = List.map simple_copy sch_args in
+  let ty_lst = List.map simple_copy sch_lst in
+  let ty = copy sch in
+  cleanup_types ();
+  (ty_args, ty_lst, ty)
+
+let map_kind f = function
+  | Type_abstract -> Type_abstract
+  | Type_open -> Type_open
+  | Type_variant cl ->
+      Type_variant (
+        List.map
+          (fun c ->
+             {c with
+              cd_args = map_type_expr_cstr_args f c.cd_args;
+              cd_res = may_map f c.cd_res
+             })
+          cl)
+  | Type_record (fl, rr) ->
+      Type_record (
+        List.map
+          (fun l ->
+             {l with ld_type = f l.ld_type}
+          ) fl, rr)
+
+
+let instance_declaration decl =
+  let decl =
+    {decl with type_params = List.map simple_copy decl.type_params;
+     type_manifest = may_map simple_copy decl.type_manifest;
+     type_kind = map_kind simple_copy decl.type_kind;
+    }
+  in
+  cleanup_types ();
+  decl
+
+let instance_class params cty =
+  let rec copy_class_type =
+    function
+      Cty_constr (path, tyl, cty) ->
+        Cty_constr (path, List.map simple_copy tyl, copy_class_type cty)
+    | Cty_signature sign ->
+        Cty_signature
+          {csig_self = copy sign.csig_self;
+           csig_vars =
+             Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.csig_vars;
+           csig_concr = sign.csig_concr;
+           csig_inher =
+             List.map (fun (p,tl) -> (p, List.map simple_copy tl))
+               sign.csig_inher}
+    | Cty_arrow (l, ty, cty) ->
+        Cty_arrow (l, copy ty, copy_class_type cty)
+  in
+  let params' = List.map simple_copy params in
+  let cty' = copy_class_type cty in
+  cleanup_types ();
+  (params', cty')
+
+(**** Instanciation for types with free universal variables ****)
+
+let rec diff_list l1 l2 =
+  if l1 == l2 then [] else
+  match l1 with [] -> invalid_arg "Ctype.diff_list"
+  | a :: l1 -> a :: diff_list l1 l2
+
+let conflicts free bound =
+  let bound = List.map repr bound in
+  TypeSet.exists (fun t -> List.memq (repr t) bound) free
+
+let delayed_copy = ref []
+    (* copying to do later *)
+
+(* Copy without sharing until there are no free univars left *)
+(* all free univars must be included in [visited]            *)
+let rec copy_sep fixed free bound visited ty =
+  let ty = repr ty in
+  let univars = free ty in
+  if TypeSet.is_empty univars then
+    if ty.level <> generic_level then ty else
+    let t = newvar () in
+    delayed_copy :=
+      lazy (t.desc <- Tlink (copy ty))
+      :: !delayed_copy;
+    t
+  else try
+    let t, bound_t = List.assq ty visited in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
+    if dl <> [] && conflicts univars dl then raise Not_found;
+    t
+  with Not_found -> begin
+    let t = newvar() in          (* Stub *)
+    let visited =
+      match ty.desc with
+        Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
+          (ty,(t,bound)) :: visited
+      | _ -> visited in
+    let copy_rec = copy_sep fixed free bound visited in
+    t.desc <-
+      begin match ty.desc with
+      | Tvariant row0 ->
+          let row = row_repr row0 in
+          let more = repr row.row_more in
+          (* We shall really check the level on the row variable *)
+          let keep = is_Tvar more && more.level <> generic_level in
+          let more' = copy_rec more in
+          let fixed' = fixed && is_Tvar (repr more') in
+          let row = copy_row copy_rec fixed' row keep more' in
+          Tvariant row
+      | Tpoly (t1, tl) ->
+          let tl = List.map repr tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
+          let bound = tl @ bound in
+          let visited =
+            List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
+          Tpoly (copy_sep fixed free bound visited t1, tl')
+      | _ -> copy_type_desc copy_rec ty.desc
+      end;
+    t
+  end
+
+let instance_poly ?(keep_names=false) fixed univars sch =
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
+  delayed_copy := [];
+  let ty = copy_sep fixed (compute_univars sch) [] pairs sch in
+  List.iter Lazy.force !delayed_copy;
+  delayed_copy := [];
+  cleanup_types ();
+  vars, ty
+
+let instance_label fixed lbl =
+  let ty_res = copy lbl.lbl_res in
+  let vars, ty_arg =
+    match repr lbl.lbl_arg with
+      {desc = Tpoly (ty, tl)} ->
+        instance_poly fixed tl ty
+    | _ ->
+        [], copy lbl.lbl_arg
+  in
+  cleanup_types ();
+  (vars, ty_arg, ty_res)
+
+(**** Instantiation with parameter substitution ****)
+
+let unify' = (* Forward declaration *)
+  ref (fun _env _ty1 _ty2 -> raise (Unify []))
+
+let subst env level priv abbrev ty params args body =
+  if List.length params <> List.length args then raise (Unify []);
+  let old_level = !current_level in
+  current_level := level;
+  try
+    let body0 = newvar () in          (* Stub *)
+    begin match ty with
+      None      -> ()
+    | Some ({desc = Tconstr (path, tl, _)} as ty) ->
+        let abbrev = proper_abbrevs path tl abbrev in
+        memorize_abbrev abbrev priv path ty body0
+    | _ ->
+        assert false
+    end;
+    abbreviations := abbrev;
+    let (params', body') = instance_parameterized_type params body in
+    abbreviations := ref Mnil;
+    !unify' env body0 body';
+    List.iter2 (!unify' env) params' args;
+    current_level := old_level;
+    body'
+  with Unify _ as exn ->
+    current_level := old_level;
+    raise exn
+
+(*
+   Only the shape of the type matters, not whether is is generic or
+   not. [generic_level] might be somewhat slower, but it ensures
+   invariants on types are enforced (decreasing levels.), and we don't
+   care about efficiency here.
+*)
+let apply env params body args =
+  try
+    subst env generic_level Public (ref Mnil) None params args body
+  with
+    Unify _ -> raise Cannot_apply
+
+
+                              (****************************)
+                              (*  Abbreviation expansion  *)
+                              (****************************)
+
+(*
+   If the environnement has changed, memorized expansions might not
+   be correct anymore, and so we flush the cache. This is safe but
+   quite pessimistic: it would be enough to flush the cache when a
+   type or module definition is overridden in the environnement.
+*)
+let previous_env = ref Env.empty
+(*let string_of_kind = function Public -> "public" | Private -> "private"*)
+let check_abbrev_env env =
+  if env != !previous_env then begin
+    (* prerr_endline "cleanup expansion cache"; *)
+    cleanup_abbrev ();
+    previous_env := env
+  end
+
+
+(* Expand an abbreviation. The expansion is memorized. *)
+(*
+   Assume the level is greater than the path binding time of the
+   expanded abbreviation.
+*)
+(*
+   An abbreviation expansion will fail in either of these cases:
+   1. The type constructor does not correspond to a manifest type.
+   2. The type constructor is defined in an external file, and this
+      file is not in the path (missing -I options).
+   3. The type constructor is not in the "local" environment. This can
+      happens when a non-generic type variable has been instantiated
+      afterwards to the not yet defined type constructor. (Actually,
+      this cannot happen at the moment due to the strong constraints
+      between type levels and constructor binding time.)
+   4. The expansion requires the expansion of another abbreviation,
+      and this other expansion fails.
+*)
+let expand_abbrev_gen kind find_type_expansion env ty =
+  check_abbrev_env env;
+  match ty with
+    {desc = Tconstr (path, args, abbrev); level = level} ->
+      let lookup_abbrev = proper_abbrevs path args abbrev in
+      begin match find_expans kind path !lookup_abbrev with
+        Some ty' ->
+          (* prerr_endline
+            ("found a "^string_of_kind kind^" expansion for "^Path.name path);*)
+          if level <> generic_level then
+            begin try
+              update_level env level ty'
+            with Unify _ ->
+              (* XXX This should not happen.
+                 However, levels are not correctly restored after a
+                 typing error *)
+              ()
+            end;
+          let ty' = repr ty' in
+          (* assert (ty != ty'); *) (* PR#7324 *)
+          ty'
+      | None ->
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' = subst env level kind abbrev (Some ty) params args body in
+            (* Hack to name the variant type *)
+            begin match repr ty' with
+              {desc=Tvariant row} as ty when static_row row ->
+                ty.desc <- Tvariant { row with row_name = Some (path, args) }
+            | _ -> ()
+            end;
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            if !trace_gadt_instances then begin
+              match max lv (Env.gadt_instance_level env ty) with
+                None -> ()
+              | Some lv ->
+                  if level < lv then raise (Unify [(ty, newvar2 level)]);
+                  Env.add_gadt_instances env lv [ty; ty']
+            end;
+            ty'
+      end
+  | _ ->
+      assert false
+
+(* Expand respecting privacy *)
+let expand_abbrev env ty =
+  expand_abbrev_gen Public Env.find_type_expansion env ty
+
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+  try expand_abbrev env (repr ty) with Cannot_expand -> assert false
+
+(* Check whether a type can be expanded *)
+let safe_abbrev env ty =
+  let snap = Btype.snapshot () in
+  try ignore (expand_abbrev env ty); true
+  with Cannot_expand | Unify _ ->
+    Btype.backtrack snap;
+    false
+
+(* Expand the head of a type once.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Unify, if a recursion was hidden in the type. *)
+let try_expand_once env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev env ty)
+  | _ -> raise Cannot_expand
+
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once env ty
+  with Unify _ ->
+    Btype.backtrack snap; raise Cannot_expand
+
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+  let ty' = try_once env ty in
+  try try_expand_head try_once env ty'
+  with Cannot_expand -> ty'
+
+let try_expand_head try_once env ty =
+  let ty' = try_expand_head try_once env ty in
+  begin match Env.gadt_instance_level env ty' with
+    None -> ()
+  | Some lv -> Env.add_gadt_instance_chain env lv ty
+  end;
+  ty'
+
+(* Unsafe full expansion, may raise Unify. *)
+let expand_head_unif env ty =
+  try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
+
+(* Safe version of expand_head, never fails *)
+let expand_head env ty =
+  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_once := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, p, decl) else
+      let ty =
+        try try_expand_once env ty with Cannot_expand -> raise Not_found
+      in
+      let (_, p', decl) = extract_concrete_typedecl env ty in
+        (p, p', decl)
+  | _ -> raise Not_found
+
+(* Implementing function [expand_head_opt], the compiler's own version of
+   [expand_head] used for type-based optimisations.
+   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
+   manifest type information of private abstract data types which is
+   normally hidden to the type-checker out of the implementation module of
+   the private abbreviation. *)
+
+let expand_abbrev_opt =
+  expand_abbrev_gen Private Env.find_type_expansion_opt
+
+let try_expand_once_opt env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev_opt env ty)
+  | _ -> raise Cannot_expand
+
+let rec try_expand_head_opt env ty =
+  let ty' = try_expand_once_opt env ty in
+  begin try
+    try_expand_head_opt env ty'
+  with Cannot_expand ->
+    ty'
+  end
+
+let expand_head_opt env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_head_opt env ty
+  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
+    Btype.backtrack snap;
+    repr ty
+
+(* Make sure that the type parameters of the type constructor [ty]
+   respect the type constraints *)
+let enforce_constraints env ty =
+  match ty with
+    {desc = Tconstr (path, args, _abbrev); level = level} ->
+      begin try
+        let decl = Env.find_type path env in
+        ignore
+          (subst env level Public (ref Mnil) None decl.type_params args
+             (newvar2 level))
+      with Not_found -> ()
+      end
+  | _ ->
+      assert false
+
+(* Recursively expand the head of a type.
+   Also expand #-types. *)
+let full_expand env ty =
+  let ty = repr (expand_head env ty) in
+  match ty.desc with
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
+      newty2 ty.level (Tobject (fi, ref None))
+  | _ ->
+      ty
+
+(*
+   Check whether the abbreviation expands to a well-defined type.
+   During the typing of a class, abbreviations for correspondings
+   types expand to non-generic types.
+*)
+let generic_abbrev env path =
+  try
+    let (_, body, _) = Env.find_type_expansion path env in
+    (repr body).level = generic_level
+  with
+    Not_found ->
+      false
+
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
+
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
+  with Not_found -> false
+
+
+                              (*****************)
+                              (*  Occur check  *)
+                              (*****************)
+
+
+exception Occur
+
+let rec occur_rec env allow_recursive visited ty0 = function
+  | {desc=Tlink ty} ->
+      occur_rec env allow_recursive visited ty0 ty
+  | ty ->
+  if ty == ty0  then raise Occur;
+  match ty.desc with
+    Tconstr(p, _tl, _abbrev) ->
+      if allow_recursive && is_contractive env p then () else
+      begin try
+        if TypeSet.mem ty visited then raise Occur;
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      with Occur -> try
+        let ty' = try_expand_head try_expand_once env ty in
+        (* This call used to be inlined, but there seems no reason for it.
+           Message was referring to change in rev. 1.58 of the CVS repo. *)
+        occur_rec env allow_recursive visited ty0 ty'
+      with Cannot_expand ->
+        raise Occur
+      end
+  | Tobject _ | Tvariant _ ->
+      ()
+  | _ ->
+      if allow_recursive ||  TypeSet.mem ty visited then () else begin
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      end
+
+let type_changed = ref false (* trace possible changes to the studied type *)
+
+let merge r b = if b then r := true
+
+let occur env ty0 ty =
+  let allow_recursive = !Clflags.recursive_types || !umode = Pattern  in
+  let old = !type_changed in
+  try
+    while
+      type_changed := false;
+      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      !type_changed
+    do () (* prerr_endline "changed" *) done;
+    merge type_changed old
+  with exn ->
+    merge type_changed old;
+    raise (match exn with Occur -> Unify [] | _ -> exn)
+
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Unify _ -> true
+
+(* Check that a local constraint is well-founded *)
+(* PR#6405: not needed since we allow recursion and work on normalized types *)
+(* PR#6992: we actually need it for contractiveness *)
+(* This is a simplified version of occur, only for the rectypes case *)
+
+let rec local_non_recursive_abbrev strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
+  let ty = repr ty in
+  if not (List.memq ty visited) then begin
+    match ty.desc with
+      Tconstr(p', args, _abbrev) ->
+        if Path.same p p' then raise Occur;
+        if not strict && is_contractive env p' then () else
+        let visited = ty :: visited in
+        begin try
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev strict visited env p
+            (try_expand_head try_expand_once env ty)
+        with Cannot_expand ->
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev strict visited env p ty)
+            params args
+        end
+    | _ ->
+        if strict then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr (local_non_recursive_abbrev true visited env p) ty
+  end
+
+let local_non_recursive_abbrev env p ty =
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev false [] env p) ty;
+    true
+  with Occur -> false
+
+
+                   (*****************************)
+                   (*  Polymorphic Unification  *)
+                   (*****************************)
+
+(* Since we cannot duplicate universal variables, unification must
+   be done at meta-level, using bindings in univar_pairs *)
+let rec unify_univar t1 t2 = function
+    (cl1, cl2) :: 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 [])
+
+(* Test the occurence of free univars in a type *)
+(* that's way too expansive. Must do some kind of cacheing *)
+let occur_univar env ty =
+  let visited = ref TypeMap.empty in
+  let rec occur_rec bound ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level &&
+      if TypeSet.is_empty bound then
+        (ty.level <- pivot_level - ty.level; true)
+      else try
+        let bound' = TypeMap.find ty !visited in
+        if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then
+          (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited;
+           true)
+        else false
+      with Not_found ->
+        visited := TypeMap.add ty bound !visited;
+        true
+    then
+      match ty.desc with
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
+      | Tpoly (ty, tyl) ->
+          let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+          occur_rec bound  ty
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (fun t v ->
+                if Variance.(mem May_pos v || mem May_neg v)
+                then occur_rec bound t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter (occur_rec bound) tl
+          end
+      | _ -> iter_type_expr (occur_rec bound) ty
+  in
+  try
+    occur_rec TypeSet.empty ty; unmark_type ty
+  with exn ->
+    unmark_type ty; raise exn
+
+(* Grouping univars by families according to their binders *)
+let add_univars =
+  List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+  if univars = [] then TypeSet.empty else
+  let insert s = function
+      cl1, (_::_ as cl2) ->
+        if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+          add_univars s cl2
+        else s
+    | _ -> s
+  in
+  let s = List.fold_right TypeSet.add univars TypeSet.empty in
+  List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+  let family = get_univar_family univar_pairs vl in
+  let visited = ref TypeSet.empty in
+  let rec occur t =
+    let t = repr t in
+    if TypeSet.mem t !visited then () else begin
+      visited := TypeSet.add t !visited;
+      match t.desc with
+        Tpoly (t, tl) ->
+          if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+          else occur t
+      | Tunivar _ ->
+          if TypeSet.mem t family then raise Occur
+      | Tconstr (_, [], _) -> ()
+      | Tconstr (p, tl, _) ->
+          begin try
+            let td = Env.find_type p env in
+            List.iter2
+              (fun t v ->
+                if Variance.(mem May_pos v || mem May_neg v) then occur t)
+              tl td.type_variance
+          with Not_found ->
+            List.iter occur tl
+          end
+      | _ ->
+          iter_type_expr occur t
+    end
+  in
+  try occur ty; false with Occur -> true
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+  let old_univars = !univar_pairs in
+  let known_univars =
+    List.fold_left (fun s (cl,_) -> add_univars s cl)
+      TypeSet.empty old_univars
+  in
+  let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+  if List.exists (fun t -> TypeSet.mem t known_univars) tl1 &&
+    univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)))
+  || List.exists (fun t -> TypeSet.mem t known_univars) tl2 &&
+    univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)))
+  then raise (Unify []);
+  let cl1 = List.map (fun t -> t, ref None) tl1
+  and cl2 = List.map (fun t -> t, ref None) tl2 in
+  univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+  try let res = f t1 t2 in univar_pairs := old_univars; res
+  with exn -> univar_pairs := old_univars; raise exn
+
+let univar_pairs = ref []
+
+
+                              (*****************)
+                              (*  Unification  *)
+                              (*****************)
+
+
+
+let rec has_cached_expansion p abbrev =
+  match abbrev with
+    Mnil                   -> false
+  | Mcons(_, p', _, _, rem)   -> Path.same p p' || has_cached_expansion p rem
+  | Mlink rem              -> has_cached_expansion p !rem
+
+(**** Transform error trace ****)
+(* +++ Move it to some other place ? *)
+
+let expand_trace env trace =
+  List.fold_right
+    (fun (t1, t2) rem ->
+       (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. *)
+let deep_occur t0 ty =
+  let rec occur_rec ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty == t0 then raise Occur;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr occur_rec ty
+    end
+  in
+  try
+    occur_rec ty; unmark_type ty; false
+  with Occur ->
+    unmark_type ty; true
+
+(*
+   1. When unifying two non-abbreviated types, one type is made a link
+      to the other. When unifying an abbreviated type with a
+      non-abbreviated type, the non-abbreviated type is made a link to
+      the other one. When unifying to abbreviated types, these two
+      types are kept distincts, but they are made to (temporally)
+      expand to the same type.
+   2. Abbreviations with at least one parameter are systematically
+      expanded. The overhead does not seem to high, and that way
+      abbreviations where some parameters does not appear in the
+      expansion, such as ['a t = int], are correctly handled. In
+      particular, for this example, unifying ['a t] with ['b t] keeps
+      ['a] and ['b] distincts. (Is it really important ?)
+   3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield
+      ['a t as 'a]. Indeed, the type variable would otherwise be lost.
+      This problem occurs for abbreviations expanding to a type
+      variable, but also to many other constrained abbreviations (for
+      instance, [(< x : 'a > -> unit) t = ]). The solution is
+      that, if an abbreviation is unified with some subpart of its
+      parameters, then the parameter actually does not get
+      abbreviated.  It would be possible to check whether some
+      information is indeed lost, but it probably does not worth it.
+*)
+
+let newtype_level = ref None
+
+let get_newtype_level () =
+  match !newtype_level with
+  | None -> assert false
+  | Some x -> x
+
+(* a local constraint can be added only if the rhs
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let newtype_level = get_newtype_level () in
+  let create_fresh_constr lev name =
+    let decl = new_declaration (Some (newtype_level, newtype_level)) None in
+    let name = match name with Some s -> "$'"^s | _ -> "$" in
+    let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+    let new_env = Env.add_local_type path decl !env in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
+    env := new_env;
+    t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty =
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let t = create_fresh_constr ty.level o in
+          link_type ty t;
+          if ty.level < newtype_level then
+            raise (Unify [t, newvar2 ty.level])
+      | Tvariant r ->
+          let r = row_repr r in
+          if not (static_row r) then begin
+            if r.row_fixed then iterator (row_more r) else
+            let m = r.row_more in
+            match m.desc with
+              Tvar o ->
+                let t = create_fresh_constr m.level o in
+                let row =
+                  {r with row_fields=[]; row_fixed=true; row_more = t} in
+                link_type m (newty2 m.level (Tvariant row));
+                if m.level < newtype_level then
+                  raise (Unify [t, newvar2 m.level])
+            | _ -> assert false
+          end;
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_newtype env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_newtype_level <> None &&
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public
+  with Not_found -> false
+
+let non_aliasable p decl =
+  (* in_pervasives p ||  (subsumed by in_current_module) *)
+  in_current_module p && decl.type_newtype_level = None
+
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
+(* PR#7113: -safe-string should be a global property *)
+let compatible_paths p1 p2 =
+  let open Predef in
+  Path.same p1 p2 ||
+  Path.same p1 path_bytes && Path.same p2 path_string ||
+  Path.same p1 path_string && Path.same p2 path_bytes
+
+(* Check for datatypes carefully; see PR#6348 *)
+let rec expands_to_datatype env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      begin try
+        is_datatype (Env.find_type p env) ||
+        expands_to_datatype env (try_expand_once env ty)
+      with Not_found | Cannot_expand -> false
+      end
+  | _ -> false
+
+(* mcomp type_pairs subst env t1 t2 does not raise an
+   exception if it is possible that t1 and t2 are actually
+   equal, assuming the types in type_pairs are equal and
+   that the mapping subst holds.
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+  match (t1.desc, t2.desc) with
+  | (Tvar _, _)
+  | (_, Tvar _)  ->
+      ()
+  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+      ()
+  | _ ->
+      let t1' = expand_head_opt env t1 in
+      let t2' = expand_head_opt env t2 in
+      (* Expansion may have changed the representative of the types... *)
+      let t1' = repr t1' and t2' = repr t2' in
+      if t1' == t2' then () else
+      begin try TypePairs.find type_pairs (t1', t2')
+      with Not_found ->
+        TypePairs.add type_pairs (t1', t2') ();
+        match (t1'.desc, t2'.desc) with
+          (Tvar _, Tvar _) -> assert false
+        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+            mcomp type_pairs env t1 t2;
+            mcomp type_pairs env u1 u2;
+        | (Ttuple tl1, Ttuple tl2) ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+            begin try
+              let decl = Env.find_type p env in
+              if non_aliasable p decl || is_datatype decl then raise (Unify [])
+            with Not_found -> ()
+            end
+        (*
+        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
+            mcomp_list type_pairs env tl1 tl2
+        *)
+        | (Tpackage _, Tpackage _) -> ()
+        | (Tvariant row1, Tvariant row2) ->
+            mcomp_row type_pairs env row1 row2
+        | (Tobject (fi1, _), Tobject (fi2, _)) ->
+            mcomp_fields type_pairs env fi1 fi2
+        | (Tfield _, Tfield _) ->       (* Actually unused *)
+            mcomp_fields type_pairs env t1' t2'
+        | (Tnil, Tnil) ->
+            ()
+        | (Tpoly (t1, []), Tpoly (t2, [])) ->
+            mcomp type_pairs env t1 t2
+        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+            enter_poly env univar_pairs t1 tl1 t2 tl2
+              (mcomp type_pairs env)
+        | (Tunivar _, Tunivar _) ->
+            unify_univar t1' t2' !univar_pairs
+        | (_, _) ->
+            raise (Unify [])
+      end
+
+and mcomp_list type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (mcomp type_pairs env) tl1 tl2
+
+and mcomp_fields type_pairs env ty1 ty2 =
+  if not (concrete_object ty1 && concrete_object ty2) then assert false;
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
+  mcomp type_pairs env rest1 rest2;
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise (Unify []);
+  List.iter
+    (function (_n, k1, t1, k2, t2) ->
+       mcomp_kind k1 k2;
+       mcomp type_pairs env t1 t2)
+    pairs
+
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise (Unify [])
+  | _                   -> ()
+
+and mcomp_row type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let cannot_erase (_,f) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []);
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise (Unify [])
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs env t2) tl1
+      | _ -> ())
+    pairs
+
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
+  try
+    let decl = Env.find_type p1 env in
+    let decl' = Env.find_type p2 env in
+    if compatible_paths p1 p2 then begin
+      let inj =
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+        with Not_found -> List.map (fun _ -> false) tl1
+      in
+      List.iter2
+        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+        inj (List.combine tl1 tl2)
+    end else if non_aliasable p1 decl && non_aliasable p2 decl' then
+      raise (Unify [])
+    else
+      match decl.type_kind, decl'.type_kind with
+      | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_record_description type_pairs env lst lst'
+      | Type_variant v1, Type_variant v2 ->
+          mcomp_list type_pairs env tl1 tl2;
+          mcomp_variant_description type_pairs env v1 v2
+      | Type_open, Type_open ->
+          mcomp_list type_pairs env tl1 tl2
+      | Type_abstract, Type_abstract -> ()
+      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
+      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
+      | _ -> raise (Unify [])
+  with Not_found -> ()
+
+and mcomp_type_option type_pairs env t t' =
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs env t t'
+  | _ -> raise (Unify [])
+
+and mcomp_variant_description type_pairs env xs ys =
+  let rec iter = fun x y ->
+    match x, y with
+    | c1 :: xs, c2 :: ys   ->
+      mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
+      begin match c1.cd_args, c2.cd_args with
+      | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
+      | Cstr_record l1, Cstr_record l2 ->
+          mcomp_record_description type_pairs env l1 l2
+      | _ -> raise (Unify [])
+      end;
+     if Ident.name c1.cd_id = Ident.name c2.cd_id
+      then iter xs ys
+      else raise (Unify [])
+    | [],[] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter xs ys
+
+and mcomp_record_description type_pairs env =
+  let rec iter x y =
+    match x, y with
+    | l1 :: xs, l2 :: ys ->
+        mcomp type_pairs env l1.ld_type l2.ld_type;
+        if Ident.name l1.ld_id = Ident.name l2.ld_id &&
+           l1.ld_mutable = l2.ld_mutable
+        then iter xs ys
+        else raise (Unify [])
+    | [], [] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) env t1 t2
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty.level < !lowest then lowest := ty.level;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_newtype_level env path =
+  try match (Env.find_type path env).type_newtype_level with
+    Some x -> x
+  | None -> raise Not_found
+  with Not_found -> let lev = Path.binding_time path in (lev, lev)
+
+let add_gadt_equation env source destination =
+  if local_non_recursive_abbrev !env source destination then begin
+    let destination = duplicate_type destination in
+    let source_lev = find_newtype_level !env source in
+    let decl = new_declaration (Some source_lev) (Some destination) in
+    let newtype_level = get_newtype_level () in
+    env := Env.add_local_constraint source decl newtype_level !env;
+    cleanup_abbrev ()
+  end
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 =
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+
+let eq_package_path env p1 p2 =
+  Path.same p1 p2 ||
+  Path.same (normalize_package_path env p1) (normalize_package_path env p2)
+
+let nondep_type' = ref (fun _ _ _ -> assert false)
+let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false)
+
+let rec concat_longident lid1 =
+  let open Longident in
+  function
+    Lident s -> Ldot (lid1, s)
+  | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s)
+  | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid)
+
+let nondep_instance env level id ty =
+  let ty = !nondep_type' env id ty in
+  if level = generic_level then duplicate_type ty else
+  let old = !current_level in
+  current_level := level;
+  let ty = instance env ty in
+  current_level := old;
+  ty
+
+(* Find the type paths nl1 in the module type mty2, and add them to the
+   list (nl2, tl2). raise Not_found if impossible *)
+let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
+  let id2 = Ident.create "Pkg" in
+  let env' = Env.add_module id2 mty2 env in
+  let rec complete nl1 ntl2 =
+    match nl1, ntl2 with
+      [], _ -> ntl2
+    | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
+        nt2 :: complete (if n = n2 then nl else nl1) ntl'
+    | n :: nl, _ ->
+        try
+          let path =
+            Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env'
+          in
+          match Env.find_type path env' with
+            {type_arity = 0; type_kind = Type_abstract;
+             type_private = Public; type_manifest = Some t2} ->
+               (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
+          | {type_arity = 0; type_kind = Type_abstract;
+             type_private = Public; type_manifest = None} when allow_absent ->
+               complete nl ntl2
+          | _ -> raise Exit
+        with
+        | Not_found when allow_absent -> complete nl ntl2
+        | Exit -> raise Not_found
+  in
+  complete nl1 (List.combine nl2 tl2)
+
+(* raise Not_found rather than Unify if the module types are incompatible *)
+let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
+  let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2
+  and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in
+  unify_list (List.map snd ntl1) (List.map snd ntl2);
+  if eq_package_path env p1 p2
+  || !package_subtype env p1 n1 tl1 p2 n2 tl2
+  && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
+
+
+(* force unification in Reither when one side has as non-conjunctive type *)
+let rigid_variants = ref false
+
+(* drop not force unification in Reither, even in fixed case
+   (not sound, only use it when checking exhaustiveness) *)
+let passive_variants = ref false
+let with_passive_variants f x =
+  if !passive_variants then f x else
+  match passive_variants := true; f x with
+  | r           -> passive_variants := false; r
+  | exception e -> passive_variants := false; raise e
+
+let unify_eq t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let unify1_var env t1 t2 =
+  assert (is_Tvar t1);
+  occur env t1 t2;
+  occur_univar env t2;
+  let d1 = t1.desc in
+  link_type t1 t2;
+  try
+    update_level env t1.level t2
+  with Unify _ as e ->
+    t1.desc <- d1;
+    raise e
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+
+  try
+    type_changed := true;
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
+        unify2 env t1 t2
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
+        unify2 env t1 t2
+    | (Tvar _, _) ->
+        unify1_var !env t1 t2
+    | (_, Tvar _) ->
+        unify1_var !env t2 t1
+    | (Tunivar _, Tunivar _) ->
+        unify_univar t1 t2 !univar_pairs;
+        update_level !env t1.level t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
+            (* This optimization assumes that t1 does not expand to t2
+               (and conversely), so we fall back to the general case
+               when any of the types has a cached expansion. *)
+            && not (has_cached_expansion p1 !a1
+                 || has_cached_expansion p2 !a2) ->
+        update_level !env t1.level t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+      when Env.has_local_constraints !env
+      && is_newtype !env p1 && is_newtype !env p2 ->
+        (* Do not use local constraints more than necessary *)
+        begin try
+          if find_newtype_level !env p1 < find_newtype_level !env p2 then
+            unify env t1 (try_expand_once !env t2)
+          else
+            unify env (try_expand_once !env t1) t2
+        with Cannot_expand ->
+          unify2 env t1 t2
+        end
+    | _ ->
+        unify2 env t1 t2
+    end;
+    reset_trace_gadt_instances reset_tracing;
+  with Unify trace ->
+    reset_trace_gadt_instances reset_tracing;
+    raise (Unify ((t1, t2)::trace))
+
+and unify2 env t1 t2 =
+  (* Second step: expansion of abbreviations *)
+  (* Expansion may change the representative of the types. *)
+  ignore (expand_head_unif !env t1);
+  ignore (expand_head_unif !env t2);
+  let t1' = expand_head_unif !env t1 in
+  let t2' = expand_head_unif !env t2 in
+  let lv = min t1'.level t2'.level in
+  update_level !env lv t2;
+  update_level !env lv t1;
+  if unify_eq t1' t2' then () else
+
+  let t1 = repr t1 and t2 = repr t2 in
+  if !trace_gadt_instances then begin
+    (* All types in chains already have the same ambiguity levels *)
+    let ilevel t =
+      match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in
+    let lv1 = ilevel t1 and lv2 = ilevel t2 in
+    if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
+    if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1
+  end;
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
+    unify3 env t1 t1' t2 t2'
+  else
+    try unify3 env t2 t2' t1 t1' with Unify trace ->
+      raise (Unify (List.map (fun (x, y) -> (y, x)) trace))
+
+and unify3 env t1 t1' t2 t2' =
+  (* Third step: truly unification *)
+  (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+  let d1 = t1'.desc and d2 = t2'.desc in
+  let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
+
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      occur !env t1' t2;
+      occur_univar !env t2;
+      link_type t1' t2;
+  | (_, Tvar _) ->
+      occur !env t2' t1;
+      occur_univar !env t1;
+      link_type t2' t1;
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+    begin match !umode with
+    | Expression ->
+        occur !env t1' t2';
+        link_type t1' t2
+    | Pattern ->
+        add_type_equality t1' t2'
+    end;
+    try
+      begin match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        (!Clflags.classic || !umode = Pattern) &&
+        not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || not !generate_equations then
+            unify_list env tl1 tl2
+          else if !assume_injective then
+            set_mode_pattern ~generate:true ~injective:false
+                             (fun () -> unify_list env tl1 tl2)
+          else if in_current_module p1 (* || in_pervasives p1 *)
+                  || List.exists (expands_to_datatype !env) [t1'; t1; t2] then
+            unify_list env tl1 tl2
+          else
+            let inj =
+              try List.map Variance.(mem Inj)
+                    (Env.find_type p1 !env).type_variance
+              with Not_found -> List.map (fun _ -> false) tl1
+            in
+            List.iter2
+              (fun i (t1, t2) ->
+                if i then unify env t1 t2 else
+                set_mode_pattern ~generate:false ~injective:false
+                  begin fun () ->
+                    let snap = snapshot () in
+                    try unify env t1 t2 with Unify _ ->
+                      backtrack snap;
+                      reify env t1; reify env t2
+                  end)
+              inj (List.combine tl1 tl2)
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
+        && !generate_equations ->
+          let source, destination =
+            if find_newtype_level !env path > find_newtype_level !env path'
+            then  path , t2'
+            else  path', t1'
+          in
+          add_gadt_equation env source destination
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && !generate_equations ->
+          reify env t2';
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && !generate_equations ->
+          reify env t1';
+          add_gadt_equation env path t1'
+      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          if !generate_equations then mcomp !env t1' t2'
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          if !umode = Expression then
+            unify_row env row1 row2
+          else begin
+            let snap = snapshot () in
+            try unify_row env row1 row2
+            with Unify _ ->
+              backtrack snap;
+              reify env t1';
+              reify env t2';
+              if !generate_equations then mcomp !env t1' t2'
+          end
+      | (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;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      -> raise (Unify [])
+          end
+      | (Tnil, Tnil) ->
+          ()
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+          begin try
+            unify_package !env (unify_list env)
+              t1.level p1 n1 tl1 t2.level p2 n2 tl2
+          with Not_found ->
+            if !umode = Expression then raise (Unify []);
+            List.iter (reify env) (tl1 @ tl2);
+            (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)
+          end
+      | (_, _) ->
+          raise (Unify [])
+      end;
+      (* XXX Commentaires + changer "create_recursion"
+         ||| Comments + change "create_recursion" *)
+      if create_recursion then
+        match t2.desc with
+          Tconstr (p, tl, abbrev) ->
+            forget_abbrev abbrev p;
+            let t2'' = expand_head_unif !env t2 in
+            if not (closed_parameterized_type tl t2'') then
+              link_type (repr t2) (repr t2')
+        | _ ->
+            () (* t2 has already been expanded by update_level *)
+    with Unify trace ->
+      t1'.desc <- d1;
+      raise (Unify trace)
+  end
+
+and unify_list env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (unify env) tl1 tl2
+
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> log_type ty; ty.desc <- Tvar name
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
+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 = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
+  let d1 = rest1.desc and d2 = rest2.desc in
+  try
+    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;
+        try
+          if !trace_gadt_instances then update_level !env va.level t1;
+          unify env t1 t2
+        with Unify trace ->
+          raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)),
+                         newty (Tfield(n, k2, t2, newty Tnil)))::trace)))
+      pairs
+  with exn ->
+    log_type rest1; rest1.desc <- d1;
+    log_type rest2; rest2.desc <- d2;
+    raise exn
+
+and unify_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2
+  | (Fpresent, Fvar r)            -> set_kind r k1
+  | (Fpresent, Fpresent)          -> ()
+  | _                             -> assert false
+
+and unify_row env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = row_more row1 and rm2 = row_more row2 in
+  if unify_eq rm1 rm2 then () else
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if r1 <> [] && r2 <> [] then begin
+    let ht = Hashtbl.create (List.length r1) in
+    List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1;
+    List.iter
+      (fun (l,_) ->
+        try raise (Tags(l, Hashtbl.find ht (hash_variant l)))
+        with Not_found -> ())
+      r2
+  end;
+  let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in
+  let more =
+    if fixed1 then rm1 else
+    if fixed2 then rm2 else
+    newty2 (min rm1.level rm2.level) (Tvar None) in
+  let fixed = fixed1 || fixed2
+  and closed = row1.row_closed || row2.row_closed in
+  let keep switch =
+    List.for_all
+      (fun (_,f1,f2) ->
+        let f1, f2 = switch f1 f2 in
+        row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
+      pairs
+  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 *)
+  if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed)
+  && List.for_all
+      (fun (_,f1,f2) ->
+        row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent)
+      pairs
+  then raise (Unify [mkvariant [] true, mkvariant [] true]);
+  let name =
+    if row1.row_name <> None && (row1.row_closed || empty r2) &&
+      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
+    then row1.row_name
+    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
+      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
+    then row2.row_name
+    else None
+  in
+  let row0 = {row_fields = []; row_more = more; row_bound = ();
+              row_closed = closed; row_fixed = fixed; row_name = name} in
+  let set_more row rest =
+    let rest =
+      if closed then
+        filter_row_fields row.row_closed rest
+      else rest in
+    if rest <> [] && (row.row_closed || row_fixed row)
+    || closed && row_fixed row && not row.row_closed then begin
+      let t1 = mkvariant [] true and t2 = mkvariant rest false in
+      raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
+    end;
+    (* The following test is not principal... should rather use Tnil *)
+    let rm = row_more row in
+    if !trace_gadt_instances && rm.desc = Tnil then () else
+    if !trace_gadt_instances then
+      update_level !env rm.level (newgenty (Tvariant row));
+    if row_fixed row then
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
+    else
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level !env rm.level ty;
+      link_type rm ty
+  in
+  let md1 = rm1.desc and md2 = rm2.desc in
+  begin try
+    set_more row2 r1;
+    set_more row1 r2;
+    List.iter
+      (fun (l,f1,f2) ->
+        try unify_row_field env fixed1 fixed2 more l f1 f2
+        with Unify trace ->
+          raise (Unify ((mkvariant [l,f1] true,
+                         mkvariant [l,f2] true) :: trace)))
+      pairs;
+  with exn ->
+    log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
+  end
+
+and unify_row_field env fixed1 fixed2 more 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
+    Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+  | Rpresent None, Rpresent None -> ()
+  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
+      if e1 == e2 then () else
+      let redo =
+        not !passive_variants &&
+        (m1 || m2 || fixed1 || fixed2 ||
+         !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
+        begin match tl1 @ tl2 with [] -> false
+        | t1 :: tl ->
+            if c1 || c2 then raise (Unify []);
+            List.iter (unify env t1) tl;
+            !e1 <> None || !e2 <> None
+        end in
+      if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else
+      let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+      let rec remq tl = function [] -> []
+        | ty :: tl' ->
+            if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+      in
+      let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
+      (* PR#6744 *)
+      let split_univars =
+        List.partition
+          (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in
+      let (tl1',tlu1) = split_univars tl1'
+      and (tl2',tlu2) = split_univars tl2' in
+      begin match tlu1, tlu2 with
+        [], [] -> ()
+      | (tu1::tlu1), _ :: _ ->
+          (* Attempt to merge all the types containing univars *)
+          if not !passive_variants then
+          List.iter (unify env tu1) (tlu1@tlu2)
+      | (tu::_, []) | ([], tu::_) -> occur_univar !env tu
+      end;
+      (* Is this handling of levels really principal? *)
+      List.iter (update_level !env (repr more).level) (tl1' @ tl2');
+      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';
+  | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2
+  | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1
+  | Rabsent, Rabsent -> ()
+  | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
+      set_row_field e1 f2;
+      update_level !env (repr more).level t2;
+      (try List.iter (fun t1 -> unify env t1 t2) tl
+      with exn -> e1 := None; raise exn)
+  | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
+      set_row_field e2 f1;
+      update_level !env (repr more).level t1;
+      (try List.iter (unify env t1) tl
+      with exn -> e2 := None; raise exn)
+  | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
+      set_row_field e1 f2
+  | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
+      set_row_field e2 f1
+  | _ -> raise (Unify [])
+
+
+let unify env ty1 ty2 =
+  let snap = Btype.snapshot () in
+  try
+    unify env ty1 ty2
+  with
+    Unify trace ->
+      undo_compress snap;
+      raise (Unify (expand_trace !env trace))
+  | Recursive_abbrev ->
+      undo_compress snap;
+      raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)]))
+
+let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    newtype_level := Some lev;
+    set_mode_pattern ~generate:true ~injective:true
+                     (fun () -> unify env ty1 ty2);
+    newtype_level := None;
+    TypePairs.clear unify_eq_set;
+  with e ->
+    newtype_level := None;
+    TypePairs.clear unify_eq_set;
+    raise e
+
+let unify_var env t1 t2 =
+  let t1 = repr t1 and t2 = repr t2 in
+  if t1 == t2 then () else
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
+      let reset_tracing = check_trace_gadt_instances env in
+      begin try
+        occur env t1 t2;
+        update_level env t1.level t2;
+        link_type t1 t2;
+        reset_trace_gadt_instances reset_tracing;
+      with Unify trace ->
+        reset_trace_gadt_instances reset_tracing;
+        let expanded_trace = expand_trace env ((t1,t2)::trace) in
+        raise (Unify expanded_trace)
+      end
+  | _ ->
+      unify (ref env) t1 t2
+
+let _ = unify' := unify_var
+
+let unify_pairs env ty1 ty2 pairs =
+  univar_pairs := pairs;
+  unify env ty1 ty2
+
+let unify env ty1 ty2 =
+  unify_pairs (ref env) ty1 ty2 []
+
+
+
+(**** Special cases of unification ****)
+
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  reset_trace_gadt_instances reset_tracing;
+  t
+
+(*
+   Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
+   In label mode, label mismatch is accepted when
+   (1) the requested label is ""
+   (2) the original label is not optional
+*)
+
+let filter_arrow env t l =
+  let t = expand_head_trace env t in
+  match t.desc with
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
+      link_type t t';
+      (t1, t2)
+  | Tarrow(l', t1, t2, _)
+    when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
+      (t1, t2)
+  | _ ->
+      raise (Unify [])
+
+(* Used by [filter_method]. *)
+let rec filter_method_field env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let level = ty.level in
+      let ty1 = newvar2 level and ty2 = newvar2 level in
+      let ty' = newty2 level (Tfield (name,
+                                      begin match priv with
+                                        Private -> Fvar (ref None)
+                                      | Public  -> Fpresent
+                                      end,
+                                      ty1, ty2))
+      in
+      link_type ty ty';
+      ty1
+  | Tfield(n, kind, ty1, ty2) ->
+      let kind = field_kind_repr kind in
+      if (n = name) && (kind <> Fabsent) then begin
+        if priv = Public then
+          unify_kind kind Fpresent;
+        ty1
+      end else
+        filter_method_field env name priv ty2
+  | _ ->
+      raise (Unify [])
+
+(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
+let filter_method env name priv ty =
+  let ty = expand_head_trace env ty in
+  match ty.desc with
+    Tvar _ ->
+      let ty1 = newvar () in
+      let ty' = newobj ty1 in
+      update_level env ty.level ty';
+      link_type ty ty';
+      filter_method_field env name priv ty1
+  | Tobject(f, _) ->
+      filter_method_field env name priv f
+  | _ ->
+      raise (Unify [])
+
+let check_filter_method env name priv ty =
+  ignore(filter_method env name priv ty)
+
+let filter_self_method env lab priv meths ty =
+  let ty' = filter_method env lab priv ty in
+  try
+    Meths.find lab !meths
+  with Not_found ->
+    let pair = (Ident.create lab, ty') in
+    meths := Meths.add lab pair !meths;
+    pair
+
+
+                        (***********************************)
+                        (*  Matching between type schemes  *)
+                        (***********************************)
+
+(*
+   Update the level of [ty]. First check that the levels of generic
+   variables from the subject are not lowered.
+*)
+let moregen_occur env level ty =
+  let rec occur ty =
+    let ty = repr ty in
+    if ty.level > level then begin
+      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
+      ty.level <- pivot_level - ty.level;
+      match ty.desc with
+        Tvariant row when static_row row ->
+          iter_row occur row
+      | _ ->
+          iter_type_expr occur ty
+    end
+  in
+  begin try
+    occur ty; unmark_type ty
+  with Occur ->
+    unmark_type ty; raise (Unify [])
+  end;
+  (* also check for free univars *)
+  occur_univar env ty;
+  update_level env level ty
+
+let may_instantiate inst_nongen t1 =
+  if inst_nongen then t1.level <> generic_level - 1
+                 else t1.level =  generic_level
+
+let rec moregen inst_nongen type_pairs env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) when may_instantiate inst_nongen t1 ->
+        moregen_occur env t1.level t2;
+        occur env t1 t2;
+        link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        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' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
+              moregen_occur env t1'.level t2;
+              link_type t1' t2
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              moregen inst_nongen type_pairs env t1 t2;
+              moregen inst_nongen type_pairs env u1 u2
+          | (Ttuple tl1, Ttuple tl2) ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              moregen_list inst_nongen type_pairs env tl1 tl2
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+              begin try
+                unify_package env (moregen_list inst_nongen type_pairs env)
+                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
+              with Not_found -> raise (Unify [])
+              end
+          | (Tvariant row1, Tvariant row2) ->
+              moregen_row inst_nongen type_pairs env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              moregen_fields inst_nongen type_pairs env fi1 fi2
+          | (Tfield _, Tfield _) ->           (* Actually unused *)
+              moregen_fields inst_nongen type_pairs env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              moregen inst_nongen type_pairs env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly env univar_pairs t1 tl1 t2 tl2
+                (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
+          | (_, _) ->
+              raise (Unify [])
+        end
+  with Unify trace ->
+    raise (Unify ((t1, t2)::trace))
+
+and moregen_list inst_nongen type_pairs env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+
+and moregen_fields inst_nongen type_pairs env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1
+  and (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  if miss1 <> [] then raise (Unify []);
+  moregen inst_nongen type_pairs env rest1
+    (build_fields (repr ty2).level miss2 rest2);
+  List.iter
+    (fun (n, k1, t1, k2, t2) ->
+       moregen_kind k1 k2;
+       try moregen inst_nongen type_pairs env t1 t2 with Unify trace ->
+         raise (Unify ((newty (Tfield(n, k1, t1, rest2)),
+                        newty (Tfield(n, k2, t2, rest2)))::trace)))
+    pairs
+
+and moregen_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  if k1 == k2 then () else
+  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent))  -> set_kind r k2
+  | (Fpresent, Fpresent)           -> ()
+  | _                              -> raise (Unify [])
+
+and moregen_row inst_nongen type_pairs env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+  if rm1 == rm2 then () else
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let r1, r2 =
+    if row2.row_closed then
+      filter_row_fields may_inst r1, filter_row_fields false r2
+    else r1, r2
+  in
+  if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
+  then raise (Unify []);
+  begin match rm1.desc, rm2.desc with
+    Tunivar _, Tunivar _ ->
+      unify_univar rm1 rm2 !univar_pairs
+  | Tunivar _, _ | _, Tunivar _ ->
+      raise (Unify [])
+  | _ when static_row row1 -> ()
+  | _ when may_inst ->
+      let ext =
+        newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
+      in
+      moregen_occur env rm1.level ext;
+      link_type rm1 ext
+  | Tconstr _, Tconstr _ ->
+      moregen inst_nongen type_pairs env rm1 rm2
+  | _ -> raise (Unify [])
+  end;
+  List.iter
+    (fun (_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
+        Rpresent(Some t1), Rpresent(Some t2) ->
+          moregen inst_nongen type_pairs env t1 t2
+      | Rpresent None, Rpresent None -> ()
+      | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
+          set_row_field e1 f2;
+          List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
+          if e1 != e2 then begin
+            if c1 && not c2 then raise(Unify []);
+            set_row_field e1 (Reither (c2, [], m2, e2));
+            if List.length tl1 = List.length tl2 then
+              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+            else match tl2 with
+              t2 :: _ ->
+                List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+                  tl1
+            | [] ->
+                if tl1 <> [] then raise (Unify [])
+          end
+      | Reither(true, [], _, e1), Rpresent None when may_inst ->
+          set_row_field e1 f2
+      | Reither(_, _, _, e1), Rabsent when may_inst ->
+          set_row_field e1 f2
+      | Rabsent, Rabsent -> ()
+      | _ -> raise (Unify []))
+    pairs
+
+(* Must empty univar_pairs first *)
+let moregen inst_nongen type_pairs env patt subj =
+  univar_pairs := [];
+  moregen inst_nongen type_pairs env patt subj
+
+(*
+   Non-generic variable can be instanciated only if [inst_nongen] is
+   true. So, [inst_nongen] should be set to false if the subject might
+   contain non-generic variables (and we do not want them to be
+   instanciated).
+   Usually, the subject is given by the user, and the pattern
+   is unimportant.  So, no need to propagate abbreviations.
+*)
+let moregeneral env inst_nongen pat_sch subj_sch =
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let subj = duplicate_type (instance env subj_sch) in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let patt = instance env pat_sch in
+  let res =
+    try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
+      Unify _ -> false
+  in
+  current_level := old_level;
+  res
+
+
+(* Alternative approach: "rigidify" a type scheme,
+   and check validity after unification *)
+(* Simpler, no? *)
+
+let rec rigidify_rec vars ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
+    match ty.desc with
+    | Tvar _ ->
+        if not (List.memq ty !vars) then vars := ty :: !vars
+    | Tvariant row ->
+        let row = row_repr row in
+        let more = repr row.row_more in
+        if is_Tvar more && not (row_fixed row) then begin
+          let more' = newty2 more.level more.desc in
+          let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
+          in link_type more (newty2 ty.level (Tvariant row'))
+        end;
+        iter_row (rigidify_rec vars) row;
+        (* only consider the row variable if the variant is not static *)
+        if not (static_row row) then rigidify_rec vars (row_more row)
+    | _ ->
+        iter_type_expr (rigidify_rec vars) ty
+  end
+
+let rigidify ty =
+  let vars = ref [] in
+  rigidify_rec vars ty;
+  unmark_type ty;
+  !vars
+
+let all_distinct_vars env vars =
+  let tyl = ref [] in
+  List.for_all
+    (fun ty ->
+      let ty = expand_head env ty in
+      if List.memq ty !tyl then false else
+      (tyl := ty :: !tyl; is_Tvar ty))
+    vars
+
+let matches env ty ty' =
+  let snap = snapshot () in
+  let vars = rigidify ty in
+  cleanup_abbrev ();
+  let ok =
+    try unify env ty ty'; all_distinct_vars env vars
+    with Unify _ -> false
+  in
+  backtrack snap;
+  ok
+
+
+                 (*********************************************)
+                 (*  Equivalence between parameterized types  *)
+                 (*********************************************)
+
+let expand_head_rigid env ty =
+  let old = !rigid_variants in
+  rigid_variants := true;
+  let ty' = expand_head env ty in
+  rigid_variants := old; ty'
+
+let normalize_subst subst =
+  if List.exists
+      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+      !subst
+  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
+
+let rec eqtype rename type_pairs subst env t1 t2 =
+  if t1 == t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then () else
+
+  try
+    match (t1.desc, t2.desc) with
+      (Tvar _, Tvar _) when rename ->
+        begin try
+          normalize_subst subst;
+          if List.assq t1 !subst != t2 then raise (Unify [])
+        with Not_found ->
+          if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []);
+          subst := (t1, t2) :: !subst
+        end
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+    | _ ->
+        let t1' = expand_head_rigid env t1 in
+        let t2' = expand_head_rigid env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+        begin try
+          TypePairs.find type_pairs (t1', t2')
+        with Not_found ->
+          TypePairs.add type_pairs (t1', t2') ();
+          match (t1'.desc, t2'.desc) with
+            (Tvar _, Tvar _) when rename ->
+              begin try
+                normalize_subst subst;
+                if List.assq t1' !subst != t2' then raise (Unify [])
+              with Not_found ->
+                if List.exists (fun (_, t) -> t == t2') !subst
+                then raise (Unify []);
+                subst := (t1', t2') :: !subst
+              end
+          | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+            || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+              eqtype rename type_pairs subst env t1 t2;
+              eqtype rename type_pairs subst env u1 u2;
+          | (Ttuple tl1, Ttuple tl2) ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+                when Path.same p1 p2 ->
+              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) ->
+              begin try
+                unify_package env (eqtype_list rename type_pairs subst env)
+                  t1'.level p1 n1 tl1 t2'.level p2 n2 tl2
+              with Not_found -> raise (Unify [])
+              end
+          | (Tvariant row1, Tvariant row2) ->
+              eqtype_row rename type_pairs subst env row1 row2
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
+              eqtype_fields rename type_pairs subst env fi1 fi2
+          | (Tfield _, Tfield _) ->       (* Actually unused *)
+              eqtype_fields rename type_pairs subst env t1' t2'
+          | (Tnil, Tnil) ->
+              ()
+          | (Tpoly (t1, []), Tpoly (t2, [])) ->
+              eqtype rename type_pairs subst env t1 t2
+          | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+              enter_poly env univar_pairs t1 tl1 t2 tl2
+                (eqtype rename type_pairs subst env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
+          | (_, _) ->
+              raise (Unify [])
+        end
+  with Unify trace ->
+    raise (Unify ((t1, t2)::trace))
+
+and eqtype_list rename type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+
+and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env rest2 with
+    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+  | _ ->
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  eqtype rename type_pairs subst env rest1 rest2;
+  if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
+  List.iter
+    (function (n, k1, t1, k2, t2) ->
+       eqtype_kind k1 k2;
+       try eqtype rename type_pairs subst env t1 t2 with Unify trace ->
+         raise (Unify ((newty (Tfield(n, k1, t1, rest2)),
+                        newty (Tfield(n, k2, t2, rest2)))::trace)))
+    pairs
+
+and eqtype_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise (Unify [])
+
+and eqtype_row rename type_pairs subst env row1 row2 =
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  match expand_head_rigid env (row_more row2) with
+    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+  | _ ->
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  if row1.row_closed <> row2.row_closed
+  || not row1.row_closed && (r1 <> [] || r2 <> [])
+  || filter_row_fields false (r1 @ r2) <> []
+  then raise (Unify []);
+  if not (static_row row1) then
+    eqtype rename type_pairs subst env row1.row_more row2.row_more;
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+        Rpresent(Some t1), Rpresent(Some t2) ->
+          eqtype rename type_pairs subst env t1 t2
+      | Reither(true, [], _, _), Reither(true, [], _, _) ->
+          ()
+      | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
+          eqtype rename type_pairs subst env t1 t2;
+          if List.length tl1 = List.length tl2 then
+            (* if same length allow different types (meaning?) *)
+            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+          else begin
+            (* otherwise everything must be equal *)
+            List.iter (eqtype rename type_pairs subst env t1) tl2;
+            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
+          end
+      | Rpresent None, Rpresent None -> ()
+      | Rabsent, Rabsent -> ()
+      | _ -> raise (Unify []))
+    pairs
+
+(* Must empty univar_pairs first *)
+let eqtype_list rename type_pairs subst env tl1 tl2 =
+  univar_pairs := [];
+  let snap = Btype.snapshot () in
+  try eqtype_list rename type_pairs subst env tl1 tl2; backtrack snap
+  with exn -> backtrack snap; raise exn
+
+let eqtype rename type_pairs subst env t1 t2 =
+  eqtype_list rename type_pairs subst env [t1] [t2]
+
+(* Two modes: with or without renaming of variables *)
+let equal env rename tyl1 tyl2 =
+  try
+    eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
+  with
+    Unify _ -> false
+
+
+                          (*************************)
+                          (*  Class type matching  *)
+                          (*************************)
+
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
+  | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+
+exception Failure of class_match_failure list
+
+let rec moregen_clty trace type_pairs env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), _ ->
+        moregen_clty true type_pairs env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        moregen_clty true type_pairs env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        moregen_clty false type_pairs env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+            begin try moregen true type_pairs env t1 t2 with Unify trace ->
+              raise (Failure [CM_Meth_type_mismatch
+                                 (lab, env, expand_trace env trace)])
+           end)
+        pairs;
+      Vars.iter
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
+           try moregen true type_pairs env ty' ty with Unify trace ->
+             raise (Failure [CM_Val_type_mismatch
+                                (lab, env, expand_trace env trace)]))
+        sign2.csig_vars
+  | _ ->
+      raise (Failure [])
+  with
+    Failure error when trace || error = [] ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_types ?(trace=true) env pat_sch subj_sch =
+  let type_pairs = TypePairs.create 53 in
+  let old_level = !current_level in
+  current_level := generic_level - 1;
+  (*
+     Generic variables are first duplicated with [instance].  So,
+     their levels are lowered to [generic_level - 1].  The subject is
+     then copied with [duplicate_type].  That way, its levels won't be
+     changed.
+  *)
+  let (_, subj_inst) = instance_class [] subj_sch in
+  let subj = duplicate_class_type subj_inst in
+  current_level := generic_level;
+  (* Duplicate generic variables *)
+  let (_, patt) = instance_class [] pat_sch in
+  let res =
+    let sign1 = signature_of_class_type patt in
+    let sign2 = signature_of_class_type subj in
+    let t1 = repr sign1.csig_self in
+    let t2 = repr sign2.csig_self in
+    TypePairs.add type_pairs (t1, t2) ();
+    let (fields1, rest1) = flatten_fields (object_fields t1)
+    and (fields2, rest2) = flatten_fields (object_fields t2) in
+    let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+    let error =
+      List.fold_right
+        (fun (lab, k, _) err ->
+           let err =
+             let k = field_kind_repr k in
+             begin match k with
+               Fvar r -> set_kind r Fabsent; err
+             | _      -> CM_Hide_public lab::err
+             end
+           in
+           if Concr.mem lab sign1.csig_concr then err
+           else CM_Hide_virtual ("method", lab) :: err)
+        miss1 []
+    in
+    let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+    let error =
+      (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+    in
+    (* Always succeeds *)
+    moregen true type_pairs env rest1 rest2;
+    let error =
+      List.fold_right
+        (fun (lab, k1, _t1, k2, _t2) err ->
+           try moregen_kind k1 k2; err with
+             Unify _ -> CM_Public_method lab::err)
+        pairs error
+    in
+    let error =
+      Vars.fold
+        (fun lab (mut, vr, _ty) err ->
+          try
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+            if mut = Mutable && mut' <> Mutable then
+              CM_Non_mutable_value lab::err
+            else if vr = Concrete && vr' <> Concrete then
+              CM_Non_concrete_value lab::err
+            else
+              err
+          with Not_found ->
+            CM_Missing_value lab::err)
+        sign2.csig_vars error
+    in
+    let error =
+      Vars.fold
+        (fun lab (_,vr,_) err ->
+          if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+            CM_Hide_virtual ("instance variable", lab) :: err
+          else err)
+        sign1.csig_vars error
+    in
+    let error =
+      List.fold_right
+        (fun e l ->
+           if List.mem e missing_method then l else CM_Virtual_method e::l)
+        (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+        error
+    in
+    match error with
+      [] ->
+        begin try
+          moregen_clty trace type_pairs env patt subj;
+          []
+        with
+          Failure r -> r
+        end
+    | error ->
+        CM_Class_type_mismatch (env, patt, subj)::error
+  in
+  current_level := old_level;
+  res
+
+let rec equal_clty trace type_pairs subst env cty1 cty2 =
+  try
+    match cty1, cty2 with
+      Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | Cty_constr (_, _, cty1), _ ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | _, Cty_constr (_, _, cty2) ->
+        equal_clty true type_pairs subst env cty1 cty2
+    | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 ->
+        begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
+        end;
+        equal_clty false type_pairs subst env cty1' cty2'
+    | Cty_signature sign1, Cty_signature sign2 ->
+        let ty1 = object_fields (repr sign1.csig_self) in
+        let ty2 = object_fields (repr sign2.csig_self) in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
+        List.iter
+          (fun (lab, _k1, t1, _k2, t2) ->
+             begin try eqtype true type_pairs subst env t1 t2 with
+               Unify trace ->
+                 raise (Failure [CM_Meth_type_mismatch
+                                    (lab, env, expand_trace env trace)])
+             end)
+          pairs;
+        Vars.iter
+          (fun lab (_, _, ty) ->
+             let (_, _, ty') = Vars.find lab sign1.csig_vars in
+             try eqtype true type_pairs subst env ty' ty with Unify trace ->
+               raise (Failure [CM_Val_type_mismatch
+                                  (lab, env, expand_trace env trace)]))
+          sign2.csig_vars
+    | _ ->
+        raise
+          (Failure (if trace then []
+                    else [CM_Class_type_mismatch (env, cty1, cty2)]))
+  with
+    Failure error when trace ->
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
+
+let match_class_declarations env patt_params patt_type subj_params subj_type =
+  let type_pairs = TypePairs.create 53 in
+  let subst = ref [] in
+  let sign1 = signature_of_class_type patt_type in
+  let sign2 = signature_of_class_type subj_type in
+  let t1 = repr sign1.csig_self in
+  let t2 = repr sign2.csig_self in
+  TypePairs.add type_pairs (t1, t2) ();
+  let (fields1, rest1) = flatten_fields (object_fields t1)
+  and (fields2, rest2) = flatten_fields (object_fields t2) in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let error =
+    List.fold_right
+      (fun (lab, k, _) err ->
+        let err =
+          let k = field_kind_repr k in
+          begin match k with
+            Fvar _ -> err
+          | _      -> CM_Hide_public lab::err
+          end
+        in
+        if Concr.mem lab sign1.csig_concr then err
+        else CM_Hide_virtual ("method", lab) :: err)
+      miss1 []
+  in
+  let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+  let error =
+    (List.map (fun m -> CM_Missing_method m) missing_method) @ error
+  in
+  (* Always succeeds *)
+  eqtype true type_pairs subst env rest1 rest2;
+  let error =
+    List.fold_right
+      (fun (lab, k1, _t1, k2, _t2) err ->
+        let k1 = field_kind_repr k1 in
+        let k2 = field_kind_repr k2 in
+        match k1, k2 with
+          (Fvar _, Fvar _)
+        | (Fpresent, Fpresent) -> err
+        | (Fvar _, Fpresent)   -> CM_Private_method lab::err
+        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
+        | _                    -> assert false)
+      pairs error
+  in
+  let error =
+    Vars.fold
+      (fun lab (mut, vr, _ty) err ->
+         try
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
+           if mut = Mutable && mut' <> Mutable then
+             CM_Non_mutable_value lab::err
+           else if vr = Concrete && vr' <> Concrete then
+             CM_Non_concrete_value lab::err
+           else
+             err
+         with Not_found ->
+           CM_Missing_value lab::err)
+      sign2.csig_vars error
+  in
+  let error =
+    Vars.fold
+      (fun lab (_,vr,_) err ->
+        if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
+          CM_Hide_virtual ("instance variable", lab) :: err
+        else err)
+      sign1.csig_vars error
+  in
+  let error =
+    List.fold_right
+      (fun e l ->
+        if List.mem e missing_method then l else CM_Virtual_method e::l)
+      (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
+      error
+  in
+  match error with
+    [] ->
+      begin try
+        let lp = List.length patt_params in
+        let ls = List.length subj_params in
+        if lp  <> ls then
+          raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
+        List.iter2 (fun p s ->
+          try eqtype true type_pairs subst env p s with Unify trace ->
+            raise (Failure [CM_Type_parameter_mismatch
+                               (env, expand_trace env trace)]))
+          patt_params subj_params;
+     (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
+        equal_clty false type_pairs subst env
+          (Cty_signature sign1) (Cty_signature sign2);
+        (* Use moregeneral for class parameters, need to recheck everything to
+           keeps relationships (PR#4824) *)
+        let clty_params =
+          List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
+        match_class_types ~trace:false env
+          (clty_params patt_params patt_type)
+          (clty_params subj_params subj_type)
+      with
+        Failure r -> r
+      end
+  | error ->
+      error
+
+
+                              (***************)
+                              (*  Subtyping  *)
+                              (***************)
+
+
+(**** Build a subtype of a given type. ****)
+
+(* build_subtype:
+   [visited] traces traversed object and variant types
+   [loops] is a mapping from variables to variables, to reproduce
+     positive loops in a class type
+   [posi] true if the current variance is positive
+   [level] number of expansions/enlargement allowed on this branch *)
+
+let warn = ref false  (* whether double coercion might do better *)
+let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
+let pred_enlarge n = if n mod 2 = 1 then pred n else n
+
+type change = Unchanged | Equiv | Changed
+let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l
+
+let rec filter_visited = function
+    [] -> []
+  | {desc=Tobject _|Tvariant _} :: _ as l -> l
+  | _ :: l -> filter_visited l
+
+let memq_warn t visited =
+  if List.memq t visited then (warn := true; true) else false
+
+let rec lid_of_path ?(hash="") = function
+    Path.Pident id ->
+      Longident.Lident (hash ^ Ident.name id)
+  | Path.Pdot (p1, s, _) ->
+      Longident.Ldot (lid_of_path p1, hash ^ s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2)
+
+let find_cltype_for_path env p =
+  let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in
+  let cl_abbr = Env.find_type cl_path 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 has_constr_row' env t =
+  has_constr_row (expand_abbrev env t)
+
+let rec build_subtype env visited loops posi level t =
+  let t = repr t in
+  match t.desc with
+    Tvar _ ->
+      if posi then
+        try
+          let t' = List.assq t loops in
+          warn := true;
+          (t', Equiv)
+        with Not_found ->
+          (t, Unchanged)
+      else
+        (t, Unchanged)
+  | Tarrow(l, t1, t2, _) ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let (t1', c1) = build_subtype env visited loops (not posi) level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max c1 c2 in
+      if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c)
+      else (t, Unchanged)
+  | Ttuple tlist ->
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      let tlist' =
+        List.map (build_subtype env visited loops posi level) tlist
+      in
+      let c = collect tlist' in
+      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
+      else (t, Unchanged)
+  | Tconstr(p, tl, abbrev)
+    when level > 0 && generic_abbrev env p && safe_abbrev env t
+    && not (has_constr_row' env t) ->
+      let t' = repr (expand_abbrev env t) in
+      let level' = pred_expand level in
+      begin try match t'.desc with
+        Tobject _ when posi && not (opened_object t') ->
+          let cl_abbr, body = find_cltype_for_path env p in
+          let ty =
+            subst env !current_level Public abbrev None
+              cl_abbr.type_params tl body in
+          let ty = repr ty in
+          let ty1, tl1 =
+            match ty.desc with
+              Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' ->
+                ty1, tl1
+            | _ -> raise Not_found
+          in
+          (* Fix PR4505: do not set ty to Tvar when it appears in tl1,
+             as this occurence might break the occur check.
+             XXX not clear whether this correct anyway... *)
+          if List.exists (deep_occur ty) tl1 then raise Not_found;
+          ty.desc <- Tvar None;
+          let t'' = newvar () in
+          let loops = (ty, t'') :: loops in
+          (* May discard [visited] as level is going down *)
+          let (ty1', c) =
+            build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
+          assert (is_Tvar t'');
+          let nm =
+            if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
+          t''.desc <- Tobject (ty1', ref nm);
+          (try unify_var env ty t with Unify _ -> assert false);
+          (t'', Changed)
+      | _ -> raise Not_found
+      with Not_found ->
+        let (t'',c) = build_subtype env visited loops posi level' t' in
+        if c > Unchanged then (t'',c)
+        else (t, Unchanged)
+      end
+  | Tconstr(p, tl, _abbrev) ->
+      (* Must check recursion on constructors, since we do not always
+         expand them *)
+      if memq_warn t visited then (t, Unchanged) else
+      let visited = t :: visited in
+      begin try
+        let decl = Env.find_type p env in
+        if level = 0 && generic_abbrev env p && safe_abbrev env t
+        && not (has_constr_row' env t)
+        then warn := true;
+        let tl' =
+          List.map2
+            (fun v t ->
+              let (co,cn) = Variance.get_upper v in
+              if cn then
+                if co then (t, Unchanged)
+                else build_subtype env visited loops (not posi) level t
+              else
+                if co then build_subtype env visited loops posi level t
+                else (newvar(), Changed))
+            decl.type_variance tl
+        in
+        let c = collect tl' in
+        if c > Unchanged then (newconstr p (List.map fst tl'), c)
+        else (t, Unchanged)
+      with Not_found ->
+        (t, Unchanged)
+      end
+  | Tvariant row ->
+      let row = row_repr row in
+      if memq_warn t visited || not (static_row row) then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let fields = filter_row_fields false row.row_fields in
+      let fields =
+        List.map
+          (fun (l,f as orig) -> match row_field_repr f with
+            Rpresent None ->
+              if posi then
+                (l, Reither(true, [], false, ref None)), Unchanged
+              else
+                orig, Unchanged
+          | Rpresent(Some t) ->
+              let (t', c) = build_subtype env visited loops posi level' t in
+              let f =
+                if posi && level > 0
+                then Reither(false, [t'], false, ref None)
+                else Rpresent(Some t')
+              in (l, f), c
+          | _ -> assert false)
+          fields
+      in
+      let c = collect fields in
+      let row =
+        { row_fields = List.map fst fields; row_more = newvar();
+          row_bound = (); row_closed = posi; row_fixed = false;
+          row_name = if c > Unchanged then None else row.row_name }
+      in
+      (newty (Tvariant row), Changed)
+  | Tobject (t1, _) ->
+      if memq_warn t visited || opened_object t1 then (t, Unchanged) else
+      let level' = pred_enlarge level in
+      let visited =
+        t :: if level' < level then [] else filter_visited visited in
+      let (t1', c) = build_subtype env visited loops posi level' t1 in
+      if c > Unchanged then (newty (Tobject (t1', ref None)), c)
+      else (t, Unchanged)
+  | Tfield(s, _, t1, t2) (* Always present *) ->
+      let (t1', c1) = build_subtype env visited loops posi level t1 in
+      let (t2', c2) = build_subtype env visited loops posi level t2 in
+      let c = max c1 c2 in
+      if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c)
+      else (t, Unchanged)
+  | Tnil ->
+      if posi then
+        let v = newvar () in
+        (v, Changed)
+      else begin
+        warn := true;
+        (t, Unchanged)
+      end
+  | Tsubst _ | Tlink _ ->
+      assert false
+  | Tpoly(t1, tl) ->
+      let (t1', c) = build_subtype env visited loops posi level t1 in
+      if c > Unchanged then (newty (Tpoly(t1', tl)), c)
+      else (t, Unchanged)
+  | Tunivar _ | Tpackage _ ->
+      (t, Unchanged)
+
+let enlarge_type env ty =
+  warn := false;
+  (* [level = 4] allows 2 expansions involving objects/variants *)
+  let (ty', _) = build_subtype env [] [] true 4 ty in
+  (ty', !warn)
+
+(**** Check whether a type is a subtype of another type. ****)
+
+(*
+    During the traversal, a trace of visited types is maintained. It
+    is printed in case of error.
+    Constraints (pairs of types that must be equals) are accumulated
+    rather than being enforced straight. Indeed, the result would
+    otherwise depend on the order in which these constraints are
+    enforced.
+    A function enforcing these constraints is returned. That way, type
+    variables can be bound to their actual values before this function
+    is called (see Typecore).
+    Only well-defined abbreviations are expanded (hence the tests
+    [generic_abbrev ...]).
+*)
+
+let subtypes = TypePairs.create 17
+
+let subtype_error env trace =
+  raise (Subtype (expand_trace env (List.rev trace), []))
+
+let rec subtype_rec env trace t1 t2 cstrs =
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if t1 == t2 then cstrs else
+
+  begin try
+    TypePairs.find subtypes (t1, t2);
+    cstrs
+  with Not_found ->
+    TypePairs.add subtypes (t1, t2) ();
+    match (t1.desc, t2.desc) with
+      (Tvar _, _) | (_, Tvar _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
+      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+        let cstrs = subtype_rec env ((t2, t1)::trace) t2 t1 cstrs in
+        subtype_rec env ((u1, u2)::trace) u1 u2 cstrs
+    | (Ttuple tl1, Ttuple tl2) ->
+        subtype_list env trace tl1 tl2 cstrs
+    | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+        cstrs
+    | (Tconstr(p1, _tl1, _abbrev1), _)
+      when generic_abbrev env p1 && safe_abbrev env t1 ->
+        subtype_rec env trace (expand_abbrev env t1) t2 cstrs
+    | (_, Tconstr(p2, _tl2, _abbrev2))
+      when generic_abbrev env p2 && safe_abbrev env t2 ->
+        subtype_rec env trace t1 (expand_abbrev env t2) cstrs
+    | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+        begin try
+          let decl = Env.find_type p1 env in
+          List.fold_left2
+            (fun cstrs v (t1, t2) ->
+              let (co, cn) = Variance.get_upper v in
+              if co then
+                if cn then
+                  (trace, newty2 t1.level (Ttuple[t1]),
+                   newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs
+                else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+              else
+                if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs
+                else cstrs)
+            cstrs decl.type_variance (List.combine tl1 tl2)
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
+        subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
+    | (Tobject (f1, _), Tobject (f2, _))
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
+        (* Same row variable implies same object. *)
+        (trace, t1, t2, !univar_pairs)::cstrs
+    | (Tobject (f1, _), Tobject (f2, _)) ->
+        subtype_fields env trace f1 f2 cstrs
+    | (Tvariant row1, Tvariant row2) ->
+        begin try
+          subtype_row env trace row1 row2 cstrs
+        with Exit ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpoly (u1, []), Tpoly (u2, [])) ->
+        subtype_rec env trace u1 u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2, [])) ->
+        let _, u1' = instance_poly false tl1 u1 in
+        subtype_rec env trace u1' u2 cstrs
+    | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+        begin try
+          enter_poly env univar_pairs u1 tl1 u2 tl2
+            (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+        with Unify _ ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) ->
+        begin try
+          let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1
+          and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2
+              ~allow_absent:true in
+          let cstrs' =
+            List.map
+              (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
+              ntl2
+          in
+          if eq_package_path env p1 p2 then cstrs' @ cstrs
+          else begin
+            (* need to check module subtyping *)
+            let snap = Btype.snapshot () in
+            try
+              List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs';
+              if !package_subtype env p1 nl1 tl1 p2 nl2 tl2
+              then (Btype.backtrack snap; cstrs' @ cstrs)
+              else raise (Unify [])
+            with Unify _ ->
+              Btype.backtrack snap; raise Not_found
+          end
+        with Not_found ->
+          (trace, t1, t2, !univar_pairs)::cstrs
+        end
+    | (_, _) ->
+        (trace, t1, t2, !univar_pairs)::cstrs
+  end
+
+and subtype_list env trace tl1 tl2 cstrs =
+  if List.length tl1 <> List.length tl2 then
+    subtype_error env trace;
+  List.fold_left2
+    (fun cstrs t1 t2 -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
+    cstrs tl1 tl2
+
+and subtype_fields env trace ty1 ty2 cstrs =
+  (* Assume that either rest1 or rest2 is not Tvar *)
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let cstrs =
+    if rest2.desc = Tnil then cstrs else
+    if miss1 = [] then
+      subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs
+    else
+      (trace, build_fields (repr ty1).level miss1 rest1, rest2,
+       !univar_pairs) :: cstrs
+  in
+  let cstrs =
+    if miss2 = [] then cstrs else
+    (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
+     !univar_pairs) :: cstrs
+  in
+  List.fold_left
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
+      (* Theses fields are always present *)
+      subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
+    cstrs pairs
+
+and subtype_row env trace row1 row2 cstrs =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs =
+    merge_row_fields row1.row_fields row2.row_fields in
+  let more1 = repr row1.row_more
+  and more2 = repr row2.row_more in
+  match more1.desc, more2.desc with
+    Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+      subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
+    when row1.row_closed && r1 = [] ->
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2) ->
+              subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
+              subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+          | Rabsent, _ -> cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | Tunivar _, Tunivar _
+    when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+      let cstrs =
+        subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
+      List.fold_left
+        (fun cstrs (_,f1,f2) ->
+          match row_field_repr f1, row_field_repr f2 with
+            Rpresent None, Rpresent None
+          | Reither(true,[],_,_), Reither(true,[],_,_)
+          | Rabsent, Rabsent ->
+              cstrs
+          | Rpresent(Some t1), Rpresent(Some t2)
+          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
+              subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+          | _ -> raise Exit)
+        cstrs pairs
+  | _ ->
+      raise Exit
+
+let subtype env ty1 ty2 =
+  TypePairs.clear subtypes;
+  univar_pairs := [];
+  (* Build constraint set. *)
+  let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in
+  TypePairs.clear subtypes;
+  (* Enforce constraints. *)
+  function () ->
+    List.iter
+      (function (trace0, t1, t2, pairs) ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
+           raise (Subtype (expand_trace env (List.rev trace0),
+                           List.tl (List.tl trace))))
+      (List.rev cstrs)
+
+                              (*******************)
+                              (*  Miscellaneous  *)
+                              (*******************)
+
+(* Utility for printing. The resulting type is not used in computation. *)
+let rec unalias_object ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tfield (s, k, t1, t2) ->
+      newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
+  | Tvar _ | Tnil ->
+      newty2 ty.level ty.desc
+  | Tunivar _ ->
+      ty
+  | Tconstr _ ->
+      newvar2 ty.level
+  | _ ->
+      assert false
+
+let unalias ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ ->
+      ty
+  | Tvariant row ->
+      let row = row_repr row in
+      let more = row.row_more in
+      newty2 ty.level
+        (Tvariant {row with row_more = newty2 more.level more.desc})
+  | Tobject (ty, nm) ->
+      newty2 ty.level (Tobject (unalias_object ty, nm))
+  | _ ->
+      newty2 ty.level ty.desc
+
+(* Return the arity (as for curried functions) of the given type. *)
+let rec arity ty =
+  match (repr ty).desc with
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
+  | _ -> 0
+
+(* Check whether an abbreviation expands to itself. *)
+let cyclic_abbrev env id ty =
+  let rec check_cycle seen ty =
+    let ty = repr ty in
+    match ty.desc with
+      Tconstr (p, _tl, _abbrev) ->
+        p = Path.Pident id || List.memq ty seen ||
+        begin try
+          check_cycle (ty :: seen) (expand_abbrev_opt env ty)
+        with
+          Cannot_expand -> false
+        | Unify _ -> true
+        end
+    | _ ->
+        false
+  in check_cycle [] ty
+
+(* Check for non-generalizable type variables *)
+exception Non_closed0
+let visited = ref TypeSet.empty
+
+let rec closed_schema_rec env ty =
+  let ty = repr ty in
+  if TypeSet.mem ty !visited then () else begin
+    visited := TypeSet.add ty !visited;
+    match ty.desc with
+      Tvar _ when ty.level <> generic_level ->
+        raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
+    | Tfield(_, kind, t1, t2) ->
+        if field_kind_repr kind = Fpresent then
+          closed_schema_rec env t1;
+        closed_schema_rec env t2
+    | Tvariant row ->
+        let row = row_repr row in
+        iter_row (closed_schema_rec env) row;
+        if not (static_row row) then closed_schema_rec env row.row_more
+    | _ ->
+        iter_type_expr (closed_schema_rec env) ty
+  end
+
+(* Return whether all variables of type [ty] are generic. *)
+let closed_schema env ty =
+  visited := TypeSet.empty;
+  try
+    closed_schema_rec env ty;
+    visited := TypeSet.empty;
+    true
+  with Non_closed0 ->
+    visited := TypeSet.empty;
+    false
+
+(* Normalize a type before printing, saving... *)
+(* Cannot use mark_type because deep_occur uses it too *)
+let rec normalize_type_rec env visited ty =
+  let ty = repr ty in
+  if not (TypeSet.mem ty !visited) then begin
+    visited := TypeSet.add ty !visited;
+    let tm = row_of_type ty in
+    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+      match tm.desc with (* PR#7348 *)
+        Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) ->
+          let i' = String.sub i 0 (String.length i - 4) in
+          log_type ty;
+          ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil)
+      | _ -> assert false
+    else match ty.desc with
+    | Tvariant row ->
+      let row = row_repr row in
+      let fields = List.map
+          (fun (l,f0) ->
+            let f = row_field_repr f0 in l,
+            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+              let tyl' =
+                List.fold_left
+                  (fun tyl ty ->
+                    if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
+                    then tyl else ty::tyl)
+                  [ty] tyl
+              in
+              if f != f0 || List.length tyl' < List.length tyl then
+                Reither(b, List.rev tyl', m, e)
+              else f
+            | _ -> f)
+          row.row_fields in
+      let fields =
+        List.sort (fun (p,_) (q,_) -> compare p q)
+          (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in
+      log_type ty;
+      ty.desc <- Tvariant {row with row_fields = fields}
+    | Tobject (fi, nm) ->
+        begin match !nm with
+        | None -> ()
+        | Some (n, v :: l) ->
+            if deep_occur ty (newgenty (Ttuple l)) then
+              (* The abbreviation may be hiding something, so remove it *)
+              set_name nm None
+            else let v' = repr v in
+            begin match v'.desc with
+            | Tvar _ | Tunivar _ ->
+                if v' != v then set_name nm (Some (n, v' :: l))
+            | Tnil ->
+                log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
+            | _ -> set_name nm None
+            end
+        | _ ->
+            fatal_error "Ctype.normalize_type_rec"
+        end;
+        let fi = repr fi in
+        if fi.level < lowest_level then () else
+        let fields, row = flatten_fields fi in
+        let fi' = build_fields fi.level fields row in
+        log_type ty; fi.desc <- fi'.desc
+    | _ -> ()
+    end;
+    iter_type_expr (normalize_type_rec env visited) ty
+  end
+
+let normalize_type env ty =
+  normalize_type_rec env (ref TypeSet.empty) ty
+
+
+                              (*************************)
+                              (*  Remove dependencies  *)
+                              (*************************)
+
+
+(*
+   Variables are left unchanged. Other type nodes are duplicated, with
+   levels set to generic level.
+   We cannot use Tsubst here, because unification may be called by
+   expand_abbrev.
+*)
+
+let nondep_hash     = TypeHash.create 47
+let nondep_variants = TypeHash.create 17
+let clear_hash ()   =
+  TypeHash.clear nondep_hash; TypeHash.clear nondep_variants
+
+let rec nondep_type_rec env id ty =
+  match ty.desc with
+    Tvar _ | Tunivar _ -> ty
+  | Tlink ty -> nondep_type_rec env id ty
+  | _ -> try TypeHash.find nondep_hash ty
+  with Not_found ->
+    let ty' = newgenvar () in        (* Stub *)
+    TypeHash.add nondep_hash ty ty';
+    ty'.desc <-
+      begin match ty.desc with
+      | Tconstr(p, tl, _abbrev) ->
+          if Path.isfree id p then
+            begin try
+              Tlink (nondep_type_rec env id
+                       (expand_abbrev env (newty2 ty.level ty.desc)))
+              (*
+                 The [Tlink] is important. The expanded type may be a
+                 variable, or may not be completely copied yet
+                 (recursive type), so one cannot just take its
+                 description.
+               *)
+            with Cannot_expand | Unify _ ->
+              raise Not_found
+            end
+          else
+            Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil)
+      | Tpackage(p, nl, tl) when Path.isfree id p ->
+          let p' = normalize_package_path env p in
+          if Path.isfree id p' then raise Not_found;
+          Tpackage (p', nl, List.map (nondep_type_rec env id) tl)
+      | Tobject (t1, name) ->
+          Tobject (nondep_type_rec env id t1,
+                 ref (match !name with
+                        None -> None
+                      | Some (p, tl) ->
+                          if Path.isfree id p then None
+                          else Some (p, List.map (nondep_type_rec env id) tl)))
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must keep sharing according to the row variable *)
+          begin try
+            let ty2 = TypeHash.find nondep_variants more in
+            (* This variant type has been already copied *)
+            TypeHash.add nondep_hash ty ty2;
+            Tlink ty2
+          with Not_found ->
+            (* Register new type first for recursion *)
+            TypeHash.add nondep_variants more ty';
+            let static = static_row row in
+            let more' = if static then newgenty Tnil else more in
+            (* Return a new copy *)
+            let row =
+              copy_row (nondep_type_rec env id) true row true more' in
+            match row.row_name with
+              Some (p, _tl) when Path.isfree id p ->
+                Tvariant {row with row_name = None}
+            | _ -> Tvariant row
+          end
+      | _ -> copy_type_desc (nondep_type_rec env id) ty.desc
+      end;
+    ty'
+
+let nondep_type env id ty =
+  try
+    let ty' = nondep_type_rec env id ty in
+    clear_hash ();
+    ty'
+  with Not_found ->
+    clear_hash ();
+    raise Not_found
+
+let () = nondep_type' := nondep_type
+
+let unroll_abbrev id tl ty =
+  let ty = repr ty and path = Path.Pident id in
+  if is_Tvar ty || (List.exists (deep_occur ty) tl)
+  || is_object_type path then
+    ty
+  else
+    let ty' = newty2 ty.level ty.desc in
+    link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil)));
+    ty'
+
+(* Preserve sharing inside type declarations. *)
+let nondep_type_decl env mid id is_covariant decl =
+  try
+    let params = List.map (nondep_type_rec env mid) decl.type_params in
+    let tk =
+      try map_kind (nondep_type_rec env mid) decl.type_kind
+      with Not_found when is_covariant -> Type_abstract
+    and tm =
+      try match decl.type_manifest with
+        None -> None
+      | Some ty ->
+          Some (unroll_abbrev id params (nondep_type_rec env mid ty))
+      with Not_found when is_covariant ->
+        None
+    in
+    clear_hash ();
+    let priv =
+      match tm with
+      | Some ty when Btype.has_constr_row ty -> Private
+      | _ -> decl.type_private
+    in
+    { type_params = params;
+      type_arity = decl.type_arity;
+      type_kind = tk;
+      type_manifest = tm;
+      type_private = priv;
+      type_variance = decl.type_variance;
+      type_newtype_level = None;
+      type_loc = decl.type_loc;
+      type_attributes = decl.type_attributes;
+      type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
+    }
+  with Not_found ->
+    clear_hash ();
+    raise Not_found
+
+(* Preserve sharing inside extension constructors. *)
+let nondep_extension_constructor env mid ext =
+  try
+    let type_path, type_params =
+      if Path.isfree mid ext.ext_type_path then
+        begin
+          let ty =
+            newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil))
+          in
+          let ty' = nondep_type_rec env mid ty in
+            match (repr ty').desc with
+                Tconstr(p, tl, _) -> p, tl
+              | _ -> raise Not_found
+        end
+      else
+        let type_params =
+          List.map (nondep_type_rec env mid) ext.ext_type_params
+        in
+          ext.ext_type_path, type_params
+    in
+    let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in
+    let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in
+      clear_hash ();
+      { ext_type_path = type_path;
+        ext_type_params = type_params;
+        ext_args = args;
+        ext_ret_type = ret_type;
+        ext_private = ext.ext_private;
+        ext_attributes = ext.ext_attributes;
+        ext_loc = ext.ext_loc;
+      }
+  with Not_found ->
+    clear_hash ();
+    raise Not_found
+
+
+(* Preserve sharing inside class types. *)
+let nondep_class_signature env id sign =
+  { csig_self = nondep_type_rec env id sign.csig_self;
+    csig_vars =
+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+        sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.csig_inher }
+
+let rec nondep_class_type env id =
+  function
+    Cty_constr (p, _, cty) when Path.isfree id p ->
+      nondep_class_type env id cty
+  | Cty_constr (p, tyl, cty) ->
+      Cty_constr (p, List.map (nondep_type_rec env id) tyl,
+                   nondep_class_type env id cty)
+  | Cty_signature sign ->
+      Cty_signature (nondep_class_signature env id sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, nondep_type_rec env id ty, nondep_class_type env id cty)
+
+let nondep_class_declaration env id decl =
+  assert (not (Path.isfree id decl.cty_path));
+  let decl =
+    { cty_params = List.map (nondep_type_rec env id) decl.cty_params;
+      cty_variance = decl.cty_variance;
+      cty_type = nondep_class_type env id decl.cty_type;
+      cty_path = decl.cty_path;
+      cty_new =
+        begin match decl.cty_new with
+          None    -> None
+        | Some ty -> Some (nondep_type_rec env id ty)
+        end;
+      cty_loc = decl.cty_loc;
+      cty_attributes = decl.cty_attributes;
+    }
+  in
+  clear_hash ();
+  decl
+
+let nondep_cltype_declaration env id decl =
+  assert (not (Path.isfree id decl.clty_path));
+  let decl =
+    { clty_params = List.map (nondep_type_rec env id) decl.clty_params;
+      clty_variance = decl.clty_variance;
+      clty_type = nondep_class_type env id decl.clty_type;
+      clty_path = decl.clty_path;
+      clty_loc = decl.clty_loc;
+      clty_attributes = decl.clty_attributes;
+    }
+  in
+  clear_hash ();
+  decl
+
+(* collapse conjonctive types in class parameters *)
+let rec collapse_conj env visited ty =
+  let ty = repr ty in
+  if List.memq ty visited then () else
+  let visited = ty :: visited in
+  match ty.desc with
+    Tvariant row ->
+      let row = row_repr row in
+      List.iter
+        (fun (_l,fi) ->
+          match row_field_repr fi with
+            Reither (c, t1::(_::_ as tl), m, e) ->
+              List.iter (unify env t1) tl;
+              set_row_field e (Reither (c, [t1], m, ref None))
+          | _ ->
+              ())
+        row.row_fields;
+      iter_row (collapse_conj env visited) row
+  | _ ->
+      iter_type_expr (collapse_conj env visited) ty
+
+let collapse_conj_params env params =
+  List.iter (collapse_conj env []) params
+
+let same_constr env t1 t2 =
+  let t1 = expand_head env t1 in
+  let t2 = expand_head env t2 in
+  match t1.desc, t2.desc with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
+  | _ -> false
+
+let () =
+  Env.same_constr := same_constr
+
+let maybe_pointer_type env typ =
+   match (repr typ).desc with
+  | Tconstr(p, _args, _abbrev) ->
+    begin try
+      let type_decl = Env.find_type p env in
+      not type_decl.type_immediate
+    with Not_found -> true
+    (* This can happen due to e.g. missing -I options,
+       causing some .cmi files to be unavailable.
+       Maybe we should emit a warning. *)
+    end
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      (* if all labels are devoid of arguments, not a pointer *)
+      not row.row_closed
+      || List.exists
+          (function
+            | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
+            | _ -> false)
+          row.row_fields
+  | _ -> true
diff --git a/typing/ctype.mli b/typing/ctype.mli
new file mode 100644
index 00000000..f7a22e21
--- /dev/null
+++ b/typing/ctype.mli
@@ -0,0 +1,292 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on core types *)
+
+open Asttypes
+open Types
+
+exception Unify of (type_expr * type_expr) list
+exception Tags of label * label
+exception Subtype of
+        (type_expr * type_expr) list * (type_expr * type_expr) list
+exception Cannot_expand
+exception Cannot_apply
+exception Recursive_abbrev
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
+
+val init_def: int -> unit
+        (* Set the initial variable level *)
+val begin_def: unit -> unit
+        (* Raise the variable level by one at the beginning of a definition. *)
+val end_def: unit -> unit
+        (* Lower the variable level by one at the end of a definition *)
+val begin_class_def: unit -> unit
+val raise_nongen_level: unit -> unit
+val reset_global_level: unit -> unit
+        (* Reset the global level before typing an expression *)
+val increase_global_level: unit -> int
+val restore_global_level: int -> unit
+        (* This pair of functions is only used in Typetexp *)
+type levels =
+    { current_level: int; nongen_level: int; global_level: int;
+      saved_level: (int * int) list; }
+val save_levels: unit -> levels
+val set_levels: levels -> unit
+
+val newty: type_desc -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
+        (* Return a fresh variable *)
+val new_global_var: ?name:string -> unit -> type_expr
+        (* Return a fresh variable, bound at toplevel
+           (as type variables ['a] in type constraints). *)
+val newobj: type_expr -> type_expr
+val newconstr: Path.t -> type_expr list -> type_expr
+val none: type_expr
+        (* A dummy type expression *)
+
+val repr: type_expr -> type_expr
+        (* Return the canonical representative of a type. *)
+
+val object_fields: type_expr -> type_expr
+val flatten_fields:
+        type_expr -> (string * field_kind * type_expr) list * type_expr
+        (* Transform a field type into a list of pairs label-type *)
+        (* The fields are sorted *)
+val associate_fields:
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr) list ->
+        (string * field_kind * type_expr * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list *
+        (string * field_kind * type_expr) list
+val opened_object: type_expr -> bool
+val close_object: type_expr -> unit
+val row_variable: type_expr -> type_expr
+        (* Return the row variable of an open object type *)
+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 lid_of_path: ?hash:string -> Path.t -> Longident.t
+
+val sort_row_fields: (label * row_field) list -> (label * row_field) list
+val merge_row_fields:
+        (label * row_field) list -> (label * row_field) list ->
+        (label * row_field) list * (label * row_field) list *
+        (label * row_field * row_field) list
+val filter_row_fields:
+        bool -> (label * row_field) list -> (label * row_field) list
+
+val generalize: type_expr -> unit
+        (* Generalize in-place the given type *)
+val generalize_expansive: Env.t -> type_expr -> unit
+        (* Generalize the covariant part of a type, making
+           contravariant branches non-generalizable *)
+val generalize_global: type_expr -> unit
+        (* Generalize the structure of a type, lowering variables
+           to !global_level *)
+val generalize_structure: type_expr -> unit
+        (* Same, but variables are only lowered to !current_level *)
+val generalize_spine: type_expr -> unit
+        (* Special function to generalize a method during inference *)
+val correct_levels: type_expr -> type_expr
+        (* Returns a copy with decreasing levels *)
+val limited_generalize: type_expr -> type_expr -> unit
+        (* Only generalize some part of the type
+           Make the remaining of the type non-generalizable *)
+
+val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
+        (* Take an instance of a type scheme *)
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val instance_def: type_expr -> type_expr
+        (* use defaults *)
+val generic_instance: Env.t -> type_expr -> type_expr
+        (* Same as instance, but new nodes at generic_level *)
+val instance_list: Env.t -> type_expr list -> type_expr list
+        (* Take an instance of a list of type schemes *)
+val instance_constructor:
+        ?in_pattern:Env.t ref * int ->
+        constructor_description -> type_expr list * type_expr
+        (* Same, for a constructor *)
+val instance_parameterized_type:
+        ?keep_names:bool ->
+        type_expr list -> type_expr -> type_expr list * type_expr
+val instance_parameterized_type_2:
+        type_expr list -> type_expr list -> type_expr ->
+        type_expr list * type_expr list * type_expr
+val instance_declaration: type_declaration -> type_declaration
+val instance_class:
+        type_expr list -> class_type -> type_expr list * class_type
+val instance_poly:
+        ?keep_names:bool ->
+        bool -> type_expr list -> type_expr -> type_expr list * type_expr
+        (* Take an instance of a type scheme containing free univars *)
+val instance_label:
+        bool -> label_description -> type_expr list * type_expr * type_expr
+        (* Same, for a label *)
+val apply:
+        Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr
+        (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to
+        the parameters [pi] and returns the corresponding instance of
+        [t]. Exception [Cannot_apply] is raised in case of failure. *)
+
+val expand_head_once: Env.t -> type_expr -> type_expr
+val expand_head: Env.t -> type_expr -> type_expr
+val try_expand_once_opt: Env.t -> type_expr -> type_expr
+val expand_head_opt: Env.t -> type_expr -> type_expr
+(** The compiler's own version of [expand_head] necessary for type-based
+    optimisations. *)
+
+val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+        Env.t -> type_expr -> Path.t * Path.t * type_declaration
+        (* Return the original path of the types, and the first concrete
+           type declaration found expanding it.
+           Raise [Not_found] if none appears or not a type constructor. *)
+
+val enforce_constraints: Env.t -> type_expr -> unit
+
+val unify: Env.t -> type_expr -> type_expr -> unit
+        (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
+        (* Unify the two types given and update the environment with the
+           local constraints. Raise [Unify] if not possible. *)
+val unify_var: Env.t -> type_expr -> type_expr -> unit
+        (* Same as [unify], but allow free univars when first type
+           is a variable. *)
+val with_passive_variants: ('a -> 'b) -> ('a -> 'b)
+        (* Call [f] in passive_variants mode, for exhaustiveness check. *)
+val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
+        (* A special case of unification (with l:'a -> 'b). *)
+val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
+        (* A special case of unification (with {m : 'a; 'b}). *)
+val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
+        (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
+val deep_occur: type_expr -> type_expr -> bool
+val filter_self_method:
+        Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
+        type_expr -> Ident.t * type_expr
+val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
+        (* Check if the first type scheme is more general than the second. *)
+
+val rigidify: type_expr -> type_expr list
+        (* "Rigidify" a type and return its type variable *)
+val all_distinct_vars: Env.t -> type_expr list -> bool
+        (* Check those types are all distinct type variables *)
+val matches: Env.t -> type_expr -> type_expr -> bool
+        (* Same as [moregeneral false], implemented using the two above
+           functions and backtracking. Ignore levels *)
+
+type class_match_failure =
+    CM_Virtual_class
+  | CM_Parameter_arity_mismatch of int * int
+  | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
+  | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
+  | CM_Non_mutable_value of string
+  | CM_Non_concrete_value of string
+  | CM_Missing_value of string
+  | CM_Missing_method of string
+  | CM_Hide_public of string
+  | CM_Hide_virtual of string * string
+  | CM_Public_method of string
+  | CM_Private_method of string
+  | CM_Virtual_method of string
+val match_class_types:
+    ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool
+        (* [equal env [x1...xn] tau [y1...yn] sigma]
+           checks whether the parameterized types
+           [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
+val match_class_declarations:
+        Env.t -> type_expr list -> class_type -> type_expr list ->
+        class_type -> class_match_failure list
+        (* Check if the first class type is more general than the second. *)
+
+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
+        (* [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
+           constraints. *)
+
+val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr
+        (* Return a type equivalent to the given type but without
+           references to the given module identifier. Raise [Not_found]
+           if no such type exists. *)
+val nondep_type_decl:
+        Env.t -> Ident.t -> Ident.t -> bool -> type_declaration ->
+        type_declaration
+        (* Same for type declarations. *)
+val nondep_extension_constructor:
+        Env.t -> Ident.t -> extension_constructor ->
+        extension_constructor
+          (* Same for extension constructor *)
+val nondep_class_declaration:
+        Env.t -> Ident.t -> class_declaration -> class_declaration
+        (* Same for class declarations. *)
+val nondep_cltype_declaration:
+        Env.t -> Ident.t -> class_type_declaration -> class_type_declaration
+        (* Same for class type declarations. *)
+(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
+val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool
+val is_contractive: Env.t -> Path.t -> bool
+val normalize_type: Env.t -> type_expr -> unit
+
+val closed_schema: Env.t -> type_expr -> bool
+        (* Check whether the given type scheme contains no non-generic
+           type variables *)
+
+val free_variables: ?env:Env.t -> type_expr -> type_expr list
+        (* If env present, then check for incomplete definitions too *)
+val closed_type_decl: type_declaration -> type_expr option
+val closed_extension_constructor: extension_constructor -> type_expr option
+type closed_class_failure =
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
+val closed_class:
+        type_expr list -> class_signature -> closed_class_failure option
+        (* Check whether all type variables are bound *)
+
+val unalias: type_expr -> type_expr
+val signature_of_class_type: class_type -> class_signature
+val self_type: class_type -> type_expr
+val class_type_arity: class_type -> int
+val arity: type_expr -> int
+        (* Return the arity (as for curried functions) of the given type. *)
+
+val collapse_conj_params: Env.t -> type_expr list -> unit
+        (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int
+val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
+val reset_reified_var_counter: unit -> unit
+
+val maybe_pointer_type : Env.t -> type_expr -> bool
+       (* True if type is possibly pointer, false if definitely not a pointer *)
+
+(* Stubs *)
+val package_subtype :
+    (Env.t -> Path.t -> Longident.t list -> type_expr list ->
+      Path.t -> Longident.t list -> type_expr list -> bool) ref
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
new file mode 100644
index 00000000..5c46ae15
--- /dev/null
+++ b/typing/datarepr.ml
@@ -0,0 +1,237 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Asttypes
+open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let free_vars ?(param=false) ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      ty.level <- pivot_level - ty.level;
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then begin
+            match row.row_more.desc with
+            | Tvar _ when param -> ret := TypeSet.add ty !ret
+            | _ -> loop row.row_more
+          end
+      (* XXX: What about Tobject ? *)
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
+
+let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
+
+let constructor_existentials cd_args cd_res =
+  let tyl =
+    match cd_args with
+    | Cstr_tuple l -> l
+    | Cstr_record l -> List.map (fun l -> l.ld_type) l
+  in
+  let existentials =
+    match cd_res with
+    | None -> []
+    | Some type_ret ->
+        let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
+        let res_vars = free_vars type_ret in
+        TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
+  in
+  (tyl, existentials)
+
+let constructor_args priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
+  match cd_args with
+  | Cstr_tuple l -> existentials, l, None
+  | Cstr_record lbls ->
+      let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
+      let type_params = TypeSet.elements arg_vars_set in
+      let type_unboxed =
+        match rep with
+        | Record_unboxed _ -> unboxed_true_default_false
+        | _ -> unboxed_false_default_false
+      in
+      let tdecl =
+        {
+          type_params;
+          type_arity = List.length type_params;
+          type_kind = Type_record (lbls, rep);
+          type_private = priv;
+          type_manifest = None;
+          type_variance = List.map (fun _ -> Variance.full) type_params;
+          type_newtype_level = None;
+          type_loc = Location.none;
+          type_attributes = [];
+          type_immediate = false;
+          type_unboxed;
+        }
+      in
+      existentials,
+      [ newgenconstr path type_params ],
+      Some tdecl
+
+let constructor_descrs ty_path decl cstrs =
+  let ty_res = newgenconstr ty_path decl.type_params in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
+  List.iter
+    (fun {cd_args; cd_res; _} ->
+      if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
+      if cd_res = None then incr num_normal)
+    cstrs;
+  let rec describe_constructors idx_const idx_nonconst = function
+      [] -> []
+    | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
+        let ty_res =
+          match cd_res with
+          | Some ty_res' -> ty_res'
+          | None -> ty_res
+        in
+        let (tag, descr_rem) =
+          match cd_args with
+          | _ when decl.type_unboxed.unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [] -> (Cstr_constant idx_const,
+                   describe_constructors (idx_const+1) idx_nonconst rem)
+          | _  -> (Cstr_block idx_nonconst,
+                   describe_constructors idx_const (idx_nonconst+1) rem) in
+        let cstr_name = Ident.name cd_id in
+        let existentials, cstr_args, cstr_inlined =
+          let representation =
+            if decl.type_unboxed.unboxed
+            then Record_unboxed true
+            else Record_inlined idx_nonconst
+          in
+          constructor_args decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
+        in
+        let cstr =
+          { cstr_name;
+            cstr_res = ty_res;
+            cstr_existentials = existentials;
+            cstr_args;
+            cstr_arity = List.length cstr_args;
+            cstr_tag = tag;
+            cstr_consts = !num_consts;
+            cstr_nonconsts = !num_nonconsts;
+            cstr_normal = !num_normal;
+            cstr_private = decl.type_private;
+            cstr_generalized = cd_res <> None;
+            cstr_loc = cd_loc;
+            cstr_attributes = cd_attributes;
+            cstr_inlined;
+          } in
+        (cd_id, cstr) :: descr_rem in
+  describe_constructors 0 0 cstrs
+
+let extension_descr path_ext ext =
+  let ty_res =
+    match ext.ext_ret_type with
+        Some type_ret -> type_ret
+      | None -> newgenconstr ext.ext_type_path ext.ext_type_params
+  in
+  let existentials, cstr_args, cstr_inlined =
+    constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
+      path_ext Record_extension
+  in
+    { cstr_name = Path.last path_ext;
+      cstr_res = ty_res;
+      cstr_existentials = existentials;
+      cstr_args;
+      cstr_arity = List.length cstr_args;
+      cstr_tag = Cstr_extension(path_ext, cstr_args = []);
+      cstr_consts = -1;
+      cstr_nonconsts = -1;
+      cstr_private = ext.ext_private;
+      cstr_normal = -1;
+      cstr_generalized = ext.ext_ret_type <> None;
+      cstr_loc = ext.ext_loc;
+      cstr_attributes = ext.ext_attributes;
+      cstr_inlined;
+    }
+
+let none = {desc = Ttuple []; level = -1; id = -1}
+                                        (* Clearly ill-formed type *)
+let dummy_label =
+  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+    lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+    lbl_private = Public;
+    lbl_loc = Location.none;
+    lbl_attributes = [];
+  }
+
+let label_descrs ty_res lbls repres priv =
+  let all_labels = Array.make (List.length lbls) dummy_label in
+  let rec describe_labels num = function
+      [] -> []
+    | l :: rest ->
+        let lbl =
+          { lbl_name = Ident.name l.ld_id;
+            lbl_res = ty_res;
+            lbl_arg = l.ld_type;
+            lbl_mut = l.ld_mutable;
+            lbl_pos = num;
+            lbl_all = all_labels;
+            lbl_repres = repres;
+            lbl_private = priv;
+            lbl_loc = l.ld_loc;
+            lbl_attributes = l.ld_attributes;
+          } in
+        all_labels.(num) <- lbl;
+        (l.ld_id, lbl) :: describe_labels (num+1) rest in
+  describe_labels 0 lbls
+
+exception Constr_not_found
+
+let rec find_constr tag num_const num_nonconst = function
+    [] ->
+      raise Constr_not_found
+  | {cd_args = Cstr_tuple []; _} as c  :: rem ->
+      if tag = Cstr_constant num_const
+      then c
+      else find_constr tag (num_const + 1) num_nonconst rem
+  | c :: rem ->
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
+      then c
+      else find_constr tag num_const (num_nonconst + 1) rem
+
+let find_constr_by_tag tag cstrlist =
+  find_constr tag 0 0 cstrlist
+
+let constructors_of_type ty_path decl =
+  match decl.type_kind with
+  | Type_variant cstrs -> constructor_descrs ty_path decl cstrs
+  | Type_record _ | Type_abstract | Type_open -> []
+
+let labels_of_type ty_path decl =
+  match decl.type_kind with
+  | Type_record(labels, rep) ->
+      label_descrs (newgenconstr ty_path decl.type_params)
+        labels rep decl.type_private
+  | Type_variant _ | Type_abstract | Type_open -> []
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
new file mode 100644
index 00000000..8a85282a
--- /dev/null
+++ b/typing/datarepr.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compute constructor and label descriptions from type declarations,
+   determining their representation. *)
+
+open Types
+
+val extension_descr:
+  Path.t -> extension_constructor -> constructor_description
+
+val labels_of_type:
+  Path.t -> type_declaration ->
+  (Ident.t * label_description) list
+val constructors_of_type:
+  Path.t -> type_declaration ->
+  (Ident.t * constructor_description) list
+
+
+exception Constr_not_found
+
+val find_constr_by_tag:
+  constructor_tag -> constructor_declaration list ->
+    constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)
diff --git a/typing/env.ml b/typing/env.ml
new file mode 100644
index 00000000..224e2c8d
--- /dev/null
+++ b/typing/env.ml
@@ -0,0 +1,2100 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Cmi_format
+open Config
+open Misc
+open Asttypes
+open Longident
+open Path
+open Types
+open Btype
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t =
+  Hashtbl.create 16
+    (* This table is used to usage of value declarations.  A declaration is
+       identified with its name and location.  The callback attached to a
+       declaration is called whenever the value is used explicitly
+       (lookup_value) or implicitly (inclusion test between signatures,
+       cf Includemod.value_descriptions). *)
+
+let type_declarations = Hashtbl.create 16
+let module_declarations = Hashtbl.create 16
+
+type constructor_usage = Positive | Pattern | Privatize
+type constructor_usages =
+    {
+     mutable cu_positive: bool;
+     mutable cu_pattern: bool;
+     mutable cu_privatize: bool;
+    }
+let add_constructor_usage cu = function
+  | Positive -> cu.cu_positive <- true
+  | Pattern -> cu.cu_pattern <- true
+  | Privatize -> cu.cu_privatize <- true
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_privatize = false}
+
+let used_constructors :
+    (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t
+  = Hashtbl.create 16
+
+let prefixed_sg = Hashtbl.create 113
+
+type error =
+  | Illegal_renaming of string * string * string
+  | Inconsistent_import of string * string * string
+  | Need_recursive_types of string * string
+  | Depend_on_unsafe_string_unit of string * string
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+
+exception Error of error
+
+let error err = raise (Error err)
+
+module EnvLazy : sig
+  type ('a,'b) t
+
+  val force : ('a -> 'b) -> ('a,'b) t -> 'b
+  val create : 'a -> ('a,'b) t
+  val get_arg : ('a,'b) t -> 'a option
+
+end  = struct
+
+  type ('a,'b) t = ('a,'b) eval ref
+
+  and ('a,'b) eval =
+      Done of 'b
+    | Raise of exn
+    | Thunk of 'a
+
+  let force f x =
+    match !x with
+        Done x -> x
+      | Raise e -> raise e
+      | Thunk e ->
+          try
+            let y = f e in
+            x := Done y;
+            y
+          with e ->
+            x := Raise e;
+            raise e
+
+  let get_arg x =
+    match !x with Thunk a -> Some a | _ -> None
+
+  let create x =
+    ref (Thunk x)
+
+end
+
+module PathMap = Map.Make(Path)
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration PathMap.t
+
+module EnvTbl =
+  struct
+    (* A table indexed by identifier, with an extra slot to record usage. *)
+    type 'a t = ('a * (unit -> unit)) Ident.tbl
+
+    let empty = Ident.empty
+    let nothing = fun () -> ()
+
+    let already_defined wrap s tbl x =
+      wrap (try Some (fst (Ident.find_name s tbl), x) with Not_found -> None)
+
+    let add slot wrap id x tbl ref_tbl =
+      let slot =
+        match slot with
+        | None -> nothing
+        | Some f ->
+          (fun () ->
+             let s = Ident.name id in
+             f s (already_defined wrap s ref_tbl x)
+          )
+      in
+      Ident.add id (x, slot) tbl
+
+    let find_same_not_using id tbl =
+      fst (Ident.find_same id tbl)
+
+    let find_same id tbl =
+      let (x, slot) = Ident.find_same id tbl in
+      slot ();
+      x
+
+    let find_name s tbl =
+      let (x, slot) = Ident.find_name s tbl in
+      slot ();
+      x
+
+    let find_all s tbl =
+      Ident.find_all s tbl
+
+    let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
+    let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
+  end
+
+type type_descriptions =
+    constructor_description list * label_description list
+
+let in_signature_flag = 0x01
+let implicit_coercion_flag = 0x02
+
+type t = {
+  values: (Path.t * value_description) EnvTbl.t;
+  constrs: constructor_description EnvTbl.t;
+  labels: label_description EnvTbl.t;
+  types: (Path.t * (type_declaration * type_descriptions)) EnvTbl.t;
+  modules: (Path.t * module_declaration) EnvTbl.t;
+  modtypes: (Path.t * modtype_declaration) EnvTbl.t;
+  components: (Path.t * module_components) EnvTbl.t;
+  classes: (Path.t * class_declaration) EnvTbl.t;
+  cltypes: (Path.t * class_type_declaration) EnvTbl.t;
+  functor_args: unit Ident.tbl;
+  summary: summary;
+  local_constraints: type_declaration PathMap.t;
+  gadt_instances: (int * TypeSet.t ref) list;
+  flags: int;
+}
+
+and module_components =
+  {
+    deprecated: string option;
+    loc: Location.t;
+    comps: (t * Subst.t * Path.t * Types.module_type, module_components_repr)
+           EnvLazy.t;
+  }
+
+and module_components_repr =
+    Structure_comps of structure_components
+  | Functor_comps of functor_components
+
+and structure_components = {
+  mutable comp_values: (string, (value_description * int)) Tbl.t;
+  mutable comp_constrs: (string, (constructor_description * int) list) Tbl.t;
+  mutable comp_labels: (string, (label_description * int) list) Tbl.t;
+  mutable comp_types:
+   (string, ((type_declaration * type_descriptions) * int)) Tbl.t;
+  mutable comp_modules:
+   (string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t;
+  mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
+  mutable comp_components: (string, (module_components * int)) Tbl.t;
+  mutable comp_classes: (string, (class_declaration * int)) Tbl.t;
+  mutable comp_cltypes: (string, (class_type_declaration * int)) Tbl.t
+}
+
+and functor_components = {
+  fcomp_param: Ident.t;                 (* Formal parameter *)
+  fcomp_arg: module_type option;        (* Argument signature *)
+  fcomp_res: module_type;               (* Result signature *)
+  fcomp_cache: (Path.t, module_components) Hashtbl.t;  (* For memoization *)
+  fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
+}
+
+let copy_local ~from env =
+  { env with
+    local_constraints = from.local_constraints;
+    gadt_instances = from.gadt_instances;
+    flags = from.flags }
+
+let same_constr = ref (fun _ _ _ -> assert false)
+
+(* Helper to decide whether to report an identifier shadowing
+   by some 'open'. For labels and constructors, we do not report
+   if the two elements are from the same re-exported declaration.
+
+   Later, one could also interpret some attributes on value and
+   type declarations to silence the shadowing warnings. *)
+
+let check_shadowing env = function
+  | `Constructor (Some (c1, c2))
+    when not (!same_constr env c1.cstr_res c2.cstr_res) ->
+      Some "constructor"
+  | `Label (Some (l1, l2))
+    when not (!same_constr env l1.lbl_res l2.lbl_res) ->
+      Some "label"
+  | `Value (Some _) -> Some "value"
+  | `Type (Some _) -> Some "type"
+  | `Module (Some _) | `Component (Some _) -> Some "module"
+  | `Module_type (Some _) -> Some "module type"
+  | `Class (Some _) -> Some "class"
+  | `Class_type (Some _) -> Some "class type"
+  | `Constructor _ | `Label _
+  | `Value None | `Type None | `Module None | `Module_type None
+  | `Class None | `Class_type None | `Component None ->
+      None
+
+let subst_modtype_maker (subst, mty) = Subst.modtype subst mty
+
+let empty = {
+  values = EnvTbl.empty; constrs = EnvTbl.empty;
+  labels = EnvTbl.empty; types = EnvTbl.empty;
+  modules = EnvTbl.empty; modtypes = EnvTbl.empty;
+  components = EnvTbl.empty; classes = EnvTbl.empty;
+  cltypes = EnvTbl.empty;
+  summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
+  flags = 0;
+  functor_args = Ident.empty;
+ }
+
+let in_signature b env =
+  let flags =
+    if b then env.flags lor in_signature_flag
+    else env.flags land (lnot in_signature_flag)
+  in
+  {env with flags}
+
+let implicit_coercion env =
+  {env with flags = env.flags lor implicit_coercion_flag}
+
+let is_in_signature env = env.flags land in_signature_flag <> 0
+let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0
+
+let diff_keys is_local tbl1 tbl2 =
+  let keys2 = EnvTbl.keys tbl2 in
+  List.filter
+    (fun id ->
+      is_local (EnvTbl.find_same_not_using id tbl2) &&
+      try ignore (EnvTbl.find_same_not_using id tbl1); false
+      with Not_found -> true)
+    keys2
+
+let is_ident = function
+    Pident _ -> true
+  | Pdot _ | Papply _ -> false
+
+let is_local (p, _) = is_ident p
+
+let is_local_ext = function
+  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
+  | _ -> false
+
+let diff env1 env2 =
+  diff_keys is_local env1.values env2.values @
+  diff_keys is_local_ext env1.constrs env2.constrs @
+  diff_keys is_local env1.modules env2.modules @
+  diff_keys is_local env1.classes env2.classes
+
+(* Forward declarations *)
+
+let components_of_module' =
+  ref ((fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false) :
+         deprecated:string option -> loc:Location.t -> t -> Subst.t ->
+       Path.t -> module_type ->
+       module_components)
+let components_of_module_maker' =
+  ref ((fun (_env, _sub, _path, _mty) -> assert false) :
+          t * Subst.t * Path.t * module_type -> module_components_repr)
+let components_of_functor_appl' =
+  ref ((fun _f _env _p1 _p2 -> assert false) :
+          functor_components -> t -> Path.t -> Path.t -> module_components)
+let check_modtype_inclusion =
+  (* to be filled with Includemod.check_modtype_inclusion *)
+  ref ((fun _env _mty1 _path1 _mty2 -> assert false) :
+          t -> module_type -> Path.t -> module_type -> unit)
+let strengthen =
+  (* to be filled with Mtype.strengthen *)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
+
+let md md_type =
+  {md_type; md_attributes=[]; md_loc=Location.none}
+
+let get_components c =
+  EnvLazy.force !components_of_module_maker' c.comps
+
+
+(* The name of the compilation unit currently compiled.
+   "" if outside a compilation unit. *)
+
+let current_unit = ref ""
+
+(* Persistent structure descriptions *)
+
+type pers_struct =
+  { ps_name: string;
+    ps_sig: signature Lazy.t;
+    ps_comps: module_components;
+    ps_crcs: (string * Digest.t option) list;
+    ps_filename: string;
+    ps_flags: pers_flags list }
+
+let persistent_structures =
+  (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)
+
+(* Consistency between persistent structures *)
+
+let crc_units = Consistbl.create()
+
+module StringSet =
+  Set.Make(struct type t = string let compare = String.compare end)
+
+let imported_units = ref StringSet.empty
+
+let add_import s =
+  imported_units := StringSet.add s !imported_units
+
+let imported_opaque_units = ref StringSet.empty
+
+let add_imported_opaque s =
+  imported_opaque_units := StringSet.add s !imported_opaque_units
+
+let clear_imports () =
+  Consistbl.clear crc_units;
+  imported_units := StringSet.empty;
+  imported_opaque_units := StringSet.empty
+
+let check_consistency ps =
+  try
+    List.iter
+      (fun (name, crco) ->
+         match crco with
+            None -> ()
+          | Some crc ->
+              add_import name;
+              Consistbl.check crc_units name crc ps.ps_filename)
+      ps.ps_crcs;
+  with Consistbl.Inconsistency(name, source, auth) ->
+    error (Inconsistent_import(name, auth, source))
+
+(* Reading persistent structures from .cmi files *)
+
+let save_pers_struct crc ps =
+  let modname = ps.ps_name in
+  Hashtbl.add persistent_structures modname (Some ps);
+  List.iter
+    (function
+        | Rectypes -> ()
+        | Deprecated _ -> ()
+        | Unsafe_string -> ()
+        | Opaque -> add_imported_opaque modname)
+    ps.ps_flags;
+  Consistbl.set crc_units modname crc ps.ps_filename;
+  add_import modname
+
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+    match find_in_path_uncap !load_path (unit_name ^ ".cmi") with
+    | filename -> Some { filename; cmi = read_cmi filename }
+    | exception Not_found -> None)
+end
+
+let acknowledge_pers_struct check modname
+      { Persistent_signature.filename; cmi } =
+  let name = cmi.cmi_name in
+  let sign = cmi.cmi_sign in
+  let crcs = cmi.cmi_crcs in
+  let flags = cmi.cmi_flags in
+  let deprecated =
+    List.fold_left (fun acc -> function Deprecated s -> Some s | _ -> acc) None
+      flags
+  in
+  let comps =
+      !components_of_module' ~deprecated ~loc:Location.none
+        empty Subst.identity
+                             (Pident(Ident.create_persistent name))
+                             (Mty_signature sign)
+  in
+  let ps = { ps_name = name;
+             ps_sig = lazy (Subst.signature Subst.identity sign);
+             ps_comps = comps;
+             ps_crcs = crcs;
+             ps_filename = filename;
+             ps_flags = flags;
+           } in
+  if ps.ps_name <> modname then
+    error (Illegal_renaming(modname, ps.ps_name, filename));
+
+  List.iter
+    (function
+        | Rectypes ->
+            if not !Clflags.recursive_types then
+              error (Need_recursive_types(ps.ps_name, !current_unit))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit (ps.ps_name, !current_unit));
+        | Deprecated _ -> ()
+        | Opaque -> add_imported_opaque modname)
+    ps.ps_flags;
+  if check then check_consistency ps;
+  Hashtbl.add persistent_structures modname (Some ps);
+  ps
+
+let read_pers_struct check modname filename =
+  add_import modname;
+  let cmi = read_cmi filename in
+  acknowledge_pers_struct check modname
+    { Persistent_signature.filename; cmi }
+
+let can_load_cmis = ref true
+let without_cmis f x =
+  Misc.(protect_refs [R (can_load_cmis, false)] (fun () -> f x))
+
+let find_pers_struct check name =
+  if name = "*predef*" then raise Not_found;
+  match Hashtbl.find persistent_structures name with
+  | Some ps -> ps
+  | None -> raise Not_found
+  | exception Not_found when !can_load_cmis ->
+      let ps =
+        match !Persistent_signature.load ~unit_name:name with
+        | Some ps -> ps
+        | None ->
+          Hashtbl.add persistent_structures name None;
+          raise Not_found
+      in
+      add_import name;
+      acknowledge_pers_struct check name ps
+
+(* Emits a warning if there is no valid cmi for name *)
+let check_pers_struct name =
+  try
+    ignore (find_pers_struct false name)
+  with
+  | Not_found ->
+      let warn = Warnings.No_cmi_file(name, None) in
+        Location.prerr_warning Location.none warn
+  | Cmi_format.Error err ->
+      let msg = Format.asprintf "%a" Cmi_format.report_error err in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning Location.none warn
+  | Error err ->
+      let msg =
+        match err with
+        | Illegal_renaming(name, ps_name, filename) ->
+            Format.asprintf
+              " %a@ contains the compiled interface for @ \
+               %s when %s was expected"
+              Location.print_filename filename ps_name name
+        | Inconsistent_import _ -> assert false
+        | Need_recursive_types(name, _) ->
+            Format.sprintf
+              "%s uses recursive types"
+              name
+        | Depend_on_unsafe_string_unit (name, _) ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
+        | Missing_module _ -> assert false
+        | Illegal_value_name _ -> assert false
+      in
+      let warn = Warnings.No_cmi_file(name, Some msg) in
+        Location.prerr_warning Location.none warn
+
+let read_pers_struct modname filename =
+  read_pers_struct true modname filename
+
+let find_pers_struct name =
+  find_pers_struct true name
+
+let check_pers_struct name =
+  if not (Hashtbl.mem persistent_structures name) then begin
+    (* PR#6843: record the weak dependency ([add_import]) regardless of
+       whether the check suceeds, to help make builds more
+       deterministic. *)
+    add_import name;
+    if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
+      !add_delayed_check_forward
+        (fun () -> check_pers_struct name)
+  end
+
+let reset_cache () =
+  current_unit := "";
+  Hashtbl.clear persistent_structures;
+  clear_imports ();
+  Hashtbl.clear value_declarations;
+  Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
+  Hashtbl.clear used_constructors;
+  Hashtbl.clear prefixed_sg
+
+let reset_cache_toplevel () =
+  (* Delete 'missing cmi' entries from the cache. *)
+  let l =
+    Hashtbl.fold
+      (fun name r acc -> if r = None then name :: acc else acc)
+      persistent_structures []
+  in
+  List.iter (Hashtbl.remove persistent_structures) l;
+  Hashtbl.clear value_declarations;
+  Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
+  Hashtbl.clear used_constructors;
+  Hashtbl.clear prefixed_sg
+
+
+let set_unit_name name =
+  current_unit := name
+
+let get_unit_name () =
+  !current_unit
+
+(* Lookup by identifier *)
+
+let rec find_module_descr path env =
+  match path with
+    Pident id ->
+      begin try
+        let (_p, desc) = EnvTbl.find_same id env.components
+        in desc
+      with Not_found ->
+        if Ident.persistent id && not (Ident.name id = !current_unit)
+        then (find_pers_struct (Ident.name id)).ps_comps
+        else raise Not_found
+      end
+  | Pdot(p, s, _pos) ->
+      begin match get_components (find_module_descr p env) with
+        Structure_comps c ->
+          let (descr, _pos) = Tbl.find s c.comp_components in
+          descr
+      | Functor_comps _ ->
+         raise Not_found
+      end
+  | Papply(p1, p2) ->
+      begin match get_components (find_module_descr p1 env) with
+        Functor_comps f ->
+          !components_of_functor_appl' f env p1 p2
+      | Structure_comps _ ->
+          raise Not_found
+      end
+
+let find proj1 proj2 path env =
+  match path with
+    Pident id ->
+      let (_p, data) = EnvTbl.find_same id (proj1 env)
+      in data
+  | Pdot(p, s, _pos) ->
+      begin match get_components (find_module_descr p env) with
+        Structure_comps c ->
+          let (data, _pos) = Tbl.find s (proj2 c) in data
+      | Functor_comps _ ->
+          raise Not_found
+      end
+  | Papply _ ->
+      raise Not_found
+
+let find_value =
+  find (fun env -> env.values) (fun sc -> sc.comp_values)
+and find_type_full =
+  find (fun env -> env.types) (fun sc -> sc.comp_types)
+and find_modtype =
+  find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
+and find_class =
+  find (fun env -> env.classes) (fun sc -> sc.comp_classes)
+and find_cltype =
+  find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+
+let type_of_cstr path = function
+  | {cstr_inlined = Some d; _} ->
+      (d, ([], List.map snd (Datarepr.labels_of_type path d)))
+  | _ ->
+      assert false
+
+let find_type_full path env =
+  match Path.constructor_typath path with
+  | Regular p ->
+      (try (PathMap.find p env.local_constraints, ([], []))
+       with Not_found -> find_type_full p env)
+  | Cstr (ty_path, s) ->
+      let (_, (cstrs, _)) =
+        try find_type_full ty_path env
+        with Not_found -> assert false
+      in
+      let cstr =
+        try List.find (fun cstr -> cstr.cstr_name = s) cstrs
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | LocalExt id ->
+      let cstr =
+        try EnvTbl.find_same id env.constrs
+        with Not_found -> assert false
+      in
+      type_of_cstr path cstr
+  | Ext (mod_path, s) ->
+      let comps =
+        try find_module_descr mod_path env
+        with Not_found -> assert false
+      in
+      let comps =
+        match get_components comps with
+        | Structure_comps c -> c
+        | Functor_comps _ -> assert false
+      in
+      let exts =
+        List.filter
+          (function ({cstr_tag=Cstr_extension _}, _) -> true | _ -> false)
+          (try Tbl.find s comps.comp_constrs
+           with Not_found -> assert false)
+      in
+      match exts with
+      | [(cstr, _)] -> type_of_cstr path cstr
+      | _ -> assert false
+
+let find_type p env =
+  fst (find_type_full p env)
+let find_type_descrs p env =
+  snd (find_type_full p env)
+
+let find_module ~alias path env =
+  match path with
+    Pident id ->
+      begin try
+        let (_p, data) = EnvTbl.find_same id env.modules
+        in data
+      with Not_found ->
+        if Ident.persistent id && not (Ident.name id = !current_unit) then
+          let ps = find_pers_struct (Ident.name id) in
+          md (Mty_signature(Lazy.force ps.ps_sig))
+        else raise Not_found
+      end
+  | Pdot(p, s, _pos) ->
+      begin match get_components (find_module_descr p env) with
+        Structure_comps c ->
+          let (data, _pos) = Tbl.find s c.comp_modules in
+          md (EnvLazy.force subst_modtype_maker data)
+      | Functor_comps _ ->
+          raise Not_found
+      end
+  | Papply(p1, p2) ->
+      let desc1 = find_module_descr p1 env in
+      begin match get_components desc1 with
+        Functor_comps f ->
+          md begin match f.fcomp_res with
+          | Mty_alias _ as mty -> mty
+          | mty ->
+              if alias then mty else
+              try
+                Hashtbl.find f.fcomp_subst_cache p2
+              with Not_found ->
+                let mty =
+                  Subst.modtype
+                    (Subst.add_module f.fcomp_param p2 Subst.identity)
+                    f.fcomp_res in
+                Hashtbl.add f.fcomp_subst_cache p2 mty;
+                mty
+          end
+      | Structure_comps _ ->
+          raise Not_found
+      end
+
+let required_globals = ref []
+let reset_required_globals () = required_globals := []
+let get_required_globals () = !required_globals
+let add_required_global id =
+  if Ident.global id && not !Clflags.transparent_modules
+  && not (List.exists (Ident.same id) !required_globals)
+  then required_globals := id :: !required_globals
+
+let rec normalize_path lax env path =
+  let path =
+    match path with
+      Pdot(p, s, pos) ->
+        Pdot(normalize_path lax env p, s, pos)
+    | Papply(p1, p2) ->
+        Papply(normalize_path lax env p1, normalize_path true env p2)
+    | _ -> path
+  in
+  try match find_module ~alias:true path env with
+    {md_type=Mty_alias(_, path1)} ->
+      let path' = normalize_path lax env path1 in
+      if lax || !Clflags.transparent_modules then path' else
+      let id = Path.head path in
+      if Ident.global id && not (Ident.same id (Path.head path'))
+      then add_required_global id;
+      path'
+  | _ -> path
+  with Not_found when lax
+  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
+      path
+
+let normalize_path oloc env path =
+  try normalize_path (oloc = None) env path
+  with Not_found ->
+    match oloc with None -> assert false
+    | Some loc ->
+        raise (Error(Missing_module(loc, path, normalize_path true env path)))
+
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s, pos) ->
+      Pdot(normalize_path oloc env p, s, pos)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+
+let find_module = find_module ~alias:false
+
+(* Find the manifest type associated to a type when appropriate:
+   - the type should be public or should have a private row,
+   - the type should have an associated manifest type. *)
+let find_type_expansion path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  | Some body when decl.type_private = Public
+              || decl.type_kind <> Type_abstract
+              || Btype.has_constr_row body ->
+                  (decl.type_params, body, may_map snd decl.type_newtype_level)
+  (* The manifest type of Private abstract data types without
+     private row are still considered unknown to the type system.
+     Hence, this case is caught by the following clause that also handles
+     purely abstract data types without manifest type definition. *)
+  | _ -> raise Not_found
+
+(* Find the manifest type information associated to a type, i.e.
+   the necessary information for the compiler's type-based optimisations.
+   In particular, the manifest type associated to a private abstract type
+   is revealed for the sake of compiler's type-based optimisations. *)
+let find_type_expansion_opt path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  (* The manifest type of Private abstract data types can still get
+     an approximation using their manifest type. *)
+  | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
+  | _ -> raise Not_found
+
+let find_modtype_expansion path env =
+  match (find_modtype path env).mtd_type with
+  | None -> raise Not_found
+  | Some mty -> mty
+
+let rec is_functor_arg path env =
+  match path with
+    Pident id ->
+      begin try Ident.find_same id env.functor_args; true
+      with Not_found -> false
+      end
+  | Pdot (p, _s, _) -> is_functor_arg p env
+  | Papply _ -> true
+
+(* Lookup by name *)
+
+exception Recmodule
+
+let report_deprecated ?loc p deprecated =
+  match loc, deprecated with
+  | Some loc, Some txt ->
+      let txt = if txt = "" then "" else "\n" ^ txt in
+      Location.prerr_warning loc
+        (Warnings.Deprecated (Printf.sprintf "module %s%s"
+                                (Path.name p) txt))
+  | _ -> ()
+
+let mark_module_used env name loc =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find module_declarations (name, loc) ()
+    with Not_found -> ()
+
+let rec lookup_module_descr_aux ?loc lid env =
+  match lid with
+    Lident s ->
+      begin try
+        EnvTbl.find_name s env.components
+      with Not_found ->
+        if s = !current_unit then raise Not_found;
+        let ps = find_pers_struct s in
+        (Pident(Ident.create_persistent s), ps.ps_comps)
+      end
+  | Ldot(l, s) ->
+      let (p, descr) = lookup_module_descr ?loc l env in
+      begin match get_components descr with
+        Structure_comps c ->
+          let (descr, pos) = Tbl.find s c.comp_components in
+          (Pdot(p, s, pos), descr)
+      | Functor_comps _ ->
+          raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      let (p1, desc1) = lookup_module_descr ?loc l1 env in
+      let p2 = lookup_module ~load:true ?loc l2 env in
+      let {md_type=mty2} = find_module p2 env in
+      begin match get_components desc1 with
+        Functor_comps f ->
+          Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
+          (Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
+      | Structure_comps _ ->
+          raise Not_found
+      end
+
+and lookup_module_descr ?loc lid env =
+  let (p, comps) as res = lookup_module_descr_aux ?loc lid env in
+  mark_module_used env (Path.last p) comps.loc;
+(*
+  Format.printf "USE module %s at %a@." (Path.last p)
+    Location.print comps.loc;
+*)
+  report_deprecated ?loc p comps.deprecated;
+  res
+
+and lookup_module ~load ?loc lid env : Path.t =
+  match lid with
+    Lident s ->
+      begin try
+        let (p, {md_type; md_attributes; md_loc}) =
+          EnvTbl.find_name s env.modules
+        in
+        mark_module_used env s md_loc;
+        begin match md_type with
+        | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
+          (* see #5965 *)
+          raise Recmodule
+        | _ -> ()
+        end;
+        report_deprecated ?loc p
+          (Builtin_attributes.deprecated_of_attrs md_attributes);
+        p
+      with Not_found ->
+        if s = !current_unit then raise Not_found;
+        let p = Pident(Ident.create_persistent s) in
+        if !Clflags.transparent_modules && not load then check_pers_struct s
+        else begin
+          let ps = find_pers_struct s in
+          report_deprecated ?loc p ps.ps_comps.deprecated
+        end;
+        p
+      end
+  | Ldot(l, s) ->
+      let (p, descr) = lookup_module_descr ?loc l env in
+      begin match get_components descr with
+        Structure_comps c ->
+          let (_data, pos) = Tbl.find s c.comp_modules in
+          let (comps, _) = Tbl.find s c.comp_components in
+          mark_module_used env s comps.loc;
+          let p = Pdot(p, s, pos) in
+          report_deprecated ?loc p comps.deprecated;
+          p
+      | Functor_comps _ ->
+          raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      let (p1, desc1) = lookup_module_descr ?loc l1 env in
+      let p2 = lookup_module ~load:true ?loc l2 env in
+      let {md_type=mty2} = find_module p2 env in
+      let p = Papply(p1, p2) in
+      begin match get_components desc1 with
+        Functor_comps f ->
+          Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
+          p
+      | Structure_comps _ ->
+          raise Not_found
+      end
+
+let lookup proj1 proj2 ?loc lid env =
+  match lid with
+    Lident s ->
+      EnvTbl.find_name s (proj1 env)
+  | Ldot(l, s) ->
+      let (p, desc) = lookup_module_descr ?loc l env in
+      begin match get_components desc with
+        Structure_comps c ->
+          let (data, pos) = Tbl.find s (proj2 c) in
+          (Pdot(p, s, pos), data)
+      | Functor_comps _ ->
+          raise Not_found
+      end
+  | Lapply _ ->
+      raise Not_found
+
+let lookup_all_simple proj1 proj2 shadow ?loc lid env =
+  match lid with
+    Lident s ->
+      let xl = EnvTbl.find_all s (proj1 env) in
+      let rec do_shadow =
+        function
+        | [] -> []
+        | ((x, f) :: xs) ->
+            (x, f) ::
+              (do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs))
+      in
+        do_shadow xl
+  | Ldot(l, s) ->
+      let (_p, desc) = lookup_module_descr ?loc l env in
+      begin match get_components desc with
+        Structure_comps c ->
+          let comps =
+            try Tbl.find s (proj2 c) with Not_found -> []
+          in
+          List.map
+            (fun (data, _pos) -> (data, (fun () -> ())))
+            comps
+      | Functor_comps _ ->
+          raise Not_found
+      end
+  | Lapply _ ->
+      raise Not_found
+
+let has_local_constraints env = not (PathMap.is_empty env.local_constraints)
+
+let cstr_shadow cstr1 cstr2 =
+  match cstr1.cstr_tag, cstr2.cstr_tag with
+  | Cstr_extension _, Cstr_extension _ -> true
+  | _ -> false
+
+let lbl_shadow _lbl1 _lbl2 = false
+
+let lookup_value =
+  lookup (fun env -> env.values) (fun sc -> sc.comp_values)
+and lookup_all_constructors =
+  lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+    cstr_shadow
+and lookup_all_labels =
+  lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+    lbl_shadow
+and lookup_type =
+  lookup (fun env -> env.types) (fun sc -> sc.comp_types)
+and lookup_modtype =
+  lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
+and lookup_class =
+  lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
+and lookup_cltype =
+  lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+
+let update_value s f env =
+  try
+    let ((p, vd), slot) = Ident.find_name s env.values in
+    match p with
+    | Pident id ->
+        let vd2 = f vd in
+        {env with values = Ident.add id ((p, vd2), slot) env.values;
+                  summary = Env_value(env.summary, id, vd2)}
+    | _ ->
+        env
+  with Not_found ->
+    env
+
+let mark_value_used env name vd =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find value_declarations (name, vd.val_loc) ()
+    with Not_found -> ()
+
+let mark_type_used env name vd =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find type_declarations (name, vd.type_loc) ()
+    with Not_found -> ()
+
+let mark_constructor_used usage env name vd constr =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
+    with Not_found -> ()
+
+let mark_extension_used usage env ext name =
+  if not (is_implicit_coercion env) then
+    let ty_name = Path.last ext.ext_type_path in
+    try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage
+    with Not_found -> ()
+
+let set_value_used_callback name vd callback =
+  let key = (name, vd.val_loc) in
+  try
+    let old = Hashtbl.find value_declarations key in
+    Hashtbl.replace value_declarations key (fun () -> old (); callback ())
+      (* this is to support cases like:
+               let x = let x = 1 in x in x
+         where the two declarations have the same location
+         (e.g. resulting from Camlp4 expansion of grammar entries) *)
+  with Not_found ->
+    Hashtbl.add value_declarations key callback
+
+let set_type_used_callback name td callback =
+  let loc = td.type_loc in
+  if loc.Location.loc_ghost then ()
+  else let key = (name, loc) in
+  let old =
+    try Hashtbl.find type_declarations key
+    with Not_found -> assert false
+  in
+  Hashtbl.replace type_declarations key (fun () -> callback old)
+
+let lookup_value ?loc lid env =
+  let (_, desc) as r = lookup_value ?loc lid env in
+  mark_value_used env (Longident.last lid) desc;
+  r
+
+let lookup_type ?loc lid env =
+  let (path, (decl, _)) = lookup_type ?loc lid env in
+  mark_type_used env (Longident.last lid) decl;
+  path
+
+let mark_type_path env path =
+  try
+    let decl = find_type path env in
+    mark_type_used env (Path.last path) decl
+  with Not_found -> ()
+
+let ty_path t =
+  match repr t with
+  | {desc=Tconstr(path, _, _)} -> path
+  | _ -> assert false
+
+let lookup_constructor ?loc lid env =
+  match lookup_all_constructors ?loc lid env with
+    [] -> raise Not_found
+  | (desc, use) :: _ ->
+      mark_type_path env (ty_path desc.cstr_res);
+      use ();
+      desc
+
+let is_lident = function
+    Lident _ -> true
+  | _ -> false
+
+let lookup_all_constructors ?loc lid env =
+  try
+    let cstrs = lookup_all_constructors ?loc lid env in
+    let wrap_use desc use () =
+      mark_type_path env (ty_path desc.cstr_res);
+      use ()
+    in
+    List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
+  with
+    Not_found when is_lident lid -> []
+
+let mark_constructor usage env name desc =
+  if not (is_implicit_coercion env)
+  then match desc.cstr_tag with
+  | Cstr_extension _ ->
+      begin
+        let ty_path = ty_path desc.cstr_res in
+        let ty_name = Path.last ty_path in
+        try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage
+        with Not_found -> ()
+      end
+  | _ ->
+      let ty_path = ty_path desc.cstr_res in
+      let ty_decl = try find_type ty_path env with Not_found -> assert false in
+      let ty_name = Path.last ty_path in
+      mark_constructor_used usage env ty_name ty_decl name
+
+let lookup_label ?loc lid env =
+  match lookup_all_labels ?loc lid env with
+    [] -> raise Not_found
+  | (desc, use) :: _ ->
+      mark_type_path env (ty_path desc.lbl_res);
+      use ();
+      desc
+
+let lookup_all_labels ?loc lid env =
+  try
+    let lbls = lookup_all_labels ?loc lid env in
+    let wrap_use desc use () =
+      mark_type_path env (ty_path desc.lbl_res);
+      use ()
+    in
+    List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
+  with
+    Not_found when is_lident lid -> []
+
+let lookup_class ?loc lid env =
+  let (_, desc) as r = lookup_class ?loc lid env in
+  (* special support for Typeclass.unbound_class *)
+  if Path.name desc.cty_path = "" then ignore (lookup_type ?loc lid env)
+  else mark_type_path env desc.cty_path;
+  r
+
+let lookup_cltype ?loc lid env =
+  let (_, desc) as r = lookup_cltype ?loc lid env in
+  if Path.name desc.clty_path = "" then ignore (lookup_type ?loc lid env)
+  else mark_type_path env desc.clty_path;
+  mark_type_path env desc.clty_path;
+  r
+
+(* Iter on an environment (ignoring the body of functors and
+   not yet evaluated structures) *)
+
+type iter_cont = unit -> unit
+let iter_env_cont = ref []
+
+let rec scrape_alias_for_visit env mty =
+  match mty with
+  | Mty_alias(_, Pident id)
+    when Ident.persistent id
+      && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false
+  | Mty_alias(_, path) -> (* PR#6600: find_module may raise Not_found *)
+      begin try scrape_alias_for_visit env (find_module path env).md_type
+      with Not_found -> false
+      end
+  | _ -> true
+
+let iter_env proj1 proj2 f env () =
+  Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
+  let rec iter_components path path' mcomps =
+    let cont () =
+      let visit =
+        match EnvLazy.get_arg mcomps.comps with
+        | None -> true
+        | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty
+      in
+      if not visit then () else
+      match get_components mcomps with
+        Structure_comps comps ->
+          Tbl.iter
+            (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d))
+            (proj2 comps);
+          Tbl.iter
+            (fun s (c, n) ->
+              iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c)
+            comps.comp_components
+      | Functor_comps _ -> ()
+    in iter_env_cont := (path, cont) :: !iter_env_cont
+  in
+  Hashtbl.iter
+    (fun s pso ->
+      match pso with None -> ()
+      | Some ps ->
+          let id = Pident (Ident.create_persistent s) in
+          iter_components id id ps.ps_comps)
+    persistent_structures;
+  Ident.iter
+    (fun id ((path, comps), _) -> iter_components (Pident id) path comps)
+    env.components
+
+let run_iter_cont l =
+  iter_env_cont := [];
+  List.iter (fun c -> c ()) l;
+  let cont = List.rev !iter_env_cont in
+  iter_env_cont := [];
+  cont
+
+let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f
+
+let same_types env1 env2 =
+  env1.types == env2.types && env1.components == env2.components
+
+let used_persistent () =
+  let r = ref Concr.empty in
+  Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r)
+    persistent_structures;
+  !r
+
+let find_all_comps proj s (p,mcomps) =
+  match get_components mcomps with
+    Functor_comps _ -> []
+  | Structure_comps comps ->
+      try let (c,n) = Tbl.find s (proj comps) in [Pdot(p,s,n), c]
+      with Not_found -> []
+
+let rec find_shadowed_comps path env =
+  match path with
+    Pident id ->
+      List.map fst (Ident.find_all (Ident.name id) env.components)
+  | Pdot (p, s, _) ->
+      let l = find_shadowed_comps p env in
+      let l' =
+        List.map (find_all_comps (fun comps -> comps.comp_components) s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed proj1 proj2 path env =
+  match path with
+    Pident id ->
+      List.map fst (Ident.find_all (Ident.name id) (proj1 env))
+  | Pdot (p, s, _) ->
+      let l = find_shadowed_comps p env in
+      let l' = List.map (find_all_comps proj2 s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed_types path env =
+  let l =
+    find_shadowed
+      (fun env -> env.types) (fun comps -> comps.comp_types) path env
+  in
+  List.map fst l
+
+
+(* GADT instance tracking *)
+
+let add_gadt_instance_level lv env =
+  {env with
+   gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
+
+let is_Tlink = function {desc = Tlink _} -> true | _ -> false
+
+let gadt_instance_level env t =
+  let rec find_instance = function
+      [] -> None
+    | (lv, r) :: rem ->
+        if TypeSet.exists is_Tlink !r then
+          (* Should we use set_typeset ? *)
+          r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
+        if TypeSet.mem t !r then Some lv else find_instance rem
+  in find_instance env.gadt_instances
+
+let add_gadt_instances env lv tl =
+  let r =
+    try List.assoc lv env.gadt_instances with Not_found -> assert false in
+  (* Format.eprintf "Added";
+  List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl;
+  Format.eprintf "@."; *)
+  set_typeset r (List.fold_right TypeSet.add tl !r)
+
+(* Only use this after expand_head! *)
+let add_gadt_instance_chain env lv t =
+  let r =
+    try List.assoc lv env.gadt_instances with Not_found -> assert false in
+  let rec add_instance t =
+    let t = repr t in
+    if not (TypeSet.mem t !r) then begin
+      (* Format.eprintf "@ %a" !Btype.print_raw t; *)
+      set_typeset r (TypeSet.add t !r);
+      match t.desc with
+        Tconstr (p, _, memo) ->
+          may add_instance (find_expans Private p !memo)
+      | _ -> ()
+    end
+  in
+  (* Format.eprintf "Added chain"; *)
+  add_instance t
+  (* Format.eprintf "@." *)
+
+(* Expand manifest module type names at the top of the given module type *)
+
+let rec scrape_alias env ?path mty =
+  match mty, path with
+    Mty_ident p, _ ->
+      begin try
+        scrape_alias env (find_modtype_expansion p env) ?path
+      with Not_found ->
+        mty
+      end
+  | Mty_alias(_, path), _ ->
+      begin try
+        scrape_alias env (find_module path env).md_type ~path
+      with Not_found ->
+        (*Location.prerr_warning Location.none
+          (Warnings.No_cmi_file (Path.name path));*)
+        mty
+      end
+  | mty, Some path ->
+      !strengthen ~aliasable:true env mty path
+  | _ -> mty
+
+let scrape_alias env mty = scrape_alias env mty
+
+(* Given a signature and a root path, prefix all idents in the signature
+   by the root path and build the corresponding substitution. *)
+
+let rec prefix_idents root pos sub = function
+    [] -> ([], sub)
+  | Sig_value(id, decl) :: rem ->
+      let p = Pdot(root, Ident.name id, pos) in
+      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)
+  | Sig_type(id, _, _) :: 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
+      (p::pl, final_sub)
+  | Sig_typext(id, _, _) :: rem ->
+      let p = Pdot(root, Ident.name id, pos) in
+      (* we extend the substitution in case of an inlined record *)
+      let (pl, final_sub) =
+        prefix_idents root (pos+1) (Subst.add_type id p sub) rem in
+      (p::pl, final_sub)
+  | Sig_module(id, _, _) :: 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
+      (p::pl, final_sub)
+  | Sig_modtype(id, _) :: rem ->
+      let p = Pdot(root, Ident.name id, nopos) in
+      let (pl, final_sub) =
+        prefix_idents root pos
+                      (Subst.add_modtype id (Mty_ident p) sub) rem in
+      (p::pl, final_sub)
+  | Sig_class(id, _, _) :: rem ->
+      (* pretend this is a type, cf. PR#6650 *)
+      let p = Pdot(root, Ident.name id, pos) in
+      let (pl, final_sub) =
+        prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in
+      (p::pl, final_sub)
+  | Sig_class_type(id, _, _) :: 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
+      (p::pl, final_sub)
+
+let subst_signature sub sg =
+  List.map
+    (fun item ->
+      match item with
+      | Sig_value(id, decl) ->
+          Sig_value (id, Subst.value_description sub decl)
+      | Sig_type(id, decl, x) ->
+          Sig_type(id, Subst.type_declaration sub decl, x)
+      | Sig_typext(id, ext, es) ->
+          Sig_typext (id, Subst.extension_constructor sub ext, es)
+      | Sig_module(id, mty, x) ->
+          Sig_module(id, Subst.module_declaration sub mty,x)
+      | Sig_modtype(id, decl) ->
+          Sig_modtype(id, Subst.modtype_declaration sub decl)
+      | Sig_class(id, decl, x) ->
+          Sig_class(id, Subst.class_declaration sub decl, x)
+      | Sig_class_type(id, decl, x) ->
+          Sig_class_type(id, Subst.cltype_declaration sub decl, x)
+    )
+    sg
+
+
+let prefix_idents_and_subst root sub sg =
+  let (pl, sub) = prefix_idents root 0 sub sg in
+  pl, sub, lazy (subst_signature sub sg)
+
+let prefix_idents_and_subst root sub sg =
+  if sub = Subst.identity then
+    let sgs =
+      try
+        Hashtbl.find prefixed_sg root
+      with Not_found ->
+        let sgs = ref [] in
+        Hashtbl.add prefixed_sg root sgs;
+        sgs
+    in
+    try
+      List.assq sg !sgs
+    with Not_found ->
+      let r = prefix_idents_and_subst root sub sg in
+      sgs := (sg, r) :: !sgs;
+      r
+  else
+    prefix_idents_and_subst root sub sg
+
+(* Compute structure descriptions *)
+
+let add_to_tbl id decl tbl =
+  let decls =
+    try Tbl.find id tbl with Not_found -> [] in
+  Tbl.add id (decl :: decls) tbl
+
+let rec components_of_module ~deprecated ~loc env sub path mty =
+  {
+    deprecated;
+    loc;
+    comps = EnvLazy.create (env, sub, path, mty)
+  }
+
+and components_of_module_maker (env, sub, path, mty) =
+  (match scrape_alias env mty with
+    Mty_signature sg ->
+      let c =
+        { comp_values = Tbl.empty;
+          comp_constrs = Tbl.empty;
+          comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+          comp_components = Tbl.empty; comp_classes = Tbl.empty;
+          comp_cltypes = Tbl.empty } in
+      let pl, sub, _ = prefix_idents_and_subst path sub sg in
+      let env = ref env in
+      let pos = ref 0 in
+      List.iter2 (fun item path ->
+        match item with
+          Sig_value(id, decl) ->
+            let decl' = Subst.value_description sub decl in
+            c.comp_values <-
+              Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
+            begin match decl.val_kind with
+              Val_prim _ -> () | _ -> incr pos
+            end
+        | Sig_type(id, decl, _) ->
+            let decl' = Subst.type_declaration sub decl in
+            let constructors =
+              List.map snd (Datarepr.constructors_of_type path decl') in
+            let labels =
+              List.map snd (Datarepr.labels_of_type path decl') in
+            c.comp_types <-
+              Tbl.add (Ident.name id)
+                ((decl', (constructors, labels)), nopos)
+                  c.comp_types;
+            List.iter
+              (fun descr ->
+                c.comp_constrs <-
+                  add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs)
+              constructors;
+            List.iter
+              (fun descr ->
+                c.comp_labels <-
+                  add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels)
+              labels;
+            env := store_type_infos None id (Pident id) decl !env !env
+        | Sig_typext(id, ext, _) ->
+            let ext' = Subst.extension_constructor sub ext in
+            let descr = Datarepr.extension_descr path ext' in
+            c.comp_constrs <-
+              add_to_tbl (Ident.name id) (descr, !pos) c.comp_constrs;
+            incr pos
+        | Sig_module(id, md, _) ->
+            let mty = md.md_type in
+            let mty' = EnvLazy.create (sub, mty) in
+            c.comp_modules <-
+              Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
+            let deprecated =
+              Builtin_attributes.deprecated_of_attrs md.md_attributes
+            in
+            let comps =
+              components_of_module ~deprecated ~loc:md.md_loc !env sub path mty
+            in
+            c.comp_components <-
+              Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
+            env := store_module ~check:false None id (Pident id) md !env !env;
+            incr pos
+        | Sig_modtype(id, decl) ->
+            let decl' = Subst.modtype_declaration sub decl in
+            c.comp_modtypes <-
+              Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
+            env := store_modtype None id (Pident id) decl !env !env
+        | Sig_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
+        | Sig_class_type(id, decl, _) ->
+            let decl' = Subst.cltype_declaration sub decl in
+            c.comp_cltypes <-
+              Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
+        sg pl;
+        Structure_comps c
+  | Mty_functor(param, ty_arg, ty_res) ->
+        Functor_comps {
+          fcomp_param = param;
+          (* fcomp_arg and fcomp_res must be prefixed eagerly, because
+             they are interpreted in the outer environment *)
+          fcomp_arg = may_map (Subst.modtype sub) ty_arg;
+          fcomp_res = Subst.modtype sub ty_res;
+          fcomp_cache = Hashtbl.create 17;
+          fcomp_subst_cache = Hashtbl.create 17 }
+  | Mty_ident _
+  | Mty_alias _ ->
+        Structure_comps {
+          comp_values = Tbl.empty;
+          comp_constrs = Tbl.empty;
+          comp_labels = Tbl.empty;
+          comp_types = Tbl.empty;
+          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+          comp_components = Tbl.empty; comp_classes = Tbl.empty;
+          comp_cltypes = Tbl.empty })
+
+(* Insertion of bindings by identifier + path *)
+
+and check_usage loc id warn tbl =
+  if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin
+    let name = Ident.name id in
+    let key = (name, loc) in
+    if Hashtbl.mem tbl key then ()
+    else let used = ref false in
+    Hashtbl.add tbl key (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and check_value_name name loc =
+  (* Note: we could also check here general validity of the
+     identifier, to protect against bad identifiers forged by -pp or
+     -ppx preprocessors. *)
+
+  if String.length name > 0 && (name.[0] = '#') then
+    for i = 1 to String.length name - 1 do
+      if name.[i] = '#' then
+        raise (Error(Illegal_value_name(loc, name)))
+    done
+
+
+and store_value ?check slot id path decl env renv =
+  check_value_name (Ident.name id) decl.val_loc;
+  may (fun f -> check_usage decl.val_loc id f value_declarations) check;
+  { env with
+    values = EnvTbl.add slot (fun x -> `Value x) id (path, decl)
+        env.values renv.values;
+    summary = Env_value(env.summary, id, decl) }
+
+and store_type ~check slot id path info env renv =
+  let loc = info.type_loc in
+  if check then
+    check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
+      type_declarations;
+  let constructors = Datarepr.constructors_of_type path info in
+  let labels = Datarepr.labels_of_type path info in
+  let descrs = (List.map snd constructors, List.map snd labels) in
+
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
+  then begin
+    let ty = Ident.name id in
+    List.iter
+      begin fun (_, {cstr_name = c; _}) ->
+        let k = (ty, loc, c) in
+        if not (Hashtbl.mem used_constructors k) then
+          let used = constructor_usages () in
+          Hashtbl.add used_constructors k (add_constructor_usage used);
+          if not (ty = "" || ty.[0] = '_')
+          then !add_delayed_check_forward
+              (fun () ->
+                if not (is_in_signature env) && not used.cu_positive then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_constructor
+                       (c, used.cu_pattern, used.cu_privatize)))
+      end
+      constructors
+  end;
+  { env with
+    constrs =
+      List.fold_right
+        (fun (id, descr) constrs ->
+           EnvTbl.add slot (fun x -> `Constructor x) id descr constrs
+             renv.constrs)
+        constructors
+        env.constrs;
+    labels =
+      List.fold_right
+        (fun (id, descr) labels ->
+           EnvTbl.add slot (fun x -> `Label x) id descr labels renv.labels)
+        labels
+        env.labels;
+    types =
+      EnvTbl.add slot (fun x -> `Type x) id (path, (info, descrs)) env.types
+                       renv.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_type_infos slot id path info env renv =
+  (* Simplified version of store_type that doesn't compute and store
+     constructor and label infos, but simply record the arity and
+     manifest-ness of the type.  Used in components_of_module to
+     keep track of type abbreviations (e.g. type t = float) in the
+     computation of label representations. *)
+  { env with
+    types = EnvTbl.add slot (fun x -> `Type x) id (path, (info,([],[])))
+        env.types renv.types;
+    summary = Env_type(env.summary, id, info) }
+
+and store_extension ~check slot id path ext env renv =
+  let loc = ext.ext_loc in
+  if check && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
+  then begin
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
+    let ty = Path.last ext.ext_type_path in
+    let n = Ident.name id in
+    let k = (ty, loc, n) in
+    if not (Hashtbl.mem used_constructors k) then begin
+      let used = constructor_usages () in
+      Hashtbl.add used_constructors k (add_constructor_usage used);
+      !add_delayed_check_forward
+        (fun () ->
+          if not (is_in_signature env) && not used.cu_positive then
+            Location.prerr_warning loc
+              (Warnings.Unused_extension
+                 (n, is_exception, used.cu_pattern, used.cu_privatize)
+              )
+        )
+    end;
+  end;
+  { env with
+    constrs = EnvTbl.add slot (fun x -> `Constructor x) id
+                (Datarepr.extension_descr path ext)
+                env.constrs renv.constrs;
+    summary = Env_extension(env.summary, id, ext) }
+
+and store_module ~check slot id path md env renv =
+  let loc = md.md_loc in
+  if check then
+    check_usage loc id (fun s -> Warnings.Unused_module s)
+      module_declarations;
+
+  let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in
+  { env with
+    modules = EnvTbl.add slot (fun x -> `Module x) id (path, md)
+        env.modules renv.modules;
+    components =
+      EnvTbl.add slot (fun x -> `Component x) id
+        (path, components_of_module ~deprecated ~loc:md.md_loc
+           env Subst.identity path md.md_type)
+        env.components renv.components;
+    summary = Env_module(env.summary, id, md) }
+
+and store_modtype slot id path info env renv =
+  { env with
+    modtypes = EnvTbl.add slot (fun x -> `Module_type x) id (path, info)
+        env.modtypes renv.modtypes;
+    summary = Env_modtype(env.summary, id, info) }
+
+and store_class slot id path desc env renv =
+  { env with
+    classes = EnvTbl.add slot (fun x -> `Class x) id (path, desc)
+        env.classes renv.classes;
+    summary = Env_class(env.summary, id, desc) }
+
+and store_cltype slot id path desc env renv =
+  { env with
+    cltypes = EnvTbl.add slot (fun x -> `Class_type x) id (path, desc)
+        env.cltypes renv.cltypes;
+    summary = Env_cltype(env.summary, id, desc) }
+
+(* Compute the components of a functor application in a path. *)
+
+let components_of_functor_appl f env p1 p2 =
+  try
+    Hashtbl.find f.fcomp_cache p2
+  with Not_found ->
+    let p = Papply(p1, p2) in
+    let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
+    let mty = Subst.modtype sub f.fcomp_res in
+    let comps = components_of_module ~deprecated:None ~loc:Location.none
+        (*???*)
+        env Subst.identity p mty in
+    Hashtbl.add f.fcomp_cache p2 comps;
+    comps
+
+(* Define forward functions *)
+
+let _ =
+  components_of_module' := components_of_module;
+  components_of_functor_appl' := components_of_functor_appl;
+  components_of_module_maker' := components_of_module_maker
+
+(* Insertion of bindings by identifier *)
+
+let add_functor_arg id env =
+  {env with
+   functor_args = Ident.add id () env.functor_args;
+   summary = Env_functor_arg (env.summary, id)}
+
+let add_value ?check id desc env =
+  store_value None ?check id (Pident id) desc env env
+
+let add_type ~check id info env =
+  store_type ~check None id (Pident id) info env env
+
+and add_extension ~check id ext env =
+  store_extension ~check None id (Pident id) ext env env
+
+and add_module_declaration ?(arg=false) ~check id md env =
+  let path =
+    (*match md.md_type with
+      Mty_alias path -> normalize_path env path
+    | _ ->*) Pident id
+  in
+  let env = store_module ~check None id path md env env in
+  if arg then add_functor_arg id env else env
+
+and add_modtype id info env =
+  store_modtype None id (Pident id) info env env
+
+and add_class id ty env =
+  store_class None id (Pident id) ty env env
+
+and add_cltype id ty env =
+  store_cltype None id (Pident id) ty env env
+
+let add_module ?arg id mty env =
+  add_module_declaration ~check:false ?arg id (md mty) env
+
+let add_local_type path info env =
+  { env with
+    local_constraints = PathMap.add path info env.local_constraints }
+
+let add_local_constraint path info elv env =
+  match info with
+    {type_manifest = Some _; type_newtype_level = Some (lv, _)} ->
+      (* elv is the expansion level, lv is the definition level *)
+      let info = {info with type_newtype_level = Some (lv, elv)} in
+      add_local_type path info env
+  | _ -> assert false
+
+
+(* Insertion of bindings by name *)
+
+let enter store_fun name data env =
+  let id = Ident.create name in (id, store_fun None id (Pident id) data env env)
+
+let enter_value ?check = enter (store_value ?check)
+and enter_type = enter (store_type ~check:true)
+and enter_extension = enter (store_extension ~check:true)
+and enter_module_declaration ?arg id md env =
+  add_module_declaration ?arg ~check:true id md env
+  (* let (id, env) = enter store_module name md env in
+  (id, add_functor_arg ?arg id env) *)
+and enter_modtype = enter store_modtype
+and enter_class = enter store_class
+and enter_cltype = enter store_cltype
+
+let enter_module ?arg s mty env =
+  let id = Ident.create s in
+  (id, enter_module_declaration ?arg id (md mty) env)
+
+(* Insertion of all components of a signature *)
+
+let add_item comp env =
+  match comp with
+    Sig_value(id, decl)     -> add_value id decl env
+  | Sig_type(id, decl, _)   -> add_type ~check:false id decl env
+  | Sig_typext(id, ext, _)  -> add_extension ~check:false id ext env
+  | Sig_module(id, md, _)   -> add_module_declaration ~check:false id md env
+  | Sig_modtype(id, decl)   -> add_modtype id decl env
+  | Sig_class(id, decl, _)  -> add_class id decl env
+  | Sig_class_type(id, decl, _) -> add_cltype id decl env
+
+let rec add_signature sg env =
+  match sg with
+    [] -> env
+  | comp :: rem -> add_signature rem (add_item comp env)
+
+(* Open a signature path *)
+
+let open_signature slot root sg env0 =
+  (* First build the paths and substitution *)
+  let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
+  let sg = Lazy.force sg in
+
+  (* Then enter the components in the environment after substitution *)
+
+  let newenv =
+    List.fold_left2
+      (fun env item p ->
+        match item with
+          Sig_value(id, decl) ->
+            store_value slot (Ident.hide id) p decl env env0
+        | Sig_type(id, decl, _) ->
+            store_type ~check:false slot (Ident.hide id) p decl env env0
+        | Sig_typext(id, ext, _) ->
+            store_extension ~check:false slot (Ident.hide id) p ext env env0
+        | Sig_module(id, mty, _) ->
+            store_module ~check:false slot (Ident.hide id) p mty env env0
+        | Sig_modtype(id, decl) ->
+            store_modtype slot (Ident.hide id) p decl env env0
+        | Sig_class(id, decl, _) ->
+            store_class slot (Ident.hide id) p decl env env0
+        | Sig_class_type(id, decl, _) ->
+            store_cltype slot (Ident.hide id) p decl env env0
+      )
+      env0 sg pl in
+  { newenv with summary = Env_open(env0.summary, root) }
+
+(* Open a signature from a file *)
+
+let open_pers_signature name env =
+  let ps = find_pers_struct name in
+  open_signature None (Pident(Ident.create_persistent name))
+    (Lazy.force ps.ps_sig) env
+
+let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
+  if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
+     && (Warnings.is_active (Warnings.Unused_open "")
+         || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
+         || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
+  then begin
+    let used = ref false in
+    !add_delayed_check_forward
+      (fun () ->
+        if not !used then
+          Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+      );
+    let shadowed = ref [] in
+    let slot s b =
+      begin match check_shadowing env b with
+      | Some kind when not (List.mem (kind, s) !shadowed) ->
+          shadowed := (kind, s) :: !shadowed;
+          let w =
+            match kind with
+            | "label" | "constructor" ->
+                Warnings.Open_shadow_label_constructor (kind, s)
+            | _ -> Warnings.Open_shadow_identifier (kind, s)
+          in
+          Location.prerr_warning loc w
+      | _ -> ()
+      end;
+      used := true
+    in
+    open_signature (Some slot) root sg env
+  end
+  else open_signature None root sg env
+
+(* Read a signature from a file *)
+
+let read_signature modname filename =
+  let ps = read_pers_struct modname filename in
+  Lazy.force ps.ps_sig
+
+(* Return the CRC of the interface of the given compilation unit *)
+
+let crc_of_unit name =
+  let ps = find_pers_struct name in
+  let crco =
+    try
+      List.assoc name ps.ps_crcs
+    with Not_found ->
+      assert false
+  in
+    match crco with
+      None -> assert false
+    | Some crc -> crc
+
+(* Return the list of imported interfaces with their CRCs *)
+
+let imports () =
+  Consistbl.extract (StringSet.elements !imported_units) crc_units
+
+(* Returns true if [s] is an opaque imported module  *)
+let is_imported_opaque s =
+  StringSet.mem s !imported_opaque_units
+
+(* Save a signature to a file *)
+
+let save_signature_with_imports ~deprecated sg modname filename imports =
+  (*prerr_endline filename;
+  List.iter (fun (name, crc) -> prerr_endline name) imports;*)
+  Btype.cleanup_abbrev ();
+  Subst.reset_for_saving ();
+  let sg = Subst.signature (Subst.for_saving Subst.identity) sg in
+  let flags =
+    List.concat [
+      if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
+      if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
+      (match deprecated with Some s -> [Deprecated s] | None -> []);
+    ]
+  in
+  let oc = open_out_bin filename in
+  try
+    let cmi = {
+      cmi_name = modname;
+      cmi_sign = sg;
+      cmi_crcs = imports;
+      cmi_flags = flags;
+    } in
+    let crc = output_cmi filename oc cmi in
+    close_out oc;
+    (* Enter signature in persistent table so that imported_unit()
+       will also return its crc *)
+    let comps =
+      components_of_module ~deprecated ~loc:Location.none
+        empty Subst.identity
+        (Pident(Ident.create_persistent modname)) (Mty_signature sg) in
+    let ps =
+      { ps_name = modname;
+        ps_sig = lazy (Subst.signature Subst.identity sg);
+        ps_comps = comps;
+        ps_crcs = (cmi.cmi_name, Some crc) :: imports;
+        ps_filename = filename;
+        ps_flags = cmi.cmi_flags;
+      } in
+    save_pers_struct crc ps;
+    cmi
+  with exn ->
+    close_out oc;
+    remove_file filename;
+    raise exn
+
+let save_signature ~deprecated sg modname filename =
+  save_signature_with_imports ~deprecated sg modname filename (imports())
+
+(* Folding on environments *)
+
+let find_all proj1 proj2 f lid env acc =
+  match lid with
+    | None ->
+      EnvTbl.fold_name
+        (fun id (p, data) acc -> f (Ident.name id) p data acc)
+        (proj1 env) acc
+    | Some l ->
+      let p, desc = lookup_module_descr l env in
+      begin match get_components desc with
+          Structure_comps c ->
+            Tbl.fold
+              (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc)
+              (proj2 c) acc
+        | Functor_comps _ ->
+            acc
+      end
+
+let find_all_simple_list proj1 proj2 f lid env acc =
+  match lid with
+    | None ->
+      EnvTbl.fold_name
+        (fun _id data acc -> f data acc)
+        (proj1 env) acc
+    | Some l ->
+      let (_p, desc) = lookup_module_descr l env in
+      begin match get_components desc with
+          Structure_comps c ->
+            Tbl.fold
+              (fun _s comps acc ->
+                match comps with
+                  [] -> acc
+                | (data, _pos) :: _ ->
+                  f data acc)
+              (proj2 c) acc
+        | Functor_comps _ ->
+            acc
+      end
+
+let fold_modules f lid env acc =
+  match lid with
+    | None ->
+      let acc =
+        EnvTbl.fold_name
+          (fun id (p, data) acc -> f (Ident.name id) p data acc)
+          env.modules
+          acc
+      in
+      Hashtbl.fold
+        (fun name ps acc ->
+          match ps with
+              None -> acc
+            | Some ps ->
+              f name (Pident(Ident.create_persistent name))
+                     (md (Mty_signature (Lazy.force ps.ps_sig))) acc)
+        persistent_structures
+        acc
+    | Some l ->
+      let p, desc = lookup_module_descr l env in
+      begin match get_components desc with
+          Structure_comps c ->
+            Tbl.fold
+              (fun s (data, pos) acc ->
+                f s (Pdot (p, s, pos))
+                    (md (EnvLazy.force subst_modtype_maker data)) acc)
+              c.comp_modules
+              acc
+        | Functor_comps _ ->
+            acc
+      end
+
+let fold_values f =
+  find_all (fun env -> env.values) (fun sc -> sc.comp_values) f
+and fold_constructors f =
+  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
+and fold_labels f =
+  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+and fold_types f =
+  find_all (fun env -> env.types) (fun sc -> sc.comp_types) f
+and fold_modtypes f =
+  find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f
+and fold_classs f =
+  find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f
+and fold_cltypes f =
+  find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f
+
+
+(* Make the initial environment *)
+let (initial_safe_string, initial_unsafe_string) =
+  Predef.build_initial_env
+    (add_type ~check:false)
+    (add_extension ~check:false)
+    empty
+
+(* Return the environment summary *)
+
+let summary env =
+  if PathMap.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
+
+let last_env = ref empty
+let last_reduced_env = ref empty
+
+let keep_only_summary env =
+  if !last_env == env then !last_reduced_env
+  else begin
+    let new_env =
+      {
+       empty with
+       summary = env.summary;
+       local_constraints = env.local_constraints;
+       flags = env.flags;
+      }
+    in
+    last_env := env;
+    last_reduced_env := new_env;
+    new_env
+  end
+
+
+let env_of_only_summary env_from_summary env =
+  let new_env = env_from_summary env.summary Subst.identity in
+  { new_env with
+    local_constraints = env.local_constraints;
+    flags = env.flags;
+  }
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
+      "Wrong file naming: %a@ contains the compiled interface for @ \
+       %s when %s was expected"
+      Location.print_filename filename ps_name modname
+  | Inconsistent_import(name, source1, source2) -> fprintf ppf
+      "@[The files %a@ and %a@ \
+              make inconsistent assumptions@ over interface %s@]"
+      Location.print_filename source1 Location.print_filename source2 name
+  | Need_recursive_types(import, export) ->
+      fprintf ppf
+        "@[Unit %s imports from %s, which uses recursive types.@ %s@]"
+        export import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import, export) ->
+      fprintf ppf
+        "@[Unit %s imports from %s, compiled with -unsafe-string.@ %s@]"
+        export import "This compiler has been configured in strict \
+                       -safe-string mode"
+  | Missing_module(_, path1, path2) ->
+      fprintf ppf "@[@[";
+      if Path.same path1 path2 then
+        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
+      else
+        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
+          (Path.name path1) (Path.name path2);
+      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
+        "The compiled interface for module" (Ident.name (Path.head path2))
+        "was not found"
+  | Illegal_value_name(_loc, name) ->
+      fprintf ppf "'%s' is not a valid value identifier."
+        name
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (Missing_module (loc, _, _)
+              | Illegal_value_name (loc, _)
+               as err) when loc <> Location.none ->
+          Some (Location.error_of_printer loc report_error err)
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/typing/env.mli b/typing/env.mli
new file mode 100644
index 00000000..1bf072c4
--- /dev/null
+++ b/typing/env.mli
@@ -0,0 +1,322 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Environment handling *)
+
+open Types
+
+module PathMap : Map.S with type key = Path.t
+                        and type 'a t = 'a Map.Make(Path).t
+
+type summary =
+    Env_empty
+  | Env_value of summary * Ident.t * value_description
+  | Env_type of summary * Ident.t * type_declaration
+  | Env_extension of summary * Ident.t * extension_constructor
+  | Env_module of summary * Ident.t * module_declaration
+  | Env_modtype of summary * Ident.t * modtype_declaration
+  | Env_class of summary * Ident.t * class_declaration
+  | Env_cltype of summary * Ident.t * class_type_declaration
+  | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration PathMap.t
+
+type t
+
+val empty: t
+val initial_safe_string: t
+val initial_unsafe_string: t
+val diff: t -> t -> Ident.t list
+val copy_local: from:t -> t -> t
+
+type type_descriptions =
+    constructor_description list * label_description list
+
+(* For short-paths *)
+type iter_cont
+val iter_types:
+    (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) ->
+    t -> iter_cont
+val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+        (* [without_cmis f arg] applies [f] to [arg], but does not
+           allow opening cmis during its execution *)
+
+(* Lookup by paths *)
+
+val find_value: Path.t -> t -> value_description
+val find_type: Path.t -> t -> type_declaration
+val find_type_descrs: Path.t -> t -> type_descriptions
+val find_module: Path.t -> t -> module_declaration
+val find_modtype: Path.t -> t -> modtype_declaration
+val find_class: Path.t -> t -> class_declaration
+val find_cltype: Path.t -> t -> class_type_declaration
+
+val find_type_expansion:
+    Path.t -> t -> type_expr list * type_expr * int option
+val find_type_expansion_opt:
+    Path.t -> t -> type_expr list * type_expr * int option
+(* Find the manifest type information associated to a type for the sake
+   of the compiler's type-based optimisations. *)
+val find_modtype_expansion: Path.t -> t -> module_type
+val add_functor_arg: Ident.t -> t -> t
+val is_functor_arg: Path.t -> t -> bool
+val normalize_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete value or module.
+   If the option is None, allow returning dangling paths.
+   Otherwise raise a Missing_module error, and may add forgotten
+   head as required global. *)
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Only normalize the prefix part of the path *)
+val reset_required_globals: unit -> unit
+val get_required_globals: unit -> Ident.t list
+val add_required_global: Ident.t -> unit
+
+val has_local_constraints: t -> bool
+val add_gadt_instance_level: int -> t -> t
+val gadt_instance_level: t -> type_expr -> int option
+val add_gadt_instances: t -> int -> type_expr list -> unit
+val add_gadt_instance_chain: t -> int -> type_expr -> unit
+
+(* Lookup by long identifiers *)
+
+(* ?loc is used to report 'deprecated module' warnings *)
+
+val lookup_value:
+  ?loc:Location.t -> Longident.t -> t -> Path.t * value_description
+val lookup_constructor:
+  ?loc:Location.t -> Longident.t -> t -> constructor_description
+val lookup_all_constructors:
+  ?loc:Location.t ->
+  Longident.t -> t -> (constructor_description * (unit -> unit)) list
+val lookup_label:
+  ?loc:Location.t -> Longident.t -> t -> label_description
+val lookup_all_labels:
+  ?loc:Location.t ->
+  Longident.t -> t -> (label_description * (unit -> unit)) list
+val lookup_type:
+  ?loc:Location.t -> Longident.t -> t -> Path.t
+  (* Since 4.04, this function no longer returns [type_description].
+     To obtain it, you should either call [Env.find_type], or replace
+     it by [Typetexp.find_type] *)
+val lookup_module:
+  load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t
+val lookup_modtype:
+  ?loc:Location.t -> Longident.t -> t -> Path.t * modtype_declaration
+val lookup_class:
+  ?loc:Location.t -> Longident.t -> t -> Path.t * class_declaration
+val lookup_cltype:
+  ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration
+
+val update_value:
+  string -> (value_description -> value_description) -> t -> t
+  (* Used only in Typecore.duplicate_ident_types. *)
+
+exception Recmodule
+  (* Raise by lookup_module when the identifier refers
+     to one of the modules of a recursive definition
+     during the computation of its approximation (see #5965). *)
+
+(* Insertion by identifier *)
+
+val add_value:
+    ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
+val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
+val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
+val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_declaration -> t -> t
+val add_modtype: Ident.t -> modtype_declaration -> t -> t
+val add_class: Ident.t -> class_declaration -> t -> t
+val add_cltype: Ident.t -> class_type_declaration -> t -> t
+val add_local_constraint: Path.t -> type_declaration -> int -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
+
+(* Insertion of all fields of a signature. *)
+
+val add_item: signature_item -> t -> t
+val add_signature: signature -> t -> t
+
+(* Insertion of all fields of a signature, relative to the given path.
+   Used to implement open. *)
+
+val open_signature:
+    ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
+      signature -> t -> t
+val open_pers_signature: string -> t -> t
+
+(* Insertion by name *)
+
+val enter_value:
+    ?check:(string -> Warnings.t) ->
+    string -> value_description -> t -> Ident.t * t
+val enter_type: string -> type_declaration -> t -> Ident.t * t
+val enter_extension: string -> extension_constructor -> t -> Ident.t * t
+val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t
+val enter_module_declaration:
+    ?arg:bool -> Ident.t -> module_declaration -> t -> t
+val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t
+val enter_class: string -> class_declaration -> t -> Ident.t * t
+val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t
+
+(* Initialize the cache of in-core module interfaces. *)
+val reset_cache: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
+
+(* Remember the name of the current compilation unit. *)
+val set_unit_name: string -> unit
+val get_unit_name: unit -> string
+
+(* Read, save a signature to/from a file *)
+
+val read_signature: string -> string -> signature
+        (* Arguments: module name, file name. Results: signature. *)
+val save_signature:
+  deprecated:string option -> signature -> string -> string -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name. *)
+val save_signature_with_imports:
+  deprecated:string option ->
+  signature -> string -> string -> (string * Digest.t option) list
+  -> Cmi_format.cmi_infos
+        (* Arguments: signature, module name, file name,
+           imported units with their CRCs. *)
+
+(* Return the CRC of the interface of the given compilation unit *)
+
+val crc_of_unit: string -> Digest.t
+
+(* Return the set of compilation units imported, with their CRC *)
+
+val imports: unit -> (string * Digest.t option) list
+
+(* [is_imported_opaque md] returns true if [md] is an opaque imported module  *)
+val is_imported_opaque: string -> bool
+
+(* Direct access to the table of imported compilation units with their CRC *)
+
+val crc_units: Consistbl.t
+val add_import: string -> unit
+
+(* Summaries -- compact representation of an environment, to be
+   exported in debugging information. *)
+
+val summary: t -> summary
+
+(* Return an equivalent environment where all fields have been reset,
+   except the summary. The initial environment can be rebuilt from the
+   summary, using Envaux.env_of_only_summary. *)
+
+val keep_only_summary : t -> t
+val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
+
+(* Error report *)
+
+type error =
+  | Illegal_renaming of string * string * string
+  | Inconsistent_import of string * string * string
+  | Need_recursive_types of string * string
+  | Depend_on_unsafe_string_unit of string * string
+  | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
+
+
+val mark_value_used: t -> string -> value_description -> unit
+val mark_module_used: t -> string -> Location.t -> unit
+val mark_type_used: t -> string -> type_declaration -> unit
+
+type constructor_usage = Positive | Pattern | Privatize
+val mark_constructor_used:
+    constructor_usage -> t -> string -> type_declaration -> string -> unit
+val mark_constructor:
+    constructor_usage -> t -> string -> constructor_description -> unit
+val mark_extension_used:
+    constructor_usage -> t -> extension_constructor -> string -> unit
+
+val in_signature: bool -> t -> t
+val implicit_coercion: t -> t
+
+val is_in_signature: t -> bool
+
+val set_value_used_callback:
+    string -> value_description -> (unit -> unit) -> unit
+val set_type_used_callback:
+    string -> type_declaration -> ((unit -> unit) -> unit) -> unit
+
+(* Forward declaration to break mutual recursion with Includemod. *)
+val check_modtype_inclusion:
+      (t -> module_type -> Path.t -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
+(* Forward declaration to break mutual recursion with Mtype. *)
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
+(* Forward declaration to break mutual recursion with Ctype. *)
+val same_constr: (t -> type_expr -> type_expr -> bool) ref
+
+(** Folding over all identifiers (for analysis purpose) *)
+
+val fold_values:
+  (string -> Path.t -> value_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_types:
+  (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_constructors:
+  (constructor_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_labels:
+  (label_description -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Persistent structures are only traversed if they are already loaded. *)
+val fold_modules:
+  (string -> Path.t -> module_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+val fold_modtypes:
+  (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_classs:
+  (string -> Path.t -> class_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_cltypes:
+  (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+
+(** Utilities *)
+val scrape_alias: t -> module_type -> module_type
+val check_value_name: string -> Location.t -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end
diff --git a/typing/envaux.ml b/typing/envaux.ml
new file mode 100644
index 00000000..53f4d887
--- /dev/null
+++ b/typing/envaux.ml
@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*           OCaml 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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Types
+open Env
+
+type error =
+    Module_not_found of Path.t
+
+exception Error of error
+
+let env_cache =
+  (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
+
+let reset_cache () =
+  Hashtbl.clear env_cache;
+  Env.reset_cache()
+
+let extract_sig env mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | _ -> fatal_error "Envaux.extract_sig"
+
+let rec env_from_summary sum subst =
+  try
+    Hashtbl.find env_cache (sum, subst)
+  with Not_found ->
+    let env =
+      match sum with
+        Env_empty ->
+          Env.empty
+      | Env_value(s, id, desc) ->
+          Env.add_value id (Subst.value_description subst desc)
+                        (env_from_summary s subst)
+      | Env_type(s, id, desc) ->
+          Env.add_type ~check:false id
+            (Subst.type_declaration subst desc)
+            (env_from_summary s subst)
+      | Env_extension(s, id, desc) ->
+          Env.add_extension ~check:false id
+            (Subst.extension_constructor subst desc)
+            (env_from_summary s subst)
+      | Env_module(s, id, desc) ->
+          Env.add_module_declaration ~check:false id
+            (Subst.module_declaration subst desc)
+            (env_from_summary s subst)
+      | Env_modtype(s, id, desc) ->
+          Env.add_modtype id (Subst.modtype_declaration subst desc)
+                          (env_from_summary s subst)
+      | Env_class(s, id, desc) ->
+          Env.add_class id (Subst.class_declaration subst desc)
+                        (env_from_summary s subst)
+      | Env_cltype (s, id, desc) ->
+          Env.add_cltype id (Subst.cltype_declaration subst desc)
+                         (env_from_summary s subst)
+      | Env_open(s, path) ->
+          let env = env_from_summary s subst in
+          let path' = Subst.module_path subst path in
+          let md =
+            try
+              Env.find_module path' env
+            with Not_found ->
+              raise (Error (Module_not_found path'))
+          in
+          Env.open_signature Asttypes.Override path'
+            (extract_sig env md.md_type) env
+      | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
+          Env.add_module_declaration ~check:false
+            id (Subst.module_declaration subst desc)
+            ~arg:true (env_from_summary s subst)
+      | Env_functor_arg _ -> assert false
+      | Env_constraints(s, map) ->
+          PathMap.fold
+            (fun path info ->
+              Env.add_local_type (Subst.type_path subst path)
+                (Subst.type_declaration subst info))
+            map (env_from_summary s subst)
+    in
+      Hashtbl.add env_cache (sum, subst) env;
+      env
+
+let env_of_only_summary env =
+  Env.env_of_only_summary env_from_summary env
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Module_not_found p ->
+      fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
diff --git a/typing/envaux.mli b/typing/envaux.mli
new file mode 100644
index 00000000..2869890a
--- /dev/null
+++ b/typing/envaux.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*           OCaml 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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+(* Convert environment summaries to environments *)
+
+val env_from_summary : Env.summary -> Subst.t -> Env.t
+
+(* Empty the environment caches. To be called when load_path changes. *)
+
+val reset_cache: unit -> unit
+
+val env_of_only_summary : Env.t -> Env.t
+
+(* Error report *)
+
+type error =
+    Module_not_found of Path.t
+
+exception Error of error
+
+val report_error: formatter -> error -> unit
diff --git a/typing/ident.ml b/typing/ident.ml
new file mode 100644
index 00000000..951403fe
--- /dev/null
+++ b/typing/ident.ml
@@ -0,0 +1,249 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+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 *)
+
+let currentstamp = ref 0
+
+let create s =
+  incr currentstamp;
+  { 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; flags = global_flag }
+
+let rename i =
+  incr currentstamp;
+  { i with stamp = !currentstamp }
+
+let name i = i.name
+
+let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
+
+let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp
+
+let persistent i = (i.stamp = 0)
+
+let equal i1 i2 = i1.name = i2.name
+
+let same i1 i2 = i1 = i2
+  (* Possibly more efficient version (with a real compiler, at least):
+       if i1.stamp <> 0
+       then i1.stamp = i2.stamp
+       else i2.stamp = 0 && i1.name = i2.name *)
+
+let compare i1 i2 = Pervasives.compare i1 i2
+
+let binding_time i = i.stamp
+
+let current_time() = !currentstamp
+let set_current_time t = currentstamp := max !currentstamp t
+
+let reinit_level = ref (-1)
+
+let reinit () =
+  if !reinit_level < 0
+  then reinit_level := !currentstamp
+  else currentstamp := !reinit_level
+
+let hide i =
+  { i with stamp = -1 }
+
+let make_global i =
+  i.flags <- i.flags lor global_flag
+
+let global i =
+  (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 global i then "g" else "")
+
+type 'a tbl =
+    Empty
+  | Node of 'a tbl * 'a data * 'a tbl * int
+
+and 'a data =
+  { ident: t;
+    data: 'a;
+    previous: 'a data option }
+
+let empty = Empty
+
+(* Inline expansion of height for better speed
+ * let height = function
+ *     Empty -> 0
+ *   | Node(_,_,_,h) -> h
+ *)
+
+let mknode l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let balance l d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
+  and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, ld, lr, _)
+      when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode ll ld (mknode lr d r)
+    | Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
+        mknode (mknode ll ld lrl) lrd (mknode lrr d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rd, rr, _)
+      when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
+           (match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
+        mknode (mknode l d rl) rd rr
+    | Node (Node (rll, rld, rlr, _), rd, rr, _) ->
+        mknode (mknode l d rll) rld (mknode rlr rd rr)
+    | _ -> assert false
+  else
+    mknode l d r
+
+let rec add id data = function
+    Empty ->
+      Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
+  | Node(l, k, r, h) ->
+      let c = compare id.name k.ident.name in
+      if c = 0 then
+        Node(l, {ident = id; data = data; previous = Some k}, r, h)
+      else if c < 0 then
+        balance (add id data l) k r
+      else
+        balance l k (add id data r)
+
+let rec find_stamp s = function
+    None ->
+      raise Not_found
+  | Some k ->
+      if k.ident.stamp = s then k.data else find_stamp s k.previous
+
+let rec find_same id = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = compare id.name k.ident.name in
+      if c = 0 then
+        if id.stamp = k.ident.stamp
+        then k.data
+        else find_stamp id.stamp k.previous
+      else
+        find_same id (if c < 0 then l else r)
+
+let rec find_name name = function
+    Empty ->
+      raise Not_found
+  | Node(l, k, r, _) ->
+      let c = compare name k.ident.name in
+      if c = 0 then
+        k.data
+      else
+        find_name name (if c < 0 then l else r)
+
+let rec get_all = function
+  | None -> []
+  | Some k -> k.data :: get_all k.previous
+
+let rec find_all name = function
+    Empty ->
+      []
+  | Node(l, k, r, _) ->
+      let c = compare name k.ident.name in
+      if c = 0 then
+        k.data :: get_all k.previous
+      else
+        find_all name (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> fold_aux f l accu a
+      end
+  | Node(l, k, r, _) ->
+      fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+  match d with
+    None -> accu
+  | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k.ident k.data; iter f r
+
+(* Idents for sharing keys *)
+
+(* They should be 'totally fresh' -> neg numbers *)
+let key_name = ""
+
+let make_key_generator () =
+  let c = ref 1 in
+  fun id ->
+    let stamp = !c in
+    decr c ;
+    { id with name = key_name; stamp = stamp; }
+
+let compare x y =
+  let c = x.stamp - y.stamp in
+  if c <> 0 then c
+  else
+    let c = compare x.name y.name in
+    if c <> 0 then c
+    else
+      compare x.flags y.flags
+
+let output oc id = output_string oc (unique_name id)
+let hash i = (Char.code i.name.[0]) lxor i.stamp
+
+let original_equal = equal
+include Identifiable.Make (struct
+  type nonrec t = t
+  let compare = compare
+  let output = output
+  let print = print
+  let hash = hash
+  let equal = same
+end)
+let equal = original_equal
diff --git a/typing/ident.mli b/typing/ident.mli
new file mode 100644
index 00000000..52dd54ea
--- /dev/null
+++ b/typing/ident.mli
@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Identifiers (unique names) *)
+
+type t = { stamp: int; name: string; mutable flags: int }
+
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+
+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
+val unique_toplevel_name: t -> string
+val persistent: t -> bool
+val same: t -> t -> bool
+        (* Compare identifiers by binding location.
+           Two identifiers are the same either if they are both
+           non-persistent and have been created by the same call to
+           [new], or if they are both persistent and have the same
+           name. *)
+val compare: t -> t -> int
+val hide: t -> t
+        (* Return an identifier with same name as the given identifier,
+           but stamp different from any stamp returned by new.
+           When put in a 'a tbl, this identifier can only be looked
+           up by name. *)
+
+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
+val set_current_time: int -> unit
+val reinit: unit -> unit
+
+type 'a tbl
+        (* Association tables from identifiers to type 'a. *)
+
+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 find_all: string -> 'a tbl -> 'a list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
+
+
+(* Idents for sharing keys *)
+
+val make_key_generator : unit -> (t -> t)
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
new file mode 100644
index 00000000..10748bff
--- /dev/null
+++ b/typing/includeclass.ml
@@ -0,0 +1,110 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+
+let class_types env cty1 cty2 =
+  Ctype.match_class_types env cty1 cty2
+
+let class_type_declarations env cty1 cty2 =
+  Ctype.match_class_declarations env
+    cty1.clty_params cty1.clty_type
+    cty2.clty_params cty2.clty_type
+
+let class_declarations env cty1 cty2 =
+  match cty1.cty_new, cty2.cty_new with
+    None, Some _ ->
+      [Ctype.CM_Virtual_class]
+  | _ ->
+      Ctype.match_class_declarations env
+        cty1.cty_params cty1.cty_type
+        cty2.cty_params cty2.cty_type
+
+open Format
+open Ctype
+
+(*
+let rec hide_params = function
+    Tcty_arrow ("*", _, cty) -> hide_params cty
+  | cty -> cty
+*)
+
+let include_err ppf =
+  function
+  | CM_Virtual_class ->
+      fprintf ppf "A class cannot be changed from virtual to concrete"
+  | CM_Parameter_arity_mismatch _ ->
+      fprintf ppf
+        "The classes do not have the same number of type parameters"
+  | CM_Type_parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
+        (function ppf ->
+          fprintf ppf "A type parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Class_type_mismatch (env, cty1, cty2) ->
+      Printtyp.wrap_printing_env env (fun () ->
+        fprintf ppf
+          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+          Printtyp.class_type cty1
+          "is not matched by the class type"
+          Printtyp.class_type cty2)
+  | CM_Parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
+        (function ppf ->
+          fprintf ppf "A parameter has type")
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Val_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
+        (function ppf ->
+          fprintf ppf "The instance variable %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Meth_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
+        (function ppf ->
+          fprintf ppf "The method %s@ has type" lab)
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
+  | CM_Non_mutable_value lab ->
+      fprintf ppf
+       "@[The non-mutable instance variable %s cannot become mutable@]" lab
+  | CM_Non_concrete_value lab ->
+      fprintf ppf
+       "@[The virtual instance variable %s cannot become concrete@]" lab
+  | CM_Missing_value lab ->
+      fprintf ppf "@[The first class type has no instance variable %s@]" lab
+  | CM_Missing_method lab ->
+      fprintf ppf "@[The first class type has no method %s@]" lab
+  | CM_Hide_public lab ->
+     fprintf ppf "@[The public method %s cannot be hidden@]" lab
+  | CM_Hide_virtual (k, lab) ->
+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+  | CM_Public_method lab ->
+      fprintf ppf "@[The public method %s cannot become private" lab
+  | CM_Virtual_method lab ->
+      fprintf ppf "@[The virtual method %s cannot become concrete" lab
+  | CM_Private_method lab ->
+      fprintf ppf "The private method %s cannot become public" lab
+
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[%a%a@]" include_err err print_errs errs
diff --git a/typing/includeclass.mli b/typing/includeclass.mli
new file mode 100644
index 00000000..7483ee80
--- /dev/null
+++ b/typing/includeclass.mli
@@ -0,0 +1,31 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the class language *)
+
+open Types
+open Ctype
+open Format
+
+val class_types:
+        Env.t -> class_type -> class_type -> class_match_failure list
+val class_type_declarations:
+        Env.t -> class_type_declaration -> class_type_declaration ->
+        class_match_failure list
+val class_declarations:
+        Env.t -> class_declaration -> class_declaration ->
+        class_match_failure list
+
+val report_error: formatter -> class_match_failure list -> unit
diff --git a/typing/includecore.ml b/typing/includecore.ml
new file mode 100644
index 00000000..382a33d6
--- /dev/null
+++ b/typing/includecore.ml
@@ -0,0 +1,338 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Asttypes
+open Path
+open Types
+open Typedtree
+
+(* Inclusion between value descriptions *)
+
+exception Dont_match
+
+let value_descriptions env vd1 vd2 =
+  if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
+    match (vd1.val_kind, vd2.val_kind) with
+        (Val_prim p1, Val_prim p2) ->
+          if p1 = p2 then Tcoerce_none else raise Dont_match
+      | (Val_prim p, _) ->
+          let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
+                  pc_env = env; pc_loc = vd1.Types.val_loc; } in
+          Tcoerce_primitive pc
+      | (_, Val_prim _) -> raise Dont_match
+      | (_, _) -> Tcoerce_none
+  end else
+    raise Dont_match
+
+(* Inclusion between "private" annotations *)
+
+let private_flags decl1 decl2 =
+  match decl1.type_private, decl2.type_private with
+  | Private, Public ->
+      decl2.type_kind = Type_abstract &&
+      (decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
+  | _, _ -> true
+
+(* Inclusion between manifest types (particularly for private row types) *)
+
+let is_absrow env ty =
+  match ty.desc with
+    Tconstr(Pident _, _, _) ->
+      begin match Ctype.expand_head env ty with
+        {desc=Tobject _|Tvariant _} -> true
+      | _ -> false
+      end
+  | _ -> false
+
+let type_manifest env ty1 params1 ty2 params2 priv2 =
+  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+  match ty1'.desc, ty2'.desc with
+    Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
+      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+      Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
+      begin match row1.row_more with
+        {desc=Tvar _|Tconstr _|Tnil} -> true
+      | _ -> false
+      end &&
+      let r1, r2, pairs =
+        Ctype.merge_row_fields row1.row_fields row2.row_fields in
+      (not row2.row_closed ||
+       row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
+      List.for_all
+        (fun (_,f) -> match Btype.row_field_repr f with
+          Rabsent | Reither _ -> true | Rpresent _ -> false)
+        r2 &&
+      let to_equal = ref (List.combine params1 params2) in
+      List.for_all
+        (fun (_, f1, f2) ->
+          match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+            Rpresent(Some t1),
+            (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
+              to_equal := (t1,t2) :: !to_equal; true
+          | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+          | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
+            when List.length tl1 = List.length tl2 && c1 = c2 ->
+              to_equal := List.combine tl1 tl2 @ !to_equal; true
+          | Rabsent, (Reither _ | Rabsent) -> true
+          | _ -> false)
+        pairs &&
+      let tl1, tl2 = List.split !to_equal in
+      Ctype.equal env true tl1 tl2
+  | Tobject (fi1, _), Tobject (fi2, _)
+    when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
+      let (fields2,rest2) = Ctype.flatten_fields fi2 in
+      Ctype.equal env true (ty1::params1) (rest2::params2) &&
+      let (fields1,rest1) = Ctype.flatten_fields fi1 in
+      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
+      let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+      miss2 = [] &&
+      let tl1, tl2 =
+        List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
+      Ctype.equal env true (params1 @ tl1) (params2 @ tl2)
+  | _ ->
+      let rec check_super ty1 =
+        Ctype.equal env true (ty1 :: params1) (ty2 :: params2) ||
+        priv2 = Private &&
+        try check_super
+              (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1))
+        with Ctype.Cannot_expand -> false
+      in check_super ty1
+
+(* Inclusion between type declarations *)
+
+type type_mismatch =
+    Arity
+  | Privacy
+  | Kind
+  | Constraint
+  | Manifest
+  | Variance
+  | Field_type of Ident.t
+  | Field_mutable of Ident.t
+  | Field_arity of Ident.t
+  | Field_names of int * Ident.t * Ident.t
+  | Field_missing of bool * Ident.t
+  | Record_representation of bool   (* true means second one is unboxed float *)
+  | Unboxed_representation of bool  (* true means second one is unboxed *)
+  | Immediate
+
+let report_type_mismatch0 first second decl ppf err =
+  let pr fmt = Format.fprintf ppf fmt in
+  match err with
+    Arity -> pr "They have different arities"
+  | Privacy -> pr "A private type would be revealed"
+  | Kind -> pr "Their kinds differ"
+  | Constraint -> pr "Their constraints differ"
+  | Manifest -> ()
+  | Variance -> pr "Their variances do not agree"
+  | Field_type s ->
+      pr "The types for field %s are not equal" (Ident.name s)
+  | Field_mutable s ->
+      pr "The mutability of field %s is different" (Ident.name s)
+  | Field_arity s ->
+      pr "The arities for field %s differ" (Ident.name s)
+  | Field_names (n, name1, name2) ->
+      pr "Fields number %i have different names, %s and %s"
+        n (Ident.name name1) (Ident.name name2)
+  | Field_missing (b, s) ->
+      pr "The field %s is only present in %s %s"
+        (Ident.name s) (if b then second else first) decl
+  | Record_representation b ->
+      pr "Their internal representations differ:@ %s %s %s"
+        (if b then second else first) decl
+        "uses unboxed float representation"
+  | Unboxed_representation b ->
+      pr "Their internal representations differ:@ %s %s %s"
+         (if b then second else first) decl
+         "uses unboxed representation"
+  | Immediate -> pr "%s is not an immediate type" first
+
+let report_type_mismatch first second decl ppf =
+  List.iter
+    (fun err ->
+      if err = Manifest then () else
+      Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
+
+let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
+  match arg1, arg2 with
+  | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
+      if List.length arg1 <> List.length arg2 then [Field_arity cstr]
+      else if
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
+      then [] else [Field_type cstr]
+  | Types.Cstr_record l1, Types.Cstr_record l2 ->
+      compare_records env params1 params2 0 l1 l2
+  | _ -> [Field_type cstr]
+
+and compare_variants env params1 params2 n cstrs1 cstrs2 =
+  match cstrs1, cstrs2 with
+    [], []           -> []
+  | [], c::_ -> [Field_missing (true, c.Types.cd_id)]
+  | c::_, [] -> [Field_missing (false, c.Types.cd_id)]
+  | {Types.cd_id=cstr1; cd_args=arg1; cd_res=ret1}::rem1,
+    {Types.cd_id=cstr2; cd_args=arg2; cd_res=ret2}::rem2 ->
+      if Ident.name cstr1 <> Ident.name cstr2 then
+        [Field_names (n, cstr1, cstr2)]
+      else
+        let r =
+          match ret1, ret2 with
+          | Some r1, Some r2 ->
+              if Ctype.equal env true [r1] [r2] then
+                compare_constructor_arguments env cstr1 [r1] [r2] arg1 arg2
+              else [Field_type cstr1]
+          | Some _, None | None, Some _ ->
+              [Field_type cstr1]
+          | _ ->
+              compare_constructor_arguments env cstr1
+                params1 params2 arg1 arg2
+        in
+        if r <> [] then r
+        else compare_variants env params1 params2 (n+1) rem1 rem2
+
+
+and compare_records env params1 params2 n labels1 labels2 =
+  match labels1, labels2 with
+    [], []           -> []
+  | [], l::_ -> [Field_missing (true, l.Types.ld_id)]
+  | l::_, [] -> [Field_missing (false, l.Types.ld_id)]
+  | {Types.ld_id=lab1; ld_mutable=mut1; ld_type=arg1}::rem1,
+    {Types.ld_id=lab2; ld_mutable=mut2; ld_type=arg2}::rem2 ->
+      if Ident.name lab1 <> Ident.name lab2
+      then [Field_names (n, lab1, lab2)]
+      else if mut1 <> mut2 then [Field_mutable lab1] else
+      if Ctype.equal env true (arg1::params1)
+                              (arg2::params2)
+      then (* add arguments to the parameters, cf. PR#7378 *)
+        compare_records env (arg1::params1) (arg2::params2) (n+1) rem1 rem2
+      else [Field_type lab1]
+
+let type_declarations ?(equality = false) env name decl1 id decl2 =
+  if decl1.type_arity <> decl2.type_arity then [Arity] else
+  if not (private_flags decl1 decl2) then [Privacy] else
+  let err = match (decl1.type_manifest, decl2.type_manifest) with
+      (_, None) ->
+        if Ctype.equal env true decl1.type_params decl2.type_params
+        then [] else [Constraint]
+    | (Some ty1, Some ty2) ->
+        if type_manifest env ty1 decl1.type_params ty2 decl2.type_params
+            decl2.type_private
+        then [] else [Manifest]
+    | (None, Some ty2) ->
+        let ty1 =
+          Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
+        in
+        if Ctype.equal env true decl1.type_params decl2.type_params then
+          if Ctype.equal env false [ty1] [ty2] then []
+          else [Manifest]
+        else [Constraint]
+  in
+  if err <> [] then err else
+  let err =
+    match (decl2.type_kind, decl1.type_unboxed.unboxed,
+           decl2.type_unboxed.unboxed) with
+    | Type_abstract, _, _ -> []
+    | _, true, false -> [Unboxed_representation false]
+    | _, false, true -> [Unboxed_representation true]
+    | _ -> []
+  in
+  if err <> [] then err else
+  let err = match (decl1.type_kind, decl2.type_kind) with
+      (_, Type_abstract) -> []
+    | (Type_variant cstrs1, Type_variant cstrs2) ->
+        let mark cstrs usage name decl =
+          List.iter
+            (fun c ->
+              Env.mark_constructor_used usage env name decl
+                                        (Ident.name c.Types.cd_id))
+            cstrs
+        in
+        let usage =
+          if decl1.type_private = Private || decl2.type_private = Public
+          then Env.Positive else Env.Privatize
+        in
+        mark cstrs1 usage name decl1;
+        if equality then mark cstrs2 Env.Positive (Ident.name id) decl2;
+        compare_variants env decl1.type_params decl2.type_params 1 cstrs1 cstrs2
+    | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
+        let err = compare_records env decl1.type_params decl2.type_params
+            1 labels1 labels2 in
+        if err <> [] || rep1 = rep2 then err else
+        [Record_representation (rep2 = Record_float)]
+    | (Type_open, Type_open) -> []
+    | (_, _) -> [Kind]
+  in
+  if err <> [] then err else
+  let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  (* If attempt to assign a non-immediate type (e.g. string) to a type that
+   * must be immediate, then we error *)
+  let err =
+    if abstr &&
+       not decl1.type_immediate &&
+       decl2.type_immediate then
+      [Immediate]
+    else []
+  in
+  if err <> [] then err else
+  let abstr = abstr || decl2.type_private = Private in
+  let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
+  let constrained ty = not (Btype.(is_Tvar (repr ty))) in
+  if List.for_all2
+      (fun ty (v1,v2) ->
+        let open Variance in
+        let imp a b = not a || b in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+        (if abstr then (imp co1 co2 && imp cn1 cn2)
+         else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
+         else true) &&
+        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+  then [] else [Variance]
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors env id ext1 ext2 =
+  let usage =
+    if ext1.ext_private = Private || ext2.ext_private = Public
+    then Env.Positive else Env.Privatize
+  in
+  Env.mark_extension_used usage env ext1 (Ident.name id);
+  let ty1 =
+    Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
+  in
+  let ty2 =
+    Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
+  in
+  if Ctype.equal env true
+       (ty1 :: ext1.ext_type_params)
+       (ty2 :: ext2.ext_type_params)
+  then
+    if compare_constructor_arguments env (Ident.create "")
+        ext1.ext_type_params ext2.ext_type_params
+        ext1.ext_args ext2.ext_args = [] then
+      if match ext1.ext_ret_type, ext2.ext_ret_type with
+          Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false
+        | Some _, None | None, Some _ -> false
+        | _ -> true
+      then
+        match ext1.ext_private, ext2.ext_private with
+            Private, Public -> false
+          | _, _ -> true
+      else false
+    else false
+  else false
diff --git a/typing/includecore.mli b/typing/includecore.mli
new file mode 100644
index 00000000..8ddd59cd
--- /dev/null
+++ b/typing/includecore.mli
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the core language *)
+
+open Typedtree
+open Types
+
+exception Dont_match
+
+type type_mismatch =
+    Arity
+  | Privacy
+  | Kind
+  | Constraint
+  | Manifest
+  | Variance
+  | Field_type of Ident.t
+  | Field_mutable of Ident.t
+  | Field_arity of Ident.t
+  | Field_names of int * Ident.t * Ident.t
+  | Field_missing of bool * Ident.t
+  | Record_representation of bool
+  | Unboxed_representation of bool
+  | Immediate
+
+val value_descriptions:
+    Env.t -> value_description -> value_description -> module_coercion
+val type_declarations:
+    ?equality:bool ->
+      Env.t -> string ->
+        type_declaration -> Ident.t -> type_declaration -> type_mismatch list
+val extension_constructors:
+    Env.t -> Ident.t -> extension_constructor -> extension_constructor -> bool
+(*
+val class_types:
+        Env.t -> class_type -> class_type -> bool
+*)
+
+val report_type_mismatch:
+    string -> string -> string -> Format.formatter -> type_mismatch list -> unit
diff --git a/typing/includemod.ml b/typing/includemod.ml
new file mode 100644
index 00000000..f3a3caf5
--- /dev/null
+++ b/typing/includemod.ml
@@ -0,0 +1,657 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Misc
+open Path
+open Typedtree
+open Types
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch list
+  | Extension_constructors of
+      Ident.t * extension_constructor * extension_constructor
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_modtype_path of Path.t
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * Env.t * symptom
+
+exception Error of error list
+
+(* All functions "blah env x1 x2" check that x1 is included in x2,
+   i.e. that x1 is the type of an implementation that fulfills the
+   specification x2. If not, Error is raised with a backtrace of the error. *)
+
+(* Inclusion between value descriptions *)
+
+let value_descriptions env cxt subst id vd1 vd2 =
+  Cmt_format.record_value_dependency vd1 vd2;
+  Env.mark_value_used env (Ident.name id) vd1;
+  let vd2 = Subst.value_description subst vd2 in
+  try
+    Includecore.value_descriptions env vd1 vd2
+  with Includecore.Dont_match ->
+    raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])
+
+(* Inclusion between type declarations *)
+
+let type_declarations env ?(old_env=env) cxt subst id decl1 decl2 =
+  Env.mark_type_used env (Ident.name id) decl1;
+  let decl2 = Subst.type_declaration subst decl2 in
+  let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in
+  if err <> [] then
+    raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)])
+
+(* Inclusion between extension constructors *)
+
+let extension_constructors env cxt subst id ext1 ext2 =
+  let ext2 = Subst.extension_constructor subst ext2 in
+  if Includecore.extension_constructors env id ext1 ext2
+  then ()
+  else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)])
+
+(* Inclusion between class declarations *)
+
+let class_type_declarations ~old_env env cxt subst id decl1 decl2 =
+  let decl2 = Subst.cltype_declaration subst decl2 in
+  match Includeclass.class_type_declarations env decl1 decl2 with
+    []     -> ()
+  | reason ->
+      raise(Error[cxt, old_env,
+                  Class_type_declarations(id, decl1, decl2, reason)])
+
+let class_declarations ~old_env env cxt subst id decl1 decl2 =
+  let decl2 = Subst.class_declaration subst decl2 in
+  match Includeclass.class_declarations env decl1 decl2 with
+    []     -> ()
+  | reason ->
+      raise(Error[cxt, old_env, Class_declarations(id, decl1, decl2, reason)])
+
+(* Expand a module type identifier when possible *)
+
+exception Dont_match
+
+let may_expand_module_path env path =
+  try ignore (Env.find_modtype_expansion path env); true
+  with Not_found -> false
+
+let expand_module_path env cxt path =
+  try
+    Env.find_modtype_expansion path env
+  with Not_found ->
+    raise(Error[cxt, env, Unbound_modtype_path path])
+
+let expand_module_alias env cxt path =
+  try (Env.find_module path env).md_type
+  with Not_found ->
+    raise(Error[cxt, env, Unbound_module_path path])
+
+(*
+let rec normalize_module_path env cxt path =
+  match expand_module_alias env cxt path with
+    Mty_alias path' -> normalize_module_path env cxt path'
+  | _ -> path
+*)
+
+(* Extract name, kind and ident from a signature item *)
+
+type field_desc =
+    Field_value of string
+  | Field_type of string
+  | Field_typext of string
+  | Field_module of string
+  | Field_modtype of string
+  | Field_class of string
+  | Field_classtype of string
+
+let kind_of_field_desc = function
+  | Field_value _ -> "value"
+  | Field_type _ -> "type"
+  | Field_typext _ -> "extension constructor"
+  | Field_module _ -> "module"
+  | Field_modtype _ -> "module type"
+  | Field_class _ -> "class"
+  | Field_classtype _ -> "class type"
+
+let item_ident_name = function
+    Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id))
+  | Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id))
+  | Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id))
+  | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id))
+  | Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id))
+  | Sig_class(id, d, _) -> (id, d.cty_loc, Field_class(Ident.name id))
+  | Sig_class_type(id, d, _) -> (id, d.clty_loc, Field_classtype(Ident.name id))
+
+let is_runtime_component = function
+  | Sig_value(_,{val_kind = Val_prim _})
+  | Sig_type(_,_,_)
+  | Sig_modtype(_,_)
+  | Sig_class_type(_,_,_) -> false
+  | Sig_value(_,_)
+  | Sig_typext(_,_,_)
+  | Sig_module(_,_,_)
+  | Sig_class(_, _,_) -> true
+
+(* Print a coercion *)
+
+let rec print_list pr ppf = function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l
+let print_list pr ppf l =
+  Format.fprintf ppf "[@[%a@]]" (print_list pr) l
+
+let rec print_coercion ppf c =
+  let pr fmt = Format.fprintf ppf fmt in
+  match c with
+    Tcoerce_none -> pr "id"
+  | Tcoerce_structure (fl, nl) ->
+      pr "@[<2>struct@ %a@ %a@]"
+        (print_list print_coercion2) fl
+        (print_list print_coercion3) nl
+  | Tcoerce_functor (inp, out) ->
+      pr "@[<2>functor@ (%a)@ (%a)@]"
+        print_coercion inp
+        print_coercion out
+  | Tcoerce_primitive {pc_desc; pc_env = _; pc_type}  ->
+      pr "prim %s@ (%a)" pc_desc.Primitive.prim_name
+        Printtyp.raw_type_expr pc_type
+  | Tcoerce_alias (p, c) ->
+      pr "@[<2>alias %a@ (%a)@]"
+        Printtyp.path p
+        print_coercion c
+and print_coercion2 ppf (n, c) =
+  Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c
+and print_coercion3 ppf (i, n, c) =
+  Format.fprintf ppf "@[%s, %d,@ %a@]"
+    (Ident.unique_name i) n print_coercion c
+
+(* Simplify a structure coercion *)
+
+let simplify_structure_coercion cc id_pos_list =
+  let rec is_identity_coercion pos = function
+  | [] ->
+      true
+  | (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, id_pos_list)
+
+(* Inclusion between module types.
+   Return the restriction that transforms a value of the smaller type
+   into a value of the bigger type. *)
+
+let rec modtypes env cxt subst mty1 mty2 =
+  try
+    try_modtypes env cxt subst mty1 mty2
+  with
+    Dont_match ->
+      raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
+  | Error reasons as err ->
+      match mty1, mty2 with
+        Mty_alias _, _
+      | _, Mty_alias _ -> raise err
+      | _ ->
+          raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
+                      :: reasons))
+
+and try_modtypes env cxt subst mty1 mty2 =
+  match (mty1, mty2) with
+  | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
+      if Env.is_functor_arg p2 env then
+        raise (Error[cxt, env, Invalid_module_alias p2]);
+      if not (Path.same p1 p2) then begin
+        let p1 = Env.normalize_path None env p1
+        and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
+        if not (Path.same p1 p2) then raise Dont_match
+      end;
+      match pres1, pres2 with
+      | Mta_present, Mta_present -> Tcoerce_none
+        (* Should really be Tcoerce_ignore if it existed *)
+      | Mta_absent, Mta_absent -> Tcoerce_none
+        (* Should really be Tcoerce_empty if it existed *)
+      | Mta_present, Mta_absent -> Tcoerce_none
+      | Mta_absent, Mta_present ->
+        let p1 = try
+            Env.normalize_path (Some Location.none) env p1
+          with Env.Error (Env.Missing_module (_, _, path)) ->
+            raise (Error[cxt, env, Unbound_module_path path])
+        in
+        Tcoerce_alias (p1, Tcoerce_none)
+    end
+  | (Mty_alias(pres1, p1), _) -> begin
+      let p1 = try
+        Env.normalize_path (Some Location.none) env p1
+      with Env.Error (Env.Missing_module (_, _, path)) ->
+        raise (Error[cxt, env, Unbound_module_path path])
+      in
+      let mty1 =
+        Mtype.strengthen ~aliasable:true env
+          (expand_module_alias env cxt p1) p1
+      in
+      let cc = modtypes env cxt subst mty1 mty2 in
+      match pres1 with
+      | Mta_present -> cc
+      | Mta_absent -> Tcoerce_alias (p1, cc)
+    end
+  | (Mty_ident p1, _) when may_expand_module_path env p1 ->
+      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
+  | (_, Mty_ident _) ->
+      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
+  | (Mty_signature sig1, Mty_signature sig2) ->
+      signatures env cxt subst sig1 sig2
+  | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
+      begin match modtypes env (Body param1::cxt) subst res1 res2 with
+        Tcoerce_none -> Tcoerce_none
+      | cc -> Tcoerce_functor (Tcoerce_none, cc)
+      end
+  | (Mty_functor(param1, Some arg1, res1),
+     Mty_functor(param2, Some arg2, res2)) ->
+      let arg2' = Subst.modtype subst arg2 in
+      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
+      let cc_res =
+        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
+          (Subst.add_module param2 (Pident param1) subst) res1 res2 in
+      begin match (cc_arg, cc_res) with
+          (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
+        | _ -> Tcoerce_functor(cc_arg, cc_res)
+      end
+  | (_, _) ->
+      raise Dont_match
+
+and try_modtypes2 env cxt mty1 mty2 =
+  (* mty2 is an identifier *)
+  match (mty1, mty2) with
+    (Mty_ident p1, Mty_ident p2)
+    when Path.same (Env.normalize_path_prefix None env p1)
+                   (Env.normalize_path_prefix None env p2) ->
+      Tcoerce_none
+  | (_, Mty_ident p2) when may_expand_module_path env p2 ->
+      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
+  | (_, _) ->
+      raise Dont_match
+
+(* Inclusion between signatures *)
+
+and signatures env cxt subst sig1 sig2 =
+  (* Environment used to check inclusion of components *)
+  let new_env =
+    Env.add_signature sig1 (Env.in_signature true env) in
+  (* Keep ids for module aliases *)
+  let (id_pos_list,_) =
+    List.fold_left
+      (fun (l,pos) -> function
+          Sig_module (id, _, _) ->
+            ((id,pos,Tcoerce_none)::l , pos+1)
+        | item -> (l, if is_runtime_component item then pos+1 else pos))
+      ([], 0) sig1 in
+  (* 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
+      [] -> pos, tbl
+    | item :: rem ->
+        let (id, _loc, name) = item_ident_name item in
+        let nextpos = if is_runtime_component item then pos + 1 else pos in
+        build_component_table nextpos
+                              (Tbl.add name (id, item, pos) tbl) rem in
+  let len1, comps1 =
+    build_component_table 0 Tbl.empty sig1 in
+  let len2 =
+    List.fold_left
+      (fun n i -> if is_runtime_component i then n + 1 else n)
+      0
+      sig2
+  in
+  (* Pair each component of sig2 with a component of sig1,
+     identifying the names along the way.
+     Return a coercion list indicating, for all run-time components
+     of sig2, the position of the matching run-time components of sig1
+     and the coercion to be applied to it. *)
+  let rec pair_components subst paired unpaired = function
+      [] ->
+        begin match unpaired with
+            [] ->
+              let cc =
+                signature_components env new_env cxt subst (List.rev paired)
+              in
+              if len1 = len2 then (* see PR#5098 *)
+                simplify_structure_coercion cc id_pos_list
+              else
+                Tcoerce_structure (cc, id_pos_list)
+          | _  -> raise(Error unpaired)
+        end
+    | item2 :: rem ->
+        let (id2, loc, name2) = item_ident_name item2 in
+        let name2, report =
+          match item2, name2 with
+            Sig_type (_, {type_manifest=None}, _), Field_type s
+            when let l = String.length s in
+            l >= 4 && String.sub s (l-4) 4 = "#row" ->
+              (* Do not report in case of failure,
+                 as the main type will generate an error *)
+              Field_type (String.sub s 0 (String.length s - 4)), false
+          | _ -> name2, true
+        in
+        begin try
+          let (id1, item1, pos1) = Tbl.find name2 comps1 in
+          let new_subst =
+            match item2 with
+              Sig_type _ ->
+                Subst.add_type id2 (Pident id1) subst
+            | Sig_module _ ->
+                Subst.add_module id2 (Pident id1) subst
+            | Sig_modtype _ ->
+                Subst.add_modtype id2 (Mty_ident (Pident id1)) subst
+            | Sig_value _ | Sig_typext _
+            | Sig_class _ | Sig_class_type _ ->
+                subst
+          in
+          pair_components new_subst
+            ((item1, item2, pos1) :: paired) unpaired rem
+        with Not_found ->
+          let unpaired =
+            if report then
+              (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) ::
+              unpaired
+            else unpaired in
+          pair_components subst paired unpaired rem
+        end in
+  (* Do the pairing and checking, and return the final coercion *)
+  pair_components subst [] [] sig2
+
+(* Inclusion between signature components *)
+
+and signature_components old_env env cxt subst paired =
+  let comps_rec rem = signature_components old_env env cxt subst rem in
+  match paired with
+    [] -> []
+  | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
+      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
+      begin match valdecl2.val_kind with
+        Val_prim _ -> comps_rec rem
+      | _ -> (pos, cc) :: comps_rec rem
+      end
+  | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
+      type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
+      comps_rec rem
+  | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
+    :: rem ->
+      extension_constructors env cxt subst id1 ext1 ext2;
+      (pos, Tcoerce_none) :: comps_rec rem
+  | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
+      let p1 = Pident id1 in
+      Env.mark_module_used env (Ident.name id1) mty1.md_loc;
+      let cc =
+        modtypes env (Module id1::cxt) subst
+          (Mtype.strengthen ~aliasable:true env mty1.md_type p1) mty2.md_type
+      in
+      (pos, cc) :: comps_rec rem
+  | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
+      modtype_infos env cxt subst id1 info1 info2;
+      comps_rec rem
+  | (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
+      class_declarations ~old_env env cxt subst id1 decl1 decl2;
+      (pos, Tcoerce_none) :: comps_rec rem
+  | (Sig_class_type(id1, info1, _),
+     Sig_class_type(_id2, info2, _), _pos) :: rem ->
+      class_type_declarations ~old_env env cxt subst id1 info1 info2;
+      comps_rec rem
+  | _ ->
+      assert false
+
+(* Inclusion between module type specifications *)
+
+and modtype_infos env cxt subst id info1 info2 =
+  let info2 = Subst.modtype_declaration subst info2 in
+  let cxt' = Modtype id :: cxt in
+  try
+    match (info1.mtd_type, info2.mtd_type) with
+      (None, None) -> ()
+    | (Some _, None) -> ()
+    | (Some mty1, Some mty2) ->
+        check_modtype_equiv env cxt' mty1 mty2
+    | (None, Some mty2) ->
+        check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2
+  with Error reasons ->
+    raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
+
+and check_modtype_equiv env cxt mty1 mty2 =
+  match
+    (modtypes env cxt Subst.identity mty1 mty2,
+     modtypes env cxt Subst.identity mty2 mty1)
+  with
+    (Tcoerce_none, Tcoerce_none) -> ()
+  | (_c1, _c2) ->
+      (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
+        print_coercion _c1 print_coercion _c2; *)
+      raise(Error [cxt, env, Modtype_permutation])
+
+(* Simplified inclusion check between module types (for Env) *)
+
+let can_alias env path =
+  let rec no_apply = function
+    | Pident _ -> true
+    | Pdot(p, _, _) -> no_apply p
+    | Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
+let check_modtype_inclusion env mty1 path1 mty2 =
+  try
+    let aliasable = can_alias env path1 in
+    ignore(modtypes env [] Subst.identity
+                    (Mtype.strengthen ~aliasable env mty1 path1) mty2)
+  with Error _ ->
+    raise Not_found
+
+let _ = Env.check_modtype_inclusion := check_modtype_inclusion
+
+(* Check that an implementation of a compilation unit meets its
+   interface. *)
+
+let compunit env impl_name impl_sig intf_name intf_sig =
+  try
+    signatures env [] Subst.identity impl_sig intf_sig
+  with Error reasons ->
+    raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
+                :: reasons))
+
+(* Hide the context and substitution parameters to the outside world *)
+
+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
+let type_declarations env id decl1 decl2 =
+  type_declarations env [] Subst.identity id decl1 decl2
+
+(*
+let modtypes env m1 m2 =
+  let c = modtypes env m1 m2 in
+  Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@."
+    Printtyp.modtype m1 Printtyp.modtype m2
+    print_coercion c;
+  c
+*)
+
+(* Error report *)
+
+open Format
+open Printtyp
+
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
+let include_err ppf = function
+  | Missing_field (id, loc, kind) ->
+      fprintf ppf "The %s `%a' is required but not provided" kind ident id;
+      show_loc "Expected declaration" ppf loc
+  | Value_descriptions(id, d1, d2) ->
+      fprintf ppf
+        "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
+        (value_description id) d1 (value_description id) d2;
+      show_locs ppf (d1.val_loc, d2.val_loc);
+  | Type_declarations(id, d1, d2, errs) ->
+      fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
+        "Type declarations do not match"
+        (type_declaration id) d1
+        "is not included in"
+        (type_declaration id) d2
+        show_locs (d1.type_loc, d2.type_loc)
+        (Includecore.report_type_mismatch
+           "the first" "the second" "declaration") errs
+  | Extension_constructors(id, x1, x2) ->
+      fprintf ppf
+       "@[Extension declarations do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      (extension_constructor id) x1
+      (extension_constructor id) x2;
+      show_locs ppf (x1.ext_loc, x2.ext_loc)
+  | Module_types(mty1, mty2)->
+      fprintf ppf
+       "@[Modules do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      modtype mty1
+      modtype mty2
+  | Modtype_infos(id, d1, d2) ->
+      fprintf ppf
+       "@[Module type declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]"
+      (modtype_declaration id) d1
+      (modtype_declaration id) d2
+  | Modtype_permutation ->
+      fprintf ppf "Illegal permutation of structure fields"
+  | Interface_mismatch(impl_name, intf_name) ->
+      fprintf ppf "@[The implementation %s@ does not match the interface %s:"
+       impl_name intf_name
+  | Class_type_declarations(id, d1, d2, reason) ->
+      fprintf ppf
+       "@[Class type declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]@ %a"
+      (Printtyp.cltype_declaration id) d1
+      (Printtyp.cltype_declaration id) d2
+      Includeclass.report_error reason
+  | Class_declarations(id, d1, d2, reason) ->
+      fprintf ppf
+       "@[Class declarations do not match:@ \
+        %a@;<1 -2>does not match@ %a@]@ %a"
+      (Printtyp.class_declaration id) d1
+      (Printtyp.class_declaration id) d2
+      Includeclass.report_error reason
+  | Unbound_modtype_path path ->
+      fprintf ppf "Unbound module type %a" Printtyp.path path
+  | Unbound_module_path path ->
+      fprintf ppf "Unbound module %a" Printtyp.path path
+  | Invalid_module_alias path ->
+      fprintf ppf "Module %a cannot be aliased" Printtyp.path path
+
+let rec context ppf = function
+    Module id :: rem ->
+      fprintf ppf "@[<2>module %a%a@]" ident id args rem
+  | Modtype id :: rem ->
+      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
+  | Body x :: rem ->
+      fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
+  | Arg x :: rem ->
+      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
+  | [] ->
+      fprintf ppf ""
+and context_mty ppf = function
+    (Module _ | Modtype _) :: _ as rem ->
+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+  | cxt -> context ppf cxt
+and args ppf = function
+    Body x :: rem ->
+      fprintf ppf "(%s)%a" (argname x) args rem
+  | Arg x :: rem ->
+      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
+  | cxt ->
+      fprintf ppf " :@ %a" context_mty cxt
+and argname x =
+  let s = Ident.name x in
+  if s = "*" then "" else s
+
+let path_of_context = function
+    Module id :: rem ->
+      let rec subm path = function
+          [] -> path
+        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
+        | _ -> assert false
+      in subm (Pident id) rem
+  | _ -> assert false
+
+let context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "In module %a:@ " path (path_of_context cxt)
+  else
+    fprintf ppf "@[At position@ %a@]@ " context cxt
+
+let include_err ppf (cxt, env, err) =
+  Printtyp.wrap_printing_env env (fun () ->
+    fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err)
+
+let buffer = ref Bytes.empty
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if Bytes.length !buffer < size then buffer := Bytes.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+let report_error ppf errs =
+  if errs = [] then () else
+  let (errs , err) = split_last errs in
+  let pe = ref true in
+  let include_err' ppf (_,_,obj as err) =
+    if not (is_big obj) then fprintf ppf "%a@ " include_err err
+    else if !pe then (fprintf ppf "...@ "; pe := false)
+  in
+  let print_errs ppf = List.iter (include_err' ppf) in
+  fprintf ppf "@[%a%a@]" print_errs errs include_err err
+
+
+(* We could do a better job to split the individual error items
+   as sub-messages of the main interface mismatch on the whole unit. *)
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/typing/includemod.mli b/typing/includemod.mli
new file mode 100644
index 00000000..72afe398
--- /dev/null
+++ b/typing/includemod.mli
@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Inclusion checks for the module language *)
+
+open Typedtree
+open Types
+open Format
+
+val modtypes: Env.t -> module_type -> module_type -> module_coercion
+val signatures: Env.t -> signature -> signature -> module_coercion
+val compunit:
+      Env.t -> string -> signature -> string -> signature -> module_coercion
+val type_declarations:
+      Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
+val print_coercion: formatter -> module_coercion -> unit
+
+type symptom =
+    Missing_field of Ident.t * Location.t * string (* kind *)
+  | Value_descriptions of Ident.t * value_description * value_description
+  | Type_declarations of Ident.t * type_declaration
+        * type_declaration * Includecore.type_mismatch list
+  | Extension_constructors of
+      Ident.t * extension_constructor * extension_constructor
+  | Module_types of module_type * module_type
+  | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
+  | Modtype_permutation
+  | Interface_mismatch of string * string
+  | Class_type_declarations of
+      Ident.t * class_type_declaration * class_type_declaration *
+      Ctype.class_match_failure list
+  | Class_declarations of
+      Ident.t * class_declaration * class_declaration *
+      Ctype.class_match_failure list
+  | Unbound_modtype_path of Path.t
+  | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
+
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * Env.t * symptom
+
+exception Error of error list
+
+val report_error: formatter -> error list -> unit
+val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type
diff --git a/typing/mtype.ml b/typing/mtype.ml
new file mode 100644
index 00000000..479f12e3
--- /dev/null
+++ b/typing/mtype.ml
@@ -0,0 +1,422 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Asttypes
+open Path
+open Types
+
+
+let rec scrape env mty =
+  match mty with
+    Mty_ident p ->
+      begin try
+        scrape env (Env.find_modtype_expansion p env)
+      with Not_found ->
+        mty
+      end
+  | _ -> mty
+
+let freshen mty =
+  Subst.modtype Subst.identity mty
+
+let rec strengthen ~aliasable env mty p =
+  match scrape env mty with
+    Mty_signature sg ->
+      Mty_signature(strengthen_sig ~aliasable env sg p 0)
+  | Mty_functor(param, arg, res)
+    when !Clflags.applicative_functors && Ident.name param <> "*" ->
+      Mty_functor(param, arg,
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
+  | mty ->
+      mty
+
+and strengthen_sig ~aliasable env sg p pos =
+  match sg with
+    [] -> []
+  | (Sig_value(_, desc) as sigelt) :: rem ->
+      let nextpos =
+        match desc.val_kind with
+        | Val_prim _ -> pos
+        | _ -> pos + 1
+      in
+      sigelt :: strengthen_sig ~aliasable env rem p nextpos
+  | Sig_type(id, {type_kind=Type_abstract}, _) ::
+    (Sig_type(id', {type_private=Private}, _) :: _ as rem)
+    when Ident.name id = Ident.name id' ^ "#row" ->
+      strengthen_sig ~aliasable env rem p pos
+  | Sig_type(id, decl, rs) :: rem ->
+      let newdecl =
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
+        | _ ->
+            let manif =
+              Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
+                                          decl.type_params, ref Mnil))) in
+            if decl.type_kind = Type_abstract then
+              { decl with type_private = Public; type_manifest = manif }
+            else
+              { decl with type_manifest = manif }
+      in
+      Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
+  | Sig_module(id, md, rs) :: rem ->
+      let str =
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos))
+      in
+      Sig_module(id, str, rs)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id md env) rem p (pos+1)
+      (* Need to add the module in case it defines manifest module types *)
+  | Sig_modtype(id, decl) :: rem ->
+      let newdecl =
+        match decl.mtd_type with
+          None ->
+            {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))}
+        | Some _ ->
+            decl
+      in
+      Sig_modtype(id, newdecl) ::
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos
+      (* Need to add the module type in case it is manifest *)
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p pos
+
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
+
+let () = Env.strengthen := strengthen
+
+(* In nondep_supertype, env is only used for the type it assigns to id.
+   Hence there is no need to keep env up-to-date by adding the bindings
+   traversed. *)
+
+type variance = Co | Contra | Strict
+
+let nondep_supertype env mid mty =
+
+  let rec nondep_mty env va mty =
+    match mty with
+      Mty_ident p ->
+        if Path.isfree mid p then
+          nondep_mty env va (Env.find_modtype_expansion p env)
+        else mty
+    | Mty_alias(_, p) ->
+        if Path.isfree mid p then
+          nondep_mty env va (Env.find_module p env).md_type
+        else mty
+    | Mty_signature sg ->
+        Mty_signature(nondep_sig env va sg)
+    | Mty_functor(param, arg, res) ->
+        let var_inv =
+          match va with Co -> Contra | Contra -> Co | Strict -> Strict in
+        Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg,
+                    nondep_mty
+                      (Env.add_module ~arg:true param
+                         (Btype.default_mty arg) env) va res)
+
+  and nondep_sig env va = function
+    [] -> []
+  | item :: rem ->
+      let rem' = nondep_sig env va rem in
+      match item with
+        Sig_value(id, d) ->
+          Sig_value(id,
+                    {d with val_type = Ctype.nondep_type env mid d.val_type})
+          :: rem'
+      | Sig_type(id, d, rs) ->
+          Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
+          :: rem'
+      | Sig_typext(id, ext, es) ->
+          Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es)
+          :: rem'
+      | Sig_module(id, md, rs) ->
+          Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs)
+          :: rem'
+      | Sig_modtype(id, d) ->
+          begin try
+            Sig_modtype(id, nondep_modtype_decl env d) :: rem'
+          with Not_found ->
+            match va with
+              Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
+                                     mtd_attributes=[]}) :: rem'
+            | _  -> raise Not_found
+          end
+      | Sig_class(id, d, rs) ->
+          Sig_class(id, Ctype.nondep_class_declaration env mid d, rs)
+          :: rem'
+      | Sig_class_type(id, d, rs) ->
+          Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs)
+          :: rem'
+
+  and nondep_modtype_decl env mtd =
+    {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type}
+
+  in
+    nondep_mty env Co mty
+
+let enrich_typedecl env p decl =
+  match decl.type_manifest with
+    Some _ -> decl
+  | None ->
+      try
+        let orig_decl = Env.find_type p env in
+        if orig_decl.type_arity <> decl.type_arity
+        then decl
+        else {decl with type_manifest =
+                Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))}
+      with Not_found ->
+        decl
+
+let rec enrich_modtype env p mty =
+  match mty with
+    Mty_signature sg ->
+      Mty_signature(List.map (enrich_item env p) sg)
+  | _ ->
+      mty
+
+and enrich_item env p = function
+    Sig_type(id, decl, rs) ->
+      Sig_type(id,
+                enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs)
+  | Sig_module(id, md, rs) ->
+      Sig_module(id,
+                  {md with
+                   md_type = enrich_modtype env
+                       (Pdot(p, Ident.name id, nopos)) md.md_type},
+                 rs)
+  | item -> item
+
+let rec type_paths env p mty =
+  match scrape env mty with
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
+  | Mty_signature sg -> type_paths_sig env p 0 sg
+  | Mty_functor _ -> []
+
+and type_paths_sig env p pos sg =
+  match sg with
+    [] -> []
+  | Sig_value(_id, decl) :: rem ->
+      let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
+      type_paths_sig env p pos' rem
+  | Sig_type(id, _decl, _) :: rem ->
+      Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
+  | Sig_module(id, md, _) :: rem ->
+      type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
+      type_paths_sig (Env.add_module_declaration ~check:false id md env)
+        p (pos+1) rem
+  | Sig_modtype(id, decl) :: rem ->
+      type_paths_sig (Env.add_modtype id decl env) p pos rem
+  | (Sig_typext _ | Sig_class _) :: rem ->
+      type_paths_sig env p (pos+1) rem
+  | (Sig_class_type _) :: rem ->
+      type_paths_sig env p pos rem
+
+let rec no_code_needed env mty =
+  match scrape env mty with
+    Mty_ident _ -> false
+  | Mty_signature sg -> no_code_needed_sig env sg
+  | Mty_functor(_, _, _) -> false
+  | Mty_alias(Mta_absent, _) -> true
+  | Mty_alias(Mta_present, _) -> false
+
+and no_code_needed_sig env sg =
+  match sg with
+    [] -> true
+  | Sig_value(_id, decl) :: rem ->
+      begin match decl.val_kind with
+      | Val_prim _ -> no_code_needed_sig env rem
+      | _ -> false
+      end
+  | Sig_module(id, md, _) :: rem ->
+      no_code_needed env md.md_type &&
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id md env) rem
+  | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
+      no_code_needed_sig env rem
+  | (Sig_typext _ | Sig_class _) :: _ ->
+      false
+
+
+(* Check whether a module type may return types *)
+
+let rec contains_type env = function
+    Mty_ident path ->
+      begin try match (Env.find_modtype path env).mtd_type with
+      | None -> raise Exit (* PR#6427 *)
+      | Some mty -> contains_type env mty
+      with Not_found -> raise Exit
+      end
+  | Mty_signature sg ->
+      contains_type_sig env sg
+  | Mty_functor (_, _, body) ->
+      contains_type env body
+  | Mty_alias _ ->
+      ()
+
+and contains_type_sig env = List.iter (contains_type_item env)
+
+and contains_type_item env = function
+    Sig_type (_,({type_manifest = None} |
+                 {type_kind = Type_abstract; type_private = Private}),_)
+  | Sig_modtype _
+  | Sig_typext (_, {ext_args = Cstr_record _}, _) ->
+      (* We consider that extension constructors with an inlined
+         record create a type (the inlined record), even though
+         it would be technically safe to ignore that considering
+         the current constraints which guarantee that this type
+         is kept local to expressions.  *)
+      raise Exit
+  | Sig_module (_, {md_type = mty}, _) ->
+      contains_type env mty
+  | Sig_value _
+  | Sig_type _
+  | Sig_typext _
+  | Sig_class _
+  | Sig_class_type _ ->
+      ()
+
+let contains_type env mty =
+  try contains_type env mty; false with Exit -> true
+
+
+(* Remove module aliases from a signature *)
+
+module PathSet = Set.Make (Path)
+module PathMap = Map.Make (Path)
+module IdentSet = Set.Make (Ident)
+
+let rec get_prefixes = function
+    Pident _ -> PathSet.empty
+  | Pdot (p, _, _)
+  | Papply (p, _) -> PathSet.add p (get_prefixes p)
+
+let rec get_arg_paths = function
+    Pident _ -> PathSet.empty
+  | Pdot (p, _, _) -> get_arg_paths p
+  | Papply (p1, p2) ->
+      PathSet.add p2
+        (PathSet.union (get_prefixes p2)
+           (PathSet.union (get_arg_paths p1) (get_arg_paths p2)))
+
+let rec rollback_path subst p =
+  try Pident (PathMap.find p subst)
+  with Not_found ->
+    match p with
+      Pident _ | Papply _ -> p
+    | Pdot (p1, s, n) ->
+        let p1' = rollback_path subst p1 in
+        if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n))
+
+let rec collect_ids subst bindings p =
+    begin match rollback_path subst p with
+      Pident id ->
+        let ids =
+          try collect_ids subst bindings (Ident.find_same id bindings)
+          with Not_found -> IdentSet.empty
+        in
+        IdentSet.add id ids
+    | _ -> IdentSet.empty
+    end
+
+let collect_arg_paths mty =
+  let open Btype in
+  let paths = ref PathSet.empty
+  and subst = ref PathMap.empty
+  and bindings = ref Ident.empty in
+  (* let rt = Ident.create "Root" in
+     and prefix = ref (Path.Pident rt) in *)
+  let it_path p = paths := PathSet.union (get_arg_paths p) !paths
+  and it_signature_item it si =
+    type_iterators.it_signature_item it si;
+    match si with
+      Sig_module (id, {md_type=Mty_alias(_, p)}, _) ->
+        bindings := Ident.add id p !bindings
+    | Sig_module (id, {md_type=Mty_signature sg}, _) ->
+        List.iter
+          (function Sig_module (id', _, _) ->
+              subst :=
+                PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst
+            | _ -> ())
+          sg
+    | _ -> ()
+  in
+  let it = {type_iterators with it_path; it_signature_item} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty;
+  PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p))
+    !paths IdentSet.empty
+
+let rec remove_aliases env excl mty =
+  match mty with
+    Mty_signature sg ->
+      Mty_signature (remove_aliases_sig env excl sg)
+  | Mty_alias _ ->
+      let mty' = Env.scrape_alias env mty in
+      if mty' = mty then mty else
+      remove_aliases env excl mty'
+  | mty ->
+      mty
+
+and remove_aliases_sig env excl sg =
+  match sg with
+    [] -> []
+  | Sig_module(id, md, rs) :: rem  ->
+      let mty =
+        match md.md_type with
+          Mty_alias _ when IdentSet.mem id excl ->
+            md.md_type
+        | mty ->
+            remove_aliases env excl mty
+      in
+      Sig_module(id, {md with md_type = mty} , rs) ::
+      remove_aliases_sig (Env.add_module id mty env) excl rem
+  | Sig_modtype(id, mtd) :: rem ->
+      Sig_modtype(id, mtd) ::
+      remove_aliases_sig (Env.add_modtype id mtd env) excl rem
+  | it :: rem ->
+      it :: remove_aliases_sig env excl rem
+
+let remove_aliases env sg =
+  let excl = collect_arg_paths sg in
+  (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl;
+  Format.eprintf "@."; *)
+  remove_aliases env excl sg
+
+
+(* Lower non-generalizable type variables *)
+
+let lower_nongen nglev mty =
+  let open Btype in
+  let it_type_expr it ty =
+    let ty = repr ty in
+    match ty with
+      {desc=Tvar _; level} ->
+        if level < generic_level && level > nglev then set_level ty nglev
+    | _ ->
+        type_iterators.it_type_expr it ty
+  in
+  let it = {type_iterators with it_type_expr} in
+  it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty
diff --git a/typing/mtype.mli b/typing/mtype.mli
new file mode 100644
index 00000000..84e870ac
--- /dev/null
+++ b/typing/mtype.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Operations on module types *)
+
+open Types
+
+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: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
+        (* Strengthen abstract type components relative to the
+           given path. *)
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
+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
+val contains_type: Env.t -> module_type -> bool
+val remove_aliases: Env.t -> module_type -> module_type
+val lower_nongen: int -> module_type -> unit
diff --git a/typing/oprint.ml b/typing/oprint.ml
new file mode 100644
index 00000000..b0145ec6
--- /dev/null
+++ b/typing/oprint.ml
@@ -0,0 +1,667 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+exception Ellipsis
+
+let cautious f ppf arg =
+  try f ppf arg with
+    Ellipsis -> fprintf ppf "..."
+
+let rec print_ident ppf =
+  function
+    Oide_ident s -> pp_print_string ppf s
+  | Oide_dot (id, s) ->
+      print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s
+  | Oide_apply (id1, id2) ->
+      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
+
+let parenthesized_ident name =
+  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
+  ||
+  (match name.[0] with
+      'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' ->
+        false
+    | _ -> true)
+
+let value_ident ppf name =
+  if parenthesized_ident name then
+    fprintf ppf "( %s )" name
+  else
+    pp_print_string ppf name
+
+(* Values *)
+
+let valid_float_lexeme s =
+  let l = String.length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match s.[i] with
+    | '0' .. '9' | '-' -> loop (i+1)
+    | _ -> s
+  in loop 0
+
+let float_repres f =
+  match classify_float f with
+    FP_nan -> "nan"
+  | FP_infinite ->
+      if f < 0.0 then "neg_infinity" else "infinity"
+  | _ ->
+      let float_val =
+        let s1 = Printf.sprintf "%.12g" f in
+        if f = float_of_string s1 then s1 else
+        let s2 = Printf.sprintf "%.15g" f in
+        if f = float_of_string s2 then s2 else
+        Printf.sprintf "%.18g" f
+      in valid_float_lexeme float_val
+
+let parenthesize_if_neg ppf fmt v isneg =
+  if isneg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if isneg then pp_print_char ppf ')'
+
+let print_out_value ppf tree =
+  let rec print_tree_1 ppf =
+    function
+    | Oval_constr (name, [param]) ->
+        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+    | Oval_constr (name, (_ :: _ as params)) ->
+        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+          (print_tree_list print_tree_1 ",") params
+    | Oval_variant (name, Some param) ->
+        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
+    | tree -> print_simple_tree ppf tree
+  and print_constr_param ppf = function
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
+    | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
+    | tree -> print_simple_tree ppf tree
+  and print_simple_tree ppf =
+    function
+      Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
+    | Oval_float f -> pp_print_string ppf (float_repres f)
+    | Oval_char c -> fprintf ppf "%C" c
+    | Oval_string s ->
+        begin try fprintf ppf "%S" s with
+          Invalid_argument _ (* "String.create" *)-> fprintf ppf ""
+        end
+    | Oval_list tl ->
+        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_array tl ->
+        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_variant (name, None) -> fprintf ppf "`%s" name
+    | Oval_stuff s -> pp_print_string ppf s
+    | Oval_record fel ->
+        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_ellipsis -> raise Ellipsis
+    | Oval_printer f -> f ppf
+    | Oval_tuple tree_list ->
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
+  and print_fields first ppf =
+    function
+      [] -> ()
+    | (name, tree) :: fields ->
+        if not first then fprintf ppf ";@ ";
+        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+          tree;
+        print_fields false ppf fields
+  and print_tree_list print_item sep ppf tree_list =
+    let rec print_list first ppf =
+      function
+        [] -> ()
+      | tree :: tree_list ->
+          if not first then fprintf ppf "%s@ " sep;
+          print_item ppf tree;
+          print_list false ppf tree_list
+    in
+    cautious (print_list true) ppf tree_list
+  in
+  cautious print_tree_1 ppf tree
+
+let out_value = ref print_out_value
+
+(* Types *)
+
+let rec print_list_init pr sep ppf =
+  function
+    [] -> ()
+  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
+
+let rec print_list pr sep ppf =
+  function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
+
+let pr_present =
+  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let pr_vars =
+  print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let rec print_out_type ppf =
+  function
+  | Otyp_alias (ty, s) ->
+      fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
+  | Otyp_poly (sl, ty) ->
+      fprintf ppf "@[%a.@ %a@]"
+        pr_vars sl
+        print_out_type ty
+  | ty ->
+      print_out_type_1 ppf ty
+
+and print_out_type_1 ppf =
+  function
+    Otyp_arrow (lab, ty1, ty2) ->
+      pp_open_box ppf 0;
+      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+      print_out_type_2 ppf ty1;
+      pp_print_string ppf " ->";
+      pp_print_space ppf ();
+      print_out_type_1 ppf ty2;
+      pp_close_box ppf ()
+  | ty -> print_out_type_2 ppf ty
+and print_out_type_2 ppf =
+  function
+    Otyp_tuple tyl ->
+      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
+  | ty -> print_simple_out_type ppf ty
+and print_simple_out_type ppf =
+  function
+    Otyp_class (ng, id, tyl) ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
+  | Otyp_constr (id, tyl) ->
+      pp_open_box ppf 0;
+      print_typargs ppf tyl;
+      print_ident ppf id;
+      pp_close_box ppf ()
+  | Otyp_object (fields, rest) ->
+      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+  | Otyp_stuff s -> pp_print_string ppf s
+  | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
+  | Otyp_variant (non_gen, row_fields, closed, tags) ->
+      let print_present ppf =
+        function
+          None | Some [] -> ()
+        | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l
+      in
+      let print_fields ppf =
+        function
+          Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_typ typ ->
+           print_simple_out_type ppf typ
+      in
+      fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "")
+        (if closed then if tags = None then " " else "< "
+         else if tags = None then "> " else "? ")
+        print_fields row_fields
+        print_present tags
+  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_out_type ppf ty;
+      pp_print_char ppf ')';
+      pp_close_box ppf ()
+  | Otyp_abstract | Otyp_open
+  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
+  | Otyp_record lbls -> print_record_decl ppf lbls
+  | Otyp_module (p, n, tyl) ->
+      fprintf ppf "@[<1>(module %s" p;
+      let first = ref true in
+      List.iter2
+        (fun s t ->
+          let sep = if !first then (first := false; "with") else "and" in
+          fprintf ppf " %s type %s = %a" sep s print_out_type t
+        )
+        n tyl;
+      fprintf ppf ")@]"
+  | Otyp_attribute (t, attr) ->
+      fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name
+and print_record_decl ppf lbls =
+  fprintf ppf "{%a@;<1 -2>}"
+    (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+and print_fields rest ppf =
+  function
+    [] ->
+      begin match rest with
+        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
+      | None -> ()
+      end
+  | [s, t] ->
+      fprintf ppf "%s : %a" s print_out_type t;
+      begin match rest with
+        Some _ -> fprintf ppf ";@ "
+      | None -> ()
+      end;
+      print_fields rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+and print_row_field ppf (l, opt_amp, tyl) =
+  let pr_of ppf =
+    if opt_amp then fprintf ppf " of@ &@ "
+    else if tyl <> [] then fprintf ppf " of@ "
+    else fprintf ppf ""
+  in
+  fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+    tyl
+and print_typlist print_elem sep ppf =
+  function
+    [] -> ()
+  | [ty] -> print_elem ppf ty
+  | ty :: tyl ->
+      print_elem ppf ty;
+      pp_print_string ppf sep;
+      pp_print_space ppf ();
+      print_typlist print_elem sep ppf tyl
+and print_typargs ppf =
+  function
+    [] -> ()
+  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+  | tyl ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_typlist print_out_type "," ppf tyl;
+      pp_print_char ppf ')';
+      pp_close_box ppf ();
+      pp_print_space ppf ()
+and print_out_label ppf (name, mut, arg) =
+  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+    print_out_type arg
+
+let out_type = ref print_out_type
+
+(* Class types *)
+
+let type_parameter ppf (ty, (co, cn)) =
+  fprintf ppf "%s%s"
+    (if not cn then "+" else if not co then "-" else "")
+    (if ty = "_" then ty else "'"^ty)
+
+let print_out_class_params ppf =
+  function
+    [] -> ()
+  | tyl ->
+      fprintf ppf "@[<1>[%a]@]@ "
+        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
+        tyl
+
+let rec print_out_class_type ppf =
+  function
+    Octy_constr (id, tyl) ->
+      let pr_tyl ppf =
+        function
+          [] -> ()
+        | tyl ->
+            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
+      in
+      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
+  | Octy_arrow (lab, ty, cty) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty print_out_class_type cty
+  | Octy_signature (self_ty, csil) ->
+      let pr_param ppf =
+        function
+          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
+        | None -> ()
+      in
+      fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
+        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
+        csil
+and print_out_class_sig_item ppf =
+  function
+    Ocsg_constraint (ty1, ty2) ->
+      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
+        !out_type ty2
+  | Ocsg_method (name, priv, virt, ty) ->
+      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+        (if priv then "private " else "") (if virt then "virtual " else "")
+        name !out_type ty
+  | Ocsg_value (name, mut, vr, ty) ->
+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+        (if mut then "mutable " else "")
+        (if vr then "virtual " else "")
+        name !out_type ty
+
+let out_class_type = ref print_out_class_type
+
+(* Signature *)
+
+let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
+let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
+let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
+let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
+
+let rec print_out_functor funct ppf =
+  function
+    Omty_functor (_, None, mty_res) ->
+      if funct then fprintf ppf "() %a" (print_out_functor true) mty_res
+      else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res
+  | Omty_functor (name, Some mty_arg, mty_res) -> begin
+      match name, funct with
+      | "_", true ->
+          fprintf ppf "->@ %a ->@ %a"
+            print_out_module_type mty_arg (print_out_functor false) mty_res
+      | "_", false ->
+          fprintf ppf "%a ->@ %a"
+            print_out_module_type mty_arg (print_out_functor false) mty_res
+      | name, true ->
+          fprintf ppf "(%s : %a) %a" name
+            print_out_module_type mty_arg (print_out_functor true) mty_res
+      | name, false ->
+            fprintf ppf "functor@ (%s : %a) %a" name
+              print_out_module_type mty_arg (print_out_functor true) mty_res
+    end
+  | m ->
+      if funct then fprintf ppf "->@ %a" print_out_module_type m
+      else print_out_module_type ppf m
+
+and print_out_module_type ppf =
+  function
+    Omty_abstract -> ()
+  | Omty_functor _ as t ->
+      fprintf ppf "@[<2>%a@]" (print_out_functor false) t
+  | Omty_ident id -> fprintf ppf "%a" print_ident id
+  | Omty_signature sg ->
+      fprintf ppf "@[sig@ %a@;<1 -2>end@]" !out_signature sg
+  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
+and print_out_signature ppf =
+  function
+    [] -> ()
+  | [item] -> !out_sig_item ppf item
+  | Osig_typext(ext, Oext_first) :: items ->
+      (* Gather together the extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            Osig_typext(ext, Oext_next) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
+  | item :: items ->
+      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, 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, 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_typext (ext, Oext_exception) ->
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+  | Osig_typext (ext, _es) ->
+      print_out_extension_constructor ppf ext
+  | Osig_modtype (name, Omty_abstract) ->
+      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, Omty_alias id, _) ->
+      fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id
+  | 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
+          (match rs with
+           | Orec_not   -> "type nonrec"
+           | Orec_first -> "type"
+           | Orec_next  -> "and")
+          ppf td
+  | Osig_value vd ->
+      let kwd = if vd.oval_prims = [] then "val" else "external" in
+      let pr_prims ppf =
+        function
+          [] -> ()
+        | s :: sl ->
+            fprintf ppf "@ = \"%s\"" s;
+            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
+      in
+      fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name
+        !out_type vd.oval_type pr_prims vd.oval_prims
+        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
+        vd.oval_attributes
+  | Osig_ellipsis ->
+      fprintf ppf "..."
+
+and print_out_type_decl kwd ppf td =
+  let print_constraints ppf =
+    List.iter
+      (fun (ty1, ty2) ->
+         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
+           !out_type ty2)
+      td.otype_cstrs
+  in
+  let type_defined ppf =
+    match td.otype_params with
+      [] -> pp_print_string ppf td.otype_name
+    | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
+          td.otype_params
+          td.otype_name
+  in
+  let print_manifest ppf =
+    function
+      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
+    | _ -> ()
+  in
+  let print_name_params ppf =
+    fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type
+  in
+  let ty =
+    match td.otype_type with
+      Otyp_manifest (_, ty) -> ty
+    | _ -> td.otype_type
+  in
+  let print_private ppf = function
+    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Public -> ()
+  in
+  let print_immediate ppf =
+    if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
+  in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
+  let print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " =%a %a"
+        print_private td.otype_private
+        print_record_decl lbls
+  | Otyp_sum constrs ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private
+        (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
+  | Otyp_open ->
+      fprintf ppf " = .."
+  | ty ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private td.otype_private
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[%t%a@]%t%t%t@]"
+    print_name_params
+    print_out_tkind ty
+    print_constraints
+    print_immediate
+    print_unboxed
+
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          pp_print_string ppf name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+and print_out_extension_constructor ppf ext =
+  let print_extended_type ppf =
+    let print_type_parameter ppf ty =
+      fprintf ppf "%s"
+        (if ty = "_" then ty else "'"^ty)
+    in
+      match ext.oext_type_params with
+        [] -> fprintf ppf "%s" ext.oext_type_name
+      | [ty_param] ->
+        fprintf ppf "@[%a@ %s@]"
+          print_type_parameter
+          ty_param
+          ext.oext_type_name
+      | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          ext.oext_type_params
+          ext.oext_type_name
+  in
+  fprintf ppf "@[type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if ext.oext_private = Asttypes.Private then " private" else "")
+    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+
+and print_out_type_extension ppf te =
+  let print_extended_type ppf =
+    let print_type_parameter ppf ty =
+      fprintf ppf "%s"
+        (if ty = "_" then ty else "'"^ty)
+    in
+    match te.otyext_params with
+      [] -> fprintf ppf "%s" te.otyext_name
+    | [param] ->
+      fprintf ppf "@[%a@ %s@]"
+        print_type_parameter param
+        te.otyext_name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
+          te.otyext_params
+          te.otyext_name
+  in
+  fprintf ppf "@[type %t +=%s@;<1 2>%a@]"
+    print_extended_type
+    (if te.otyext_private = Asttypes.Private then " private" else "")
+    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
+    te.otyext_constructors
+
+let _ = out_module_type := print_out_module_type
+let _ = out_signature := print_out_signature
+let _ = out_sig_item := print_out_sig_item
+let _ = out_type_extension := print_out_type_extension
+
+(* Phrases *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+    Sys.Break -> fprintf ppf "Interrupted.@."
+  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
+
+let rec print_items ppf =
+  function
+    [] -> ()
+  | (Osig_typext(ext, Oext_first), None) :: items ->
+      (* Gather together extension constructors *)
+      let rec gather_extensions acc items =
+        match items with
+            (Osig_typext(ext, Oext_next), None) :: items ->
+              gather_extensions
+                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                items
+          | _ -> (List.rev acc, items)
+      in
+      let exts, items =
+        gather_extensions
+          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          items
+      in
+      let te =
+        { otyext_name = ext.oext_type_name;
+          otyext_params = ext.oext_type_params;
+          otyext_constructors = exts;
+          otyext_private = ext.oext_private }
+      in
+        fprintf ppf "@[%a@]" !out_type_extension te;
+        if items <> [] then fprintf ppf "@ %a" print_items items
+  | (tree, valopt) :: items ->
+      begin match valopt with
+        Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
+            !out_value v
+      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
+      end;
+      if items <> [] then fprintf ppf "@ %a" print_items items
+
+let print_out_phrase ppf =
+  function
+    Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let out_phrase = ref print_out_phrase
diff --git a/typing/oprint.mli b/typing/oprint.mli
new file mode 100644
index 00000000..7ce08a38
--- /dev/null
+++ b/typing/oprint.mli
@@ -0,0 +1,28 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+open Outcometree
+
+val out_value : (formatter -> out_value -> unit) ref
+val out_type : (formatter -> out_type -> unit) ref
+val out_class_type : (formatter -> out_class_type -> unit) ref
+val out_module_type : (formatter -> out_module_type -> unit) ref
+val out_sig_item : (formatter -> out_sig_item -> unit) ref
+val out_signature : (formatter -> out_sig_item list -> unit) ref
+val out_type_extension : (formatter -> out_type_extension -> unit) ref
+val out_phrase : (formatter -> out_phrase -> unit) ref
+
+val parenthesized_ident : string -> bool
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
new file mode 100644
index 00000000..17c4862d
--- /dev/null
+++ b/typing/outcometree.mli
@@ -0,0 +1,140 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Daniel de Rauglaudre, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Outcometree]: results displayed by the toplevel *)
+
+(* These types represent messages that the toplevel displays as normal
+   results or errors. The real displaying is customisable using the hooks:
+      [Toploop.print_out_value]
+      [Toploop.print_out_type]
+      [Toploop.print_out_sig_item]
+      [Toploop.print_out_phrase] *)
+
+type out_ident =
+  | Oide_apply of out_ident * out_ident
+  | Oide_dot of out_ident * string
+  | Oide_ident of string
+
+type out_attribute =
+  { oattr_name: string }
+
+type out_value =
+  | Oval_array of out_value list
+  | Oval_char of char
+  | Oval_constr of out_ident * out_value list
+  | Oval_ellipsis
+  | Oval_float of float
+  | Oval_int of int
+  | Oval_int32 of int32
+  | Oval_int64 of int64
+  | Oval_nativeint of nativeint
+  | Oval_list of out_value list
+  | Oval_printer of (Format.formatter -> unit)
+  | Oval_record of (out_ident * out_value) list
+  | Oval_string of string
+  | Oval_stuff of string
+  | Oval_tuple of out_value list
+  | Oval_variant of string * out_value option
+
+type out_type =
+  | Otyp_abstract
+  | Otyp_open
+  | Otyp_alias of out_type * string
+  | Otyp_arrow of string * out_type * out_type
+  | Otyp_class of bool * out_ident * out_type list
+  | Otyp_constr of out_ident * out_type list
+  | Otyp_manifest of out_type * out_type
+  | Otyp_object of (string * out_type) list * bool option
+  | Otyp_record of (string * bool * out_type) list
+  | Otyp_stuff of string
+  | Otyp_sum of (string * out_type list * out_type option) list
+  | Otyp_tuple of out_type list
+  | Otyp_var of bool * string
+  | Otyp_variant of
+      bool * out_variant * bool * (string list) option
+  | Otyp_poly of string list * out_type
+  | Otyp_module of string * string list * out_type list
+  | Otyp_attribute of out_type * out_attribute
+
+and out_variant =
+  | Ovar_fields of (string * bool * out_type list) list
+  | Ovar_typ of out_type
+
+type out_class_type =
+  | Octy_constr of out_ident * out_type list
+  | Octy_arrow of string * out_type * out_class_type
+  | Octy_signature of out_type option * out_class_sig_item list
+and out_class_sig_item =
+  | Ocsg_constraint of out_type * out_type
+  | Ocsg_method of string * bool * bool * out_type
+  | Ocsg_value of string * bool * bool * out_type
+
+type out_module_type =
+  | Omty_abstract
+  | Omty_functor of string * out_module_type option * out_module_type
+  | Omty_ident of out_ident
+  | Omty_signature of out_sig_item list
+  | Omty_alias of out_ident
+and out_sig_item =
+  | Osig_class of
+      bool * string * (string * (bool * bool)) list * out_class_type *
+        out_rec_status
+  | Osig_class_type of
+      bool * string * (string * (bool * bool)) list * out_class_type *
+        out_rec_status
+  | Osig_typext of out_extension_constructor * out_ext_status
+  | Osig_modtype of string * out_module_type
+  | Osig_module of string * out_module_type * out_rec_status
+  | Osig_type of out_type_decl * out_rec_status
+  | Osig_value of out_val_decl
+  | Osig_ellipsis
+and out_type_decl =
+  { otype_name: string;
+    otype_params: (string * (bool * bool)) list;
+    otype_type: out_type;
+    otype_private: Asttypes.private_flag;
+    otype_immediate: bool;
+    otype_unboxed: bool;
+    otype_cstrs: (out_type * out_type) list }
+and out_extension_constructor =
+  { oext_name: string;
+    oext_type_name: string;
+    oext_type_params: string list;
+    oext_args: out_type list;
+    oext_ret_type: out_type option;
+    oext_private: Asttypes.private_flag }
+and out_type_extension =
+  { otyext_name: string;
+    otyext_params: string list;
+    otyext_constructors: (string * out_type list * out_type option) list;
+    otyext_private: Asttypes.private_flag }
+and out_val_decl =
+  { oval_name: string;
+    oval_type: out_type;
+    oval_prims: string list;
+    oval_attributes: out_attribute list }
+and out_rec_status =
+  | Orec_not
+  | Orec_first
+  | Orec_next
+and out_ext_status =
+  | Oext_first
+  | Oext_next
+  | Oext_exception
+
+type out_phrase =
+  | Ophr_eval of out_value * out_type
+  | Ophr_signature of (out_sig_item * out_value option) list
+  | Ophr_exception of (exn * out_value)
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
new file mode 100644
index 00000000..9e935730
--- /dev/null
+++ b/typing/parmatch.ml
@@ -0,0 +1,2313 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detection of partial matches and unused match cases. *)
+
+open Misc
+open Asttypes
+open Types
+open Typedtree
+
+(*************************************)
+(* Utilities for building patterns   *)
+(*************************************)
+
+let make_pat desc ty tenv =
+  {pat_desc = desc; pat_loc = Location.none; pat_extra = [];
+   pat_type = ty ; pat_env = tenv;
+   pat_attributes = [];
+  }
+
+let omega = make_pat Tpat_any Ctype.none Env.empty
+
+let extra_pat =
+  make_pat
+    (Tpat_var (Ident.create "+", mknoloc "+"))
+    Ctype.none Env.empty
+
+let rec omegas i =
+  if i <= 0 then [] else omega :: omegas (i-1)
+
+let omega_list l = List.map (fun _ -> omega) l
+
+let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty
+
+(***********************)
+(* Compatibility check *)
+(***********************)
+
+(* p and q compatible means, there exists V that matches both *)
+
+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 const_compare x y =
+  match x,y with
+  | Const_float f1, Const_float f2 ->
+      Pervasives.compare (float_of_string f1) (float_of_string f2)
+  | Const_string (s1, _), Const_string (s2, _) ->
+      String.compare s1 s2
+  | _, _ -> Pervasives.compare x y
+
+let records_args l1 l2 =
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
+  let rec combine r1 r2 l1 l2 = match l1,l2 with
+  | [],[] -> List.rev r1, List.rev r2
+  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        combine (p1::r1) (omega::r2) rem1 l2
+      else if lbl1.lbl_pos > lbl2.lbl_pos then
+        combine (omega::r1) (p2::r2) l1 rem2
+      else (* same label on both sides *)
+        combine (p1::r1) (p2::r2) rem1 rem2 in
+  combine [] [] l1 l2
+
+
+let rec compat p q =
+  match p.pat_desc,q.pat_desc with
+  | Tpat_alias (p,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_)      -> compat p q
+  | (Tpat_any|Tpat_var _),_ -> true
+  | _,(Tpat_any|Tpat_var _) -> true
+  | Tpat_or (p1,p2,_),_     -> compat p1 q || compat p2 q
+  | _,Tpat_or (q1,q2,_)     -> compat p q1 || compat p q2
+  | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0
+  | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
+  | Tpat_lazy p, Tpat_lazy q -> 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 && compat p1 p2
+  | Tpat_variant (l1,None, _r1), Tpat_variant(l2,None,_) ->
+      l1 = l2
+  | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
+  | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
+  | Tpat_record (l1,_),Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      compats ps qs
+  | Tpat_array ps, Tpat_array qs ->
+      List.length ps = List.length qs &&
+      compats ps qs
+  | _,_  ->
+      assert false
+
+and compats ps qs = match ps,qs with
+| [], [] -> true
+| p::ps, q::qs -> compat p q && compats ps qs
+| _,_    -> assert false
+
+exception Empty (* Empty pattern *)
+
+(****************************************)
+(* Utilities for retrieving type paths  *)
+(****************************************)
+
+(* May need a clean copy, cf. PR#4745 *)
+let clean_copy ty =
+  if ty.level = Btype.generic_level then ty
+  else Subst.type_expr Subst.identity ty
+
+let get_type_path ty tenv =
+  let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
+  match ty.desc with
+  | Tconstr (path,_,_) -> path
+  | _ -> fatal_error "Parmatch.get_type_path"
+
+(*************************************)
+(* Values as patterns pretty printer *)
+(*************************************)
+
+open Format
+;;
+
+let is_cons = function
+| {cstr_name = "::"} -> true
+| _ -> false
+
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string (s, _) -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
+
+let rec pretty_val ppf v =
+  match v.pat_extra with
+      (cstr, _loc, _attrs) :: rem ->
+        begin match cstr with
+          | Tpat_unpack ->
+            fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
+          | Tpat_constraint _ ->
+            fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
+          | Tpat_type _ ->
+            fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
+          | Tpat_open _ ->
+              fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
+        end
+    | [] ->
+  match v.pat_desc with
+  | Tpat_any -> fprintf ppf "_"
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
+  | Tpat_tuple vs ->
+      fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
+  | Tpat_construct (_, cstr, []) ->
+      fprintf ppf "%s" cstr.cstr_name
+  | Tpat_construct (_, cstr, [w]) ->
+      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+  | Tpat_construct (_, cstr, vs) ->
+      let name = cstr.cstr_name in
+      begin match (name, vs) with
+        ("::", [v1;v2]) ->
+          fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
+      |  _ ->
+          fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
+      end
+  | Tpat_variant (l, None, _) ->
+      fprintf ppf "`%s" l
+  | Tpat_variant (l, Some w, _) ->
+      fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
+  | Tpat_record (lvs,_) ->
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      begin match filtered_lvs with
+      | [] -> fprintf ppf "_"
+      | (_, lbl, _) :: q ->
+          let elision_mark ppf =
+            (* we assume that there is no label repetitions here *)
+             if Array.length lbl.lbl_all > 1 + List.length q then
+               fprintf ppf ";@ _@ "
+             else () in
+          fprintf ppf "@[{%a%t}@]"
+            pretty_lvals filtered_lvs elision_mark
+      end
+  | Tpat_array vs ->
+      fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
+  | Tpat_lazy v ->
+      fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
+  | Tpat_alias (v, x,_) ->
+      fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
+  | Tpat_or (v,w,_)    ->
+      fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
+
+and pretty_car ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [_ ; _])
+    when is_cons cstr ->
+      fprintf ppf "(%a)" pretty_val v
+| _ -> pretty_val ppf v
+
+and pretty_cdr ppf v = match v.pat_desc with
+| Tpat_construct (_,cstr, [v1 ; v2])
+    when is_cons cstr ->
+      fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
+| _ -> pretty_val ppf v
+
+and pretty_arg ppf v = match v.pat_desc with
+| Tpat_construct (_,_,_::_)
+| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
+|  _ -> pretty_val ppf v
+
+and pretty_or ppf v = match v.pat_desc with
+| Tpat_or (v,w,_) ->
+    fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+| _ -> pretty_val ppf v
+
+and pretty_vals sep ppf = function
+  | [] -> ()
+  | [v] -> pretty_val ppf v
+  | v::vs ->
+      fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
+
+and pretty_lvals ppf = function
+  | [] -> ()
+  | [_,lbl,v] ->
+      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
+  | (_, lbl,v)::rest ->
+      fprintf ppf "%s=%a;@ %a"
+        lbl.lbl_name pretty_val v pretty_lvals rest
+
+let top_pretty ppf v =
+  fprintf ppf "@[%a@]@?" pretty_val v
+
+
+let pretty_pat p =
+  top_pretty Format.str_formatter p ;
+  prerr_string (Format.flush_str_formatter ())
+
+type matrix = pattern list list
+
+let pretty_line ps =
+  List.iter
+    (fun p ->
+      top_pretty Format.str_formatter p ;
+      prerr_string " <" ;
+      prerr_string (Format.flush_str_formatter ()) ;
+      prerr_string ">")
+    ps
+
+let pretty_matrix (pss : matrix) =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun ps ->
+      pretty_line ps ;
+      prerr_endline "")
+    pss ;
+  prerr_endline "end matrix"
+
+
+(****************************)
+(* Utilities for matching   *)
+(****************************)
+
+(* Check top matching *)
+let simple_match p1 p2 =
+  match p1.pat_desc, p2.pat_desc with
+  | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) ->
+      c1.cstr_tag = c2.cstr_tag
+  | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
+      l1 = l2
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
+  | Tpat_tuple _, Tpat_tuple _ -> true
+  | Tpat_lazy _, Tpat_lazy _ -> true
+  | Tpat_record _ , Tpat_record _ -> true
+  | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s
+  | _, (Tpat_any | Tpat_var(_)) -> true
+  | _, _ -> false
+
+
+
+
+(* extract record fields as a whole *)
+let record_arg p = match p.pat_desc with
+| Tpat_any -> []
+| Tpat_record (args,_) -> args
+| _ -> fatal_error "Parmatch.as_record"
+
+
+(* Raise Not_found when pos is not present in arg *)
+let get_field pos arg =
+  let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in
+  p
+
+let extract_fields omegas arg =
+  List.map
+    (fun (_,lbl,_) ->
+      try
+        get_field lbl.lbl_pos arg
+      with Not_found -> omega)
+    omegas
+
+let all_record_args lbls = match lbls with
+| (_,{lbl_all=lbl_all},_)::_ ->
+    let t =
+      Array.map
+        (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
+        lbl_all in
+    List.iter
+      (fun ((_, lbl,_) as x) ->  t.(lbl.lbl_pos) <- x)
+      lbls ;
+    Array.to_list t
+|  _ -> fatal_error "Parmatch.all_record_args"
+
+
+(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
+let rec simple_match_args p1 p2 = match p2.pat_desc with
+| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
+| Tpat_construct(_, _, args) -> args
+| Tpat_variant(_, Some arg, _) -> [arg]
+| Tpat_tuple(args)  -> args
+| Tpat_record(args,_) ->  extract_fields (record_arg p1) args
+| Tpat_array(args) -> args
+| Tpat_lazy arg -> [arg]
+| (Tpat_any | Tpat_var(_)) ->
+    begin match p1.pat_desc with
+      Tpat_construct(_, _,args) -> omega_list args
+    | Tpat_variant(_, Some _, _) -> [omega]
+    | Tpat_tuple(args) -> omega_list args
+    | Tpat_record(args,_) ->  omega_list args
+    | Tpat_array(args) ->  omega_list args
+    | Tpat_lazy _ -> [omega]
+    | _ -> []
+    end
+| _ -> []
+
+(*
+  Normalize a pattern ->
+   all arguments are omega (simple pattern) and no more variables
+*)
+
+let rec normalize_pat q = match q.pat_desc with
+  | Tpat_any | Tpat_constant _ -> q
+  | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env
+  | Tpat_alias (p,_,_) -> normalize_pat p
+  | Tpat_tuple (args) ->
+      make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
+  | Tpat_construct  (lid, c,args) ->
+      make_pat
+        (Tpat_construct (lid, c,omega_list args))
+        q.pat_type q.pat_env
+  | Tpat_variant (l, arg, row) ->
+      make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
+        q.pat_type q.pat_env
+  | Tpat_array (args) ->
+      make_pat (Tpat_array (omega_list args))  q.pat_type q.pat_env
+  | Tpat_record (largs, closed) ->
+      make_pat
+        (Tpat_record (List.map (fun (lid,lbl,_) ->
+                                 lid, lbl,omega) largs, closed))
+        q.pat_type q.pat_env
+  | Tpat_lazy _ ->
+      make_pat (Tpat_lazy omega) q.pat_type q.pat_env
+  | Tpat_or _ -> fatal_error "Parmatch.normalize_pat"
+
+(*
+  Build normalized (cf. supra) discriminating pattern,
+  in the non-data type case
+*)
+
+let discr_pat q pss =
+
+  let rec acc_pat acc pss = match pss with
+    ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss ->
+        acc_pat acc ((p::ps)::pss)
+  | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss ->
+        acc_pat acc ((p1::ps)::(p2::ps)::pss)
+  | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss ->
+        acc_pat acc pss
+  | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p
+  | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
+  | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
+      let new_omegas =
+        List.fold_right
+          (fun (lid, lbl,_) r ->
+            try
+              let _ = get_field lbl.lbl_pos r in
+              r
+            with Not_found ->
+              (lid, lbl,omega)::r)
+          largs (record_arg acc)
+      in
+      acc_pat
+        (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env)
+        pss
+  | _ -> acc in
+
+  match normalize_pat q with
+  | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss
+  | q -> q
+
+(*
+   In case a matching value is found, set actual arguments
+   of the matching pattern.
+*)
+
+let rec read_args xs r = match xs,r with
+| [],_ -> [],r
+| _::xs, arg::rest ->
+   let args,rest = read_args xs rest in
+   arg::args,rest
+| _,_ ->
+    fatal_error "Parmatch.read_args"
+
+let do_set_args erase_mutable q r = match q with
+| {pat_desc = Tpat_tuple omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
+| {pat_desc = Tpat_record (omegas,closed)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_record
+         (List.map2 (fun (lid, lbl,_) arg ->
+           if
+             erase_mutable &&
+             (match lbl.lbl_mut with
+             | Mutable -> true | Immutable -> false)
+           then
+             lid, lbl, omega
+           else
+             lid, lbl, arg)
+            omegas args, closed))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_construct (lid, c,omegas)} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_construct (lid, c,args))
+      q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_variant (l, omega, row)} ->
+    let arg, rest =
+      match omega, r with
+        Some _, a::r -> Some a, r
+      | None, r -> None, r
+      | _ -> assert false
+    in
+    make_pat
+      (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
+    rest
+| {pat_desc = Tpat_lazy _omega} ->
+    begin match r with
+      arg::rest ->
+        make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
+    | _ -> fatal_error "Parmatch.do_set_args (lazy)"
+    end
+| {pat_desc = Tpat_array omegas} ->
+    let args,rest = read_args omegas r in
+    make_pat
+      (Tpat_array args) q.pat_type q.pat_env::
+    rest
+| {pat_desc=Tpat_constant _|Tpat_any} ->
+    q::r (* case any is used in matching.ml *)
+| _ -> fatal_error "Parmatch.set_args"
+
+let set_args q r = do_set_args false q r
+and set_args_erase_mutable q r = do_set_args true q r
+
+(* filter pss acording to pattern q *)
+let filter_one q pss =
+  let rec filter_rec = function
+      ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
+        filter_rec ((p::ps)::pss)
+    | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
+        filter_rec ((p1::ps)::(p2::ps)::pss)
+    | (p::ps)::pss ->
+        if simple_match q p
+        then (simple_match_args q p @ ps) :: filter_rec pss
+        else filter_rec pss
+    | _ -> [] in
+  filter_rec pss
+
+(*
+  Filter pss in the ``extra case''. This applies :
+  - According to an extra constructor (datatype case, non-complete signature).
+  - Acordinng to anything (all-variables case).
+*)
+let filter_extra pss =
+  let rec filter_rec = function
+      ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
+        filter_rec ((p::ps)::pss)
+    | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
+        filter_rec ((p1::ps)::(p2::ps)::pss)
+    | ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss ->
+        qs :: filter_rec pss
+    | _::pss  -> filter_rec pss
+    | [] -> [] in
+  filter_rec pss
+
+(*
+  Pattern p0 is the discriminating pattern,
+  returns [(q0,pss0) ; ... ; (qn,pssn)]
+  where the qi's are simple patterns and the pssi's are
+  matched matrices.
+
+  NOTES
+   * (qi,[]) is impossible.
+   * In the case when matching is useless (all-variable case),
+     returns []
+*)
+
+let filter_all pat0 pss =
+
+  let rec insert q qs env =
+    match env with
+      [] ->
+        let q0 = normalize_pat q in
+        [q0, [simple_match_args q0 q @ qs]]
+    | ((q0,pss) as c)::env ->
+        if simple_match q0 q
+        then (q0, ((simple_match_args q0 q @ qs) :: pss)) :: env
+        else c :: insert q qs env in
+
+  let rec filter_rec env = function
+    ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
+      filter_rec env ((p::ps)::pss)
+  | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
+      filter_rec env ((p1::ps)::(p2::ps)::pss)
+  | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss ->
+      filter_rec env pss
+  | (p::ps)::pss ->
+      filter_rec (insert p ps env) pss
+  | _ -> env
+
+  and filter_omega env = function
+    ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
+      filter_omega env ((p::ps)::pss)
+  | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
+      filter_omega env ((p1::ps)::(p2::ps)::pss)
+  | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss ->
+      filter_omega
+        (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss))
+           env)
+        pss
+  | _::pss -> filter_omega env pss
+  | [] -> env in
+
+  filter_omega
+    (filter_rec
+      (match pat0.pat_desc with
+        (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]]
+      | _ -> [])
+      pss)
+    pss
+
+(* Variant related functions *)
+
+let rec set_last a = function
+    [] -> []
+  | [_] -> [a]
+  | x::l -> x :: set_last a l
+
+(* mark constructor lines for failure when they are incomplete *)
+let rec mark_partial = function
+    ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
+      mark_partial ((p::ps)::pss)
+  | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
+      mark_partial ((p1::ps)::(p2::ps)::pss)
+  | ({pat_desc = (Tpat_any | Tpat_var(_))} :: _ as ps) :: pss ->
+      ps :: mark_partial pss
+  | ps::pss  ->
+      (set_last zero ps) :: mark_partial pss
+  | [] -> []
+
+let close_variant env row =
+  let row = Btype.row_repr row in
+  let nm =
+    List.fold_left
+      (fun nm (_tag,f) ->
+        match Btype.row_field_repr f with
+        | Reither(_, _, false, e) ->
+            (* m=false means that this tag is not explicitly matched *)
+            Btype.set_row_field e Rabsent;
+            None
+        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
+      row.row_name row.row_fields in
+  if not row.row_closed || nm != row.row_name then begin
+    (* this unification cannot fail *)
+    Ctype.unify env row.row_more
+      (Btype.newgenty
+         (Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
+                    row_closed = true; row_name = nm}))
+  end
+
+let row_of_pat pat =
+  match Ctype.expand_head pat.pat_env pat.pat_type with
+    {desc = Tvariant row} -> Btype.row_repr row
+  | _ -> assert false
+
+(*
+  Check whether the first column of env makes up a complete signature or
+  not.
+*)
+
+let full_match closing env =  match env with
+| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
+    if c.cstr_consts < 0 then false (* extensions *)
+    else List.length env = c.cstr_consts + c.cstr_nonconsts
+| ({pat_desc = Tpat_variant _} as p,_) :: _ ->
+    let fields =
+      List.map
+        (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
+          | _ -> assert false)
+        env
+    in
+    let row = row_of_pat p in
+    if closing && not (Btype.row_fixed row) then
+      (* closing=true, we are considering the variant as closed *)
+      List.for_all
+        (fun (tag,f) ->
+          match Btype.row_field_repr f with
+            Rabsent | Reither(_, _, false, _) -> true
+          | Reither (_, _, true, _)
+              (* m=true, do not discard matched tags, rather warn *)
+          | Rpresent _ -> List.mem tag fields)
+        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
+| ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
+    List.length env = 256
+| ({pat_desc = Tpat_constant(_)},_) :: _ -> false
+| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
+| ({pat_desc = Tpat_record(_)},_) :: _ -> true
+| ({pat_desc = Tpat_array(_)},_) :: _ -> false
+| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
+| ({pat_desc = (Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _)},_) :: _
+| []
+  ->
+    assert false
+
+(* Written as a non-fragile matching, PR7451 originated from a fragile matching below. *)
+let should_extend ext env = match ext with
+| None -> false
+| Some ext -> begin match env with
+  | [] -> assert false
+  | (p,_)::_ ->
+      begin match p.pat_desc with
+      | Tpat_construct
+          (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) ->
+            let path = get_type_path p.pat_type p.pat_env in
+            Path.same path ext
+      | Tpat_construct
+          (_, {cstr_tag=(Cstr_extension _)},_) -> false
+      | Tpat_constant _|Tpat_tuple _|Tpat_variant _
+      | Tpat_record  _|Tpat_array _ | Tpat_lazy _
+        -> false
+      | Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _
+        -> assert false
+      end
+end
+
+(* complement constructor tags *)
+let complete_tags nconsts nconstrs tags =
+  let seen_const = Array.make nconsts false
+  and seen_constr = Array.make nconstrs false in
+  List.iter
+    (function
+      | Cstr_constant i -> seen_const.(i) <- true
+      | Cstr_block i -> seen_constr.(i) <- true
+      | _  -> assert false)
+    tags ;
+  let r = ref [] in
+  for i = 0 to nconsts-1 do
+    if not seen_const.(i) then
+      r := Cstr_constant i :: !r
+  done ;
+  for i = 0 to nconstrs-1 do
+    if not seen_constr.(i) then
+      r := Cstr_block i :: !r
+  done ;
+  !r
+
+(* build a pattern from a constructor list *)
+let pat_of_constr ex_pat cstr =
+  {ex_pat with pat_desc =
+   Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
+                   cstr, omegas cstr.cstr_arity)}
+
+let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
+
+let rec orify_many = function
+| [] -> assert false
+| [x] -> x
+| x :: xs -> orify x (orify_many xs)
+
+let pat_of_constrs ex_pat cstrs =
+  if cstrs = [] then raise Empty else
+  orify_many (List.map (pat_of_constr ex_pat) cstrs)
+
+let pats_of_type ?(always=false) env ty =
+  let ty' = Ctype.expand_head env ty in
+  match ty'.desc with
+  | Tconstr (path, _, _) ->
+      begin try match (Env.find_type path env).type_kind with
+      | Type_variant cl when always || List.length cl = 1 ||
+        List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
+          let cstrs = fst (Env.find_type_descrs path env) in
+          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
+      | Type_record _ ->
+          let labels = snd (Env.find_type_descrs path env) in
+          let fields =
+            List.map (fun ld ->
+              mknoloc (Longident.Lident "?pat_of_label?"), ld, omega)
+              labels
+          in
+          [make_pat (Tpat_record (fields, Closed)) ty env]
+      | _ -> [omega]
+      with Not_found -> [omega]
+      end
+  | Ttuple tl ->
+      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
+  | _ -> [omega]
+
+let rec get_variant_constructors env ty =
+  match (Ctype.repr ty).desc with
+  | Tconstr (path,_,_) -> begin
+      try match Env.find_type path env with
+      | {type_kind=Type_variant _} ->
+          fst (Env.find_type_descrs path env)
+      | {type_manifest = Some _} ->
+          get_variant_constructors env
+            (Ctype.expand_head_once env (clean_copy ty))
+      | _ -> fatal_error "Parmatch.get_variant_constructors"
+      with Not_found ->
+        fatal_error "Parmatch.get_variant_constructors"
+    end
+  | _ -> fatal_error "Parmatch.get_variant_constructors"
+
+(* Sends back a pattern that complements constructor tags all_tag *)
+let complete_constrs p all_tags =
+  let c =
+    match p.pat_desc with Tpat_construct (_, c, _) -> c | _ -> assert false in
+  let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+  let constrs = get_variant_constructors p.pat_env c.cstr_res in
+  let others =
+    List.filter (fun cnstr -> List.mem cnstr.cstr_tag not_tags) constrs in
+  let const, nonconst =
+    List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
+  const @ nonconst
+
+let build_other_constrs env p =
+  match p.pat_desc with
+    Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) ->
+      let get_tag = function
+        | {pat_desc = Tpat_construct (_,c,_)} -> c.cstr_tag
+        | _ -> fatal_error "Parmatch.get_tag" in
+      let all_tags =  List.map (fun (p,_) -> get_tag p) env in
+      pat_of_constrs p (complete_constrs p all_tags)
+  | _ -> extra_pat
+
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+  let rec try_const i =
+    if List.mem i all
+    then try_const (next i)
+    else make_pat (make i) p.pat_type p.pat_env
+  in try_const first
+
+(*
+  Builds a pattern that is incompatible with all patterns in
+  in the first column of env
+*)
+
+let build_other ext env = match env with
+| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
+        (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+        make_pat (Tpat_var (Ident.create "*extension*",
+                            {lid with txt="*extension*"})) Ctype.none Env.empty
+| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
+    begin match ext with
+    | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
+        extra_pat
+    | _ ->
+        build_other_constrs env p
+    end
+| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ ->
+    let tags =
+      List.map
+        (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
+                | _ -> assert false)
+        env
+    in
+    let row = row_of_pat p in
+    let make_other_pat tag const =
+      let arg = if const then None else Some omega in
+      make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in
+    begin match
+      List.fold_left
+        (fun others (tag,f) ->
+          if List.mem tag tags then others else
+          match Btype.row_field_repr f with
+            Rabsent (* | Reither _ *) -> others
+          (* This one is called after erasing pattern info *)
+          | Reither (c, _, _, _) -> make_other_pat tag c :: others
+          | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+        [] row.row_fields
+    with
+      [] ->
+        make_other_pat "AnyExtraTag" true
+    | pat::other_pats ->
+        List.fold_left
+          (fun p_res pat ->
+            make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env)
+          pat other_pats
+    end
+| ({pat_desc = Tpat_constant(Const_char _)} as p,_) :: _ ->
+    let all_chars =
+      List.map
+        (fun (p,_) -> match p.pat_desc with
+        | Tpat_constant (Const_char c) -> c
+        | _ -> assert false)
+        env in
+
+    let rec find_other i imax =
+      if i > imax then raise Not_found
+      else
+        let ci = Char.chr i in
+        if List.mem ci all_chars then
+          find_other (i+1) imax
+        else
+          make_pat (Tpat_constant (Const_char ci)) p.pat_type p.pat_env in
+    let rec try_chars = function
+      | [] -> omega
+      | (c1,c2) :: rest ->
+          try
+            find_other (Char.code c1) (Char.code c2)
+          with
+          | Not_found -> try_chars rest in
+
+    try_chars
+      [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
+        ' ', '~' ; Char.chr 0 , Char.chr 255]
+
+| ({pat_desc=(Tpat_constant (Const_int _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_int i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_int i))
+      0 succ p env
+| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_int32 i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_int32 i))
+      0l Int32.succ p env
+| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_int64 i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_int64 i))
+      0L Int64.succ p env
+| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_nativeint i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_nativeint i))
+      0n Nativeint.succ p env
+| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_string (s, _)) -> String.length s
+              | _ -> assert false)
+      (function i -> Tpat_constant(Const_string(String.make i '*', None)))
+      0 succ p env
+| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_float f) -> float_of_string f
+              | _ -> assert false)
+      (function f -> Tpat_constant(Const_float (string_of_float f)))
+      0.0 (fun f -> f +. 1.0) p env
+
+| ({pat_desc = Tpat_array _} as p,_)::_ ->
+    let all_lengths =
+      List.map
+        (fun (p,_) -> match p.pat_desc with
+        | Tpat_array args -> List.length args
+        | _ -> assert false)
+        env in
+    let rec try_arrays l =
+      if List.mem l all_lengths then try_arrays (l+1)
+      else
+        make_pat
+          (Tpat_array (omegas l))
+          p.pat_type p.pat_env in
+    try_arrays 0
+| [] -> omega
+| _ -> omega
+
+(*
+  Core function :
+  Is the last row of pattern matrix pss + qs satisfiable ?
+  That is :
+    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)
+*)
+
+let rec has_instance p = match p.pat_desc with
+  | Tpat_variant (l,_,r) when is_absent l r -> false
+  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
+  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
+  | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps ->
+      has_instances ps
+  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
+  | Tpat_lazy p
+    -> has_instance p
+
+
+and has_instances = function
+  | [] -> true
+  | q::rem -> has_instance q && has_instances rem
+
+let rec satisfiable pss qs = match pss with
+| [] -> has_instances qs
+| _  ->
+    match qs with
+    | [] -> false
+    | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+        satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+    | {pat_desc = Tpat_alias(q,_,_)}::qs ->
+          satisfiable pss (q::qs)
+    | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+        let q0 = discr_pat omega pss in
+        begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+        | [] -> satisfiable (filter_extra pss) 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 ->
+        let q0 = discr_pat q pss in
+        satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
+
+(* Also return the remaining cases, to enable GADT handling *)
+let rec satisfiables pss qs = match pss with
+| [] -> if has_instances qs then [qs] else []
+| _  ->
+    match qs with
+    | [] -> []
+    | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+        satisfiables pss (q1::qs) @ satisfiables pss (q2::qs)
+    | {pat_desc = Tpat_alias(q,_,_)}::qs ->
+        satisfiables pss (q::qs)
+    | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+        let q0 = discr_pat omega pss in
+        let wild p =
+          List.map (fun qs -> p::qs) (satisfiables (filter_extra pss) qs) in
+        begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+        | [] ->
+            wild omega
+        | (p,_)::_ as constrs  ->
+            let for_constrs () =
+              List.flatten (
+              List.map
+                (fun (p,pss) ->
+                  if is_absent_pat p then [] else
+                  List.map (set_args p)
+                    (satisfiables pss (simple_match_args p omega @ qs)))
+                constrs )
+            in
+            if full_match false constrs then for_constrs () else
+            match p.pat_desc with
+              Tpat_construct _ ->
+                (* activate this code for checking non-gadt constructors *)
+                wild (build_other_constrs constrs p) @ for_constrs ()
+            | _ ->
+                wild omega
+        end
+    | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
+    | q::qs ->
+        let q0 = discr_pat q pss in
+        List.map (set_args q0)
+          (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs))
+
+(*
+  Now another satisfiable function that additionally
+  supplies an example of a matching value.
+
+  This function should be called for exhaustiveness check only.
+*)
+
+type 'a result =
+  | Rnone           (* No matching value *)
+  | Rsome of 'a     (* This matching value *)
+
+(*
+let rec try_many  f = function
+  | [] -> Rnone
+  | (p,pss)::rest ->
+      match f (p,pss) with
+      | Rnone -> try_many  f rest
+      | r -> r
+*)
+
+let rappend r1 r2 =
+  match r1, r2 with
+  | Rnone, _ -> r2
+  | _, Rnone -> r1
+  | Rsome l1, Rsome l2 -> Rsome (l1 @ l2)
+
+let rec try_many_gadt  f = function
+  | [] -> Rnone
+  | (p,pss)::rest ->
+      rappend (f (p, pss)) (try_many_gadt f rest)
+
+(*
+let rec exhaust ext pss n = match pss with
+| []    ->  Rsome (omegas n)
+| []::_ ->  Rnone
+| pss   ->
+    let q0 = discr_pat omega pss in
+    begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+    | [] ->
+        begin match exhaust ext (filter_extra pss) (n-1) with
+        | Rsome r -> Rsome (q0::r)
+        | r -> r
+      end
+    | constrs ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Rnone
+          else
+            match
+              exhaust
+                ext pss (List.length (simple_match_args p omega) + n - 1)
+            with
+            | Rsome r -> Rsome (set_args p r)
+            | r       -> r in
+        if
+          full_match true false constrs && not (should_extend ext constrs)
+        then
+          try_many try_non_omega constrs
+        else
+          (*
+             D = filter_extra pss is the default matrix
+             as it is included in pss, one can avoid
+             recursive calls on specialized matrices,
+             Essentially :
+             * D exhaustive => pss exhaustive
+             * D non-exhaustive => we have a non-filtered value
+          *)
+          let r =  exhaust ext (filter_extra pss) (n-1) in
+          match r with
+          | Rnone -> Rnone
+          | Rsome r ->
+              try
+                Rsome (build_other ext constrs::r)
+              with
+      (* cannot occur, since constructors don't make a full signature *)
+              | Empty -> fatal_error "Parmatch.exhaust"
+    end
+
+let combinations f lst lst' =
+  let rec iter2 x =
+    function
+        [] -> []
+      | y :: ys ->
+          f x y :: iter2 x ys
+  in
+  let rec iter =
+    function
+        [] -> []
+      | x :: xs -> iter2 x lst' @ iter xs
+  in
+  iter lst
+*)
+(*
+let print_pat pat =
+  let rec string_of_pat pat =
+    match pat.pat_desc with
+        Tpat_var _ -> "v"
+      | Tpat_any -> "_"
+      | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?"  (string_of_pat p)
+      | Tpat_constant n -> "0"
+      | Tpat_construct (_, lid, _) ->
+        Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt))
+      | Tpat_lazy p ->
+        Printf.sprintf "(lazy %s)" (string_of_pat p)
+      | Tpat_or (p1,p2,_) ->
+        Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2)
+      | Tpat_tuple list ->
+        Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list))
+      | Tpat_variant (_, _, _) -> "variant"
+      | Tpat_record (_, _) -> "record"
+      | Tpat_array _ -> "array"
+  in
+  Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat)
+*)
+
+(* strictly more powerful than exhaust; however, exhaust
+   was kept for backwards compatibility *)
+let rec exhaust_gadt (ext:Path.t option) pss n = match pss with
+| []    ->  Rsome [omegas n]
+| []::_ ->  Rnone
+| pss   ->
+    let q0 = discr_pat omega pss in
+    begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+    | [] ->
+        begin match exhaust_gadt ext (filter_extra pss) (n-1) with
+        | Rsome r -> Rsome (List.map (fun row -> q0::row) r)
+        | r -> r
+      end
+    | constrs ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Rnone
+          else
+            match
+              exhaust_gadt
+                ext pss (List.length (simple_match_args p omega) + n - 1)
+            with
+            | Rsome r -> Rsome (List.map (fun row ->  (set_args p row)) r)
+            | r       -> r in
+        let before = try_many_gadt try_non_omega constrs in
+        if
+          full_match false constrs && not (should_extend ext constrs)
+        then
+          before
+        else
+          (*
+            D = filter_extra pss is the default matrix
+            as it is included in pss, one can avoid
+            recursive calls on specialized matrices,
+            Essentially :
+           * D exhaustive => pss exhaustive
+           * D non-exhaustive => we have a non-filtered value
+           *)
+          let r =  exhaust_gadt ext (filter_extra pss) (n-1) in
+          match r with
+          | Rnone -> before
+          | Rsome r ->
+              try
+                let p = build_other ext constrs in
+                let dug = List.map (fun tail -> p :: tail) r in
+                match before with
+                | Rnone -> Rsome dug
+                | Rsome x -> Rsome (x @ dug)
+              with
+      (* cannot occur, since constructors don't make a full signature *)
+              | Empty -> fatal_error "Parmatch.exhaust"
+    end
+
+let exhaust_gadt ext pss n =
+  let ret = exhaust_gadt ext pss n in
+  match ret with
+    Rnone -> Rnone
+  | Rsome lst ->
+      (* The following line is needed to compile stdlib/printf.ml *)
+      if lst = [] then Rsome (omegas n) else
+      let singletons =
+        List.map
+          (function
+              [x] -> x
+            | _ -> assert false)
+          lst
+      in
+      Rsome [orify_many singletons]
+
+(*
+   Another exhaustiveness check, enforcing variant typing.
+   Note that it does not check exact exhaustiveness, but whether a
+   matching could be made exhaustive by closing all variant types.
+   When this is true of all other columns, the current column is left
+   open (even if it means that the whole matching is not exhaustive as
+   a result).
+   When this is false for the matrix minus the current column, and the
+   current column is composed of variant tags, we close the variant
+   (even if it doesn't help in making the matching exhaustive).
+*)
+
+let rec pressure_variants tdefs = function
+  | []    -> false
+  | []::_ -> true
+  | pss   ->
+      let q0 = discr_pat omega pss in
+      begin match filter_all q0 pss with
+        [] -> pressure_variants tdefs (filter_extra pss)
+      | constrs ->
+          let rec try_non_omega = function
+              (_p,pss) :: rem ->
+                let ok = pressure_variants tdefs pss in
+                try_non_omega rem && ok
+            | [] -> true
+          in
+          if full_match (tdefs=None) constrs then
+            try_non_omega constrs
+          else if tdefs = None then
+            pressure_variants None (filter_extra pss)
+          else
+            let full = full_match true constrs in
+            let ok =
+              if full then try_non_omega constrs
+              else try_non_omega (filter_all q0 (mark_partial pss))
+            in
+            begin match constrs, tdefs with
+              ({pat_desc=Tpat_variant _} as p,_):: _, Some env ->
+                let row = row_of_pat p in
+                if Btype.row_fixed row
+                || pressure_variants None (filter_extra pss) then ()
+                else close_variant env row
+            | _ -> ()
+            end;
+            ok
+      end
+
+
+(* Yet another satisfiable fonction *)
+
+(*
+   This time every_satisfiable pss qs checks the
+   utility of every expansion of qs.
+   Expansion means expansion of or-patterns inside qs
+*)
+
+type answer =
+  | Used                                (* Useful pattern *)
+  | Unused                              (* Useless pattern *)
+  | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)
+
+
+
+(* this row type enable column processing inside the matrix
+    - left  ->  elements not to be processed,
+    - right ->  elements to be processed
+*)
+type 'a row = {no_ors : 'a list ; ors : 'a list ; active : 'a list}
+
+
+(*
+let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
+  pretty_line ors ; prerr_string " *" ;
+  pretty_line no_ors ; prerr_string " *" ;
+  pretty_line active
+
+let pretty_rows rs =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun r ->
+      pretty_row r ;
+      prerr_endline "")
+    rs ;
+  prerr_endline "end matrix"
+*)
+
+(* Initial build *)
+let make_row ps = {ors=[] ; no_ors=[]; active=ps}
+
+let make_rows pss = List.map make_row pss
+
+
+(* Useful to detect and expand  or pats inside as pats *)
+let rec unalias p = match p.pat_desc with
+| Tpat_alias (p,_,_) -> unalias p
+| _ -> p
+
+
+let is_var p = match (unalias p).pat_desc with
+| Tpat_any|Tpat_var _ -> true
+| _                   -> false
+
+let is_var_column rs =
+  List.for_all
+    (fun r -> match r.active with
+    | p::_ -> is_var p
+    | []   -> assert false)
+    rs
+
+(* Standard or-args for left-to-right matching *)
+let rec or_args p = match p.pat_desc with
+| Tpat_or (p1,p2,_) -> p1,p2
+| Tpat_alias (p,_,_)  -> or_args p
+| _                 -> assert false
+
+(* Just remove current column *)
+let remove r = match r.active with
+| _::rem -> {r with active=rem}
+| []     -> assert false
+
+let remove_column rs = List.map remove rs
+
+(* Current column has been processed *)
+let push_no_or r = match r.active with
+| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
+| [] -> assert false
+
+let push_or r = match r.active with
+| p::rem -> { r with ors = p::r.ors ; active=rem}
+| [] -> assert false
+
+let push_or_column rs = List.map push_or rs
+and push_no_or_column rs = List.map push_no_or rs
+
+(* Those are adaptations of the previous homonymous functions that
+   work on the current column, instead of the first column
+*)
+
+let discr_pat q rs =
+  discr_pat q (List.map (fun r -> r.active) rs)
+
+let filter_one q rs =
+  let rec filter_rec rs = match rs with
+  | [] -> []
+  | r::rem ->
+      match r.active with
+      | [] -> assert false
+      | {pat_desc = Tpat_alias(p,_,_)}::ps ->
+          filter_rec ({r with active = p::ps}::rem)
+      | {pat_desc = Tpat_or(p1,p2,_)}::ps ->
+          filter_rec
+            ({r with active = p1::ps}::
+             {r with active = p2::ps}::
+             rem)
+      | p::ps ->
+          if simple_match q p then
+            {r with active=simple_match_args q p @ ps} :: filter_rec rem
+          else
+            filter_rec rem in
+  filter_rec rs
+
+
+(* Back to normal matrices *)
+let make_vector r = r.no_ors
+
+let make_matrix rs = List.map make_vector rs
+
+
+(* Standard union on answers *)
+let union_res r1 r2 = match r1, r2 with
+| (Unused,_)
+| (_, Unused) -> Unused
+| Used,_    -> r2
+| _, Used   -> r1
+| Upartial u1, Upartial u2 -> Upartial (u1@u2)
+
+(* propose or pats for expansion *)
+let extract_elements qs =
+  let rec do_rec seen = function
+    | [] -> []
+    | q::rem ->
+        {no_ors= List.rev_append seen rem @ qs.no_ors ;
+        ors=[] ;
+        active = [q]}::
+        do_rec (q::seen) rem in
+  do_rec [] qs.ors
+
+(* idem for matrices *)
+let transpose rs = match rs with
+| [] -> assert false
+| r::rem ->
+    let i = List.map (fun x -> [x]) r in
+    List.fold_left
+      (List.map2 (fun r x -> x::r))
+      i rem
+
+let extract_columns pss qs = match pss with
+| [] -> List.map (fun _ -> []) qs.ors
+| _  ->
+  let rows = List.map extract_elements pss in
+  transpose rows
+
+(* Core function
+   The idea is to first look for or patterns (recursive case), then
+   check or-patterns argument usefulness (terminal case)
+*)
+
+let rec every_satisfiables pss qs = match qs.active with
+| []     ->
+    (* qs is now partitionned,  check usefulness *)
+    begin match qs.ors with
+    | [] -> (* no or-patterns *)
+        if satisfiable (make_matrix pss) (make_vector qs) then
+          Used
+        else
+          Unused
+    | _  -> (* n or-patterns -> 2n expansions *)
+        List.fold_right2
+          (fun pss qs r -> match r with
+          | Unused -> Unused
+          | _ ->
+              match qs.active with
+              | [q] ->
+                  let q1,q2 = or_args q in
+                  let r_loc = every_both pss qs q1 q2 in
+                  union_res r r_loc
+              | _   -> assert false)
+          (extract_columns pss qs) (extract_elements qs)
+          Used
+    end
+| q::rem ->
+    let uq = unalias q in
+    begin match uq.pat_desc with
+    | Tpat_any | Tpat_var _ ->
+        if is_var_column pss then
+(* forget about ``all-variable''  columns now *)
+          every_satisfiables (remove_column pss) (remove qs)
+        else
+(* otherwise this is direct food for satisfiable *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+    | Tpat_or (q1,q2,_) ->
+        if
+          q1.pat_loc.Location.loc_ghost &&
+          q2.pat_loc.Location.loc_ghost
+        then
+(* syntactically generated or-pats should not be expanded *)
+          every_satisfiables (push_no_or_column pss) (push_no_or qs)
+        else
+(* this is a real or-pattern *)
+          every_satisfiables (push_or_column pss) (push_or qs)
+    | Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
+        Unused
+    | _ ->
+(* standard case, filter matrix *)
+        let q0 = discr_pat q pss in
+        every_satisfiables
+          (filter_one q0 pss)
+          {qs with active=simple_match_args q0 q @ rem}
+    end
+
+(*
+  This function ``every_both'' performs the usefulness check
+  of or-pat q1|q2.
+  The trick is to call every_satisfied twice with
+  current active columns restricted to q1 and q2,
+  That way,
+  - others orpats in qs.ors will not get expanded.
+  - all matching work performed on qs.no_ors is not performed again.
+  *)
+and every_both pss qs q1 q2 =
+  let qs1 = {qs with active=[q1]}
+  and qs2 =  {qs with active=[q2]} in
+  let r1 = every_satisfiables pss qs1
+  and r2 =  every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
+  match r1 with
+  | Unused ->
+      begin match r2 with
+      | Unused -> Unused
+      | Used   -> Upartial [q1]
+      | Upartial u2 -> Upartial (q1::u2)
+      end
+  | Used ->
+      begin match r2 with
+      | Unused -> Upartial [q2]
+      | _      -> r2
+      end
+  | Upartial u1 ->
+      begin match r2 with
+      | Unused -> Upartial (u1@[q2])
+      | Used   -> r1
+      | Upartial u2 -> Upartial (u1 @ u2)
+      end
+
+
+
+
+(* le_pat p q  means, forall V,  V matches q implies V matches p *)
+let rec le_pat p q =
+  match (p.pat_desc, q.pat_desc) with
+  | (Tpat_var _|Tpat_any),_ -> true
+  | Tpat_alias(p,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
+  | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) ->
+      c1.cstr_tag = c2.cstr_tag && le_pats ps qs
+  | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
+      (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_lazy p, Tpat_lazy q -> le_pat p q
+  | Tpat_record (l1,_), Tpat_record (l2,_) ->
+      let ps,qs = records_args l1 l2 in
+      le_pats ps qs
+  | 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])
+
+and le_pats ps qs =
+  match ps,qs with
+    p::ps, q::qs -> le_pat p q && le_pats ps qs
+  | _, _         -> true
+
+let get_mins le ps =
+  let rec select_rec r = function
+      [] -> r
+    | p::ps ->
+        if List.exists (fun p0 -> le p0 p) ps
+        then select_rec r 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 are not compatible
+*)
+
+let rec lub p q = match p.pat_desc,q.pat_desc with
+| Tpat_alias (p,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_)      -> lub p q
+| (Tpat_any|Tpat_var _),_ -> q
+| _,(Tpat_any|Tpat_var _) -> p
+| Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
+| _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
+| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
+| Tpat_tuple ps, Tpat_tuple qs ->
+    let rs = lubs ps qs in
+    make_pat (Tpat_tuple rs) p.pat_type p.pat_env
+| Tpat_lazy p, Tpat_lazy q ->
+    let r = lub p q in
+    make_pat (Tpat_lazy r) p.pat_type p.pat_env
+| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
+      when  c1.cstr_tag = c2.cstr_tag  ->
+        let rs = lubs ps1 ps2 in
+        make_pat (Tpat_construct (lid, c1,rs))
+          p.pat_type p.pat_env
+| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
+          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 -> p
+| Tpat_record (l1,closed),Tpat_record (l2,_) ->
+    let rs = record_lubs l1 l2 in
+    make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env
+| Tpat_array ps, Tpat_array qs
+      when List.length ps = List.length qs ->
+        let rs = lubs ps qs in
+        make_pat (Tpat_array rs) p.pat_type p.pat_env
+| _,_  ->
+    raise Empty
+
+and orlub p1 p2 q =
+  try
+    let r1 = lub p1 q in
+    try
+      {q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
+  with
+  | Empty -> r1
+with
+| Empty -> lub p2 q
+
+and record_lubs l1 l2 =
+  let rec lub_rec l1 l2 = match l1,l2 with
+  | [],_ -> l2
+  | _,[] -> l1
+  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
+      if lbl1.lbl_pos < lbl2.lbl_pos then
+        (lid1, lbl1,p1)::lub_rec rem1 l2
+      else if lbl2.lbl_pos < lbl1.lbl_pos  then
+        (lid2, lbl2,p2)::lub_rec l1 rem2
+      else
+        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+  lub_rec l1 l2
+
+and lubs ps qs = match ps,qs with
+| p::ps, q::qs -> lub p q :: lubs ps qs
+| _,_ -> []
+
+
+(******************************)
+(* Exported variant closing   *)
+(******************************)
+
+(* Apply pressure to variants *)
+
+let pressure_variants tdefs patl =
+  let pss = List.map (fun p -> [p;omega]) patl in
+  ignore (pressure_variants (Some tdefs) pss)
+
+(*****************************)
+(* Utilities for diagnostics *)
+(*****************************)
+
+(*
+  Build up a working pattern matrix by forgetting
+  about guarded patterns
+*)
+
+let rec initial_matrix = function
+    [] -> []
+  | {c_guard=Some _} :: rem -> initial_matrix rem
+  | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
+
+(******************************************)
+(* Look for a row that matches some value *)
+(******************************************)
+
+(*
+  Useful for seeing if the example of
+  non-matched value can indeed be matched
+  (by a guarded clause)
+*)
+
+
+
+exception NoGuard
+
+let rec initial_all no_guard = function
+  | [] ->
+      if no_guard then
+        raise NoGuard
+      else
+        []
+  | {c_lhs=pat; c_guard; _} :: rem ->
+      ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem
+
+
+let rec do_filter_var = function
+  | (_::ps,loc)::rem -> (ps,loc)::do_filter_var rem
+  | _ -> []
+
+let do_filter_one q pss =
+  let rec filter_rec = function
+    | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss ->
+        filter_rec ((p::ps,loc)::pss)
+    | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss ->
+        filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss)
+    | (p::ps,loc)::pss ->
+        if simple_match q p
+        then (simple_match_args q p @ ps, loc) :: filter_rec pss
+        else filter_rec pss
+    | _ -> [] in
+  filter_rec pss
+
+let rec do_match pss qs = match qs with
+| [] ->
+    begin match pss  with
+    | ([],loc)::_ -> Some loc
+    | _ -> None
+    end
+| q::qs -> match q with
+  | {pat_desc = Tpat_or (q1,q2,_)} ->
+      begin match do_match pss (q1::qs) with
+      | None -> do_match pss (q2::qs)
+      | r -> r
+      end
+  | {pat_desc = Tpat_any} ->
+      do_match (do_filter_var pss) qs
+  | _ ->
+      let q0 = normalize_pat q in
+      do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs)
+
+
+let check_partial_all v casel =
+  try
+    let pss = initial_all true casel in
+    do_match pss [v]
+  with
+  | NoGuard -> None
+
+(************************)
+(* Exhaustiveness check *)
+(************************)
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = Ast_helper.Pat.mk desc
+
+  let name_counter = ref 0
+  let fresh name =
+    let current = !name_counter in
+    name_counter := !name_counter + 1;
+    "#$" ^ name ^ string_of_int current
+
+  let conv typed =
+    let constrs = Hashtbl.create 7 in
+    let labels = Hashtbl.create 7 in
+    let rec loop pat =
+      match pat.pat_desc with
+        Tpat_or (pa,pb,_) ->
+          mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
+      | Tpat_any
+      | Tpat_var _ ->
+          mkpat Ppat_any
+      | Tpat_constant c ->
+          mkpat (Ppat_constant (Untypeast.constant c))
+      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_tuple lst ->
+          mkpat (Ppat_tuple (List.map loop lst))
+      | Tpat_construct (cstr_lid, cstr, lst) ->
+          let id = fresh cstr.cstr_name in
+          let lid = { cstr_lid with txt = Longident.Lident id } in
+          Hashtbl.add constrs id cstr;
+          let arg =
+            match List.map loop lst with
+            | []  -> None
+            | [p] -> Some p
+            | lst -> Some (mkpat (Ppat_tuple lst))
+          in
+          mkpat (Ppat_construct(lid, arg))
+      | Tpat_variant(label,p_opt,_row_desc) ->
+          let arg = Misc.may_map loop p_opt in
+          mkpat (Ppat_variant(label, arg))
+      | Tpat_record (subpatterns, _closed_flag) ->
+          let fields =
+            List.map
+              (fun (_, lbl, p) ->
+                let id = fresh lbl.lbl_name in
+                Hashtbl.add labels id lbl;
+                (mknoloc (Longident.Lident id), loop p))
+              subpatterns
+          in
+          mkpat (Ppat_record (fields, Open))
+      | Tpat_array lst ->
+          mkpat (Ppat_array (List.map loop lst))
+      | Tpat_lazy p ->
+          mkpat (Ppat_lazy (loop p))
+    in
+    let ps = loop typed in
+    (ps, constrs, labels)
+end
+
+
+(* Whether the counter-example contains an extension pattern *)
+let contains_extension pat =
+  let r = ref false in
+  let rec loop = function
+      {pat_desc=Tpat_var (_, {txt="*extension*"})} ->
+        r := true
+    | p -> Typedtree.iter_pattern_desc loop p.pat_desc
+  in loop pat; !r
+
+(* Build an untyped or-pattern from its expected type *)
+let ppat_of_type env ty =
+  match pats_of_type env ty with
+    [{pat_desc = Tpat_any}] ->
+      (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0)
+  | pats ->
+      Conv.conv (orify_many pats)
+
+let do_check_partial ?pred exhaust loc casel pss = match pss with
+| [] ->
+        (*
+          This can occur
+          - For empty matches generated by ocamlp4 (no warning)
+          - when all patterns have guards (then, casel <> [])
+          (specific warning)
+          Then match MUST be considered non-exhaustive,
+          otherwise compilation of PM is broken.
+          *)
+    begin match casel with
+    | [] -> ()
+    | _  -> Location.prerr_warning loc Warnings.All_clauses_guarded
+    end ;
+    Partial
+| ps::_  ->
+    begin match exhaust None pss (List.length ps) with
+    | Rnone -> Total
+    | Rsome [u] ->
+        let v =
+          match pred with
+          | Some pred ->
+              let (pattern,constrs,labels) = Conv.conv u in
+              let u' = pred constrs labels pattern in
+              (* pretty_pat u;
+              begin match u' with
+                None -> prerr_endline ": impossible"
+              | Some _ -> prerr_endline ": possible"
+              end; *)
+              u'
+          | None -> Some u
+        in
+        begin match v with
+          None -> Total
+        | Some v ->
+            let errmsg =
+              try
+                let buf = Buffer.create 16 in
+                let fmt = formatter_of_buffer buf in
+                top_pretty fmt v;
+                begin match check_partial_all v casel with
+                | None -> ()
+                | Some _ ->
+                    (* This is 'Some loc', where loc is the location of
+                       a possibly matching clause.
+                       Forget about loc, because printing two locations
+                       is a pain in the top-level *)
+                    Buffer.add_string buf
+                      "\n(However, some guarded clause may match this value.)"
+                end;
+                if contains_extension v then
+                  Buffer.add_string buf
+                    "\nMatching over values of extensible variant types \
+                       (the *extension* above)\n\
+                    must include a wild card pattern in order to be exhaustive."
+                ;
+                Buffer.contents buf
+              with _ ->
+                ""
+            in
+            Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
+            Partial
+        end
+    | _ ->
+        fatal_error "Parmatch.check_partial"
+    end
+
+(*
+let do_check_partial_normal loc casel pss =
+  do_check_partial exhaust loc casel pss
+ *)
+
+let do_check_partial_gadt pred loc casel pss =
+  do_check_partial ~pred exhaust_gadt loc casel pss
+
+
+
+(*****************)
+(* Fragile check *)
+(*****************)
+
+(* Collect all data types in a pattern *)
+
+let rec add_path path = function
+  | [] -> [path]
+  | x::rem as paths ->
+      if Path.same path x then paths
+      else x::add_path path rem
+
+let extendable_path path =
+  not
+    (Path.same path Predef.path_bool ||
+    Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
+    Path.same path Predef.path_option)
+
+let rec collect_paths_from_pat r p = match p.pat_desc with
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
+  ->
+    let path =  get_type_path p.pat_type p.pat_env in
+    List.fold_left
+      collect_paths_from_pat
+      (if extendable_path path then add_path path r else r)
+      ps
+| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
+| Tpat_tuple ps | Tpat_array ps
+| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)->
+    List.fold_left collect_paths_from_pat r ps
+| Tpat_record (lps,_) ->
+    List.fold_left
+      (fun r (_, _, p) -> collect_paths_from_pat r p)
+      r lps
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_or (p1,p2,_) ->
+    collect_paths_from_pat (collect_paths_from_pat r p1) p2
+| Tpat_lazy p
+    ->
+    collect_paths_from_pat r p
+
+
+(*
+  Actual fragile check
+   1. Collect data types in the patterns of the match.
+   2. One exhautivity check per datatype, considering that
+      the type is extended.
+*)
+
+let do_check_fragile_param exhaust loc casel pss =
+  let exts =
+    List.fold_left
+      (fun r c -> collect_paths_from_pat r c.c_lhs)
+      [] casel in
+  match exts with
+  | [] -> ()
+  | _ -> match pss with
+    | [] -> ()
+    | ps::_ ->
+        List.iter
+          (fun ext ->
+            match exhaust (Some ext) pss (List.length ps) with
+            | Rnone ->
+                Location.prerr_warning
+                  loc
+                  (Warnings.Fragile_match (Path.name ext))
+            | Rsome _ -> ())
+          exts
+
+(*let do_check_fragile_normal = do_check_fragile_param exhaust*)
+let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
+
+(********************************)
+(* Exported unused clause check *)
+(********************************)
+
+let check_unused pred casel =
+  if Warnings.is_active Warnings.Unused_match
+  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
+    let rec do_rec pref = function
+      | [] -> ()
+      | {c_lhs=q; c_guard; c_rhs} :: rem ->
+          let qs = [q] in
+            begin try
+              let pss =
+                  get_mins le_pats (List.filter (compats qs) pref) in
+              (* First look for redundant or partially redundant patterns *)
+              let r = every_satisfiables (make_rows pss) (make_row qs) in
+              let refute = (c_rhs.exp_desc = Texp_unreachable) in
+              (* Do not warn for unused [pat -> .] *)
+              if r = Unused && refute then () else
+              let r =
+                (* Do not refine if there are no other lines *)
+                let skip =
+                  r = Unused || (not refute && pref = []) ||
+                  not(refute || Warnings.is_active Warnings.Unreachable_case) in
+                if skip then r else
+                (* Then look for empty patterns *)
+                let sfs = satisfiables pss qs in
+                if sfs = [] then Unused else
+                let sfs =
+                  List.map (function [u] -> u | _ -> assert false) sfs in
+                let u = orify_many sfs in
+                (*Format.eprintf "%a@." pretty_val u;*)
+                let (pattern,constrs,labels) = Conv.conv u in
+                let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in
+                match pred refute constrs labels pattern with
+                  None when not refute ->
+                    Location.prerr_warning q.pat_loc Warnings.Unreachable_case;
+                    Used
+                | _ -> r
+              in
+              match r with
+              | Unused ->
+                  Location.prerr_warning
+                    q.pat_loc Warnings.Unused_match
+              | Upartial ps ->
+                  List.iter
+                    (fun p ->
+                      Location.prerr_warning
+                        p.pat_loc Warnings.Unused_pat)
+                    ps
+              | Used -> ()
+            with Empty | Not_found | NoGuard -> assert false
+            end ;
+
+          if c_guard <> None then
+            do_rec pref rem
+          else
+            do_rec ([q]::pref) rem in
+
+    do_rec [] casel
+
+(*********************************)
+(* Exported irrefutability tests *)
+(*********************************)
+
+let irrefutable pat = le_pat pat omega
+
+(* An inactive pattern is a pattern whose matching needs only
+   trivial computations (tag/equality tests).
+   Patterns containing (lazy _) subpatterns are active. *)
+
+let rec inactive pat = match pat with
+| Tpat_lazy _ ->
+    false
+| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
+    true
+| Tpat_tuple ps | Tpat_construct (_, _, ps) | Tpat_array ps ->
+    List.for_all (fun p -> inactive p.pat_desc) ps
+| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+    inactive p.pat_desc
+| Tpat_record (ldps,_) ->
+    List.exists (fun (_, _, p) -> inactive p.pat_desc) ldps
+| Tpat_or (p,q,_) ->
+    inactive p.pat_desc && inactive q.pat_desc
+
+(* A `fluid' pattern is both irrefutable and inactive *)
+
+let fluid pat =  irrefutable pat && inactive pat.pat_desc
+
+
+
+
+
+
+
+
+(********************************)
+(* Exported exhustiveness check *)
+(********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial_param do_check_partial do_check_fragile 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
+      let total = do_check_partial loc casel pss in
+      if
+        total = Total && Warnings.is_active (Warnings.Fragile_match "")
+      then begin
+        do_check_fragile loc casel pss
+      end ;
+      total
+    end else
+      Partial
+
+(*let check_partial =
+    check_partial_param
+      do_check_partial_normal
+      do_check_fragile_normal*)
+
+let check_partial_gadt pred loc casel =
+  check_partial_param (do_check_partial_gadt pred)
+    do_check_fragile_gadt loc casel
+
+
+(*************************************)
+(* Ambiguous variable in or-patterns *)
+(*************************************)
+
+(* Specification: ambiguous variables in or-patterns.
+
+   The semantics of or-patterns in OCaml is specified with
+   a left-to-right bias: a value [v] matches the pattern [p | q] if it
+   matches [p] or [q], but if it matches both, the environment
+   captured by the match is the environment captured by [p], never the
+   one captured by [q].
+
+   While this property is generally well-understood, one specific case
+   where users expect a different semantics is when a pattern is
+   followed by a when-guard: [| p when g -> e]. Consider for example:
+
+     | ((Const x, _) | (_, Const x)) when is_neutral x -> branch
+
+   The semantics is clear: match the scrutinee against the pattern, if
+   it matches, test the guard, and if the guard passes, take the
+   branch.
+
+   However, consider the input [(Const a, Const b)], where [a] fails
+   the test [is_neutral f], while [b] passes the test [is_neutral
+   b]. With the left-to-right semantics, the clause above is *not*
+   taken by its input: matching [(Const a, Const b)] against the
+   or-pattern succeeds in the left branch, it returns the environment
+   [x -> a], and then the guard [is_neutral a] is tested and fails,
+   the branch is not taken. Most users, however, intuitively expect
+   that any pair that has one side passing the test will take the
+   branch. They assume it is equivalent to the following:
+
+     | (Const x, _) when is_neutral x -> branch
+     | (_, Const x) when is_neutral x -> branch
+
+   while it is not.
+
+   The code below is dedicated to finding these confusing cases: the
+   cases where a guard uses "ambiguous" variables, that are bound to
+   different parts of the scrutinees by different sides of
+   a or-pattern. In other words, it finds the cases where the
+   specified left-to-right semantics is not equivalent to
+   a non-deterministic semantics (any branch can be taken) relatively
+   to a specific guard.
+*)
+
+module IdSet = Set.Make(Ident)
+
+let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p)
+
+(* Row for ambiguous variable search,
+   unseen is the traditional pattern row,
+   seen   is a list of position bindings *)
+
+type amb_row = { unseen : pattern list ; seen : IdSet.t list; }
+
+
+(* Push binding variables now *)
+
+let rec do_push r p ps seen k = match p.pat_desc with
+| Tpat_alias (p,x,_) -> do_push (IdSet.add x r) p ps seen k
+| Tpat_var (x,_) ->
+    (omega,{ unseen = ps; seen=IdSet.add x r::seen; })::k
+| Tpat_or (p1,p2,_) ->
+    do_push r p1 ps seen (do_push r p2 ps seen k)
+| _ ->
+    (p,{ unseen = ps; seen = r::seen; })::k
+
+let rec push_vars = function
+  | [] -> []
+  | { unseen = [] }::_ -> assert false
+  | { unseen = p::ps; seen; }::rem ->
+      do_push IdSet.empty p ps seen (push_vars rem)
+
+let collect_stable = function
+  | [] -> assert false
+  | { seen=xss; _}::rem ->
+      let rec c_rec xss = function
+        | [] -> xss
+        | {seen=yss; _}::rem ->
+            let xss = List.map2 IdSet.inter xss yss in
+            c_rec xss rem in
+      let inters = c_rec xss rem in
+      List.fold_left IdSet.union IdSet.empty inters
+
+
+(*********************************************)
+(* Filtering utilities for our specific rows *)
+(*********************************************)
+
+(* Take a pattern matrix as a list (rows) of lists (columns) of patterns
+     | p1, p2, .., pn
+     | q1, q2, .., qn
+     | r1, r2, .., rn
+     | ...
+
+   We split this matrix into a list of sub-matrices, one for each head
+   constructor appearing in the leftmost column. For each row whose
+   left column starts with a head constructor, remove this head
+   column, prepend one column for each argument of the constructor,
+   and add the resulting row in the sub-matrix corresponding to this
+   head constructor.
+
+   Rows whose left column is omega (the Any pattern _) may match any
+   head constructor, so they are added to all groups.
+
+   The list of sub-matrices is represented as a list of pair
+     (head constructor, submatrix)
+*)
+
+let filter_all =
+  (* the head constructor (as a pattern with omega arguments) of
+     a pattern *)
+  let discr_head pat =
+    match pat.pat_desc with
+    | Tpat_record (lbls, closed) ->
+        (* a partial record pattern { f1 = p1; f2 = p2; _ }
+           needs to be expanded, otherwise matching against this head
+           would drop the pattern arguments for non-mentioned fields *)
+        let lbls = all_record_args lbls in
+        normalize_pat { pat with pat_desc = Tpat_record (lbls, closed) }
+    | _ -> normalize_pat pat
+  in
+
+  (* insert a row of head [p] and rest [r] into the right group *)
+  let rec insert p r env = match env with
+  | [] ->
+      (* if no group matched this row, it has a head constructor that
+         was never seen before; add a new sub-matrix for this head *)
+      let p0 = discr_head p in
+      [p0,[{ r with unseen = simple_match_args p0 p @ r.unseen }]]
+  | (q0,rs) as bd::env ->
+      if simple_match q0 p then begin
+        let r = { r with unseen = simple_match_args q0 p@r.unseen; } in
+        (q0,r::rs)::env
+      end
+      else bd::insert p r env in
+
+  (* insert a row of head omega into all groups *)
+  let insert_omega r env =
+    List.map
+      (fun (q0,rs) ->
+         let r =
+           { r with unseen = simple_match_args q0 omega @ r.unseen; } in
+         (q0,r::rs))
+      env
+  in
+
+  let rec filter_rec env = function
+    | [] -> env
+    | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
+    | ({pat_desc=Tpat_any}, _)::rs -> filter_rec env rs
+    | (p,r)::rs -> filter_rec (insert p r env) rs in
+
+  let rec filter_omega env = function
+    | [] -> env
+    | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false
+    | ({pat_desc=Tpat_any},r)::rs -> filter_omega (insert_omega r env) rs
+    | _::rs -> filter_omega env rs in
+
+  fun rs ->
+    (* first insert the rows with head constructors,
+       to get the definitive list of groups *)
+    let env = filter_rec [] rs in
+    (* then add the omega rows to all groups *)
+    filter_omega env rs
+
+(* Compute stable bindings *)
+
+let rec do_stable rs = match rs with
+| [] -> assert false (* No empty matrix *)
+| { unseen=[]; _ }::_ ->
+    collect_stable rs
+| _ ->
+    let rs = push_vars rs in
+    match filter_all rs with
+    | [] ->
+        do_stable (List.map snd rs)
+    | (_,rs)::env ->
+        List.fold_left
+          (fun xs (_,rs) -> IdSet.inter xs (do_stable rs))
+          (do_stable rs) env
+
+let stable p = do_stable [{unseen=[p]; seen=[];}]
+
+
+(* All identifier paths that appear in an expression that occurs
+   as a clause right hand side or guard.
+
+  The function is rather complex due to the compilation of
+  unpack patterns by introducing code in rhs expressions
+  and **guards**.
+
+  For pattern (module M:S)  -> e the code is
+  let module M_mod = unpack M .. in e
+
+  Hence M is "free" in e iff M_mod is free in e.
+
+  Not doing so will yield excessive  warning in
+  (module (M:S) } ...) when true -> ....
+  as M is always present in
+  let module M_mod = unpack M .. in true
+*)
+
+let all_rhs_idents exp =
+  let ids = ref IdSet.empty in
+  let module Iterator = TypedtreeIter.MakeIterator(struct
+    include TypedtreeIter.DefaultIteratorArgument
+    let enter_expression exp = match exp.exp_desc with
+      | Texp_ident (path, _lid, _descr) ->
+          List.iter
+            (fun id -> ids := IdSet.add id !ids)
+            (Path.heads path)
+      | _ -> ()
+
+(* Very hackish, detect unpack pattern  compilation
+   and perfom "indirect check for them" *)
+    let is_unpack exp =
+      List.exists
+        (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes
+
+    let leave_expression exp =
+      if is_unpack exp then begin match exp.exp_desc with
+      | Texp_letmodule
+          (id_mod,_,
+           {mod_desc=
+            Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
+           _) ->
+             assert (IdSet.mem id_exp !ids) ;
+             if not (IdSet.mem id_mod !ids) then begin
+               ids := IdSet.remove id_exp !ids
+             end
+      | _ -> assert false
+      end
+  end) in
+  Iterator.iter_expression exp;
+  !ids
+
+let check_ambiguous_bindings =
+  let open Warnings in
+  let warn0 = Ambiguous_pattern [] in
+  fun cases ->
+    if is_active warn0 then
+      List.iter
+        (fun case -> match case with
+        | { c_guard=None ; _} -> ()
+        | { c_lhs=p; c_guard=Some g; _} ->
+            let all =
+              IdSet.inter (pattern_vars p) (all_rhs_idents g) in
+            if not (IdSet.is_empty all) then begin
+              let st = stable p in
+              let ambiguous = IdSet.diff all st in
+              if not (IdSet.is_empty  ambiguous) then begin
+                let pps = IdSet.elements ambiguous |> List.map Ident.name in
+                let warn = Ambiguous_pattern pps in
+                Location.prerr_warning p.pat_loc warn
+              end
+            end)
+        cases
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
new file mode 100644
index 00000000..3dcb6dde
--- /dev/null
+++ b/typing/parmatch.mli
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Detection of partial matches and unused match cases. *)
+open Asttypes
+open Typedtree
+open Types
+
+val pretty_const : constant -> string
+val top_pretty : Format.formatter -> pattern -> unit
+val pretty_pat : pattern -> unit
+val pretty_line : pattern list -> unit
+val pretty_matrix : pattern list list -> unit
+
+val omega : pattern
+val omegas : int -> pattern list
+val omega_list : 'a list -> pattern list
+val normalize_pat : pattern -> pattern
+val all_record_args :
+    (Longident.t loc * label_description * pattern) list ->
+    (Longident.t loc * label_description * pattern) list
+val const_compare : constant -> constant -> int
+
+val le_pat : pattern -> pattern -> bool
+val le_pats : pattern list -> pattern list -> bool
+val compat : pattern -> pattern -> bool
+val compats : pattern list -> pattern list -> bool
+exception Empty
+val lub : pattern -> pattern -> pattern
+val lubs : pattern list -> pattern list -> pattern list
+
+val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(* Those two functions recombine one pattern and its arguments:
+   For instance:
+     (_,_)::p1::p2::rem -> (p1, p2)::rem
+   The second one will replace mutable arguments by '_'
+*)
+val set_args : pattern -> pattern list -> pattern list
+val set_args_erase_mutable : pattern -> pattern list -> pattern list
+
+val pat_of_constr : pattern -> constructor_description -> pattern
+val complete_constrs :
+    pattern -> constructor_tag list -> constructor_description  list
+val ppat_of_type :
+    Env.t -> type_expr ->
+    Parsetree.pattern *
+    (string, constructor_description) Hashtbl.t *
+    (string, label_description) Hashtbl.t
+
+val pressure_variants: Env.t -> pattern list -> unit
+val check_partial_gadt:
+    ((string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    Location.t -> case list -> partial
+val check_unused:
+    (bool ->
+     (string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) ->
+    case list -> unit
+
+(* Irrefutability tests *)
+val irrefutable : pattern -> bool
+val fluid : pattern -> bool
+
+(* Ambiguous bindings *)
+val check_ambiguous_bindings : case list -> unit
diff --git a/typing/path.ml b/typing/path.ml
new file mode 100644
index 00000000..a1a81015
--- /dev/null
+++ b/typing/path.ml
@@ -0,0 +1,101 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string * int
+  | Papply of t * t
+
+let nopos = -1
+
+let rec same p1 p2 =
+  match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.same id1 id2
+  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+       same fun1 fun2 && same arg1 arg2
+  | (_, _) -> false
+
+let rec compare p1 p2 =
+  match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
+let rec isfree id = function
+    Pident id' -> Ident.same id id'
+  | Pdot(p, _s, _pos) -> isfree id p
+  | Papply(p1, p2) -> isfree id p1 || isfree id p2
+
+let rec binding_time = function
+    Pident id -> Ident.binding_time id
+  | Pdot(p, _s, _pos) -> binding_time p
+  | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
+
+let kfalse _ = false
+
+let rec name ?(paren=kfalse) = function
+    Pident id -> Ident.name id
+  | Pdot(p, s, _pos) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
+
+let rec head = function
+    Pident id -> id
+  | Pdot(p, _s, _pos) -> head p
+  | Papply _ -> assert false
+
+let heads p =
+  let rec heads p acc = match p with
+    | Pident id -> id :: acc
+    | Pdot (p, _s, _pos) -> heads p acc
+    | Papply(p1, p2) ->
+        heads p1 (heads p2 acc)
+  in heads p []
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s, _) -> s
+  | Papply(_, p) -> last p
+
+let is_uident s =
+  assert (s <> "");
+  match s.[0] with
+  | 'A'..'Z' -> true
+  | _ -> false
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+let constructor_typath = function
+  | Pident id when is_uident (Ident.name id) -> LocalExt id
+  | Pdot(ty_path, s, _) when is_uident s ->
+      if is_uident (last ty_path) then Ext (ty_path, s)
+      else Cstr (ty_path, s)
+  | p -> Regular p
+
+let is_constructor_typath p =
+  match constructor_typath p with
+  | Regular _ -> false
+  | _ -> true
diff --git a/typing/path.mli b/typing/path.mli
new file mode 100644
index 00000000..4853f925
--- /dev/null
+++ b/typing/path.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Access paths *)
+
+type t =
+    Pident of Ident.t
+  | Pdot of t * string * int
+  | Papply of t * t
+
+val same: t -> t -> bool
+val compare: t -> t -> int
+val isfree: Ident.t -> t -> bool
+val binding_time: t -> int
+
+val nopos: int
+
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
+val head: t -> Ident.t
+
+val heads: t -> Ident.t list
+
+val last: t -> string
+
+type typath =
+  | Regular of t
+  | Ext of t * string
+  | LocalExt of Ident.t
+  | Cstr of t * string
+
+val constructor_typath: t -> typath
+val is_constructor_typath: t -> bool
diff --git a/typing/predef.ml b/typing/predef.ml
new file mode 100644
index 00000000..a16997f9
--- /dev/null
+++ b/typing/predef.ml
@@ -0,0 +1,254 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Path
+open Types
+open Btype
+
+let builtin_idents = ref []
+
+let wrap create s =
+  let id = create s in
+  builtin_idents := (s, id) :: !builtin_idents;
+  id
+
+let ident_create = wrap Ident.create
+let ident_create_predef_exn = wrap Ident.create_predef_exn
+
+let ident_int = ident_create "int"
+and ident_char = ident_create "char"
+and ident_bytes = ident_create "bytes"
+and ident_float = ident_create "float"
+and ident_bool = ident_create "bool"
+and ident_unit = ident_create "unit"
+and ident_exn = ident_create "exn"
+and ident_array = ident_create "array"
+and ident_list = ident_create "list"
+and ident_option = ident_create "option"
+and ident_nativeint = ident_create "nativeint"
+and ident_int32 = ident_create "int32"
+and ident_int64 = ident_create "int64"
+and ident_lazy_t = ident_create "lazy_t"
+and ident_string = ident_create "string"
+and ident_extension_constructor = ident_create "extension_constructor"
+
+let path_int = Pident ident_int
+and path_char = Pident ident_char
+and path_bytes = Pident ident_bytes
+and path_float = Pident ident_float
+and path_bool = Pident ident_bool
+and path_unit = Pident ident_unit
+and path_exn = Pident ident_exn
+and path_array = Pident ident_array
+and path_list = Pident ident_list
+and path_option = Pident ident_option
+and path_nativeint = Pident ident_nativeint
+and path_int32 = Pident ident_int32
+and path_int64 = Pident ident_int64
+and path_lazy_t = Pident ident_lazy_t
+and path_string = Pident ident_string
+and path_extension_constructor = Pident ident_extension_constructor
+
+let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
+and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
+and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
+and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
+and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
+and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
+and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
+and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
+and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
+and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
+and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
+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))
+and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
+and type_extension_constructor =
+      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
+
+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 all_predef_exns = [
+  ident_match_failure;
+  ident_out_of_memory;
+  ident_invalid_argument;
+  ident_failure;
+  ident_not_found;
+  ident_sys_error;
+  ident_end_of_file;
+  ident_division_by_zero;
+  ident_stack_overflow;
+  ident_sys_blocked_io;
+  ident_assert_failure;
+  ident_undefined_recursive_module;
+]
+
+let path_match_failure = Pident ident_match_failure
+and path_assert_failure = Pident ident_assert_failure
+and path_undefined_recursive_module = Pident ident_undefined_recursive_module
+
+let decl_abstr =
+  {type_params = [];
+   type_arity = 0;
+   type_kind = Type_abstract;
+   type_loc = Location.none;
+   type_private = Asttypes.Public;
+   type_manifest = None;
+   type_variance = [];
+   type_newtype_level = None;
+   type_attributes = [];
+   type_immediate = false;
+   type_unboxed = unboxed_false_default_false;
+  }
+
+let decl_abstr_imm = {decl_abstr with type_immediate = true}
+
+let cstr id args =
+  {
+    cd_id = id;
+    cd_args = Cstr_tuple args;
+    cd_res = None;
+    cd_loc = Location.none;
+    cd_attributes = [];
+  }
+
+let ident_false = ident_create "false"
+and ident_true = ident_create "true"
+and ident_void = ident_create "()"
+and ident_nil = ident_create "[]"
+and ident_cons = ident_create "::"
+and ident_none = ident_create "None"
+and ident_some = ident_create "Some"
+let common_initial_env add_type add_extension empty_env =
+  let decl_bool =
+    {decl_abstr with
+     type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
+     type_immediate = true}
+  and decl_unit =
+    {decl_abstr with
+     type_kind = Type_variant([cstr ident_void []]);
+     type_immediate = true}
+  and decl_exn =
+    {decl_abstr with
+     type_kind = Type_open}
+  and decl_array =
+    let tvar = newgenvar() in
+    {decl_abstr with
+     type_params = [tvar];
+     type_arity = 1;
+     type_variance = [Variance.full]}
+  and decl_list =
+    let tvar = newgenvar() in
+    {decl_abstr with
+     type_params = [tvar];
+     type_arity = 1;
+     type_kind =
+     Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]);
+     type_variance = [Variance.covariant]}
+  and decl_option =
+    let tvar = newgenvar() in
+    {decl_abstr with
+     type_params = [tvar];
+     type_arity = 1;
+     type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]);
+     type_variance = [Variance.covariant]}
+  and decl_lazy_t =
+    let tvar = newgenvar() in
+    {decl_abstr with
+     type_params = [tvar];
+     type_arity = 1;
+     type_variance = [Variance.covariant]}
+  in
+
+  let add_extension id l =
+    add_extension id
+      { ext_type_path = path_exn;
+        ext_type_params = [];
+        ext_args = Cstr_tuple l;
+        ext_ret_type = None;
+        ext_private = Asttypes.Public;
+        ext_loc = Location.none;
+        ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern";
+                           loc=Location.none},
+                          Parsetree.PStr[]] }
+  in
+  add_extension ident_match_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_out_of_memory [] (
+  add_extension ident_stack_overflow [] (
+  add_extension ident_invalid_argument [type_string] (
+  add_extension ident_failure [type_string] (
+  add_extension ident_not_found [] (
+  add_extension ident_sys_blocked_io [] (
+  add_extension ident_sys_error [type_string] (
+  add_extension ident_end_of_file [] (
+  add_extension ident_division_by_zero [] (
+  add_extension ident_assert_failure
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_extension ident_undefined_recursive_module
+                         [newgenty (Ttuple[type_string; type_int; type_int])] (
+  add_type ident_int64 decl_abstr (
+  add_type ident_int32 decl_abstr (
+  add_type ident_nativeint decl_abstr (
+  add_type ident_lazy_t decl_lazy_t (
+  add_type ident_option decl_option (
+  add_type ident_list decl_list (
+  add_type ident_array decl_array (
+  add_type ident_exn decl_exn (
+  add_type ident_unit decl_unit (
+  add_type ident_bool decl_bool (
+  add_type ident_float decl_abstr (
+  add_type ident_string decl_abstr (
+  add_type ident_char decl_abstr_imm (
+  add_type ident_int decl_abstr_imm (
+  add_type ident_extension_constructor decl_abstr (
+    empty_env)))))))))))))))))))))))))))
+
+let build_initial_env add_type add_exception empty_env =
+  let common = common_initial_env add_type add_exception empty_env in
+  let safe_string = add_type ident_bytes decl_abstr common in
+  let decl_bytes_unsafe = {decl_abstr with type_manifest = Some type_string} in
+  let unsafe_string = add_type ident_bytes decl_bytes_unsafe common in
+  (safe_string, unsafe_string)
+
+let builtin_values =
+  List.map (fun id -> Ident.make_global id; (Ident.name id, id))
+      [ident_match_failure; ident_out_of_memory; ident_stack_overflow;
+       ident_invalid_argument;
+       ident_failure; ident_not_found; ident_sys_error; ident_end_of_file;
+       ident_division_by_zero; ident_sys_blocked_io;
+       ident_assert_failure; ident_undefined_recursive_module ]
+
+(* Start non-predef identifiers at 1000.  This way, more predefs can
+   be defined in this file (above!) without breaking .cmi
+   compatibility. *)
+
+let _ = Ident.set_current_time 999
+let builtin_idents = List.rev !builtin_idents
diff --git a/typing/predef.mli b/typing/predef.mli
new file mode 100644
index 00000000..a7bf0634
--- /dev/null
+++ b/typing/predef.mli
@@ -0,0 +1,77 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Predefined type constructors (with special typing rules in typecore) *)
+
+open Types
+
+val type_int: type_expr
+val type_char: type_expr
+val type_string: type_expr
+val type_bytes: type_expr
+val type_float: type_expr
+val type_bool: type_expr
+val type_unit: type_expr
+val type_exn: type_expr
+val type_array: type_expr -> type_expr
+val type_list: type_expr -> type_expr
+val type_option: type_expr -> type_expr
+val type_nativeint: type_expr
+val type_int32: type_expr
+val type_int64: type_expr
+val type_lazy_t: type_expr -> type_expr
+val type_extension_constructor:type_expr
+
+val path_int: Path.t
+val path_char: Path.t
+val path_string: Path.t
+val path_bytes: Path.t
+val path_float: Path.t
+val path_bool: Path.t
+val path_unit: Path.t
+val path_exn: Path.t
+val path_array: Path.t
+val path_list: Path.t
+val path_option: Path.t
+val path_nativeint: Path.t
+val path_int32: Path.t
+val path_int64: Path.t
+val path_lazy_t: Path.t
+val path_extension_constructor: Path.t
+
+val path_match_failure: Path.t
+val path_assert_failure : Path.t
+val path_undefined_recursive_module : Path.t
+
+(* To build the initial environment. Since there is a nasty mutual
+   recursion between predef and env, we break it by parameterizing
+   over Env.t, Env.add_type and Env.add_extension. *)
+
+val build_initial_env:
+  (Ident.t -> type_declaration -> 'a -> 'a) ->
+  (Ident.t -> extension_constructor -> 'a -> 'a) ->
+  'a -> 'a * 'a
+
+(* To initialize linker tables *)
+
+val builtin_values: (string * Ident.t) list
+val builtin_idents: (string * Ident.t) list
+
+(** All predefined exceptions, exposed as [Ident.t] for flambda (for
+    building value approximations).
+    The [Ident.t] for division by zero is also exported explicitly
+    so flambda can generate code to raise it. *)
+val ident_division_by_zero: Ident.t
+val all_predef_exns : Ident.t list
diff --git a/typing/primitive.ml b/typing/primitive.ml
new file mode 100644
index 00000000..81a33397
--- /dev/null
+++ b/typing/primitive.ml
@@ -0,0 +1,224 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+open Misc
+open Parsetree
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description =
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
+
+let is_ocaml_repr = function
+  | Same_as_ocaml_repr -> true
+  | Unboxed_float
+  | Unboxed_integer _
+  | Untagged_int -> false
+
+let is_unboxed = function
+  | Same_as_ocaml_repr
+  | Untagged_int -> false
+  | Unboxed_float
+  | Unboxed_integer _ -> true
+
+let is_untagged = function
+  | Untagged_int -> true
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer _ -> false
+
+let rec make_native_repr_args arity x =
+  if arity = 0 then
+    []
+  else
+    x :: make_native_repr_args (arity - 1) x
+
+let simple ~name ~arity ~alloc =
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = alloc;
+   prim_native_name = "";
+   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
+   prim_native_repr_res = Same_as_ocaml_repr}
+
+let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+  {prim_name = name;
+   prim_arity = List.length native_repr_args;
+   prim_alloc = alloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+let parse_declaration valdecl ~native_repr_args ~native_repr_res =
+  let arity = List.length native_repr_args in
+  let name, native_name, old_style_noalloc, old_style_float =
+    match valdecl.pval_prim with
+    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
+    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
+    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
+    | name :: "noalloc" :: _ -> (name, "", true, false)
+    | name :: name2 :: _ -> (name, name2, false, false)
+    | name :: _ -> (name, "", false, false)
+    | [] ->
+        fatal_error "Primitive.parse_declaration"
+  in
+  let noalloc_attribute =
+    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
+      valdecl.pval_attributes
+  in
+  if old_style_float &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_float_with_native_repr_attribute));
+  if old_style_noalloc && noalloc_attribute then
+    raise (Error (valdecl.pval_loc,
+                  Old_style_noalloc_with_noalloc_attribute));
+  (* The compiler used to assume "noalloc" with "float", we just make this
+     explicit now (GPR#167): *)
+  let old_style_noalloc = old_style_noalloc || old_style_float in
+  if old_style_float then
+    Location.prerr_warning valdecl.pval_loc
+      (Warnings.Deprecated "[@@unboxed] + [@@noalloc] should be used instead \
+                            of \"float\"")
+  else if old_style_noalloc then
+    Location.prerr_warning valdecl.pval_loc
+      (Warnings.Deprecated "[@@noalloc] should be used instead of \
+                            \"noalloc\"");
+  if native_name = "" &&
+     not (List.for_all is_ocaml_repr native_repr_args &&
+          is_ocaml_repr native_repr_res) then
+    raise (Error (valdecl.pval_loc,
+                  No_native_primitive_with_repr_attribute));
+  let noalloc = old_style_noalloc || noalloc_attribute in
+  let native_repr_args, native_repr_res =
+    if old_style_float then
+      (make_native_repr_args arity Unboxed_float, Unboxed_float)
+    else
+      (native_repr_args, native_repr_res)
+  in
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = not noalloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
+
+open Outcometree
+
+let rec add_native_repr_attributes ty attrs =
+  match ty, attrs with
+  | Otyp_arrow (label, a, b), attr_opt :: rest ->
+    let b = add_native_repr_attributes b rest in
+    let a =
+      match attr_opt with
+      | None -> a
+      | Some attr -> Otyp_attribute (a, attr)
+    in
+    Otyp_arrow (label, a, b)
+  | _, [Some attr] -> Otyp_attribute (ty, attr)
+  | _ ->
+    assert (List.for_all (fun x -> x = None) attrs);
+    ty
+
+let oattr_unboxed = { oattr_name = "unboxed" }
+let oattr_untagged = { oattr_name = "untagged" }
+let oattr_noalloc = { oattr_name = "noalloc" }
+
+let print p osig_val_decl =
+  let prims =
+    if p.prim_native_name <> "" then
+      [p.prim_name; p.prim_native_name]
+    else
+      [p.prim_name]
+  in
+  let for_all f =
+    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
+  in
+  let all_unboxed = for_all is_unboxed in
+  let all_untagged = for_all is_untagged in
+  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
+  let attrs =
+    if all_unboxed then
+      oattr_unboxed :: attrs
+    else if all_untagged then
+      oattr_untagged :: attrs
+    else
+      attrs
+  in
+  let attr_of_native_repr = function
+    | Same_as_ocaml_repr -> None
+    | Unboxed_float
+    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
+    | Untagged_int -> if all_untagged then None else Some oattr_untagged
+  in
+  let type_attrs =
+    List.map attr_of_native_repr p.prim_native_repr_args @
+    [attr_of_native_repr p.prim_native_repr_res]
+  in
+  { osig_val_decl with
+    oval_prims = prims;
+    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
+    oval_attributes = attrs }
+
+let native_name p =
+  if p.prim_native_name <> ""
+  then p.prim_native_name
+  else p.prim_name
+
+let byte_name p =
+  p.prim_name
+
+let report_error ppf err =
+  match err with
+  | Old_style_float_with_native_repr_attribute ->
+    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
+                        [%@unboxed]/[%@untagged]"
+  | Old_style_noalloc_with_noalloc_attribute ->
+    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
+                        [%@%@noalloc]"
+  | No_native_primitive_with_repr_attribute ->
+    Format.fprintf ppf
+      "The native code version of the primitive is mandatory when \
+       attributes [%@untagged] or [%@unboxed] are present"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/typing/primitive.mli b/typing/primitive.mli
new file mode 100644
index 00000000..02ece7d9
--- /dev/null
+++ b/typing/primitive.mli
@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of primitive functions *)
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+(* Representation of arguments/result for the native code version
+   of a primitive *)
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description = private
+  { prim_name: string;         (* Name of primitive  or C function *)
+    prim_arity: int;           (* Number of arguments *)
+    prim_alloc: bool;          (* Does it allocates or raise? *)
+    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
+
+val simple
+  :  name:string
+  -> arity:int
+  -> alloc:bool
+  -> description
+
+val make
+  :  name:string
+  -> alloc:bool
+  -> native_name:string
+  -> native_repr_args: native_repr list
+  -> native_repr_res: native_repr
+  -> description
+
+val parse_declaration
+  :  Parsetree.value_description
+  -> native_repr_args:native_repr list
+  -> native_repr_res:native_repr
+  -> description
+
+val print
+  :  description
+  -> Outcometree.out_val_decl
+  -> Outcometree.out_val_decl
+
+val native_name: description -> string
+val byte_name: description -> string
+
+type error =
+  | Old_style_float_with_native_repr_attribute
+  | Old_style_noalloc_with_noalloc_attribute
+  | No_native_primitive_with_repr_attribute
+
+exception Error of Location.t * error
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
new file mode 100644
index 00000000..64f8d0cb
--- /dev/null
+++ b/typing/printtyp.ml
@@ -0,0 +1,1579 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Misc
+open Ctype
+open Format
+open Longident
+open Path
+open Asttypes
+open Types
+open Btype
+open Outcometree
+
+(* Print a long identifier *)
+
+let rec longident ppf = function
+  | Lident s -> pp_print_string ppf s
+  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
+  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
+
+(* Print an identifier *)
+
+let unique_names = ref Ident.empty
+
+let ident_name id =
+  try Ident.find_same id !unique_names with Not_found -> Ident.name id
+
+let add_unique id =
+  try ignore (Ident.find_same id !unique_names)
+  with Not_found ->
+    unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names
+
+let ident ppf id = pp_print_string ppf (ident_name id)
+
+(* Print a path *)
+
+let ident_pervasive = Ident.create_persistent "Pervasives"
+
+let rec tree_of_path = function
+  | Pident id ->
+      Oide_ident (ident_name id)
+  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
+      Oide_ident s
+  | Pdot(p, s, _pos) ->
+      Oide_dot (tree_of_path p, s)
+  | Papply(p1, p2) ->
+      Oide_apply (tree_of_path p1, tree_of_path p2)
+
+let rec path ppf = function
+  | Pident id ->
+      ident ppf id
+  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
+      pp_print_string ppf s
+  | Pdot(p, s, _pos) ->
+      path ppf p;
+      pp_print_char ppf '.';
+      pp_print_string ppf s
+  | Papply(p1, p2) ->
+      fprintf ppf "%a(%a)" path p1 path p2
+
+let rec string_of_out_ident = function
+  | Oide_ident s -> s
+  | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
+  | Oide_apply (id1, id2) ->
+      String.concat ""
+        [string_of_out_ident id1; "("; string_of_out_ident id2; ")"]
+
+let string_of_path p = string_of_out_ident (tree_of_path p)
+
+(* 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 kind_vars = ref []
+let kind_count = ref 0
+
+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 r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
+  | 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 (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
+let string_of_label = function
+    Nolabel -> ""
+  | Labelled s -> s
+  | Optional s -> "?"^s
+
+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 name -> fprintf ppf "Tvar %a" print_name name
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
+        (string_of_label 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 "@[Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list path) (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[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 "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%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 name -> fprintf ppf "Tunivar %a" print_name name
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[{@[%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)
+  | Tpackage (p, _, tl) ->
+      fprintf ppf "@[Tpackage(@,%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 "@[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 := []; kind_vars := []; kind_count := 0;
+  raw_type ppf t;
+  visited := []; kind_vars := []
+
+let () = Btype.print_raw := raw_type_expr
+
+(* Normalize paths *)
+
+type param_subst = Id | Nth of int | Map of int list
+
+let is_nth = function
+    Nth _ -> true
+  | _ -> false
+
+let compose l1 = function
+  | Id -> Map l1
+  | Map l2 -> Map (List.map (List.nth l1) l2)
+  | Nth n  -> Nth (List.nth l1 n)
+
+let apply_subst s1 tyl =
+  match s1 with
+    Nth n1 -> [List.nth tyl n1]
+  | Map l1 -> List.map (List.nth tyl) l1
+  | Id -> tyl
+
+type best_path = Paths of Path.t list | Best of Path.t
+
+let printing_env = ref Env.empty
+let printing_depth = ref 0
+let printing_cont = ref ([] : Env.iter_cont list)
+let printing_old = ref Env.empty
+let printing_pers = ref Concr.empty
+module PathMap = Map.Make(Path)
+let printing_map = ref PathMap.empty
+
+let same_type t t' = repr t == repr t'
+
+let rec index l x =
+  match l with
+    [] -> raise Not_found
+  | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+    [] -> true
+  | a :: l -> not (List.memq a l) && uniq l
+
+let rec normalize_type_path ?(cache=false) env p =
+  try
+    let (params, ty, _) = Env.find_type_expansion p env in
+    let params = List.map repr params in
+    match repr ty with
+      {desc = Tconstr (p1, tyl, _)} ->
+        let tyl = List.map repr tyl in
+        if List.length params = List.length tyl
+        && List.for_all2 (==) params tyl
+        then normalize_type_path ~cache env p1
+        else if cache || List.length params <= List.length tyl
+             || not (uniq tyl) then (p, Id)
+        else
+          let l1 = List.map (index params) tyl in
+          let (p2, s2) = normalize_type_path ~cache env p1 in
+          (p2, compose l1 s2)
+    | ty ->
+        (p, Nth (index params ty))
+  with
+    Not_found ->
+      (Env.normalize_path None env p, Id)
+
+let penalty s =
+  if s <> "" && s.[0] = '_' then
+    10
+  else
+    try
+      for i = 0 to String.length s - 2 do
+        if s.[i] = '_' && s.[i + 1] = '_' then
+          raise Exit
+      done;
+      1
+    with Exit -> 10
+
+let rec path_size = function
+    Pident id ->
+      penalty (Ident.name id), -Ident.binding_time id
+  | Pdot (p, _, _) ->
+      let (l, b) = path_size p in (1+l, b)
+  | Papply (p1, p2) ->
+      let (l, b) = path_size p1 in
+      (l + fst (path_size p2), b)
+
+let same_printing_env env =
+  let used_pers = Env.used_persistent () in
+  Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
+
+let set_printing_env env =
+  printing_env := if !Clflags.real_paths then Env.empty else env;
+  if !printing_env == Env.empty || same_printing_env env then () else
+  begin
+    (* printf "Reset printing_map@."; *)
+    printing_old := env;
+    printing_pers := Env.used_persistent ();
+    printing_map := PathMap.empty;
+    printing_depth := 0;
+    (* printf "Recompute printing_map.@."; *)
+    let cont =
+      Env.iter_types
+        (fun p (p', _decl) ->
+          let (p1, s1) = normalize_type_path env p' ~cache:true in
+          (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
+          if s1 = Id then
+          try
+            let r = PathMap.find p1 !printing_map in
+            match !r with
+              Paths l -> r := Paths (p :: l)
+            | Best p' -> r := Paths [p; p'] (* assert false *)
+          with Not_found ->
+            printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map)
+        env in
+    printing_cont := [cont];
+  end
+
+let wrap_printing_env env f =
+  set_printing_env env;
+  try_finally f (fun () -> set_printing_env Env.empty)
+
+let wrap_printing_env env f =
+  Env.without_cmis (wrap_printing_env env) f
+
+let is_unambiguous path env =
+  let l = Env.find_shadowed_types path env in
+  List.exists (Path.same path) l || (* concrete paths are ok *)
+  match l with
+    [] -> true
+  | p :: rem ->
+      (* allow also coherent paths:  *)
+      let normalize p = fst (normalize_type_path ~cache:true env p) in
+      let p' = normalize p in
+      List.for_all (fun p -> Path.same (normalize p) p') rem ||
+      (* also allow repeatedly defining and opening (for toplevel) *)
+      let id = lid_of_path p in
+      List.for_all (fun p -> lid_of_path p = id) rem &&
+      Path.same p (Env.lookup_type id env)
+
+let rec get_best_path r =
+  match !r with
+    Best p' -> p'
+  | Paths [] -> raise Not_found
+  | Paths l ->
+      r := Paths [];
+      List.iter
+        (fun p ->
+          (* Format.eprintf "evaluating %a@." path p; *)
+          match !r with
+            Best p' when path_size p >= path_size p' -> ()
+          | _ -> if is_unambiguous p !printing_env then r := Best p)
+              (* else Format.eprintf "%a ignored as ambiguous@." path p *)
+        l;
+      get_best_path r
+
+let best_type_path p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then (p, Id)
+  else
+    let (p', s) = normalize_type_path !printing_env p in
+    let get_path () = get_best_path (PathMap.find  p' !printing_map) in
+    while !printing_cont <> [] &&
+      try fst (path_size (get_path ())) > !printing_depth with Not_found -> true
+    do
+      printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
+      incr printing_depth;
+    done;
+    let p'' = try get_path () with Not_found -> p' in
+    (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
+    (p'', s)
+
+(* Print a type expression *)
+
+let names = ref ([] : (type_expr * string) list)
+let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
+
+let rec new_name () =
+  let name =
+    if !name_counter < 26
+    then String.make 1 (Char.chr(97 + !name_counter))
+    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
+           string_of_int(!name_counter / 26) in
+  incr name_counter;
+  if List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  then new_name ()
+  else name
+
+let name_of_type t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
+  try List.assq t !names with Not_found ->
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (string_of_int !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          new_name ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
+    name
+
+let check_name_of_type t = ignore(name_of_type t)
+
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+let visited_objects = ref ([] : type_expr list)
+let aliased = ref ([] : type_expr list)
+let delayed = ref ([] : type_expr list)
+
+let add_delayed t =
+  if not (List.memq t !delayed) then delayed := t :: !delayed
+
+let is_aliased ty = List.memq (proxy ty) !aliased
+let add_alias ty =
+  let px = proxy ty in
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
+let aliasable ty =
+  match ty.desc with
+    Tvar _ | Tunivar _ | Tpoly _ -> false
+  | Tconstr (p, _, _) ->
+      not (is_nth (snd (best_type_path p)))
+  | _ -> true
+
+let namable_row row =
+  row.row_name <> None &&
+  List.for_all
+    (fun (_, f) ->
+       match row_field_repr f with
+       | Reither(c, l, _, _) ->
+           row.row_closed && if c then l = [] else List.length l = 1
+       | _ -> true)
+    row.row_fields
+
+let rec mark_loops_rec visited ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.memq px visited && aliasable ty then add_alias px else
+    let visited = px :: visited in
+    match ty.desc with
+    | Tvar _ -> add_named_var ty
+    | Tarrow(_, ty1, ty2, _) ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+    | Tconstr(p, tyl, _) ->
+        let (_p', s) = best_type_path p in
+        List.iter (mark_loops_rec visited) (apply_subst s tyl)
+    | Tpackage (_, _, tyl) ->
+        List.iter (mark_loops_rec visited) tyl
+    | Tvariant row ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          let row = row_repr row in
+          if not (static_row row) then
+            visited_objects := px :: !visited_objects;
+          match row.row_name with
+          | Some(_p, tyl) when namable_row row ->
+              List.iter (mark_loops_rec visited) tyl
+          | _ ->
+              iter_row (mark_loops_rec visited) row
+         end
+    | Tobject (fi, nm) ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
+          if opened_object ty then
+            visited_objects := px :: !visited_objects;
+          begin match !nm with
+          | None ->
+              let fields, _ = flatten_fields fi in
+              List.iter
+                (fun (_, kind, ty) ->
+                  if field_kind_repr kind = Fpresent then
+                    mark_loops_rec visited ty)
+                fields
+          | Some (_, l) ->
+              List.iter (mark_loops_rec visited) (List.tl l)
+          end
+        end
+    | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
+        mark_loops_rec visited ty1; mark_loops_rec visited ty2
+    | Tfield(_, _, _, ty2) ->
+        mark_loops_rec visited ty2
+    | Tnil -> ()
+    | Tsubst ty -> mark_loops_rec visited ty
+    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
+    | Tpoly (ty, tyl) ->
+        List.iter (fun t -> add_alias t) tyl;
+        mark_loops_rec visited ty
+    | Tunivar _ -> add_named_var ty
+
+let mark_loops ty =
+  normalize_type Env.empty ty;
+  mark_loops_rec [] ty;;
+
+let reset_loop_marks () =
+  visited_objects := []; aliased := []; delayed := []
+
+let reset () =
+  unique_names := Ident.empty; reset_names (); reset_loop_marks ()
+
+let reset_and_mark_loops ty =
+  reset (); mark_loops ty
+
+let reset_and_mark_loops_list tyl =
+  reset (); List.iter mark_loops tyl
+
+(* Disabled in classic mode when printing an unification error *)
+let print_labels = ref true
+
+let rec tree_of_typexp sch ty =
+  let ty = repr ty in
+  let px = proxy ty in
+  if List.mem_assq px !names && not (List.memq px !delayed) then
+   let mark = is_non_gen sch ty in
+   Otyp_var (mark, name_of_type px) else
+
+  let pr_typ () =
+    match ty.desc with
+    | Tvar _ ->
+        (*let lev =
+          if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*)
+        Otyp_var (is_non_gen sch ty, name_of_type ty)
+    | Tarrow(l, ty1, ty2, _) ->
+        let pr_arrow l ty1 ty2 =
+          let lab =
+            if !print_labels || is_optional l then string_of_label l else ""
+          in
+          let t1 =
+            if is_optional l then
+              match (repr ty1).desc with
+              | Tconstr(path, [ty], _)
+                when Path.same path Predef.path_option ->
+                  tree_of_typexp sch ty
+              | _ -> Otyp_stuff ""
+            else tree_of_typexp sch ty1 in
+          Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in
+        pr_arrow l ty1 ty2
+    | Ttuple tyl ->
+        Otyp_tuple (tree_of_typlist sch tyl)
+    | Tconstr(p, tyl, _abbrev) ->
+        let p', s = best_type_path p in
+        let tyl' = apply_subst s tyl in
+        if is_nth s then tree_of_typexp sch (List.hd tyl') else
+        Otyp_constr (tree_of_path p', tree_of_typlist sch tyl')
+    | Tvariant row ->
+        let row = row_repr row in
+        let fields =
+          if row.row_closed then
+            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
+              row.row_fields
+          else row.row_fields in
+        let present =
+          List.filter
+            (fun (_, f) ->
+               match row_field_repr f with
+               | Rpresent _ -> true
+               | _ -> false)
+            fields in
+        let all_present = List.length present = List.length fields in
+        begin match row.row_name with
+        | Some(p, tyl) when namable_row row ->
+            let (p', s) = best_type_path p in
+            let id = tree_of_path p' in
+            let args = tree_of_typlist sch (apply_subst s tyl) in
+            let out_variant =
+              if is_nth s then List.hd args else Otyp_constr (id, args) in
+            if row.row_closed && all_present then
+              out_variant
+            else
+              let non_gen = is_non_gen sch px in
+              let tags =
+                if all_present then None else Some (List.map fst present) in
+              Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
+        | _ ->
+            let non_gen =
+              not (row.row_closed && all_present) && is_non_gen sch px in
+            let fields = List.map (tree_of_row_field sch) fields in
+            let tags =
+              if all_present then None else Some (List.map fst present) in
+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+        end
+    | Tobject (fi, nm) ->
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
+    | Tsubst ty ->
+        tree_of_typexp sch ty
+    | Tlink _ ->
+        fatal_error "Printtyp.tree_of_typexp"
+    | Tpoly (ty, []) ->
+        tree_of_typexp sch ty
+    | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
+        let tyl = List.map repr tyl in
+        if tyl = [] then tree_of_typexp sch ty else begin
+          let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
+          List.iter add_delayed tyl;
+          let tl = List.map name_of_type tyl in
+          let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
+          delayed := old_delayed; tr
+        end
+    | Tunivar _ ->
+        Otyp_var (false, name_of_type ty)
+    | Tpackage (p, n, tyl) ->
+        let n =
+          List.map (fun li -> String.concat "." (Longident.flatten li)) n in
+        Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
+  in
+  if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
+  if is_aliased px && aliasable ty then begin
+    check_name_of_type px;
+    Otyp_alias (pr_typ (), name_of_type px) end
+  else pr_typ ()
+
+and tree_of_row_field sch (l, f) =
+  match row_field_repr f with
+  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+  | Reither(c, tyl, _, _) ->
+      if c (* contradiction: constant constructor with an argument *)
+      then (l, true, tree_of_typlist sch tyl)
+      else (l, false, tree_of_typlist sch tyl)
+  | Rabsent -> (l, false, [] (* actually, an error *))
+
+and tree_of_typlist sch tyl =
+  List.map (tree_of_typexp sch) tyl
+
+and tree_of_typobject sch fi nm =
+  begin match nm with
+  | None ->
+      let pr_fields fi =
+        let (fields, rest) = flatten_fields fi in
+        let present_fields =
+          List.fold_right
+            (fun (n, k, t) l ->
+               match field_kind_repr k with
+               | Fpresent -> (n, t) :: l
+               | _ -> l)
+            fields [] in
+        let sorted_fields =
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
+        tree_of_typfields sch rest sorted_fields in
+      let (fields, rest) = pr_fields fi in
+      Otyp_object (fields, rest)
+  | Some (p, ty :: tyl) ->
+      let non_gen = is_non_gen sch (repr ty) in
+      let args = tree_of_typlist sch tyl in
+      let (p', s) = best_type_path p in
+      assert (s = Id);
+      Otyp_class (non_gen, tree_of_path p', args)
+  | _ ->
+      fatal_error "Printtyp.tree_of_typobject"
+  end
+
+and is_non_gen sch ty =
+    sch && is_Tvar ty && ty.level <> generic_level
+
+and tree_of_typfields sch rest = function
+  | [] ->
+      let rest =
+        match rest.desc with
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
+        | Tconstr _ -> Some false
+        | Tnil -> None
+        | _ -> fatal_error "typfields (1)"
+      in
+      ([], rest)
+  | (s, t) :: l ->
+      let field = (s, tree_of_typexp sch t) in
+      let (fields, rest) = tree_of_typfields sch rest l in
+      (field :: fields, rest)
+
+let typexp sch ppf ty =
+  !Oprint.out_type ppf (tree_of_typexp sch ty)
+
+let type_expr ppf ty = typexp false ppf ty
+
+and type_sch ppf ty = typexp true ppf ty
+
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
+
+(* Maxence *)
+let type_scheme_max ?(b_reset_names=true) ppf ty =
+  if b_reset_names then reset_names () ;
+  typexp true ppf ty
+(* End Maxence *)
+
+let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
+
+(* Print one type declaration *)
+
+let tree_of_constraints params =
+  List.fold_right
+    (fun ty list ->
+       let ty' = unalias ty in
+       if proxy ty != proxy ty' then
+         let tr = tree_of_typexp true ty in
+         (tr, tree_of_typexp true ty') :: list
+       else list)
+    params []
+
+let filter_params tyl =
+  let params =
+    List.fold_left
+      (fun tyl ty ->
+        let ty = repr ty in
+        if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl
+        else ty :: tyl)
+      [] tyl
+  in List.rev params
+
+let mark_loops_constructor_arguments = function
+  | Cstr_tuple l -> List.iter mark_loops l
+  | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
+
+let rec tree_of_type_decl id decl =
+
+  reset();
+
+  let params = filter_params decl.type_params in
+
+  begin match decl.type_manifest with
+  | Some ty ->
+      let vars = free_variables ty in
+      List.iter
+        (function {desc = Tvar (Some "_")} as ty ->
+            if List.memq ty vars then ty.desc <- Tvar None
+          | _ -> ())
+        params
+  | None -> ()
+  end;
+
+  List.iter add_alias params;
+  List.iter mark_loops params;
+  List.iter check_name_of_type (List.map proxy params);
+  let ty_manifest =
+    match decl.type_manifest with
+    | None -> None
+    | Some ty ->
+        let ty =
+          (* Special hack to hide variant name *)
+          match repr ty with {desc=Tvariant row} ->
+            let row = row_repr row in
+            begin match row.row_name with
+              Some (Pident id', _) when Ident.same id id' ->
+                newgenty (Tvariant {row with row_name = None})
+            | _ -> ty
+            end
+          | _ -> ty
+        in
+        mark_loops ty;
+        Some ty
+  in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant cstrs ->
+      List.iter
+        (fun c ->
+           mark_loops_constructor_arguments c.cd_args;
+           may mark_loops c.cd_res)
+        cstrs
+  | Type_record(l, _rep) ->
+      List.iter (fun l -> mark_loops l.ld_type) l
+  | Type_open -> ()
+  end;
+
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let type_defined decl =
+    let abstr =
+      match decl.type_kind with
+        Type_abstract ->
+          decl.type_manifest = None || decl.type_private = Private
+      | Type_record _ ->
+          decl.type_private = Private
+      | Type_variant tll ->
+          decl.type_private = Private ||
+          List.exists (fun cd -> cd.cd_res <> None) tll
+      | Type_open ->
+          decl.type_manifest = None
+    in
+    let vari =
+      List.map2
+        (fun ty v ->
+          if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v
+          else (true,true))
+        decl.type_params decl.type_variance
+    in
+    (Ident.name id,
+     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+       params vari)
+  in
+  let tree_of_manifest ty1 =
+    match ty_manifest with
+    | None -> ty1
+    | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
+  in
+  let (name, args) = type_defined decl in
+  let constraints = tree_of_constraints params in
+  let ty, priv =
+    match decl.type_kind with
+    | Type_abstract ->
+        begin match ty_manifest with
+        | None -> (Otyp_abstract, Public)
+        | Some ty ->
+            tree_of_typexp false ty, decl.type_private
+        end
+    | Type_variant cstrs ->
+        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
+        decl.type_private
+    | Type_record(lbls, _rep) ->
+        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
+        decl.type_private
+    | Type_open ->
+        tree_of_manifest Otyp_open,
+        Public
+  in
+  let immediate =
+    Builtin_attributes.immediate decl.type_attributes
+  in
+    { otype_name = name;
+      otype_params = args;
+      otype_type = ty;
+      otype_private = priv;
+      otype_immediate = immediate;
+      otype_unboxed = decl.type_unboxed.unboxed;
+      otype_cstrs = constraints }
+
+and tree_of_constructor_arguments = function
+  | Cstr_tuple l -> tree_of_typlist false l
+  | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
+
+and tree_of_constructor cd =
+  let name = Ident.name cd.cd_id in
+  let arg () = tree_of_constructor_arguments cd.cd_args in
+  match cd.cd_res with
+  | None -> (name, arg (), None)
+  | Some res ->
+      let nm = !names in
+      names := [];
+      let ret = tree_of_typexp false res in
+      let args = arg () in
+      names := nm;
+      (name, args, Some ret)
+
+and tree_of_label l =
+  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
+
+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 Trec_first)
+
+let constructor_arguments ppf a =
+  let tys = tree_of_constructor_arguments a in
+  !Oprint.out_type ppf (Otyp_tuple tys)
+
+(* Print an extension declaration *)
+
+let tree_of_extension_constructor id ext es =
+  reset ();
+  let ty_name = Path.name ext.ext_type_path in
+  let ty_params = filter_params ext.ext_type_params in
+  List.iter add_alias ty_params;
+  List.iter mark_loops ty_params;
+  List.iter check_name_of_type (List.map proxy ty_params);
+  mark_loops_constructor_arguments ext.ext_args;
+  may mark_loops ext.ext_ret_type;
+  let type_param =
+    function
+    | Otyp_var (_, id) -> id
+    | _ -> "?"
+  in
+  let ty_params =
+    List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params
+  in
+  let name = Ident.name id in
+  let args, ret =
+    match ext.ext_ret_type with
+    | None -> (tree_of_constructor_arguments ext.ext_args, None)
+    | Some res ->
+        let nm = !names in
+        names := [];
+        let ret = tree_of_typexp false res in
+        let args = tree_of_constructor_arguments ext.ext_args in
+        names := nm;
+        (args, Some ret)
+  in
+  let ext =
+    { oext_name = name;
+      oext_type_name = ty_name;
+      oext_type_params = ty_params;
+      oext_args = args;
+      oext_ret_type = ret;
+      oext_private = ext.ext_private }
+  in
+  let es =
+    match es with
+        Text_first -> Oext_first
+      | Text_next -> Oext_next
+      | Text_exception -> Oext_exception
+  in
+    Osig_typext (ext, es)
+
+let extension_constructor id ppf ext =
+  !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
+
+(* Print a value declaration *)
+
+let tree_of_value_description id decl =
+  (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *)
+  let id = Ident.name id in
+  let ty = tree_of_type_scheme decl.val_type in
+  let vd =
+    { oval_name = id;
+      oval_type = ty;
+      oval_prims = [];
+      oval_attributes = [] }
+  in
+  let vd =
+    match decl.val_kind with
+    | Val_prim p -> Primitive.print p vd
+    | _ -> vd
+  in
+  Osig_value vd
+
+let value_description id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_value_description id decl)
+
+(* Print a class type *)
+
+let method_type (_, kind, ty) =
+  match field_kind_repr kind, repr ty with
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
+
+let tree_of_metho sch concrete csil (lab, kind, ty) =
+  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, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
+  end
+  else csil
+
+let rec prepare_class_type params = function
+  | Cty_constr (_p, tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      || List.exists (deep_occur sty) tyl
+      then prepare_class_type params cty
+      else List.iter mark_loops tyl
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      (* Self may have a name *)
+      let px = proxy sty in
+      if List.memq px !visited_objects then add_alias sty
+      else visited_objects := px :: !visited_objects;
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
+  | Cty_arrow (_, ty, cty) ->
+      mark_loops ty;
+      prepare_class_type params cty
+
+let rec tree_of_class_type sch params =
+  function
+  | Cty_constr (p', tyl, cty) ->
+      let sty = Ctype.self_type cty in
+      if List.memq (proxy sty) !visited_objects
+      || not (List.for_all is_Tvar params)
+      then
+        tree_of_class_type sch params cty
+      else
+        Octy_constr (tree_of_path p', tree_of_typlist true tyl)
+  | Cty_signature sign ->
+      let sty = repr sign.csig_self in
+      let self_ty =
+        if is_aliased sty then
+          Some (Otyp_var (false, name_of_type (proxy sty)))
+        else None
+      in
+      let (fields, _) =
+        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+      in
+      let csil = [] in
+      let csil =
+        List.fold_left
+          (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
+          csil (tree_of_constraints params)
+      in
+      let all_vars =
+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars []
+      in
+      (* Consequence of PR#3607: order of Map.fold has changed! *)
+      let all_vars = List.rev all_vars in
+      let csil =
+        List.fold_left
+          (fun csil (l, m, v, t) ->
+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
+            :: csil)
+          csil all_vars
+      in
+      let csil =
+        List.fold_left (tree_of_metho sch sign.csig_concr) csil fields
+      in
+      Octy_signature (self_ty, List.rev csil)
+  | Cty_arrow (l, ty, cty) ->
+      let lab =
+        if !print_labels || is_optional l then string_of_label l else ""
+      in
+      let ty =
+       if is_optional l then
+         match (repr ty).desc with
+         | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
+         | _ -> newconstr (Path.Pident(Ident.create "")) []
+       else ty in
+      let tr = tree_of_typexp sch ty in
+      Octy_arrow (lab, tr, tree_of_class_type sch params cty)
+
+let class_type ppf cty =
+  reset ();
+  prepare_class_type [] cty;
+  !Oprint.out_class_type ppf (tree_of_class_type false [] cty)
+
+let tree_of_class_param param variance =
+  (match tree_of_typexp true param with
+    Otyp_var (_, s) -> s
+  | _ -> "?"),
+  if is_Tvar (repr param) then (true, true) else variance
+
+let class_variance =
+  List.map Variance.(fun v -> mem May_pos v, mem May_neg v)
+
+let tree_of_class_declaration id cl rs =
+  let params = filter_params cl.cty_params in
+
+  reset ();
+  List.iter add_alias params;
+  prepare_class_type params cl.cty_type;
+  let sty = Ctype.self_type cl.cty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let vir_flag = cl.cty_new = None in
+  Osig_class
+    (vir_flag, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
+     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 Trec_first)
+
+let tree_of_cltype_declaration id cl rs =
+  let params = List.map repr cl.clty_params in
+
+  reset ();
+  List.iter add_alias params;
+  prepare_class_type params cl.clty_type;
+  let sty = Ctype.self_type cl.clty_type in
+  List.iter mark_loops params;
+
+  List.iter check_name_of_type (List.map proxy params);
+  if is_aliased sty then check_name_of_type (proxy sty);
+
+  let sign = Ctype.signature_of_class_type cl.clty_type in
+
+  let virt =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
+    List.exists
+      (fun (lab, _, _) ->
+         not (lab = dummy_method || Concr.mem lab sign.csig_concr))
+      fields
+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
+  in
+
+  Osig_class_type
+    (virt, Ident.name id,
+     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
+     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 Trec_first)
+
+(* Print a module type *)
+
+let wrap_env fenv ftree arg =
+  let env = !printing_env in
+  set_printing_env (fenv env);
+  let tree = ftree arg in
+  set_printing_env env;
+  tree
+
+let filter_rem_sig item rem =
+  match item, rem with
+  | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem ->
+      ([ctydecl; tydecl1; tydecl2], rem)
+  | Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
+      ([tydecl1; tydecl2], rem)
+  | _ ->
+      ([], rem)
+
+let dummy =
+  { type_params = []; type_arity = 0; type_kind = Type_abstract;
+    type_private = Public; type_manifest = None; type_variance = [];
+    type_newtype_level = None; type_loc = Location.none;
+    type_attributes = [];
+    type_immediate = false;
+    type_unboxed = unboxed_false_default_false;
+  }
+
+let hide_rec_items = function
+  | Sig_type(id, _decl, rs) ::rem
+    when rs = Trec_first && not !Clflags.real_paths ->
+      let rec get_ids = function
+          Sig_type (id, _, Trec_next) :: rem ->
+            id :: get_ids rem
+        | _ -> []
+      in
+      let ids = id :: get_ids rem in
+      set_printing_env
+        (List.fold_right
+           (fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
+           ids !printing_env)
+  | _ -> ()
+
+let rec tree_of_modtype ?(ellipsis=false) = function
+  | Mty_ident p ->
+      Omty_ident (tree_of_path p)
+  | Mty_signature sg ->
+      Omty_signature (if ellipsis then [Osig_ellipsis]
+                      else tree_of_signature sg)
+  | Mty_functor(param, ty_arg, ty_res) ->
+      let res =
+        match ty_arg with None -> tree_of_modtype ~ellipsis ty_res
+        | Some mty ->
+            wrap_env (Env.add_module ~arg:true param mty)
+                     (tree_of_modtype ~ellipsis) ty_res
+      in
+      Omty_functor (Ident.name param,
+                    may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
+  | Mty_alias(_, p) ->
+      Omty_alias (tree_of_path p)
+
+and tree_of_signature sg =
+  wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg
+
+and tree_of_signature_rec env' in_type_group = function
+    [] -> []
+  | item :: rem as items ->
+      let in_type_group =
+        match in_type_group, item with
+          true, Sig_type (_, _, Trec_next) -> true
+        | _, Sig_type (_, _, (Trec_not | Trec_first)) ->
+            set_printing_env env'; true
+        | _ -> set_printing_env env'; false
+      in
+      let (sg, rem) = filter_rem_sig item rem in
+      hide_rec_items items;
+      let trees = trees_of_sigitem item in
+      let env' = Env.add_signature (item :: sg) env' in
+      trees @ tree_of_signature_rec env' in_type_group rem
+
+and trees_of_sigitem = function
+  | Sig_value(id, decl) ->
+      [tree_of_value_description id decl]
+  | Sig_type(id, _, _) when is_row_name (Ident.name id) ->
+      []
+  | Sig_type(id, decl, rs) ->
+      [tree_of_type_declaration id decl rs]
+  | Sig_typext(id, ext, es) ->
+      [tree_of_extension_constructor id ext es]
+  | Sig_module(id, md, rs) ->
+      let ellipsis =
+        List.exists (function ({txt="..."}, Parsetree.PStr []) -> true
+                            | _ -> false)
+          md.md_attributes in
+      [tree_of_module id md.md_type rs ~ellipsis]
+  | Sig_modtype(id, decl) ->
+      [tree_of_modtype_declaration id decl]
+  | Sig_class(id, decl, rs) ->
+      [tree_of_class_declaration id decl rs]
+  | Sig_class_type(id, decl, rs) ->
+      [tree_of_cltype_declaration id decl rs]
+
+and tree_of_modtype_declaration id decl =
+  let mty =
+    match decl.mtd_type with
+    | None -> Omty_abstract
+    | Some mty -> tree_of_modtype mty
+  in
+  Osig_modtype (Ident.name id, mty)
+
+and tree_of_module id ?ellipsis mty rs =
+  Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs)
+
+let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
+let modtype_declaration id ppf decl =
+  !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
+
+(* For the toplevel: merge with tree_of_signature? *)
+let rec print_items showval env = function
+  | [] -> []
+  | item :: rem as items ->
+      let (_sg, rem) = filter_rem_sig item rem in
+      hide_rec_items items;
+      let trees = trees_of_sigitem item in
+      List.map (fun d -> (d, showval env item)) trees @
+      print_items showval env rem
+
+(* Print a signature body (used by -i when compiling a .ml) *)
+
+let print_signature ppf tree =
+  fprintf ppf "@[%a@]" !Oprint.out_signature tree
+
+let signature ppf sg =
+  fprintf ppf "%a" print_signature (tree_of_signature sg)
+
+(* Print an unification error *)
+
+let same_path t t' =
+  let t = repr t and t' = repr t' in
+  t == t' ||
+  match t.desc, t'.desc with
+    Tconstr(p,tl,_), Tconstr(p',tl',_) ->
+      let (p1, s1) = best_type_path p and (p2, s2)  = best_type_path p' in
+      begin match s1, s2 with
+        Nth n1, Nth n2 when n1 = n2 -> true
+      | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
+          let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
+          List.length tl = List.length tl' &&
+          List.for_all2 same_type tl tl'
+      | _ -> false
+      end
+  | _ ->
+      false
+
+let type_expansion t ppf t' =
+  if same_path t t'
+  then begin add_delayed (proxy t); type_expr ppf t end
+  else
+  let t' = if proxy t == proxy t' then unalias t' else t' in
+  fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
+
+let type_path_expansion tp ppf tp' =
+  if Path.same tp tp' then path ppf tp else
+  fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'
+
+let rec trace fst txt ppf = function
+  | (t1, t1') :: (t2, t2') :: rem ->
+      if not fst then fprintf ppf "@,";
+      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
+       (type_expansion t1) t1' txt (type_expansion t2) t2'
+       (trace false txt) rem
+  | _ -> ()
+
+let rec filter_trace keep_last = function
+  | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' ->
+      []
+  | (t1, t1') :: (t2, t2') :: rem ->
+      let rem' = filter_trace keep_last rem in
+      if is_constr_row ~allow_ident:true t1'
+      || is_constr_row ~allow_ident:true t2'
+      || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])
+      then rem'
+      else (t1, t1') :: (t2, t2') :: rem'
+  | _ -> []
+
+let rec type_path_list ppf = function
+  | [tp, tp'] -> type_path_expansion tp ppf tp'
+  | (tp, tp') :: rem ->
+      fprintf ppf "%a@;<2 0>%a"
+        (type_path_expansion tp) tp'
+        type_path_list rem
+  | [] -> ()
+
+(* Hide variant name and var, to force printing the expanded type *)
+let hide_variant_name t =
+  match repr t with
+  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+      newty2 t.level
+        (Tvariant {(row_repr row) with row_name = None;
+                   row_more = newvar2 (row_more row).level})
+  | _ -> t
+
+let prepare_expansion (t, t') =
+  let t' = hide_variant_name t' in
+  mark_loops t;
+  if not (same_path 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 t3 t4 =
+  match t3.desc, t4.desc with
+    Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
+  | Tnil, Tconstr _ | Tconstr _, Tnil
+  | _, Tvar _ | Tvar _, _
+  | Tvariant _, Tvariant _ -> true
+  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
+  | _ -> false
+
+let rec mismatch = function
+    (_, t) :: (_, t') :: rem ->
+      begin match mismatch rem with
+        Some _ as m -> m
+      | None ->
+          if has_explanation t t' then Some(t,t') else None
+      end
+  | [] -> None
+  | _ -> assert false
+
+let explanation unif t3 t4 ppf =
+  match t3.desc, t4.desc with
+  | Ttuple [], Tvar _ | Tvar _, Ttuple [] ->
+      fprintf ppf "@,Self type cannot escape its class"
+  | Tconstr (p, _, _), Tvar _
+    when unif && t4.level < Path.binding_time p ->
+      fprintf ppf
+        "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+        path p
+  | Tvar _, Tconstr (p, _, _)
+    when unif && t3.level < Path.binding_time p ->
+      fprintf ppf
+        "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+        path p
+  | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
+      fprintf ppf "@,The universal variable %a would escape its scope"
+        type_expr (if is_Tunivar t3 then t3 else t4)
+  | Tvar _, _ | _, Tvar _ ->
+      let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in
+      if occur_in Env.empty t t' then
+        fprintf ppf "@,@[The type variable %a occurs inside@ %a@]"
+          type_expr t type_expr t'
+      else
+        fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]"
+          type_expr t'
+          "it would escape the scope of its equation"
+  | Tfield (lab, _, _, _), _ when lab = dummy_method ->
+      fprintf ppf
+        "@,Self type cannot be unified with a closed object type"
+  | _, Tfield (lab, _, _, _) when lab = dummy_method ->
+      fprintf ppf
+        "@,Self type cannot be unified with a closed object type"
+  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' ->
+      fprintf ppf "@,Types for method %s are incompatible" l
+  | (Tnil|Tconstr _), Tfield (l, _, _, _) ->
+      fprintf ppf
+        "@,@[The first object type has no method %s@]" l
+  | Tfield (l, _, _, _), (Tnil|Tconstr _) ->
+      fprintf ppf
+        "@,@[The second object type has no method %s@]" l
+  | Tnil, Tconstr _ | Tconstr _, Tnil ->
+      fprintf ppf
+        "@,@[The %s object type has an abstract row, it cannot be closed@]"
+        (if t4.desc = Tnil then "first" else "second")
+  | Tvariant row1, Tvariant row2 ->
+      let row1 = row_repr row1 and row2 = row_repr row2 in
+      begin match
+        row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with
+      | [], true, [], true ->
+          fprintf ppf "@,These two variant types have no intersection"
+      | [], true, (_::_ as fields), _ ->
+          fprintf ppf
+            "@,@[The first variant type does not allow tag(s)@ @[%a@]@]"
+            print_tags fields
+      | (_::_ as fields), _, [], true ->
+          fprintf ppf
+            "@,@[The second variant type does not allow tag(s)@ @[%a@]@]"
+            print_tags fields
+      | [l1,_], true, [l2,_], true when l1 = l2 ->
+          fprintf ppf "@,Types for tag `%s are incompatible" l1
+      | _ -> ()
+      end
+  | _ -> ()
+
+
+let warn_on_missing_def env ppf t =
+  match t.desc with
+  | Tconstr (p,_,_) ->
+    begin
+      try
+        ignore(Env.find_type p env : Types.type_declaration)
+      with Not_found ->
+        fprintf ppf
+          "@,@[%a is abstract because no corresponding cmi file was found \
+           in path.@]" path p
+    end
+  | _ -> ()
+
+let explanation unif mis ppf =
+  match mis with
+    None -> ()
+  | Some (t3, t4) -> explanation unif t3 t4 ppf
+
+let ident_same_name id1 id2 =
+  if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin
+    add_unique id1; add_unique id2
+  end
+
+let rec path_same_name p1 p2 =
+  match p1, p2 with
+    Pident id1, Pident id2 -> ident_same_name id1 id2
+  | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2
+  | Papply (p1, p1'), Papply (p2, p2') ->
+      path_same_name p1 p2; path_same_name p1' p2'
+  | _ -> ()
+
+let type_same_name t1 t2 =
+  match (repr t1).desc, (repr t2).desc with
+    Tconstr (p1, _, _), Tconstr (p2, _, _) ->
+      path_same_name (fst (best_type_path p1)) (fst (best_type_path p2))
+  | _ -> ()
+
+let rec trace_same_names = function
+    (t1, t1') :: (t2, t2') :: rem ->
+      type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem
+  | _ -> ()
+
+let unification_error env unif tr txt1 ppf txt2 =
+  reset ();
+  trace_same_names tr;
+  let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
+  let mis = mismatch tr in
+  match tr with
+  | [] | _ :: [] -> assert false
+  | t1 :: t2 :: tr ->
+    try
+      let tr = filter_trace (mis = None) 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
+        "@[\
+          @[%t@;<1 2>%a@ \
+            %t@;<1 2>%a\
+          @]%a%t\
+         @]"
+        txt1 (type_expansion t1) t1'
+        txt2 (type_expansion t2) t2'
+        (trace false "is not compatible with type") tr
+        (explanation unif mis);
+      if env <> Env.empty
+      then begin
+        warn_on_missing_def env ppf t1;
+        warn_on_missing_def env ppf t2
+      end;
+      print_labels := true
+    with exn ->
+      print_labels := true;
+      raise exn
+
+let report_unification_error ppf env ?(unif=true)
+    tr txt1 txt2 =
+  wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2)
+;;
+
+let trace fst keep_last txt ppf tr =
+  print_labels := not !Clflags.classic;
+  trace_same_names tr;
+  try match tr with
+    t1 :: t2 :: tr' ->
+      if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
+      else trace fst txt ppf (filter_trace keep_last tr);
+      print_labels := true
+  | _ -> ()
+  with exn ->
+    print_labels := true;
+    raise exn
+
+let report_subtyping_error ppf env tr1 txt1 tr2 =
+  wrap_printing_env env (fun () ->
+    reset ();
+    let tr1 = List.map prepare_expansion tr1
+    and tr2 = List.map prepare_expansion tr2 in
+    fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1;
+    if tr2 = [] then fprintf ppf "@]" else
+    let mis = mismatch tr2 in
+    fprintf ppf "%a%t@]"
+      (trace false (mis = None) "is not compatible with type") tr2
+      (explanation true mis))
+
+let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
+  wrap_printing_env env (fun () ->
+    reset ();
+    List.iter
+      (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
+      tpl;
+    match tpl with
+      [] -> assert false
+    | [tp, tp'] ->
+        fprintf ppf
+          "@[%t@;<1 2>%a@ \
+             %t@;<1 2>%a\
+           @]"
+          txt1 (type_path_expansion tp) tp'
+          txt3 (type_path_expansion tp0) tp0'
+    | _ ->
+        fprintf ppf
+          "@[%t@;<1 2>@[%a@]\
+             @ %t@;<1 2>%a\
+           @]"
+          txt2 type_path_list tpl
+          txt3 (type_path_expansion tp0) tp0')
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
new file mode 100644
index 00000000..8fd027ec
--- /dev/null
+++ b/typing/printtyp.mli
@@ -0,0 +1,90 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Printing functions *)
+
+open Format
+open Types
+open Outcometree
+
+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 string_of_path: Path.t -> string
+val raw_type_expr: formatter -> type_expr -> unit
+val string_of_label: Asttypes.arg_label -> string
+
+val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a
+    (* Call the function using the environment for type path shortening *)
+    (* This affects all the printing functions below *)
+
+val reset: unit -> unit
+val mark_loops: type_expr -> unit
+val reset_and_mark_loops: type_expr -> unit
+val reset_and_mark_loops_list: type_expr list -> unit
+val type_expr: formatter -> type_expr -> unit
+val constructor_arguments: formatter -> constructor_arguments -> unit
+val tree_of_type_scheme: type_expr -> out_type
+val type_sch : formatter -> type_expr -> unit
+val type_scheme: formatter -> type_expr -> unit
+(* Maxence *)
+val reset_names: unit -> unit
+val type_scheme_max: ?b_reset_names: bool ->
+        formatter -> type_expr -> unit
+(* End 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 -> rec_status -> out_sig_item
+val type_declaration: Ident.t -> formatter -> type_declaration -> unit
+val tree_of_extension_constructor:
+    Ident.t -> extension_constructor -> ext_status -> out_sig_item
+val extension_constructor:
+    Ident.t -> formatter -> extension_constructor -> unit
+val tree_of_module:
+    Ident.t -> ?ellipsis:bool -> 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 tree_of_signature: Types.signature -> out_sig_item list
+val tree_of_typexp: bool -> type_expr -> out_type
+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 -> rec_status -> out_sig_item
+val class_declaration: Ident.t -> formatter -> class_declaration -> unit
+val tree_of_cltype_declaration:
+    Ident.t -> class_type_declaration -> rec_status -> out_sig_item
+val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
+val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
+val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
+val trace:
+    bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit
+val report_unification_error:
+    formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
+    (formatter -> unit) -> (formatter -> unit) ->
+    unit
+val report_subtyping_error:
+    formatter -> Env.t -> (type_expr * type_expr) list ->
+    string -> (type_expr * type_expr) list -> unit
+val report_ambiguous_type_error:
+    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+(* for toploop *)
+val print_items: (Env.t -> signature_item -> 'a option) ->
+  Env.t -> signature_item list -> (out_sig_item * 'a option) list
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
new file mode 100644
index 00000000..78e1b60a
--- /dev/null
+++ b/typing/printtyped.ml
@@ -0,0 +1,871 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes;;
+open Format;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let fmt_position f l =
+  if l.pos_lnum = -1
+  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+               (l.pos_cnum - l.pos_bol)
+;;
+
+let fmt_location f loc =
+  fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+  if loc.loc_ghost then fprintf f " ghost";
+;;
+
+let rec fmt_longident_aux f x =
+  match x with
+  | Longident.Lident (s) -> fprintf f "%s" s;
+  | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+  | Longident.Lapply (y, z) ->
+      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+;;
+
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+
+let fmt_ident = Ident.print
+
+let rec fmt_path_aux f x =
+  match x with
+  | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
+  | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s;
+  | Path.Papply (y, z) ->
+      fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z;
+;;
+
+let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;
+
+let fmt_constant f x =
+  match x with
+  | Const_int (i) -> fprintf f "Const_int %d" i;
+  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
+  | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
+  | Const_string (s, Some delim) ->
+      fprintf f "Const_string (%S,Some %S)" s delim;
+  | Const_float (s) -> fprintf f "Const_float %s" s;
+  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
+  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
+  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
+;;
+
+let fmt_mutable_flag f x =
+  match x with
+  | Immutable -> fprintf f "Immutable";
+  | Mutable -> fprintf f "Mutable";
+;;
+
+let fmt_virtual_flag f x =
+  match x with
+  | Virtual -> fprintf f "Virtual";
+  | Concrete -> fprintf f "Concrete";
+;;
+
+let fmt_override_flag f x =
+  match x with
+  | Override -> fprintf f "Override";
+  | Fresh -> fprintf f "Fresh";
+;;
+
+let fmt_closed_flag f x =
+  match x with
+  | Closed -> fprintf f "Closed"
+  | Open -> fprintf f "Open"
+
+let fmt_rec_flag f x =
+  match x with
+  | Nonrecursive -> fprintf f "Nonrec";
+  | Recursive -> fprintf f "Rec";
+;;
+
+let fmt_direction_flag f x =
+  match x with
+  | Upto -> fprintf f "Up";
+  | Downto -> fprintf f "Down";
+;;
+
+let fmt_private_flag f x =
+  match x with
+  | Public -> fprintf f "Public";
+  | Private -> fprintf f "Private";
+;;
+
+let line i f s (*...*) =
+  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f s (*...*)
+;;
+
+let list i f ppf l =
+  match l with
+  | [] -> line i ppf "[]\n";
+  | _ :: _ ->
+     line i ppf "[\n";
+     List.iter (f (i+1) ppf) l;
+     line i ppf "]\n";
+;;
+
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
+let option i f ppf x =
+  match x with
+  | None -> line i ppf "None\n";
+  | Some x ->
+      line i ppf "Some\n";
+      f (i+1) ppf x;
+;;
+
+let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let arg_label i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional s -> line i ppf "Optional \"%s\"\n" s
+  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
+;;
+
+let attributes i ppf l =
+  let i = i + 1 in
+  List.iter
+    (fun (s, arg) ->
+      line i ppf "attribute \"%s\"\n" s.txt;
+      Printast.payload (i + 1) ppf arg;
+    )
+    l
+
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
+  attributes i ppf x.ctyp_attributes;
+  let i = i+1 in
+  match x.ctyp_desc with
+  | Ttyp_any -> line i ppf "Ttyp_any\n";
+  | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
+  | Ttyp_arrow (l, ct1, ct2) ->
+      line i ppf "Ttyp_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
+  | Ttyp_tuple l ->
+      line i ppf "Ttyp_tuple\n";
+      list i core_type ppf l;
+  | Ttyp_constr (li, _, l) ->
+      line i ppf "Ttyp_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_variant (l, closed, low) ->
+      line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed;
+      list i label_x_bool_x_core_type_list ppf l;
+      option i (fun i -> list i string) ppf low
+  | Ttyp_object (l, c) ->
+      line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
+      let i = i + 1 in
+      List.iter
+        (fun (s, attrs, t) ->
+          line i ppf "method %s\n" s;
+          attributes i ppf attrs;
+          core_type (i + 1) ppf t
+        )
+        l
+  | Ttyp_class (li, _, l) ->
+      line i ppf "Ttyp_class %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Ttyp_alias (ct, s) ->
+      line i ppf "Ttyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
+  | Ttyp_poly (sl, ct) ->
+      line i ppf "Ttyp_poly%a\n"
+        (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
+      core_type i ppf ct;
+  | Ttyp_package { pack_path = s; pack_fields = l } ->
+      line i ppf "Ttyp_package %a\n" fmt_path s;
+      list i package_with ppf l;
+
+and package_with i ppf (s, t) =
+  line i ppf "with type %a\n" fmt_longident s;
+  core_type i ppf t
+
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.pat_loc;
+  attributes i ppf x.pat_attributes;
+  let i = i+1 in
+  match x.pat_extra with
+    | (Tpat_unpack, _, attrs) :: rem ->
+        line i ppf "Tpat_unpack\n";
+        attributes i ppf attrs;
+        pattern i ppf { x with pat_extra = rem }
+    | (Tpat_constraint cty, _, attrs) :: rem ->
+        line i ppf "Tpat_constraint\n";
+        attributes i ppf attrs;
+        core_type i ppf cty;
+        pattern i ppf { x with pat_extra = rem }
+    | (Tpat_type (id, _), _, attrs) :: rem ->
+        line i ppf "Tpat_type %a\n" fmt_path id;
+        attributes i ppf attrs;
+        pattern i ppf { x with pat_extra = rem }
+    | (Tpat_open (id,_,_), _, attrs)::rem ->
+        line i ppf "Tpat_open \"%a\"\n" fmt_path id;
+        attributes i ppf attrs;
+        pattern i ppf { x with pat_extra = rem }
+    | [] ->
+  match x.pat_desc with
+  | Tpat_any -> line i ppf "Tpat_any\n";
+  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_) ->
+      line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
+      pattern i ppf p;
+  | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
+  | Tpat_tuple (l) ->
+      line i ppf "Tpat_tuple\n";
+      list i pattern ppf l;
+  | Tpat_construct (li, _, po) ->
+      line i ppf "Tpat_construct %a\n" fmt_longident li;
+      list i pattern ppf po;
+  | Tpat_variant (l, po, _) ->
+      line i ppf "Tpat_variant \"%s\"\n" l;
+      option i pattern ppf po;
+  | Tpat_record (l, _c) ->
+      line i ppf "Tpat_record\n";
+      list i longident_x_pattern ppf l;
+  | Tpat_array (l) ->
+      line i ppf "Tpat_array\n";
+      list i pattern ppf l;
+  | Tpat_or (p1, p2, _) ->
+      line i ppf "Tpat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
+  | Tpat_lazy p ->
+      line i ppf "Tpat_lazy\n";
+      pattern i ppf p;
+
+and expression_extra i ppf x attrs =
+  match x with
+  | Texp_constraint ct ->
+      line i ppf "Texp_constraint\n";
+      attributes i ppf attrs;
+      core_type i ppf ct;
+  | Texp_coerce (cto1, cto2) ->
+      line i ppf "Texp_coerce\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto1;
+      core_type i ppf cto2;
+  | Texp_open (ovf, m, _, _) ->
+      line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+      attributes i ppf attrs;
+  | Texp_poly cto ->
+      line i ppf "Texp_poly\n";
+      attributes i ppf attrs;
+      option i core_type ppf cto;
+  | Texp_newtype s ->
+      line i ppf "Texp_newtype \"%s\"\n" s;
+      attributes i ppf attrs;
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.exp_loc;
+  attributes i ppf x.exp_attributes;
+  let i =
+    List.fold_left (fun i (extra,_,attrs) ->
+                      expression_extra i ppf extra attrs; i+1)
+      (i+1) x.exp_extra
+  in
+  match x.exp_desc with
+  | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li;
+  | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li;
+  | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c;
+  | Texp_let (rf, l, e) ->
+      line i ppf "Texp_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+      expression i ppf e;
+  | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
+      line i ppf "Texp_function\n";
+      arg_label i ppf p;
+      list i case ppf cases;
+  | Texp_apply (e, l) ->
+      line i ppf "Texp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
+  | Texp_match (e, l1, l2, _partial) ->
+      line i ppf "Texp_match\n";
+      expression i ppf e;
+      list i case ppf l1;
+      list i case ppf l2;
+  | Texp_try (e, l) ->
+      line i ppf "Texp_try\n";
+      expression i ppf e;
+      list i case ppf l;
+  | Texp_tuple (l) ->
+      line i ppf "Texp_tuple\n";
+      list i expression ppf l;
+  | Texp_construct (li, _, eo) ->
+      line i ppf "Texp_construct %a\n" fmt_longident li;
+      list i expression ppf eo;
+  | Texp_variant (l, eo) ->
+      line i ppf "Texp_variant \"%s\"\n" l;
+      option i expression ppf eo;
+  | Texp_record { fields; extended_expression; _ } ->
+      line i ppf "Texp_record\n";
+      array i record_field ppf fields;
+      option i expression ppf extended_expression;
+  | Texp_field (e, li, _) ->
+      line i ppf "Texp_field\n";
+      expression i ppf e;
+      longident i ppf li;
+  | Texp_setfield (e1, li, _, e2) ->
+      line i ppf "Texp_setfield\n";
+      expression i ppf e1;
+      longident i ppf li;
+      expression i ppf e2;
+  | Texp_array (l) ->
+      line i ppf "Texp_array\n";
+      list i expression ppf l;
+  | Texp_ifthenelse (e1, e2, eo) ->
+      line i ppf "Texp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
+  | Texp_sequence (e1, e2) ->
+      line i ppf "Texp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_while (e1, e2) ->
+      line i ppf "Texp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
+  | Texp_for (s, _, e1, e2, df, e3) ->
+      line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
+  | Texp_send (e, Tmeth_name s, eo) ->
+      line i ppf "Texp_send \"%s\"\n" s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_send (e, Tmeth_val s, eo) ->
+      line i ppf "Texp_send \"%a\"\n" fmt_ident s;
+      expression i ppf e;
+      option i expression ppf eo
+  | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
+  | Texp_setinstvar (_, s, _, e) ->
+      line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
+      expression i ppf e;
+  | Texp_override (_, l) ->
+      line i ppf "Texp_override\n";
+      list i string_x_expression ppf l;
+  | Texp_letmodule (s, _, me, e) ->
+      line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
+      module_expr i ppf me;
+      expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
+  | Texp_assert (e) ->
+      line i ppf "Texp_assert";
+      expression i ppf e;
+  | Texp_lazy (e) ->
+      line i ppf "Texp_lazy";
+      expression i ppf e;
+  | Texp_object (s, _) ->
+      line i ppf "Texp_object";
+      class_structure i ppf s
+  | Texp_pack me ->
+      line i ppf "Texp_pack";
+      module_expr i ppf me
+  | Texp_unreachable ->
+      line i ppf "Texp_unreachable"
+  | Texp_extension_constructor (li, _) ->
+      line i ppf "Texp_extension_constructor %a" fmt_longident li
+
+and value_description i ppf x =
+  line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location
+       x.val_loc;
+  attributes i ppf x.val_attributes;
+  core_type (i+1) ppf x.val_desc;
+  list (i+1) string ppf x.val_prim;
+
+and type_parameter i ppf (x, _variance) = core_type i ppf x
+
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location
+       x.typ_loc;
+  attributes i ppf x.typ_attributes;
+  let i = i+1 in
+  line i ppf "ptype_params =\n";
+  list (i+1) type_parameter ppf x.typ_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.typ_kind;
+  line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.typ_manifest;
+
+and type_kind i ppf x =
+  match x with
+  | Ttype_abstract ->
+      line i ppf "Ttype_abstract\n"
+  | Ttype_variant l ->
+      line i ppf "Ttype_variant\n";
+      list (i+1) constructor_decl ppf l;
+  | Ttype_record l ->
+      line i ppf "Ttype_record\n";
+      list (i+1) label_decl ppf l;
+  | Ttype_open ->
+      line i ppf "Ttype_open\n"
+
+and type_extension i ppf x =
+  line i ppf "type_extension\n";
+  attributes i ppf x.tyext_attributes;
+  let i = i+1 in
+  line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path;
+  line i ppf "ptyext_params =\n";
+  list (i+1) type_parameter ppf x.tyext_params;
+  line i ppf "ptyext_constructors =\n";
+  list (i+1) extension_constructor ppf x.tyext_constructors;
+  line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private;
+
+and extension_constructor i ppf x =
+  line i ppf "extension_constructor %a\n" fmt_location x.ext_loc;
+  attributes i ppf x.ext_attributes;
+  let i = i + 1 in
+  line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id;
+  line i ppf "pext_kind =\n";
+  extension_constructor_kind (i + 1) ppf x.ext_kind;
+
+and extension_constructor_kind i ppf x =
+  match x with
+      Text_decl(a, r) ->
+        line i ppf "Text_decl\n";
+        constructor_arguments (i+1) ppf a;
+        option (i+1) core_type ppf r;
+    | Text_rebind(p, _) ->
+        line i ppf "Text_rebind\n";
+        line (i+1) ppf "%a\n" fmt_path p;
+
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+  attributes i ppf x.cltyp_attributes;
+  let i = i+1 in
+  match x.cltyp_desc with
+  | Tcty_constr (li, _, l) ->
+      line i ppf "Tcty_constr %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcty_signature (cs) ->
+      line i ppf "Tcty_signature\n";
+      class_signature i ppf cs;
+  | Tcty_arrow (l, co, cl) ->
+      line i ppf "Tcty_arrow\n";
+      arg_label i ppf l;
+      core_type i ppf co;
+      class_type i ppf cl;
+
+and class_signature i ppf { csig_self = ct; csig_fields = l } =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf ct;
+  list (i+1) class_type_field ppf l;
+
+and class_type_field i ppf x =
+  line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+  let i = i+1 in
+  attributes i ppf x.ctf_attributes;
+  match x.ctf_desc with
+  | Tctf_inherit (ct) ->
+      line i ppf "Tctf_inherit\n";
+      class_type i ppf ct;
+  | Tctf_val (s, mf, vf, ct) ->
+      line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_method (s, pf, vf, ct) ->
+      line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf
+           fmt_virtual_flag vf;
+      core_type (i+1) ppf ct;
+  | Tctf_constraint (ct1, ct2) ->
+      line i ppf "Tctf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tctf_attribute (s, arg) ->
+      line i ppf "Tctf_attribute \"%s\"\n" s.txt;
+      Printast.payload i ppf arg
+
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.ci_loc;
+  attributes i ppf x.ci_attributes;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.ci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+  attributes i ppf x.cl_attributes;
+  let i = i+1 in
+  match x.cl_desc with
+  | Tcl_ident (li, _, l) ->
+      line i ppf "Tcl_ident %a\n" fmt_path li;
+      list i core_type ppf l;
+  | Tcl_structure (cs) ->
+      line i ppf "Tcl_structure\n";
+      class_structure i ppf cs;
+  | Tcl_fun (l, p, _, ce, _) ->
+      line i ppf "Tcl_fun\n";
+      arg_label i ppf l;
+      pattern i ppf p;
+      class_expr i ppf ce
+  | Tcl_apply (ce, l) ->
+      line i ppf "Tcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
+  | Tcl_let (rf, l1, l2, ce) ->
+      line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l1;
+      list i ident_x_loc_x_expression_def ppf l2;
+      class_expr i ppf ce;
+  | Tcl_constraint (ce, Some ct, _, _, _) ->
+      line i ppf "Tcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct
+  | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+
+and class_structure i ppf { cstr_self = p; cstr_fields = l } =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
+
+and class_field i ppf x =
+  line i ppf "class_field %a\n" fmt_location x.cf_loc;
+  let i = i + 1 in
+  attributes i ppf x.cf_attributes;
+  match x.cf_desc with
+  | Tcf_inherit (ovf, ce, so, _, _) ->
+      line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf;
+      class_expr (i+1) ppf ce;
+      option (i+1) string ppf so;
+  | Tcf_val (s, mf, _, k, _) ->
+      line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf;
+      class_field_kind (i+1) ppf k
+  | Tcf_method (s, pf, k) ->
+      line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf;
+      class_field_kind (i+1) ppf k
+  | Tcf_constraint (ct1, ct2) ->
+      line i ppf "Tcf_constraint\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
+  | Tcf_initializer (e) ->
+      line i ppf "Tcf_initializer\n";
+      expression (i+1) ppf e;
+  | Tcf_attribute (s, arg) ->
+      line i ppf "Tcf_attribute \"%s\"\n" s.txt;
+      Printast.payload i ppf arg
+
+and class_field_kind i ppf = function
+  | Tcfk_concrete (o, e) ->
+      line i ppf "Concrete %a\n" fmt_override_flag o;
+      expression i ppf e
+  | Tcfk_virtual t ->
+      line i ppf "Virtual\n";
+      core_type i ppf t
+
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.ci_loc;
+  let i = i+1 in
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
+  line i ppf "pci_params =\n";
+  list (i+1) type_parameter ppf x.ci_params;
+  line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.ci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.mty_loc;
+  attributes i ppf x.mty_attributes;
+  let i = i+1 in
+  match x.mty_desc with
+  | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li;
+  | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li;
+  | Tmty_signature (s) ->
+      line i ppf "Tmty_signature\n";
+      signature i ppf s;
+  | Tmty_functor (s, _, mt1, mt2) ->
+      line i ppf "Tmty_functor \"%a\"\n" fmt_ident s;
+      Misc.may (module_type i ppf) mt1;
+      module_type i ppf mt2;
+  | Tmty_with (mt, l) ->
+      line i ppf "Tmty_with\n";
+      module_type i ppf mt;
+      list i longident_x_with_constraint ppf l;
+  | Tmty_typeof m ->
+      line i ppf "Tmty_typeof\n";
+      module_expr i ppf m;
+
+and signature i ppf x = list i signature_item ppf x.sig_items
+
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.sig_loc;
+  let i = i+1 in
+  match x.sig_desc with
+  | Tsig_value vd ->
+      line i ppf "Tsig_value\n";
+      value_description i ppf vd;
+  | Tsig_type (rf, l) ->
+      line i ppf "Tsig_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tsig_typext e ->
+      line i ppf "Tsig_typext\n";
+      type_extension i ppf e;
+  | Tsig_exception ext ->
+      line i ppf "Tsig_exception\n";
+      extension_constructor i ppf ext
+  | Tsig_module md ->
+      line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id;
+      attributes i ppf md.md_attributes;
+      module_type i ppf md.md_type
+  | Tsig_recmodule decls ->
+      line i ppf "Tsig_recmodule\n";
+      list i module_declaration ppf decls;
+  | Tsig_modtype x ->
+      line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tsig_open od ->
+      line i ppf "Tsig_open %a %a\n"
+           fmt_override_flag od.open_override
+           fmt_path od.open_path;
+      attributes i ppf od.open_attributes
+  | Tsig_include incl ->
+      line i ppf "Tsig_include\n";
+      attributes i ppf incl.incl_attributes;
+      module_type i ppf incl.incl_mod
+  | Tsig_class (l) ->
+      line i ppf "Tsig_class\n";
+      list i class_description ppf l;
+  | Tsig_class_type (l) ->
+      line i ppf "Tsig_class_type\n";
+      list i class_type_declaration ppf l;
+  | Tsig_attribute (s, arg) ->
+      line i ppf "Tsig_attribute \"%s\"\n" s.txt;
+      Printast.payload i ppf arg
+
+and module_declaration i ppf md =
+  line i ppf "%a" fmt_ident md.md_id;
+  attributes i ppf md.md_attributes;
+  module_type (i+1) ppf md.md_type;
+
+and module_binding i ppf x =
+  line i ppf "%a\n" fmt_ident x.mb_id;
+  attributes i ppf x.mb_attributes;
+  module_expr (i+1) ppf x.mb_expr
+
+and modtype_declaration i ppf = function
+  | None -> line i ppf "#abstract"
+  | Some mt -> module_type (i + 1) ppf mt
+
+and with_constraint i ppf x =
+  match x with
+  | Twith_type (td) ->
+      line i ppf "Twith_type\n";
+      type_declaration (i+1) ppf td;
+  | Twith_typesubst (td) ->
+      line i ppf "Twith_typesubst\n";
+      type_declaration (i+1) ppf td;
+  | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li;
+  | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li;
+
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.mod_loc;
+  attributes i ppf x.mod_attributes;
+  let i = i+1 in
+  match x.mod_desc with
+  | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li;
+  | Tmod_structure (s) ->
+      line i ppf "Tmod_structure\n";
+      structure i ppf s;
+  | Tmod_functor (s, _, mt, me) ->
+      line i ppf "Tmod_functor \"%a\"\n" fmt_ident s;
+      Misc.may (module_type i ppf) mt;
+      module_expr i ppf me;
+  | Tmod_apply (me1, me2, _) ->
+      line i ppf "Tmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
+  | Tmod_constraint (me, _, Tmodtype_explicit mt, _) ->
+      line i ppf "Tmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
+  | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me
+  | Tmod_unpack (e, _) ->
+      line i ppf "Tmod_unpack\n";
+      expression i ppf e;
+
+and structure i ppf x = list i structure_item ppf x.str_items
+
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.str_loc;
+  let i = i+1 in
+  match x.str_desc with
+  | Tstr_eval (e, attrs) ->
+      line i ppf "Tstr_eval\n";
+      attributes i ppf attrs;
+      expression i ppf e;
+  | Tstr_value (rf, l) ->
+      line i ppf "Tstr_value %a\n" fmt_rec_flag rf;
+      list i value_binding ppf l;
+  | Tstr_primitive vd ->
+      line i ppf "Tstr_primitive\n";
+      value_description i ppf vd;
+  | Tstr_type (rf, l) ->
+      line i ppf "Tstr_type %a\n" fmt_rec_flag rf;
+      list i type_declaration ppf l;
+  | Tstr_typext te ->
+      line i ppf "Tstr_typext\n";
+      type_extension i ppf te
+  | Tstr_exception ext ->
+      line i ppf "Tstr_exception\n";
+      extension_constructor i ppf ext;
+  | Tstr_module x ->
+      line i ppf "Tstr_module\n";
+      module_binding i ppf x
+  | Tstr_recmodule bindings ->
+      line i ppf "Tstr_recmodule\n";
+      list i module_binding ppf bindings
+  | Tstr_modtype x ->
+      line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
+  | Tstr_open od ->
+      line i ppf "Tstr_open %a %a\n"
+           fmt_override_flag od.open_override
+           fmt_path od.open_path;
+      attributes i ppf od.open_attributes
+  | Tstr_class (l) ->
+      line i ppf "Tstr_class\n";
+      list i class_declaration ppf (List.map (fun (cl, _) -> cl) l);
+  | Tstr_class_type (l) ->
+      line i ppf "Tstr_class_type\n";
+      list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
+  | Tstr_include incl ->
+      line i ppf "Tstr_include";
+      attributes i ppf incl.incl_attributes;
+      module_expr i ppf incl.incl_mod;
+  | Tstr_attribute (s, arg) ->
+      line i ppf "Tstr_attribute \"%s\"\n" s.txt;
+      Printast.payload i ppf arg
+
+and longident_x_with_constraint i ppf (li, _, wc) =
+  line i ppf "%a\n" fmt_path li;
+  with_constraint (i+1) ppf wc;
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf " %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc;
+                            cd_attributes} =
+  line i ppf "%a\n" fmt_location cd_loc;
+  line (i+1) ppf "%a\n" fmt_ident cd_id;
+  attributes i ppf cd_attributes;
+  constructor_arguments (i+1) ppf cd_args;
+  option (i+1) core_type ppf cd_res
+
+and constructor_arguments i ppf = function
+  | Cstr_tuple l -> list i core_type ppf l
+  | Cstr_record l -> list i label_decl ppf l
+
+and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc;
+                      ld_attributes} =
+  line i ppf "%a\n" fmt_location ld_loc;
+  attributes i ppf ld_attributes;
+  line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
+  line (i+1) ppf "%a" fmt_ident ld_id;
+  core_type (i+1) ppf ld_type
+
+and longident_x_pattern i ppf (li, _, p) =
+  line i ppf "%a\n" fmt_longident li;
+  pattern (i+1) ppf p;
+
+and case i ppf {c_lhs; c_guard; c_rhs} =
+  line i ppf "\n";
+  pattern (i+1) ppf c_lhs;
+  begin match c_guard with
+  | None -> ()
+  | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g
+  end;
+  expression (i+1) ppf c_rhs;
+
+and value_binding i ppf x =
+  line i ppf "\n";
+  attributes (i+1) ppf x.vb_attributes;
+  pattern (i+1) ppf x.vb_pat;
+  expression (i+1) ppf x.vb_expr
+
+and string_x_expression i ppf (s, _, e) =
+  line i ppf " \"%a\"\n" fmt_path s;
+  expression (i+1) ppf e;
+
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf ""
+
+and label_x_expression i ppf (l, e) =
+  line i ppf "\n";
+  arg_label (i+1) ppf l;
+  (match e with None -> () | Some e -> expression (i+1) ppf e)
+
+and ident_x_loc_x_expression_def i ppf (l,_, e) =
+  line i ppf " \"%a\"\n" fmt_ident l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf x =
+  match x with
+    Ttag (l, attrs, b, ctl) ->
+      line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+      attributes (i+1) ppf attrs;
+      list (i+1) core_type ppf ctl
+  | Tinherit (ct) ->
+      line i ppf "Rinherit\n";
+      core_type (i+1) ppf ct
+;;
+
+let interface ppf x = list 0 signature_item ppf x.sig_items;;
+
+let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf (x, _) = implementation ppf x
diff --git a/typing/printtyped.mli b/typing/printtyped.mli
new file mode 100644
index 00000000..ded42bb3
--- /dev/null
+++ b/typing/printtyped.mli
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*              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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree;;
+open Format;;
+
+val interface : formatter -> signature -> unit;;
+val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+    formatter -> (structure * module_coercion) -> unit;;
diff --git a/typing/stypes.ml b/typing/stypes.ml
new file mode 100644
index 00000000..140b79e2
--- /dev/null
+++ b/typing/stypes.ml
@@ -0,0 +1,212 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(*
+  We record all types in a list as they are created.
+  This means we can dump type information even if type inference fails,
+  which is extremely important, since type information is most
+  interesting in case of errors.
+*)
+
+open Annot;;
+open Lexing;;
+open Location;;
+open Typedtree;;
+
+let output_int oc i = output_string oc (string_of_int i)
+
+type annotation =
+  | Ti_pat   of pattern
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+let get_location ti =
+  match ti with
+    Ti_pat p   -> p.pat_loc
+  | Ti_expr e  -> e.exp_loc
+  | Ti_class c -> c.cl_loc
+  | Ti_mod m   -> m.mod_loc
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
+;;
+
+let annotations = ref ([] : annotation list);;
+let phrases = ref ([] : Location.t list);;
+
+let record ti =
+  if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
+    annotations := ti :: !annotations
+;;
+
+let record_phrase loc =
+  if !Clflags.annotations then phrases := loc :: !phrases;
+;;
+
+(* comparison order:
+   the intervals are sorted by order of increasing upper bound
+   same upper bound -> sorted by decreasing lower bound
+*)
+let cmp_loc_inner_first loc1 loc2 =
+  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
+  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
+  | x -> x
+;;
+let cmp_ti_inner_first ti1 ti2 =
+  cmp_loc_inner_first (get_location ti1) (get_location ti2)
+;;
+
+let print_position pp pos =
+  if pos = dummy_pos then
+    output_string pp "--"
+  else begin
+    output_char pp '\"';
+    output_string pp (String.escaped pos.pos_fname);
+    output_string pp "\" ";
+    output_int pp pos.pos_lnum;
+    output_char pp ' ';
+    output_int pp pos.pos_bol;
+    output_char pp ' ';
+    output_int pp pos.pos_cnum;
+  end
+;;
+
+let print_location pp loc =
+  print_position pp loc.loc_start;
+  output_char pp ' ';
+  print_position pp loc.loc_end;
+;;
+
+let sort_filter_phrases () =
+  let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
+  let rec loop accu cur l =
+    match l with
+    | [] -> accu
+    | loc :: t ->
+       if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
+          && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
+       then loop accu cur t
+       else loop (loc :: accu) loc t
+  in
+  phrases := loop [] Location.none ph;
+;;
+
+let rec printtyp_reset_maybe loc =
+  match !phrases with
+  | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
+     Printtyp.reset ();
+     phrases := t;
+     printtyp_reset_maybe loc;
+  | _ -> ()
+;;
+
+let call_kind_string k =
+  match k with
+  | Tail -> "tail"
+  | Stack -> "stack"
+  | Inline -> "inline"
+;;
+
+let print_ident_annot pp str k =
+  match k with
+  | Idef l ->
+      output_string pp "def ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_internal l ->
+      output_string pp "int_ref ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_external ->
+      output_string pp "ext_ref ";
+      output_string pp str;
+      output_char pp '\n'
+;;
+
+(* The format of the annotation file is documented in emacs/caml-types.el. *)
+
+let print_info pp prev_loc ti =
+  match ti with
+  | Ti_class _ | Ti_mod _ -> prev_loc
+  | Ti_pat  {pat_loc = loc; pat_type = typ; pat_env = env}
+  | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "type(\n";
+      printtyp_reset_maybe loc;
+      Printtyp.mark_loops typ;
+      Format.pp_print_string Format.str_formatter "  ";
+      Printtyp.wrap_printing_env env
+                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
+      Format.pp_print_newline Format.str_formatter ();
+      let s = Format.flush_str_formatter () in
+      output_string pp s;
+      output_string pp ")\n";
+      loc
+  | An_call (loc, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "call(\n  ";
+      output_string pp (call_kind_string k);
+      output_string pp "\n)\n";
+      loc
+  | An_ident (loc, str, k) ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "ident(\n  ";
+      print_ident_annot pp str k;
+      output_string pp ")\n";
+      loc
+;;
+
+let get_info () =
+  let info = List.fast_sort cmp_ti_inner_first !annotations in
+  annotations := [];
+  info
+;;
+
+let dump filename =
+  if !Clflags.annotations then begin
+    let info = get_info () in
+    let pp =
+      match filename with
+          None -> stdout
+        | Some filename -> open_out filename in
+    sort_filter_phrases ();
+    ignore (List.fold_left (print_info pp) Location.none info);
+    begin match filename with
+    | None -> ()
+    | Some _ -> close_out pp
+    end;
+    phrases := [];
+  end else begin
+    annotations := [];
+  end;
+;;
diff --git a/typing/stypes.mli b/typing/stypes.mli
new file mode 100644
index 00000000..46df1ce6
--- /dev/null
+++ b/typing/stypes.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Recording and dumping (partial) type information *)
+
+(* Clflags.save_types must be true *)
+
+open Typedtree;;
+
+type annotation =
+  | Ti_pat   of pattern
+  | Ti_expr  of expression
+  | Ti_class of class_expr
+  | Ti_mod   of module_expr
+  | An_call of Location.t * Annot.call
+  | An_ident of Location.t * string * Annot.ident
+;;
+
+val record : annotation -> unit;;
+val record_phrase : Location.t -> unit;;
+val dump : string option -> unit;;
+
+val get_location : annotation -> Location.t;;
+val get_info : unit -> annotation list;;
diff --git a/typing/subst.ml b/typing/subst.ml
new file mode 100644
index 00000000..e6fc9e3d
--- /dev/null
+++ b/typing/subst.ml
@@ -0,0 +1,440 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Misc
+open Path
+open Types
+open Btype
+
+type t =
+  { types: (Ident.t, Path.t) Tbl.t;
+    modules: (Ident.t, Path.t) Tbl.t;
+    modtypes: (Ident.t, module_type) Tbl.t;
+    for_saving: bool }
+
+let identity =
+  { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
+    for_saving = false }
+
+let add_type id p s = { s with types = Tbl.add id p s.types }
+
+let add_module id p s = { s with modules = Tbl.add id p s.modules }
+
+let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
+
+let for_saving s = { s with for_saving = true }
+
+let loc s x =
+  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+
+let remove_loc =
+  let open Ast_mapper in
+  {default_mapper with location = (fun _this _loc -> Location.none)}
+
+let is_not_doc = function
+  | ({Location.txt = "ocaml.doc"}, _) -> false
+  | ({Location.txt = "ocaml.text"}, _) -> false
+  | ({Location.txt = "doc"}, _) -> false
+  | ({Location.txt = "text"}, _) -> false
+  | _ -> true
+
+let attrs s x =
+  let x =
+    if s.for_saving && not !Clflags.keep_docs then
+      List.filter is_not_doc x
+    else x
+  in
+    if s.for_saving && not !Clflags.keep_locs
+    then remove_loc.Ast_mapper.attributes remove_loc x
+    else x
+
+let rec module_path s = function
+    Pident id as p ->
+      begin try Tbl.find id s.modules with Not_found -> p end
+  | Pdot(p, n, pos) ->
+      Pdot(module_path s p, n, pos)
+  | Papply(p1, p2) ->
+      Papply(module_path s p1, module_path s p2)
+
+let modtype_path s = function
+    Pident id as p ->
+      begin try
+        match Tbl.find id s.modtypes with
+          | Mty_ident p -> p
+          | _ -> fatal_error "Subst.modtype_path"
+      with Not_found -> p end
+  | Pdot(p, n, pos) ->
+      Pdot(module_path s p, n, pos)
+  | Papply _ ->
+      fatal_error "Subst.modtype_path"
+
+let type_path s = function
+    Pident id as p ->
+      begin try Tbl.find id s.types with Not_found -> p end
+  | Pdot(p, n, pos) ->
+      Pdot(module_path s p, n, pos)
+  | Papply _ ->
+      fatal_error "Subst.type_path"
+
+let type_path s p =
+  match Path.constructor_typath p with
+  | Regular p -> type_path s p
+  | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos)
+  | LocalExt _ -> type_path s p
+  | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos)
+
+(* Special type ids for saved signatures *)
+
+let new_id = ref (-1)
+let reset_for_saving () = new_id := -1
+
+let newpersty desc =
+  decr new_id;
+  { desc = desc; level = generic_level; id = !new_id }
+
+(* ensure that all occurrences of 'Tvar None' are physically shared *)
+let tvar_none = Tvar None
+let tunivar_none = Tunivar None
+let norm = function
+  | Tvar None -> tvar_none
+  | Tunivar None -> tunivar_none
+  | d -> d
+
+(* Similar to [Ctype.nondep_type_rec]. *)
+let rec typexp s ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tvar _ | Tunivar _ as desc ->
+      if s.for_saving || ty.id < 0 then
+        let ty' =
+          if s.for_saving then newpersty (norm desc)
+          else newty2 ty.level desc
+        in
+        save_desc ty desc; ty.desc <- Tsubst ty'; ty'
+      else ty
+  | Tsubst ty ->
+      ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
+(* cannot do it, since it would omit subsitution
+  | Tvariant row when not (static_row row) ->
+      ty
+*)
+  | _ ->
+    let desc = ty.desc in
+    save_desc ty desc;
+    let tm = row_of_type ty in
+    let has_fixed_row =
+      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
+    (* Make a stub *)
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
+    ty.desc <- Tsubst ty';
+    ty'.desc <-
+      begin if has_fixed_row then
+        match tm.desc with (* PR#7348 *)
+          Tconstr (Pdot(m,i,pos), tl, _abbrev) ->
+            let i' = String.sub i 0 (String.length i - 4) in
+            Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil)
+        | _ -> assert false
+      else match desc with
+      | Tconstr(p, tl, _abbrev) ->
+          Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
+      | Tpackage(p, n, tl) ->
+          Tpackage(modtype_path s p, n, List.map (typexp s) tl)
+      | Tobject (t1, name) ->
+          Tobject (typexp s t1,
+                 ref (match !name with
+                        None -> None
+                      | Some (p, tl) ->
+                          Some (type_path s p, List.map (typexp s) tl)))
+      | Tvariant row ->
+          let row = row_repr row in
+          let more = repr row.row_more in
+          (* We must substitute in a subtle way *)
+          (* Tsubst takes a tuple containing the row var and the variant *)
+          begin match more.desc with
+            Tsubst {desc = Ttuple [_;ty2]} ->
+              (* This variant type has been already copied *)
+              ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
+              Tlink ty2
+          | _ ->
+              let dup =
+                s.for_saving || more.level = generic_level || static_row row ||
+                match more.desc with Tconstr _ -> true | _ -> false in
+              (* Various cases for the row variable *)
+              let more' =
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ | Tnil -> typexp s more
+                | Tunivar _ | Tvar _ ->
+                    save_desc more more.desc;
+                    if s.for_saving then newpersty (norm more.desc) else
+                    if dup && is_Tvar more then newgenty more.desc else more
+                | _ -> assert false
+              in
+              (* Register new type first for recursion *)
+              more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
+              (* Return a new copy *)
+              let row =
+                copy_row (typexp s) true row (not dup) more' in
+              match row.row_name with
+                Some (p, tl) ->
+                  Tvariant {row with row_name = Some (type_path s p, tl)}
+              | None ->
+                  Tvariant row
+          end
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp s t2)
+      | _ -> copy_type_desc (typexp s) desc
+      end;
+    ty'
+
+(*
+   Always make a copy of the type. If this is not done, type levels
+   might not be correct.
+*)
+let type_expr s ty =
+  let ty' = typexp s ty in
+  cleanup_types ();
+  ty'
+
+let label_declaration s l =
+  {
+    ld_id = l.ld_id;
+    ld_mutable = l.ld_mutable;
+    ld_type = typexp s l.ld_type;
+    ld_loc = loc s l.ld_loc;
+    ld_attributes = attrs s l.ld_attributes;
+  }
+
+let constructor_arguments s = function
+  | Cstr_tuple l ->
+      Cstr_tuple (List.map (typexp s) l)
+  | Cstr_record l ->
+      Cstr_record (List.map (label_declaration s) l)
+
+let constructor_declaration s c =
+  {
+    cd_id = c.cd_id;
+    cd_args = constructor_arguments s c.cd_args;
+    cd_res = may_map (typexp s) c.cd_res;
+    cd_loc = loc s c.cd_loc;
+    cd_attributes = attrs s c.cd_attributes;
+  }
+
+let type_declaration s decl =
+  let decl =
+    { type_params = List.map (typexp s) decl.type_params;
+      type_arity = decl.type_arity;
+      type_kind =
+        begin match decl.type_kind with
+          Type_abstract -> Type_abstract
+        | Type_variant cstrs ->
+            Type_variant (List.map (constructor_declaration s) cstrs)
+        | Type_record(lbls, rep) ->
+            Type_record (List.map (label_declaration s) lbls, rep)
+        | Type_open -> Type_open
+        end;
+      type_manifest =
+        begin
+          match decl.type_manifest with
+            None -> None
+          | Some ty -> Some(typexp s ty)
+        end;
+      type_private = decl.type_private;
+      type_variance = decl.type_variance;
+      type_newtype_level = None;
+      type_loc = loc s decl.type_loc;
+      type_attributes = attrs s decl.type_attributes;
+      type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
+    }
+  in
+  cleanup_types ();
+  decl
+
+let class_signature s sign =
+  { csig_self = typexp s sign.csig_self;
+    csig_vars =
+      Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.csig_vars;
+    csig_concr = sign.csig_concr;
+    csig_inher =
+      List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
+        sign.csig_inher;
+  }
+
+let rec class_type s =
+  function
+    Cty_constr (p, tyl, cty) ->
+      Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty)
+  | Cty_signature sign ->
+      Cty_signature (class_signature s sign)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, typexp s ty, class_type s cty)
+
+let class_declaration s decl =
+  let decl =
+    { cty_params = List.map (typexp s) decl.cty_params;
+      cty_variance = decl.cty_variance;
+      cty_type = class_type s decl.cty_type;
+      cty_path = type_path s decl.cty_path;
+      cty_new =
+        begin match decl.cty_new with
+          None    -> None
+        | Some ty -> Some (typexp s ty)
+        end;
+      cty_loc = loc s decl.cty_loc;
+      cty_attributes = attrs s decl.cty_attributes;
+    }
+  in
+  (* Do not clean up if saving: next is cltype_declaration *)
+  if not s.for_saving then cleanup_types ();
+  decl
+
+let cltype_declaration s decl =
+  let decl =
+    { clty_params = List.map (typexp s) decl.clty_params;
+      clty_variance = decl.clty_variance;
+      clty_type = class_type s decl.clty_type;
+      clty_path = type_path s decl.clty_path;
+      clty_loc = loc s decl.clty_loc;
+      clty_attributes = attrs s decl.clty_attributes;
+    }
+  in
+  (* Do clean up even if saving: type_declaration may be recursive *)
+  cleanup_types ();
+  decl
+
+let class_type s cty =
+  let cty = class_type s cty in
+  cleanup_types ();
+  cty
+
+let value_description s descr =
+  { val_type = type_expr s descr.val_type;
+    val_kind = descr.val_kind;
+    val_loc = loc s descr.val_loc;
+    val_attributes = attrs s descr.val_attributes;
+   }
+
+let extension_constructor s ext =
+  let ext =
+    { ext_type_path = type_path s ext.ext_type_path;
+      ext_type_params = List.map (typexp s) ext.ext_type_params;
+      ext_args = constructor_arguments s ext.ext_args;
+      ext_ret_type = may_map (typexp s) ext.ext_ret_type;
+      ext_private = ext.ext_private;
+      ext_attributes = attrs s ext.ext_attributes;
+      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
+  in
+    cleanup_types ();
+    ext
+
+let rec rename_bound_idents s idents = function
+    [] -> (List.rev idents, s)
+  | Sig_type(id, _, _) :: sg ->
+      let id' = Ident.rename id in
+      rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
+  | Sig_module(id, _, _) :: sg ->
+      let id' = Ident.rename id in
+      rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
+  | Sig_modtype(id, _) :: sg ->
+      let id' = Ident.rename id in
+      rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s)
+                          (id' :: idents) sg
+  | (Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg ->
+      (* cheat and pretend they are types cf. PR#6650 *)
+      let id' = Ident.rename id in
+      rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
+  | (Sig_value(id, _) | Sig_typext(id, _, _)) :: sg ->
+      let id' = Ident.rename id in
+      rename_bound_idents s (id' :: idents) sg
+
+let rec modtype s = function
+    Mty_ident p as mty ->
+      begin match p with
+        Pident id ->
+          begin try Tbl.find id s.modtypes with Not_found -> mty end
+      | Pdot(p, n, pos) ->
+          Mty_ident(Pdot(module_path s p, n, pos))
+      | Papply _ ->
+          fatal_error "Subst.modtype"
+      end
+  | Mty_signature sg ->
+      Mty_signature(signature s sg)
+  | Mty_functor(id, arg, res) ->
+      let id' = Ident.rename id in
+      Mty_functor(id', may_map (modtype s) arg,
+                       modtype (add_module id (Pident id') s) res)
+  | Mty_alias(pres, p) ->
+      Mty_alias(pres, module_path s p)
+
+and signature s sg =
+  (* Components of signature may be mutually recursive (e.g. type declarations
+     or class and type declarations), so first build global renaming
+     substitution... *)
+  let (new_idents, s') = rename_bound_idents s [] sg in
+  (* ... then apply it to each signature component in turn *)
+  List.map2 (signature_component s') sg new_idents
+
+and signature_component s comp newid =
+  match comp with
+    Sig_value(_id, d) ->
+      Sig_value(newid, value_description s d)
+  | Sig_type(_id, d, rs) ->
+      Sig_type(newid, type_declaration s d, rs)
+  | Sig_typext(_id, ext, es) ->
+      Sig_typext(newid, extension_constructor s ext, es)
+  | Sig_module(_id, d, rs) ->
+      Sig_module(newid, module_declaration s d, rs)
+  | Sig_modtype(_id, d) ->
+      Sig_modtype(newid, modtype_declaration s d)
+  | Sig_class(_id, d, rs) ->
+      Sig_class(newid, class_declaration s d, rs)
+  | Sig_class_type(_id, d, rs) ->
+      Sig_class_type(newid, cltype_declaration s d, rs)
+
+and module_declaration s decl =
+  {
+    md_type = modtype s decl.md_type;
+    md_attributes = attrs s decl.md_attributes;
+    md_loc = loc s decl.md_loc;
+  }
+
+and modtype_declaration s decl  =
+  {
+    mtd_type = may_map (modtype s) decl.mtd_type;
+    mtd_attributes = attrs s decl.mtd_attributes;
+    mtd_loc = loc s decl.mtd_loc;
+  }
+
+(* For every binding k |-> d of m1, add k |-> f d to m2
+   and return resulting merged map. *)
+
+let merge_tbls f m1 m2 =
+  Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+
+let compose s1 s2 =
+  { types = merge_tbls (type_path s2) s1.types s2.types;
+    modules = merge_tbls (module_path s2) s1.modules s2.modules;
+    modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
+    for_saving = s1.for_saving || s2.for_saving }
diff --git a/typing/subst.mli b/typing/subst.mli
new file mode 100644
index 00000000..55eee757
--- /dev/null
+++ b/typing/subst.mli
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Substitutions *)
+
+open Types
+
+type t
+
+(*
+   Substitutions are used to translate a type from one context to
+   another.  This requires substituing paths for identifiers, and
+   possibly also lowering the level of non-generic variables so that
+   it be inferior to the maximum level of the new context.
+
+   Substitutions can also be used to create a "clean" copy of a type.
+   Indeed, non-variable node of a type are duplicated, with their
+   levels set to generic level.  That way, the resulting type is
+   well-formed (decreasing levels), even if the original one was not.
+*)
+
+val identity: t
+
+val add_type: Ident.t -> Path.t -> t -> t
+val add_module: Ident.t -> Path.t -> t -> t
+val add_modtype: Ident.t -> module_type -> t -> t
+val for_saving: t -> t
+val reset_for_saving: unit -> unit
+
+val module_path: t -> Path.t -> Path.t
+val type_path: t -> Path.t -> Path.t
+
+val type_expr: t -> type_expr -> type_expr
+val class_type: t -> class_type -> class_type
+val value_description: t -> value_description -> value_description
+val type_declaration: t -> type_declaration -> type_declaration
+val extension_constructor:
+        t -> extension_constructor -> extension_constructor
+val class_declaration: t -> class_declaration -> class_declaration
+val cltype_declaration: t -> class_type_declaration -> class_type_declaration
+val modtype: t -> module_type -> module_type
+val signature: t -> signature -> signature
+val modtype_declaration: t -> modtype_declaration -> modtype_declaration
+val module_declaration: t -> module_declaration -> module_declaration
+val typexp : t -> Types.type_expr -> Types.type_expr
+val class_signature: t -> class_signature -> class_signature
+
+(* Composition of substitutions:
+     apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+val compose: t -> t -> t
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
new file mode 100644
index 00000000..0873dd4c
--- /dev/null
+++ b/typing/tast_mapper.ml
@@ -0,0 +1,692 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(* TODO: add 'methods' for location, attribute, extension,
+   open_description, include_declaration, include_description *)
+
+type mapper =
+  {
+    case: mapper -> case -> case;
+    cases: mapper -> case list -> case list;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: mapper -> pattern -> pattern;
+    row_field: mapper -> row_field -> row_field;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list) ->
+      (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+let id x = x
+let tuple2 f1 f2 (x, y) = (f1 x, f2 y)
+let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let opt f = function None -> None | Some x -> Some (f x)
+
+let structure sub {str_items; str_type; str_final_env} =
+  {
+    str_items = List.map (sub.structure_item sub) str_items;
+    str_final_env = sub.env sub str_final_env;
+    str_type;
+  }
+
+let class_infos sub f x =
+  {x with
+   ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params;
+   ci_expr = f x.ci_expr;
+  }
+
+let module_type_declaration sub x =
+  let mtd_type = opt (sub.module_type sub) x.mtd_type in
+  {x with mtd_type}
+
+let module_declaration sub x =
+  let md_type = sub.module_type sub x.md_type in
+  {x with md_type}
+
+let include_infos f x = {x with incl_mod = f x.incl_mod}
+
+let class_type_declaration sub x =
+  class_infos sub (sub.class_type sub) x
+
+let class_declaration sub x =
+  class_infos sub (sub.class_expr sub) x
+
+let structure_item sub {str_desc; str_loc; str_env} =
+  let str_env = sub.env sub str_env in
+  let str_desc =
+    match str_desc with
+    | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Tstr_value (rec_flag, list)
+    | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v)
+    | Tstr_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tstr_type (rec_flag, list)
+    | Tstr_typext te -> Tstr_typext (sub.type_extension sub te)
+    | Tstr_exception ext -> Tstr_exception (sub.extension_constructor sub ext)
+    | Tstr_module mb -> Tstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Tstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x)
+    | Tstr_class list ->
+        Tstr_class
+          (List.map (tuple2 (sub.class_declaration sub) id) list)
+    | Tstr_class_type list ->
+        Tstr_class_type
+          (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
+    | Tstr_include incl ->
+        Tstr_include (include_infos (sub.module_expr sub) incl)
+    | Tstr_open _
+    | Tstr_attribute _ as d -> d
+  in
+  {str_desc; str_env; str_loc}
+
+let value_description sub x =
+  let val_desc = sub.typ sub x.val_desc in
+  {x with val_desc}
+
+let label_decl sub x =
+  let ld_type = sub.typ sub x.ld_type in
+  {x with ld_type}
+
+let constructor_args sub = function
+  | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l)
+  | Cstr_record l -> Cstr_record (List.map (label_decl sub) l)
+
+let constructor_decl sub cd =
+  let cd_args = constructor_args sub cd.cd_args in
+  let cd_res = opt (sub.typ sub) cd.cd_res in
+  {cd with cd_args; cd_res}
+
+let type_kind sub = function
+  | Ttype_abstract -> Ttype_abstract
+  | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list)
+  | Ttype_record list -> Ttype_record (List.map (label_decl sub) list)
+  | Ttype_open -> Ttype_open
+
+let type_declaration sub x =
+  let typ_cstrs =
+    List.map
+      (tuple3 (sub.typ sub) (sub.typ sub) id)
+      x.typ_cstrs
+  in
+  let typ_kind = sub.type_kind sub x.typ_kind in
+  let typ_manifest = opt (sub.typ sub) x.typ_manifest in
+  let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in
+  {x with typ_cstrs; typ_kind; typ_manifest; typ_params}
+
+let type_declarations sub (rec_flag, list) =
+  (rec_flag, List.map (sub.type_declaration sub) list)
+
+let type_extension sub x =
+  let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in
+  let tyext_constructors =
+    List.map (sub.extension_constructor sub) x.tyext_constructors
+  in
+  {x with tyext_constructors; tyext_params}
+
+let extension_constructor sub x =
+  let ext_kind =
+    match x.ext_kind with
+      Text_decl(ctl, cto) ->
+        Text_decl(constructor_args sub ctl, opt (sub.typ sub) cto)
+    | Text_rebind _ as d -> d
+  in
+  {x with ext_kind}
+
+let pat sub x =
+  let extra = function
+    | Tpat_type _
+    | Tpat_unpack as d -> d
+    | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
+    | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
+  in
+  let pat_env = sub.env sub x.pat_env in
+  let pat_extra = List.map (tuple3 extra id id) x.pat_extra in
+  let pat_desc =
+    match x.pat_desc with
+    | Tpat_any
+    | Tpat_var _
+    | Tpat_constant _ as d -> d
+    | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l)
+    | Tpat_construct (loc, cd, l) ->
+        Tpat_construct (loc, cd, List.map (sub.pat sub) l)
+    | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd)
+    | Tpat_record (l, closed) ->
+        Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
+    | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
+    | Tpat_or (p1, p2, rd) ->
+        Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
+    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
+  in
+  {x with pat_extra; pat_desc; pat_env}
+
+let expr sub x =
+  let extra = function
+    | Texp_constraint cty ->
+        Texp_constraint (sub.typ sub cty)
+    | Texp_coerce (cty1, cty2) ->
+        Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2)
+    | Texp_open (ovf, path, loc, env) ->
+        Texp_open (ovf, path, loc, sub.env sub env)
+    | Texp_newtype _ as d -> d
+    | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto)
+  in
+  let exp_extra = List.map (tuple3 extra id id) x.exp_extra in
+  let exp_env = sub.env sub x.exp_env in
+  let exp_desc =
+    match x.exp_desc with
+    | Texp_ident _
+    | Texp_constant _ as d -> d
+    | Texp_let (rec_flag, list, exp) ->
+        let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
+        Texp_let (rec_flag, list, sub.expr sub exp)
+    | Texp_function { arg_label; param; cases; partial; } ->
+        Texp_function { arg_label; param; cases = sub.cases sub cases;
+          partial; }
+    | Texp_apply (exp, list) ->
+        Texp_apply (
+          sub.expr sub exp,
+          List.map (tuple2 id (opt (sub.expr sub))) list
+        )
+    | Texp_match (exp, cases, exn_cases, p) ->
+        Texp_match (
+          sub.expr sub exp,
+          sub.cases sub cases,
+          sub.cases sub exn_cases,
+          p
+        )
+    | Texp_try (exp, cases) ->
+        Texp_try (
+          sub.expr sub exp,
+          sub.cases sub cases
+        )
+    | Texp_tuple list ->
+        Texp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, cd, args) ->
+        Texp_construct (lid, cd, List.map (sub.expr sub) args)
+    | Texp_variant (l, expo) ->
+        Texp_variant (l, opt (sub.expr sub) expo)
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = opt (sub.expr sub) extended_expression;
+        }
+    | Texp_field (exp, lid, ld) ->
+        Texp_field (sub.expr sub exp, lid, ld)
+    | Texp_setfield (exp1, lid, ld, exp2) ->
+        Texp_setfield (
+          sub.expr sub exp1,
+          lid,
+          ld,
+          sub.expr sub exp2
+        )
+    | Texp_array list ->
+        Texp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Texp_ifthenelse (
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          opt (sub.expr sub) expo
+        )
+    | Texp_sequence (exp1, exp2) ->
+        Texp_sequence (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_while (exp1, exp2) ->
+        Texp_while (
+          sub.expr sub exp1,
+          sub.expr sub exp2
+        )
+    | Texp_for (id, p, exp1, exp2, dir, exp3) ->
+        Texp_for (
+          id,
+          p,
+          sub.expr sub exp1,
+          sub.expr sub exp2,
+          dir,
+          sub.expr sub exp3
+        )
+    | Texp_send (exp, meth, expo) ->
+        Texp_send
+          (
+            sub.expr sub exp,
+            meth,
+            opt (sub.expr sub) expo
+          )
+    | Texp_new _
+    | Texp_instvar _ as d -> d
+    | Texp_setinstvar (path1, path2, id, exp) ->
+        Texp_setinstvar (
+          path1,
+          path2,
+          id,
+          sub.expr sub exp
+        )
+    | Texp_override (path, list) ->
+        Texp_override (
+          path,
+          List.map (tuple3 id id (sub.expr sub)) list
+        )
+    | Texp_letmodule (id, s, mexpr, exp) ->
+        Texp_letmodule (
+          id,
+          s,
+          sub.module_expr sub mexpr,
+          sub.expr sub exp
+        )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
+    | Texp_assert exp ->
+        Texp_assert (sub.expr sub exp)
+    | Texp_lazy exp ->
+        Texp_lazy (sub.expr sub exp)
+    | Texp_object (cl, sl) ->
+        Texp_object (sub.class_structure sub cl, sl)
+    | Texp_pack mexpr ->
+        Texp_pack (sub.module_expr sub mexpr)
+    | Texp_unreachable ->
+        Texp_unreachable
+    | Texp_extension_constructor _ as e ->
+        e
+  in
+  {x with exp_extra; exp_desc; exp_env}
+
+
+let package_type sub x =
+  let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in
+  {x with pack_fields}
+
+let signature sub x =
+  let sig_final_env = sub.env sub x.sig_final_env in
+  let sig_items = List.map (sub.signature_item sub) x.sig_items in
+  {x with sig_items; sig_final_env}
+
+let signature_item sub x =
+  let sig_env = sub.env sub x.sig_env in
+  let sig_desc =
+    match x.sig_desc with
+    | Tsig_value v ->
+        Tsig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in
+        Tsig_type (rec_flag, list)
+    | Tsig_typext te ->
+        Tsig_typext (sub.type_extension sub te)
+    | Tsig_exception ext ->
+        Tsig_exception (sub.extension_constructor sub ext)
+    | Tsig_module x ->
+        Tsig_module (sub.module_declaration sub x)
+    | Tsig_recmodule list ->
+        Tsig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype x ->
+        Tsig_modtype (sub.module_type_declaration sub x)
+    | Tsig_include incl ->
+        Tsig_include (include_infos (sub.module_type sub) incl)
+    | Tsig_class list ->
+        Tsig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Tsig_class_type
+          (List.map (sub.class_type_declaration sub) list)
+    | Tsig_open _
+    | Tsig_attribute _ as d -> d
+  in
+  {x with sig_desc; sig_env}
+
+let class_description sub x =
+  class_infos sub (sub.class_type sub) x
+
+let module_type sub x =
+  let mty_env = sub.env sub x.mty_env in
+  let mty_desc =
+    match x.mty_desc with
+    | Tmty_ident _
+    | Tmty_alias _ as d -> d
+    | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
+    | Tmty_functor (id, s, mtype1, mtype2) ->
+        Tmty_functor (
+          id,
+          s,
+          opt (sub.module_type sub) mtype1,
+          sub.module_type sub mtype2
+        )
+    | Tmty_with (mtype, list) ->
+        Tmty_with (
+          sub.module_type sub mtype,
+          List.map (tuple3 id id (sub.with_constraint sub)) list
+        )
+    | Tmty_typeof mexpr ->
+        Tmty_typeof (sub.module_expr sub mexpr)
+  in
+  {x with mty_desc; mty_env}
+
+let with_constraint sub = function
+  | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
+  | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
+  | Twith_module _
+  | Twith_modsubst _ as d -> d
+
+let module_coercion sub = function
+  | Tcoerce_none -> Tcoerce_none
+  | Tcoerce_functor (c1,c2) ->
+      Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2)
+  | Tcoerce_alias (p, c1) ->
+      Tcoerce_alias (p, sub.module_coercion sub c1)
+  | Tcoerce_structure (l1, l2) ->
+      let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in
+      let l2' =
+        List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2
+      in
+      Tcoerce_structure (l1', l2')
+  | Tcoerce_primitive pc ->
+      Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env}
+
+let module_expr sub x =
+  let mod_env = sub.env sub x.mod_env in
+  let mod_desc =
+    match x.mod_desc with
+    | Tmod_ident _ as d -> d
+    | Tmod_structure st -> Tmod_structure (sub.structure sub st)
+    | Tmod_functor (id, s, mtype, mexpr) ->
+        Tmod_functor (
+          id,
+          s,
+          opt (sub.module_type sub) mtype,
+          sub.module_expr sub mexpr
+        )
+    | Tmod_apply (mexp1, mexp2, c) ->
+        Tmod_apply (
+          sub.module_expr sub mexp1,
+          sub.module_expr sub mexp2,
+          sub.module_coercion sub c
+        )
+    | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) ->
+        Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit,
+                         sub.module_coercion sub c)
+    | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) ->
+        Tmod_constraint (
+          sub.module_expr sub mexpr,
+          mt,
+          Tmodtype_explicit (sub.module_type sub mtype),
+          sub.module_coercion sub c
+        )
+    | Tmod_unpack (exp, mty) ->
+        Tmod_unpack
+          (
+            sub.expr sub exp,
+            mty
+          )
+  in
+  {x with mod_desc; mod_env}
+
+let module_binding sub x =
+  let mb_expr = sub.module_expr sub x.mb_expr in
+  {x with mb_expr}
+
+let class_expr sub x =
+  let cl_env = sub.env sub x.cl_env in
+  let cl_desc =
+    match x.cl_desc with
+    | Tcl_constraint (cl, clty, vals, meths, concrs) ->
+        Tcl_constraint (
+          sub.class_expr sub cl,
+          opt (sub.class_type sub) clty,
+          vals,
+          meths,
+          concrs
+        )
+    | Tcl_structure clstr ->
+        Tcl_structure (sub.class_structure sub clstr)
+    | Tcl_fun (label, pat, priv, cl, partial) ->
+        Tcl_fun (
+          label,
+          sub.pat sub pat,
+          List.map (tuple3 id id (sub.expr sub)) priv,
+          sub.class_expr sub cl,
+          partial
+        )
+    | Tcl_apply (cl, args) ->
+        Tcl_apply (
+          sub.class_expr sub cl,
+          List.map (tuple2 id (opt (sub.expr sub))) args
+        )
+    | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
+        let (rec_flag, value_bindings) =
+          sub.value_bindings sub (rec_flag, value_bindings)
+        in
+        Tcl_let (
+          rec_flag,
+          value_bindings,
+          List.map (tuple3 id id (sub.expr sub)) ivars,
+          sub.class_expr sub cl
+        )
+    | Tcl_ident (path, lid, tyl) ->
+        Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+  in
+  {x with cl_desc; cl_env}
+
+let class_type sub x =
+  let cltyp_env = sub.env sub x.cltyp_env in
+  let cltyp_desc =
+    match x.cltyp_desc with
+    | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (path, lid, list) ->
+        Tcty_constr (
+          path,
+          lid,
+          List.map (sub.typ sub) list
+        )
+    | Tcty_arrow (label, ct, cl) ->
+        Tcty_arrow
+          (label,
+           sub.typ sub ct,
+           sub.class_type sub cl
+          )
+  in
+  {x with cltyp_desc; cltyp_env}
+
+let class_signature sub x =
+  let csig_self = sub.typ sub x.csig_self in
+  let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in
+  {x with csig_self; csig_fields}
+
+let class_type_field sub x =
+  let ctf_desc =
+    match x.ctf_desc with
+    | Tctf_inherit ct ->
+        Tctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Tctf_val (s, mut, virt, sub.typ sub ct)
+    | Tctf_method (s, priv, virt, ct) ->
+        Tctf_method (s, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute _ as d -> d
+  in
+  {x with ctf_desc}
+
+let typ sub x =
+  let ctyp_env = sub.env sub x.ctyp_env in
+  let ctyp_desc =
+    match x.ctyp_desc with
+    | Ttyp_any
+    | Ttyp_var _ as d -> d
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (path, lid, list) ->
+        Ttyp_constr (path, lid, List.map (sub.typ sub) list)
+    | Ttyp_object (list, closed) ->
+        Ttyp_object (
+          List.map (tuple3 id id (sub.typ sub)) list,
+          closed
+        )
+    | Ttyp_class (path, lid, list) ->
+        Ttyp_class
+          (path,
+           lid,
+           List.map (sub.typ sub) list
+          )
+    | Ttyp_alias (ct, s) ->
+        Ttyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, closed, labels) ->
+        Ttyp_variant (List.map (sub.row_field sub) list, closed, labels)
+    | Ttyp_poly (sl, ct) ->
+        Ttyp_poly (sl, sub.typ sub ct)
+    | Ttyp_package pack ->
+        Ttyp_package (sub.package_type sub pack)
+  in
+  {x with ctyp_desc; ctyp_env}
+
+let class_structure sub x =
+  let cstr_self = sub.pat sub x.cstr_self in
+  let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in
+  {x with cstr_self; cstr_fields}
+
+let row_field sub = function
+  | Ttag (label, attrs, b, list) ->
+      Ttag (label, attrs, b, List.map (sub.typ sub) list)
+  | Tinherit ct -> Tinherit (sub.typ sub ct)
+
+let class_field_kind sub = function
+  | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct)
+  | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e)
+
+let class_field sub x =
+  let cf_desc =
+    match x.cf_desc with
+    | Tcf_inherit (ovf, cl, super, vals, meths) ->
+        Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths)
+    | Tcf_constraint (cty, cty') ->
+        Tcf_constraint (
+          sub.typ sub cty,
+          sub.typ sub cty'
+        )
+    | Tcf_val (s, mf, id, k, b) ->
+        Tcf_val (s, mf, id, class_field_kind sub k, b)
+    | Tcf_method (s, priv, k) ->
+        Tcf_method (s, priv, class_field_kind sub k)
+    | Tcf_initializer exp ->
+        Tcf_initializer (sub.expr sub exp)
+    | Tcf_attribute _ as d -> d
+  in
+  {x with cf_desc}
+
+let value_bindings sub (rec_flag, list) =
+  (rec_flag, List.map (sub.value_binding sub) list)
+
+let cases sub l =
+  List.map (sub.case sub) l
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  {
+    c_lhs = sub.pat sub c_lhs;
+    c_guard = opt (sub.expr sub) c_guard;
+    c_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub x =
+  let vb_pat = sub.pat sub x.vb_pat in
+  let vb_expr = sub.expr sub x.vb_expr in
+  {x with vb_pat; vb_expr}
+
+let env _sub x = x
+
+let default =
+  {
+    case;
+    cases;
+    class_declaration;
+    class_description;
+    class_expr;
+    class_field;
+    class_signature;
+    class_structure;
+    class_type;
+    class_type_declaration;
+    class_type_field;
+    env;
+    expr;
+    extension_constructor;
+    module_binding;
+    module_coercion;
+    module_declaration;
+    module_expr;
+    module_type;
+    module_type_declaration;
+    package_type;
+    pat;
+    row_field;
+    signature;
+    signature_item;
+    structure;
+    structure_item;
+    typ;
+    type_declaration;
+    type_declarations;
+    type_extension;
+    type_kind;
+    value_binding;
+    value_bindings;
+    value_description;
+    with_constraint;
+  }
diff --git a/typing/tast_mapper.mli b/typing/tast_mapper.mli
new file mode 100644
index 00000000..ae9dd8ba
--- /dev/null
+++ b/typing/tast_mapper.mli
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Alain Frisch, LexiFi                            *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+(** {2 A generic Typedtree mapper} *)
+
+type mapper =
+  {
+    case: mapper -> case -> case;
+    cases: mapper -> case list -> case list;
+    class_declaration: mapper -> class_declaration -> class_declaration;
+    class_description: mapper -> class_description -> class_description;
+    class_expr: mapper -> class_expr -> class_expr;
+    class_field: mapper -> class_field -> class_field;
+    class_signature: mapper -> class_signature -> class_signature;
+    class_structure: mapper -> class_structure -> class_structure;
+    class_type: mapper -> class_type -> class_type;
+    class_type_declaration: mapper -> class_type_declaration ->
+      class_type_declaration;
+    class_type_field: mapper -> class_type_field -> class_type_field;
+    env: mapper -> Env.t -> Env.t;
+    expr: mapper -> expression -> expression;
+    extension_constructor: mapper -> extension_constructor ->
+      extension_constructor;
+    module_binding: mapper -> module_binding -> module_binding;
+    module_coercion: mapper -> module_coercion -> module_coercion;
+    module_declaration: mapper -> module_declaration -> module_declaration;
+    module_expr: mapper -> module_expr -> module_expr;
+    module_type: mapper -> module_type -> module_type;
+    module_type_declaration:
+      mapper -> module_type_declaration -> module_type_declaration;
+    package_type: mapper -> package_type -> package_type;
+    pat: mapper -> pattern -> pattern;
+    row_field: mapper -> row_field -> row_field;
+    signature: mapper -> signature -> signature;
+    signature_item: mapper -> signature_item -> signature_item;
+    structure: mapper -> structure -> structure;
+    structure_item: mapper -> structure_item -> structure_item;
+    typ: mapper -> core_type -> core_type;
+    type_declaration: mapper -> type_declaration -> type_declaration;
+    type_declarations: mapper -> (rec_flag * type_declaration list) ->
+      (rec_flag * type_declaration list);
+    type_extension: mapper -> type_extension -> type_extension;
+    type_kind: mapper -> type_kind -> type_kind;
+    value_binding: mapper -> value_binding -> value_binding;
+    value_bindings: mapper -> (rec_flag * value_binding list) ->
+      (rec_flag * value_binding list);
+    value_description: mapper -> value_description -> value_description;
+    with_constraint: mapper -> with_constraint -> with_constraint;
+  }
+
+
+val default: mapper
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
new file mode 100644
index 00000000..51f8a256
--- /dev/null
+++ b/typing/typeclass.ml
@@ -0,0 +1,1921 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+open Asttypes
+open Path
+open Types
+open Typecore
+open Typetexp
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+type error =
+    Unconsistent_constraint of (type_expr * type_expr) list
+  | Field_type_mismatch of string * string * (type_expr * type_expr) list
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * (type_expr * type_expr) list
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of (type_expr * type_expr) list
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Make_nongen_seltype of type_expr
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | 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
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+open Typedtree
+
+let ctyp desc typ env loc =
+  { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
+    ctyp_attributes = [] }
+
+                       (**********************)
+                       (*  Useful constants  *)
+                       (**********************)
+
+
+(*
+   Self type have a dummy private method, thus preventing it to become
+   closed.
+*)
+let dummy_method = Btype.dummy_method
+
+(*
+   Path associated to the temporary class type of a class being typed
+   (its constructor is not available).
+*)
+let unbound_class = Path.Pident (Ident.create "*undef*")
+
+
+                (************************************)
+                (*  Some operations on class types  *)
+                (************************************)
+
+
+(* Fully expand the head of a class type *)
+let rec scrape_class_type =
+  function
+    Cty_constr (_, _, cty) -> scrape_class_type cty
+  | cty                     -> cty
+
+(* Generalize a class type *)
+let rec generalize_class_type gen =
+  function
+    Cty_constr (_, params, cty) ->
+      List.iter gen params;
+      generalize_class_type gen cty
+  | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
+      gen sty;
+      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+      List.iter (fun (_,tl) -> List.iter gen tl) inher
+  | Cty_arrow (_, ty, cty) ->
+      gen ty;
+      generalize_class_type gen cty
+
+let generalize_class_type vars =
+  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+  generalize_class_type gen
+
+(* Return the virtual methods of a class type *)
+let virtual_methods sign =
+  let (fields, _) =
+    Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
+  in
+  List.fold_left
+    (fun virt (lab, _, _) ->
+       if lab = dummy_method then virt else
+       if Concr.mem lab sign.csig_concr then virt else
+       lab::virt)
+    [] fields
+
+(* Return the constructor type associated to a class type *)
+let rec constructor_type constr cty =
+  match cty with
+    Cty_constr (_, _, cty) ->
+      constructor_type constr cty
+  | Cty_signature _ ->
+      constr
+  | Cty_arrow (l, ty, cty) ->
+      Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
+
+let rec class_body cty =
+  match cty with
+    Cty_constr _ ->
+      cty (* Only class bodies can be abbreviated *)
+  | Cty_signature _ ->
+      cty
+  | Cty_arrow (_, _, cty) ->
+      class_body cty
+
+let extract_constraints cty =
+  let sign = Ctype.signature_of_class_type cty in
+  (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
+   begin let (fields, _) =
+     Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
+   in
+   List.fold_left
+     (fun meths (lab, _, _) ->
+        if lab = dummy_method then meths else lab::meths)
+     [] fields
+   end,
+   sign.csig_concr)
+
+let rec abbreviate_class_type path params cty =
+  match cty with
+    Cty_constr (_, _, _) | Cty_signature _ ->
+      Cty_constr (path, params, cty)
+  | Cty_arrow (l, ty, cty) ->
+      Cty_arrow (l, ty, abbreviate_class_type path params cty)
+
+(* Check that all type variables are generalizable *)
+(* Use Env.empty to prevent expansion of recursively defined object types;
+   cf. typing-poly/poly.ml *)
+let rec closed_class_type =
+  function
+    Cty_constr (_, params, _) ->
+      List.for_all (Ctype.closed_schema Env.empty) params
+  | Cty_signature sign ->
+      Ctype.closed_schema Env.empty sign.csig_self
+        &&
+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
+        sign.csig_vars
+        true
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.closed_schema Env.empty ty
+        &&
+      closed_class_type cty
+
+let closed_class cty =
+  List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
+    &&
+  closed_class_type cty.cty_type
+
+let rec limited_generalize rv =
+  function
+    Cty_constr (_path, params, cty) ->
+      List.iter (Ctype.limited_generalize rv) params;
+      limited_generalize rv cty
+  | Cty_signature sign ->
+      Ctype.limited_generalize rv sign.csig_self;
+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+        sign.csig_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.csig_inher
+  | Cty_arrow (_, ty, cty) ->
+      Ctype.limited_generalize rv ty;
+      limited_generalize rv cty
+
+(* Record a class type *)
+let rc node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
+  Stypes.record (Stypes.Ti_class node); (* moved to genannot *)
+  node
+
+
+                (***********************************)
+                (*  Primitives for typing classes  *)
+                (***********************************)
+
+
+(* Enter a value in the method environment only *)
+let enter_met_env ?check loc lab kind ty val_env met_env par_env =
+  let (id, val_env) =
+    Env.enter_value lab {val_type = ty; val_kind = Val_unbound;
+                         val_attributes = [];
+                         Types.val_loc = loc} val_env
+  in
+  (id, val_env,
+   Env.add_value ?check id {val_type = ty; val_kind = kind;
+                            val_attributes = [];
+                            Types.val_loc = loc} met_env,
+   Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                     val_attributes = [];
+                     Types.val_loc = loc} par_env)
+
+(* Enter an instance variable in the environment *)
+let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
+  let instance = Ctype.instance val_env in
+  let (id, virt) =
+    try
+      let (id, mut', virt', ty') = Vars.find lab !vars in
+      if mut' <> mut then
+        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
+      Ctype.unify val_env (instance ty) (instance ty');
+      (if not inh then Some id else None),
+      (if virt' = Concrete then virt' else virt)
+    with
+      Ctype.Unify tr ->
+        raise (Error(loc, val_env,
+                     Field_type_mismatch("instance variable", lab, tr)))
+    | Not_found -> None, virt
+  in
+  let (id, _, _, _) as result =
+    match id with Some id -> (id, val_env, met_env, par_env)
+    | None ->
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num))
+          ty val_env met_env par_env
+  in
+  vars := Vars.add lab (id, mut, virt, ty) !vars;
+  result
+
+let concr_vals vars =
+  Vars.fold
+    (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
+    vars Concr.empty
+
+let inheritance self_type env ovf concr_meths warn_vals loc parent =
+  match scrape_class_type parent with
+    Cty_signature cl_sig ->
+
+      (* Methods *)
+      begin try
+        Ctype.unify env self_type cl_sig.csig_self
+      with Ctype.Unify trace ->
+        match trace with
+          _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
+            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
+        | _ ->
+            assert false
+      end;
+
+      (* Overriding *)
+      let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
+      let concr_vals = concr_vals cl_sig.csig_vars in
+      let over_vals = Concr.inter concr_vals warn_vals in
+      begin match ovf with
+        Some Fresh ->
+          let cname =
+            match parent with
+              Cty_constr (p, _, _) -> Path.name p
+            | _ -> "inherited"
+          in
+          if not (Concr.is_empty over_meths) then
+            Location.prerr_warning loc
+              (Warnings.Method_override (cname :: Concr.elements over_meths));
+          if not (Concr.is_empty over_vals) then
+            Location.prerr_warning loc
+              (Warnings.Instance_variable_override
+                 (cname :: Concr.elements over_vals));
+      | Some Override
+        when Concr.is_empty over_meths && Concr.is_empty over_vals ->
+        raise (Error(loc, env, No_overriding ("","")))
+      | _ -> ()
+      end;
+
+      let concr_meths = Concr.union cl_sig.csig_concr concr_meths
+      and warn_vals = Concr.union concr_vals warn_vals in
+
+      (cl_sig, concr_meths, warn_vals)
+
+  | _ ->
+      raise(Error(loc, env, Structure_expected parent))
+
+let virtual_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  let cty = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
+  end;
+  cty
+
+let delayed_meth_specs = ref []
+
+let declare_method val_env meths self_type lab priv sty loc =
+  let (_, ty') =
+     Ctype.filter_self_method val_env lab priv meths self_type
+  in
+  let unif ty =
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
+  in
+  let sty = Ast_helper.Typ.force_poly sty in
+  match sty.ptyp_desc, priv with
+    Ptyp_poly ([],sty'), Public ->
+(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
+so that we can get an immediate value. Is that correct ? Ask Jacques. *)
+      let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
+      delayed_meth_specs :=
+      lazy (
+        let cty = transl_simple_type_univars val_env sty' in
+        let ty = cty.ctyp_type in
+        unif ty;
+        returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
+        returned_cty.ctyp_type <- ty;
+        ) ::
+      !delayed_meth_specs;
+      returned_cty
+  | _ ->
+      let cty = transl_simple_type val_env false sty in
+      let ty = cty.ctyp_type in
+      unif ty;
+      cty
+
+let type_constraint val_env sty sty' loc =
+  let cty  = transl_simple_type val_env false sty in
+  let ty = cty.ctyp_type in
+  let cty' = transl_simple_type val_env false sty' in
+  let ty' = cty'.ctyp_type in
+  begin
+    try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+        raise(Error(loc, val_env, Unconsistent_constraint trace));
+  end;
+  (cty, cty')
+
+let make_method loc cl_num expr =
+  let open Ast_helper in
+  let mkid s = mkloc s loc in
+  Exp.fun_ ~loc:expr.pexp_loc Nolabel None
+    (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
+    expr
+
+(*******************************)
+
+let add_val lab (mut, virt, ty) val_sig =
+  let virt =
+    try
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
+      if virt' = Concrete then virt' else virt
+    with Not_found -> virt
+  in
+  Vars.add lab (mut, virt, ty) val_sig
+
+let rec class_type_field env self_type meths
+    (fields, val_sig, concr_meths, inher) ctf =
+  let loc = ctf.pctf_loc in
+  let mkctf desc =
+    { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
+  in
+  match ctf.pctf_desc with
+    Pctf_inherit sparent ->
+      let parent = class_type env sparent in
+      let inher =
+        match parent.cltyp_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, _) =
+        inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
+          parent.cltyp_type
+      in
+      let val_sig =
+        Vars.fold add_val cl_sig.csig_vars val_sig in
+      (mkctf (Tctf_inherit parent) :: fields,
+       val_sig, concr_meths, inher)
+
+  | Pctf_val ({txt=lab}, mut, virt, sty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
+
+  | Pctf_method ({txt=lab}, priv, virt, sty)  ->
+      let cty =
+        declare_method env meths self_type lab priv sty  ctf.pctf_loc in
+      let concr_meths =
+        match virt with
+        | Concrete -> Concr.add lab concr_meths
+        | Virtual -> concr_meths
+      in
+      (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint env sty sty'  ctf.pctf_loc in
+      (mkctf (Tctf_constraint (cty, cty')) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_attribute x ->
+      Builtin_attributes.warning_attribute [x];
+      (mkctf (Tctf_attribute x) :: fields,
+        val_sig, concr_meths, inher)
+
+  | Pctf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
+  let meths = ref Meths.empty in
+  let self_cty = transl_simple_type env false sty in
+  let self_cty = { self_cty with
+    ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
+  let self_type =  self_cty.ctyp_type in
+
+  (* Check that the binder is a correct type, and introduce a dummy
+     method preventing self type from being closed. *)
+  let dummy_obj = Ctype.newvar () in
+  Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
+    (Ctype.newty (Ttuple []));
+  begin try
+    Ctype.unify env self_type dummy_obj
+  with Ctype.Unify _ ->
+    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
+  end;
+
+  (* Class type fields *)
+  Builtin_attributes.warning_enter_scope ();
+  let (rev_fields, val_sig, concr_meths, inher) =
+    List.fold_left (class_type_field env self_type meths)
+      ([], Vars.empty, Concr.empty, [])
+      sign
+  in
+  Builtin_attributes.warning_leave_scope ();
+  let cty =   {csig_self = self_type;
+   csig_vars = val_sig;
+   csig_concr = concr_meths;
+   csig_inher = inher}
+  in
+  { csig_self = self_cty;
+    csig_fields = List.rev rev_fields;
+    csig_type = cty;
+  }
+
+and class_type env scty =
+  let cltyp desc typ =
+    {
+     cltyp_desc = desc;
+     cltyp_type = typ;
+     cltyp_loc = scty.pcty_loc;
+     cltyp_env = env;
+     cltyp_attributes = scty.pcty_attributes;
+    }
+  in
+  match scty.pcty_desc with
+    Pcty_constr (lid, styl) ->
+      let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
+      if Path.same decl.clty_path unbound_class then
+        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
+      let (params, clty) =
+        Ctype.instance_class decl.clty_params decl.clty_type
+      in
+      if List.length params <> List.length styl then
+        raise(Error(scty.pcty_loc, env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length styl)));
+      let ctys = List.map2
+        (fun sty ty ->
+          let cty' = transl_simple_type env false sty in
+          let ty' = cty'.ctyp_type in
+          begin
+           try Ctype.unify env ty' ty with Ctype.Unify trace ->
+                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
+            end;
+            cty'
+        )       styl params
+      in
+      let typ = Cty_constr (path, params, clty) in
+      cltyp (Tcty_constr ( path, lid , ctys)) typ
+
+  | Pcty_signature pcsig ->
+      let clsig = class_signature env pcsig in
+      let typ = Cty_signature clsig.csig_type in
+      cltyp (Tcty_signature clsig) typ
+
+  | Pcty_arrow (l, sty, scty) ->
+      let cty = transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      let ty =
+        if Btype.is_optional l
+        then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+        else ty in
+      let clty = class_type env scty in
+      let typ = Cty_arrow (l, ty, clty.cltyp_type) in
+      cltyp (Tcty_arrow (l, cty, clty)) typ
+  | Pcty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let class_type env scty =
+  delayed_meth_specs := [];
+  let cty = class_type env scty in
+  List.iter Lazy.force (List.rev !delayed_meth_specs);
+  delayed_meth_specs := [];
+  cty
+
+(*******************************)
+
+let rec class_field self_loc cl_num self_type meths vars
+    (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher,
+     local_meths, local_vals)
+  cf =
+  let loc = cf.pcf_loc in
+  let mkcf desc =
+    { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
+  in
+  match cf.pcf_desc with
+    Pcf_inherit (ovf, sparent, super) ->
+      let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Cty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
+      let (cl_sig, concr_meths, warn_vals) =
+        inheritance self_type val_env (Some ovf) concr_meths warn_vals
+          sparent.pcl_loc parent.cl_type
+      in
+      (* Variables *)
+      let (val_env, met_env, par_env, inh_vars) =
+        Vars.fold
+          (fun lab info (val_env, met_env, par_env, inh_vars) ->
+             let mut, vr, ty = info in
+             let (id, val_env, met_env, par_env) =
+               enter_val cl_num vars true lab mut vr ty val_env met_env par_env
+                 sparent.pcl_loc
+             in
+             (val_env, met_env, par_env, (lab, id) :: inh_vars))
+          cl_sig.csig_vars (val_env, met_env, par_env, [])
+      in
+      (* Inherited concrete methods *)
+      let inh_meths =
+        Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
+          cl_sig.csig_concr []
+      in
+      (* Super *)
+      let (val_env, met_env, par_env,super) =
+        match super with
+          None ->
+            (val_env, met_env, par_env,None)
+        | Some {txt=name} ->
+            let (_id, val_env, met_env, par_env) =
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
+                val_env met_env par_env
+            in
+            (val_env, met_env, par_env,Some name)
+      in
+      (val_env, met_env, par_env,
+       lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
+       :: fields,
+       concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_virtual styp) ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let cty = Typetexp.transl_simple_type val_env false styp in
+      let ty = cty.ctyp_type in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure ty
+      end;
+      let (id, val_env, met_env', par_env) =
+        enter_val cl_num vars false lab.txt mut Virtual ty
+          val_env met_env par_env loc
+      in
+      (val_env, met_env', par_env,
+       lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
+                            met_env == met_env')))
+             :: fields,
+             concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
+      if Concr.mem lab.txt local_vals then
+        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
+      if Concr.mem lab.txt warn_vals then begin
+        if ovf = Fresh then
+          Location.prerr_warning lab.loc
+            (Warnings.Instance_variable_override[lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env,
+                      No_overriding ("instance variable", lab.txt)))
+      end;
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp =
+        try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
+          raise(Error(loc, val_env, Make_nongen_seltype ty))
+      in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+       end;
+      let (id, val_env, met_env', par_env) =
+        enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
+          val_env met_env par_env loc
+      in
+      (val_env, met_env', par_env,
+       lazy (mkcf (Tcf_val (lab, mut, id,
+                            Tcfk_concrete (ovf, exp), met_env == met_env')))
+       :: fields,
+       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+       Concr.add lab.txt local_vals)
+
+  | Pcf_method (lab, priv, Cfk_virtual sty) ->
+      let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
+      (val_env, met_env, par_env,
+        lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
+       ::fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_method (lab, priv, Cfk_concrete (ovf, expr))  ->
+      let expr =
+        match expr.pexp_desc with
+        | Pexp_poly _ -> expr
+        | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
+      in
+      if Concr.mem lab.txt local_meths then
+        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
+      if Concr.mem lab.txt concr_meths then begin
+        if ovf = Fresh then
+          Location.prerr_warning loc (Warnings.Method_override [lab.txt])
+      end else begin
+        if ovf = Override then
+          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
+      end;
+      let (_, ty) =
+        Ctype.filter_self_method val_env lab.txt priv meths self_type
+      in
+      begin try match expr.pexp_desc with
+        Pexp_poly (sbody, sty) ->
+          begin match sty with None -> ()
+                | Some sty ->
+                    let sty = Ast_helper.Typ.force_poly sty in
+                    let cty' = Typetexp.transl_simple_type val_env false sty in
+                    let ty' = cty'.ctyp_type in
+              Ctype.unify val_env ty' ty
+          end;
+          begin match (Ctype.repr ty).desc with
+            Tvar _ ->
+              let ty' = Ctype.newvar () in
+              Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
+              Ctype.unify val_env (type_approx val_env sbody) ty'
+          | Tpoly (ty1, tl) ->
+              let _, ty1' = Ctype.instance_poly false tl ty1 in
+              let ty2 = type_approx val_env sbody in
+              Ctype.unify val_env ty2 ty1'
+          | _ -> assert false
+          end
+      | _ -> assert false
+      with Ctype.Unify trace ->
+        raise(Error(loc, val_env,
+                    Field_type_mismatch ("method", lab.txt, trace)))
+      end;
+      let meth_expr = make_method self_loc cl_num expr in
+      (* backup variables for Pexp_override *)
+      let vars_local = !vars in
+
+      let field =
+        lazy begin
+          (* Read the generalized type *)
+          let (_, ty) = Meths.find lab.txt !meths in
+          let meth_type =
+            Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)) in
+          Ctype.raise_nongen_level ();
+          vars := vars_local;
+          let texp = type_expect met_env meth_expr meth_type in
+          Ctype.end_def ();
+          mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
+        end in
+      (val_env, met_env, par_env, field::fields,
+       Concr.add lab.txt concr_meths, warn_vals, inher,
+       Concr.add lab.txt local_meths, local_vals)
+
+  | Pcf_constraint (sty, sty') ->
+      let (cty, cty') = type_constraint val_env sty sty' loc in
+      (val_env, met_env, par_env,
+        lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+
+  | Pcf_initializer expr ->
+      let expr = make_method self_loc cl_num expr in
+      let vars_local = !vars in
+      let field =
+        lazy begin
+          Ctype.raise_nongen_level ();
+          let meth_type =
+            Ctype.newty
+              (Tarrow (Nolabel, self_type,
+                       Ctype.instance_def Predef.type_unit, Cok)) in
+          vars := vars_local;
+          let texp = type_expect met_env expr meth_type in
+          Ctype.end_def ();
+          mkcf (Tcf_initializer texp)
+        end in
+      (val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
+       inher, local_meths, local_vals)
+  | Pcf_attribute x ->
+      Builtin_attributes.warning_attribute [x];
+      (val_env, met_env, par_env,
+        lazy (mkcf (Tcf_attribute x)) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
+  | Pcf_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and class_structure cl_num final val_env met_env loc
+  { pcstr_self = spat; pcstr_fields = str } =
+  (* Environment for substructures *)
+  let par_env = met_env in
+
+  (* Location of self. Used for locations of self arguments *)
+  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} 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 private_self val_env met_env par_env spat
+  in
+  let public_self = pat.pat_type in
+
+  (* 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, val_env, 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;
+
+  (* Typing of class fields *)
+  Builtin_attributes.warning_enter_scope ();
+  let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) =
+    List.fold_left (class_field self_loc cl_num self_type meths vars)
+      (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
+       Concr.empty, Concr.empty)
+      str
+  in
+  Builtin_attributes.warning_leave_scope ();
+  Ctype.unify val_env self_type (Ctype.newvar ());
+  let sign =
+    {csig_self = public_self;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_concr = concr_meths;
+      csig_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 csig_self = self_type} in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> [] || vals <> [] then
+      raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
+    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, val_env, Final_self_clash trace))
+    end;
+  end;
+
+  (* Typing of method bodies *)
+  (* if !Clflags.principal then *) begin
+    let ms = !meths in
+    (* Generalize the spine of methods accessed through self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
+    meths :=
+      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance val_env ty)) ms;
+    (* But keep levels correct on the type of self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
+  end;
+  let fields = List.map Lazy.force (List.rev fields) in
+  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.Implicit_public_methods added);
+  let sign = if final then sign else
+      {sign with Types.csig_self = Ctype.expand_head val_env public_self} in
+  {
+    cstr_self = pat;
+    cstr_fields = fields;
+    cstr_type = sign;
+    cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
+
+and class_expr cl_num val_env met_env scl =
+  match scl.pcl_desc with
+    Pcl_constr (lid, styl) ->
+      let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in
+      if Path.same decl.cty_path unbound_class then
+        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
+      let tyl = List.map
+          (fun sty -> transl_simple_type val_env false sty)
+          styl
+      in
+      let (params, clty) =
+        Ctype.instance_class decl.cty_params decl.cty_type
+      in
+      let clty' = abbreviate_class_type path params clty in
+      if List.length params <> List.length tyl then
+        raise(Error(scl.pcl_loc, val_env,
+                    Parameter_arity_mismatch (lid.txt, List.length params,
+                                                   List.length tyl)));
+      List.iter2
+        (fun cty' ty ->
+          let ty' = cty'.ctyp_type in
+           try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
+             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
+        tyl params;
+      let cl =
+        rc {cl_desc = Tcl_ident (path, lid, tyl);
+            cl_loc = scl.pcl_loc;
+            cl_type = clty';
+            cl_env = val_env;
+            cl_attributes = scl.pcl_attributes;
+           }
+      in
+      let (vals, meths, concrs) = extract_constraints clty in
+      rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = clty';
+          cl_env = val_env;
+          cl_attributes = []; (* attributes are kept on the inner cl node *)
+         }
+  | Pcl_structure cl_str ->
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
+      rc {cl_desc = Tcl_structure desc;
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_signature ty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_fun (l, Some default, spat, sbody) ->
+      let loc = default.pexp_loc in
+      let open Ast_helper in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let smatch =
+        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let sfun =
+        Cl.fun_ ~loc:scl.pcl_loc
+          l None
+          (Pat.var ~loc (mknoloc "*opt*"))
+          (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
+          (* Note: we don't put the '#default' attribute, as it
+             is not detected for class-level let bindings.  See #5975.*)
+      in
+      class_expr cl_num val_env met_env sfun
+  | Pcl_fun (l, None, spat, scl') ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let (pat, pv, val_env', met_env) =
+        Typecore.type_class_arg_pattern cl_num val_env met_env l spat
+      in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        iter_pattern (fun {pat_type=ty} -> Ctype.generalize_structure ty) pat
+      end;
+      let pv =
+        List.map
+          begin fun (id, id_loc, id', _ty) ->
+            let path = Pident id' in
+            (* do not mark the value as being used *)
+            let vd = Env.find_value path val_env' in
+            (id, id_loc,
+             {exp_desc =
+              Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
+              exp_loc = Location.none; exp_extra = [];
+              exp_type = Ctype.instance val_env' vd.val_type;
+              exp_attributes = []; (* check *)
+              exp_env = val_env'})
+          end
+          pv
+      in
+      let not_function = function
+          Cty_arrow _ -> false
+        | _ -> true
+      in
+      let partial =
+        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
+        Typecore.check_partial val_env pat.pat_type pat.pat_loc
+          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
+      in
+      Ctype.raise_nongen_level ();
+      let cl = class_expr cl_num val_env' met_env scl' in
+      Ctype.end_def ();
+      if Btype.is_optional l && not_function cl.cl_type then
+        Location.prerr_warning pat.pat_loc
+          Warnings.Unerasable_optional_argument;
+      rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
+          cl_loc = scl.pcl_loc;
+          cl_type = Cty_arrow
+            (l, Ctype.instance_def pat.pat_type, cl.cl_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_apply (scl', sargs) ->
+      assert (sargs <> []);
+      if !Clflags.principal then Ctype.begin_def ();
+      let cl = class_expr cl_num val_env met_env scl' in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        generalize_class_type false cl.cl_type;
+      end;
+      let rec nonopt_labels ls ty_fun =
+        match ty_fun with
+        | Cty_arrow (l, _, ty_res) ->
+            if Btype.is_optional l then nonopt_labels ls ty_res
+            else nonopt_labels (l::ls) ty_res
+        | _    -> ls
+      in
+      let ignore_labels =
+        !Clflags.classic ||
+        let labels = nonopt_labels [] cl.cl_type in
+        List.length labels = List.length sargs &&
+        List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+        List.exists (fun l -> l <> Nolabel) labels &&
+        begin
+          Location.prerr_warning
+            cl.cl_loc
+            (Warnings.Labels_omitted
+               (List.map Printtyp.string_of_label
+                         (List.filter ((<>) Nolabel) labels)));
+          true
+        end
+      in
+      let rec type_args args omitted ty_fun ty_fun0 sargs more_sargs =
+        match ty_fun, ty_fun0 with
+        | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
+          when sargs <> [] || more_sargs <> [] ->
+            let name = Btype.label_name l
+            and optional = Btype.is_optional l in
+            let sargs, more_sargs, arg =
+              if ignore_labels && not (Btype.is_optional l) then begin
+                match sargs, more_sargs with
+                  (l', sarg0)::_, _ ->
+                    raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l'))
+                | _, (l', sarg0)::more_sargs ->
+                    if l <> l' && l' <> Nolabel then
+                      raise(Error(sarg0.pexp_loc, val_env,
+                                  Apply_wrong_label l'))
+                    else ([], more_sargs,
+                          Some (type_argument val_env sarg0 ty ty0))
+                | _ ->
+                    assert false
+              end else try
+                let (l', sarg0, sargs, more_sargs) =
+                  try
+                    let (l', sarg0, sargs1, sargs2) =
+                      Btype.extract_label name sargs
+                    in (l', sarg0, sargs1 @ sargs2, more_sargs)
+                  with Not_found ->
+                    let (l', sarg0, sargs1, sargs2) =
+                      Btype.extract_label name more_sargs
+                    in (l', sarg0, sargs @ sargs1, sargs2)
+                in
+                if not optional && Btype.is_optional l' then
+                  Location.prerr_warning sarg0.pexp_loc
+                    (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+                sargs, more_sargs,
+                if not optional || Btype.is_optional l' then
+                  Some (type_argument val_env sarg0 ty ty0)
+                else
+                  let ty' = extract_option_type val_env ty
+                  and ty0' = extract_option_type val_env ty0 in
+                  let arg = type_argument val_env sarg0 ty' ty0' in
+                  Some (option_some arg)
+              with Not_found ->
+                sargs, more_sargs,
+                if Btype.is_optional l
+                   && (List.mem_assoc Nolabel sargs
+                       || List.mem_assoc Nolabel more_sargs)
+                then
+                  Some (option_none ty0 Location.none)
+                else None
+            in
+            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+            type_args ((l,arg)::args) omitted ty_fun ty_fun0
+              sargs more_sargs
+        | _ ->
+            match sargs @ more_sargs with
+              (l, sarg0)::_ ->
+                if omitted <> [] then
+                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
+                else
+                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
+            | [] ->
+                (List.rev args,
+                 List.fold_left
+                   (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
+                   ty_fun0 omitted)
+      in
+      let (args, cty) =
+        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
+        if ignore_labels then
+          type_args [] [] cl.cl_type ty_fun0 [] sargs
+        else
+          type_args [] [] cl.cl_type ty_fun0 sargs []
+      in
+      rc {cl_desc = Tcl_apply (cl, args);
+          cl_loc = scl.pcl_loc;
+          cl_type = cty;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_let (rec_flag, sdefs, scl') ->
+      let (defs, val_env) =
+        try
+          Typecore.type_let val_env rec_flag sdefs None
+        with Ctype.Unify [(ty, _)] ->
+          raise(Error(scl.pcl_loc, val_env, Make_nongen_seltype ty))
+      in
+      let (vals, met_env) =
+        List.fold_right
+          (fun (id, id_loc) (vals, met_env) ->
+             let path = Pident id in
+             (* do not mark the value as used *)
+             let vd = Env.find_value path val_env in
+             Ctype.begin_def ();
+             let expr =
+               {exp_desc =
+                Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
+                exp_loc = Location.none; exp_extra = [];
+                exp_type = Ctype.instance val_env vd.val_type;
+                exp_attributes = [];
+                exp_env = val_env;
+               }
+             in
+             Ctype.end_def ();
+             Ctype.generalize expr.exp_type;
+             let desc =
+               {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
+                                                               cl_num);
+                val_attributes = [];
+                Types.val_loc = vd.Types.val_loc;
+               }
+             in
+             let id' = Ident.create (Ident.name id) in
+             ((id', id_loc, expr)
+              :: vals,
+              Env.add_value id' desc met_env))
+          (let_bound_idents_with_loc defs)
+          ([], met_env)
+      in
+      let cl = class_expr cl_num val_env met_env scl' in
+      rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_constraint (scl', scty) ->
+      Ctype.begin_class_def ();
+      let context = Typetexp.narrow () in
+      let cl = class_expr cl_num val_env met_env scl' in
+      Typetexp.widen context;
+      let context = Typetexp.narrow () in
+      let clty = class_type val_env scty in
+      Typetexp.widen context;
+      Ctype.end_def ();
+
+      limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
+          cl.cl_type;
+      limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
+        clty.cltyp_type;
+
+      begin match
+        Includeclass.class_types val_env cl.cl_type clty.cltyp_type
+      with
+        []    -> ()
+      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
+      end;
+      let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
+      rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
+  | Pcl_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+(*******************************)
+
+(* Approximate the type of the constructor to allow recursive use *)
+(* of optional parameters                                         *)
+
+let var_option = Predef.type_option (Btype.newgenvar ())
+
+let rec approx_declaration cl =
+  match cl.pcl_desc with
+    Pcl_fun (l, _, _, cl) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance_def var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
+  | Pcl_let (_, _, cl) ->
+      approx_declaration cl
+  | Pcl_constraint (cl, _) ->
+      approx_declaration cl
+  | _ -> Ctype.newvar ()
+
+let rec approx_description ct =
+  match ct.pcty_desc with
+    Pcty_arrow (l, _, ct) ->
+      let arg =
+        if Btype.is_optional l then Ctype.instance_def var_option
+        else Ctype.newvar () in
+      Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
+  | _ -> Ctype.newvar ()
+
+(*******************************)
+
+let temp_abbrev loc env id arity =
+  let params = ref [] in
+  for _i = 1 to arity do
+    params := Ctype.newvar () :: !params
+  done;
+  let ty = Ctype.newobj (Ctype.newvar ()) in
+  let env =
+    Env.add_type ~check:true id
+      {type_params = !params;
+       type_arity = arity;
+       type_kind = Type_abstract;
+       type_private = Public;
+       type_manifest = Some ty;
+       type_variance = Misc.replicate_list Variance.full arity;
+       type_newtype_level = None;
+       type_loc = loc;
+       type_attributes = []; (* or keep attrs from the class decl? *)
+       type_immediate = false;
+       type_unboxed = unboxed_false_default_false;
+      }
+      env
+  in
+  (!params, ty, env)
+
+let initial_env define_class approx
+    (res, env) (cl, id, ty_id, obj_id, cl_id) =
+  (* Temporary abbreviations *)
+  let arity = List.length cl.pci_params in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in
+
+  (* Temporary type for the class constructor *)
+  let constr_type = approx cl.pci_expr in
+  if !Clflags.principal then Ctype.generalize_spine constr_type;
+  let dummy_cty =
+    Cty_signature
+      { csig_self = Ctype.newvar ();
+        csig_vars = Vars.empty;
+        csig_concr = Concr.empty;
+        csig_inher = [] }
+  in
+  let dummy_class =
+    {Types.cty_params = [];             (* Dummy value *)
+     cty_variance = [];
+     cty_type = dummy_cty;        (* Dummy value *)
+     cty_path = unbound_class;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = Location.none;
+     cty_attributes = [];
+    }
+  in
+  let env =
+    Env.add_cltype ty_id
+      {clty_params = [];            (* Dummy value *)
+       clty_variance = [];
+       clty_type = dummy_cty;       (* Dummy value *)
+       clty_path = unbound_class;
+       clty_loc = Location.none;
+       clty_attributes = [];
+      }
+      (
+        if define_class then
+          Env.add_class id dummy_class env
+        else
+          env
+      )
+  in
+  ((cl, id, ty_id,
+    obj_id, obj_params, obj_ty,
+    cl_id, cl_params, cl_ty,
+    constr_type, dummy_class)::res,
+   env)
+
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+
+  reset_type_variables ();
+  Ctype.begin_class_def ();
+
+  (* Introduce class parameters *)
+  let ci_params =
+    let make_param (sty, v) =
+      try
+          (transl_type_param env sty, v)
+      with Already_bound ->
+        raise(Error(sty.ptyp_loc, env, Repeated_parameter))
+    in
+      List.map make_param cl.pci_params
+  in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
+
+  (* Allow self coercions (only for class declarations) *)
+  let coercion_locs = ref [] in
+
+  (* Type the class expression *)
+  let (expr, typ) =
+    try
+      Typecore.self_coercion :=
+        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+      let res = kind env cl.pci_expr in
+      Typecore.self_coercion := List.tl !Typecore.self_coercion;
+      res
+    with exn ->
+      Typecore.self_coercion := []; raise exn
+  in
+
+  Ctype.end_def ();
+
+  let sty = Ctype.self_type typ in
+
+  (* First generalize the type of the dummy method (cf PR#6123) *)
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+    fields;
+  (* Generalize the row variable *)
+  let rv = Ctype.row_variable sty in
+  List.iter (Ctype.limited_generalize rv) params;
+  limited_generalize rv typ;
+
+  (* Check the abbreviation for the object type *)
+  let (obj_params', obj_type) = Ctype.instance_class params typ in
+  let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+  begin
+    let ty = Ctype.self_type obj_type in
+    Ctype.hide_private_methods ty;
+    Ctype.close_object ty;
+    begin try
+      List.iter2 (Ctype.unify env) obj_params obj_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (obj_id, constr,
+                            Ctype.newconstr (Path.Pident obj_id)
+                                            obj_params')))
+    end;
+    begin try
+      Ctype.unify env ty constr
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+        Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
+    end
+  end;
+
+  (* Check the other temporary abbreviation (#-type) *)
+  begin
+    let (cl_params', cl_type) = Ctype.instance_class params typ in
+    let ty = Ctype.self_type cl_type in
+    Ctype.hide_private_methods ty;
+    Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+    begin try
+      List.iter2 (Ctype.unify env) cl_params cl_params'
+    with Ctype.Unify _ ->
+      raise(Error(cl.pci_loc, env,
+            Bad_parameters (cl_id,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params,
+                            Ctype.newconstr (Path.Pident cl_id)
+                                            cl_params')))
+    end;
+    begin try
+      Ctype.unify env ty cl_ty
+    with Ctype.Unify _ ->
+      let constr = Ctype.newconstr (Path.Pident cl_id) params in
+      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
+    end
+  end;
+
+  (* Type of the class constructor *)
+  begin try
+    Ctype.unify env
+      (constructor_type constr obj_type)
+      (Ctype.instance env constr_type)
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env,
+                Constructor_type_mismatch (cl.pci_name.txt, trace)))
+  end;
+
+  (* Class and class type temporary definitions *)
+  let cty_variance = List.map (fun _ -> Variance.full) params in
+  let cltydef =
+    {clty_params = params; clty_type = class_body typ;
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+    }
+  and clty =
+    {cty_params = params; cty_type = typ;
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some constr_type
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+    }
+  in
+  dummy_class.cty_type <- typ;
+  let env =
+    Env.add_cltype ty_id cltydef (
+    if define_class then Env.add_class id clty env else env)
+  in
+
+  if cl.pci_virt = Concrete then begin
+    let sign = Ctype.signature_of_class_type typ in
+    let mets = virtual_methods sign in
+    let vals =
+      Vars.fold
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
+        sign.csig_vars [] in
+    if mets <> []  || vals <> [] then
+      raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
+                                                 vals)));
+  end;
+
+  (* Misc. *)
+  let arity = Ctype.class_type_arity typ in
+  let pub_meths =
+    let (fields, _) =
+      Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
+    in
+    List.map (function (lab, _, _) -> lab) fields
+  in
+
+  (* Final definitions *)
+  let (params', typ') = Ctype.instance_class params typ in
+  let cltydef =
+    {clty_params = params'; clty_type = class_body typ';
+     clty_variance = cty_variance;
+     clty_path = Path.Pident obj_id;
+     clty_loc = cl.pci_loc;
+     clty_attributes = cl.pci_attributes;
+    }
+  and clty =
+    {cty_params = params'; cty_type = typ';
+     cty_variance = cty_variance;
+     cty_path = Path.Pident obj_id;
+     cty_new =
+       begin match cl.pci_virt with
+       | Virtual  -> None
+       | Concrete -> Some (Ctype.instance env constr_type)
+       end;
+     cty_loc = cl.pci_loc;
+     cty_attributes = cl.pci_attributes;
+    }
+  in
+  let obj_abbr =
+    {type_params = obj_params;
+     type_arity = List.length obj_params;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some obj_ty;
+     type_variance = List.map (fun _ -> Variance.full) obj_params;
+     type_newtype_level = None;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = false;
+     type_unboxed = unboxed_false_default_false;
+    }
+  in
+  let (cl_params, cl_ty) =
+    Ctype.instance_parameterized_type params (Ctype.self_type typ)
+  in
+  Ctype.hide_private_methods cl_ty;
+  Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+  let cl_abbr =
+    {type_params = cl_params;
+     type_arity = List.length cl_params;
+     type_kind = Type_abstract;
+     type_private = Public;
+     type_manifest = Some cl_ty;
+     type_variance = List.map (fun _ -> Variance.full) cl_params;
+     type_newtype_level = None;
+     type_loc = cl.pci_loc;
+     type_attributes = []; (* or keep attrs from cl? *)
+     type_immediate = false;
+     type_unboxed = unboxed_false_default_false;
+    }
+  in
+  ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
+   env)
+
+let final_decl env define_class
+    (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
+     arity, pub_meths, coe, expr) =
+
+  begin try Ctype.collapse_conj_params env clty.cty_params
+  with Ctype.Unify trace ->
+    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
+  end;
+
+  List.iter Ctype.generalize clty.cty_params;
+  generalize_class_type true clty.cty_type;
+  Misc.may  Ctype.generalize clty.cty_new;
+  List.iter Ctype.generalize obj_abbr.type_params;
+  Misc.may  Ctype.generalize obj_abbr.type_manifest;
+  List.iter Ctype.generalize cl_abbr.type_params;
+  Misc.may  Ctype.generalize cl_abbr.type_manifest;
+
+  if not (closed_class clty) then
+    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
+
+  begin match
+    Ctype.closed_class clty.cty_params
+      (Ctype.signature_of_class_type clty.cty_type)
+  with
+    None        -> ()
+  | Some reason ->
+      let printer =
+        if define_class
+        then function ppf -> Printtyp.class_declaration id ppf clty
+        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
+      in
+      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
+  end;
+
+  (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+   arity, pub_meths, coe, expr,
+   { ci_loc = cl.pci_loc;
+     ci_virt = cl.pci_virt;
+     ci_params = ci_params;
+(* TODO : check that we have the correct use of identifiers *)
+     ci_id_name = cl.pci_name;
+     ci_id_class = id;
+     ci_id_class_type = ty_id;
+     ci_id_object = obj_id;
+     ci_id_typehash = cl_id;
+     ci_expr = expr;
+     ci_decl = clty;
+     ci_type_decl = cltydef;
+     ci_attributes = cl.pci_attributes;
+ })
+(*   (cl.pci_variance, cl.pci_loc)) *)
+
+let extract_type_decls
+    (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr,
+     _arity, _pub_meths, _coe, _expr, required) decls =
+  (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls
+
+let merge_type_decls
+    (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr,
+     arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) =
+  (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+   arity, pub_meths, coe, expr, req)
+
+let final_env define_class env
+    (id, _id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+     _arity, _pub_meths, _coe, _expr, _req) =
+  (* Add definitions after cleaning them *)
+  Env.add_type ~check:true obj_id
+    (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type ~check:true 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
+    (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+     arity, pub_meths, coercion_locs, _expr, req) =
+  begin match coercion_locs with [] -> ()
+  | loc :: _ ->
+      let cl_ty, obj_ty =
+        match cl_abbr.type_manifest, obj_abbr.type_manifest with
+          Some cl_ab, Some obj_ab ->
+            let cl_params, cl_ty =
+              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
+            and obj_params, obj_ty =
+              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
+            in
+            List.iter2 (Ctype.unify env) cl_params obj_params;
+            cl_ty, obj_ty
+        | _ -> assert false
+      in
+      begin try Ctype.subtype env cl_ty obj_ty ()
+      with Ctype.Subtype (tr1, tr2) ->
+        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
+      end;
+      if not (Ctype.opened_object cl_ty) then
+        raise(Error(loc, env, Cannot_coerce_self obj_ty))
+  end;
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
+
+(*******************************)
+
+let type_classes define_class approx kind env cls =
+  let cls =
+    List.map
+      (function cl ->
+         (cl,
+          Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt,
+          Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt)))
+      cls
+  in
+  Ctype.init_def (Ident.current_time ());
+  Ctype.begin_class_def ();
+  let (res, env) =
+    List.fold_left (initial_env define_class approx) ([], env) cls
+  in
+  let (res, env) =
+    List.fold_right (class_infos define_class kind) res ([], env)
+  in
+  Ctype.end_def ();
+  let res = List.rev_map (final_decl env define_class) res in
+  let decls = List.fold_right extract_type_decls res [] in
+  let decls = Typedecl.compute_variance_decls env decls in
+  let res = List.map2 merge_type_decls res decls in
+  let env = List.fold_left (final_env define_class) env res in
+  let res = List.map (check_coercions env) res in
+  (res, env)
+
+let class_num = ref 0
+let class_declaration env sexpr =
+  incr class_num;
+  let expr = class_expr (string_of_int !class_num) env env sexpr in
+  (expr, expr.cl_type)
+
+let class_description env sexpr =
+  let expr = class_type env sexpr in
+  (expr, expr.cltyp_type)
+
+let class_declarations env cls =
+  type_classes true approx_declaration class_declaration env cls
+
+let class_descriptions env cls =
+  type_classes true approx_description class_description env cls
+
+let class_type_declarations env cls =
+  let (decls, env) =
+    type_classes false approx_description class_description env cls
+  in
+  (List.map
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
+   env)
+
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tcl_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 env body)
+      with
+        Not_found -> ()
+      | _exn -> assert false
+      end
+  | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_fun (_, _, _, cl, _)
+  | Tcl_apply (cl, _)
+  | Tcl_let (_, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function
+      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
+          unify_parents env ty cl
+      | _ -> ())
+    st.cstr_fields
+
+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.csig_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.csig_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
+(*******************************)
+
+(* Approximate the class declaration as class ['params] id = object end *)
+let approx_class sdecl =
+  let open Ast_helper in
+  let self' = Typ.any () in
+  let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
+  { sdecl with pci_expr = clty' }
+
+let approx_class_declarations env sdecls =
+  fst (class_type_declarations env (List.map approx_class sdecls))
+
+(*******************************)
+
+(* Error report *)
+
+open Format
+
+let report_error env ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Unconsistent_constraint trace ->
+      fprintf ppf "The class constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Field_type_mismatch (k, m, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The %s %s@ has type" k m)
+        (function ppf ->
+           fprintf ppf "but is expected to have type")
+  | Structure_expected clty ->
+      fprintf ppf
+        "@[This class expression is not a class structure; it has type@ %a@]"
+        Printtyp.class_type clty
+  | Cannot_apply _ ->
+      fprintf ppf
+        "This class expression is not a class function, it cannot be applied"
+  | Apply_wrong_label l ->
+      let mark_label = function
+        | Nolabel -> "out label"
+        |  l -> sprintf " label %s" (Btype.prefixed_label_name l) in
+      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
+  | Pattern_type_clash ty ->
+      (* XXX Trace *)
+      (* XXX Revoir message d'erreur | Improve error message *)
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf "@[%s@ %a@]"
+        "This pattern cannot match self: it only matches values of type"
+        Printtyp.type_expr ty
+  | Unbound_class_2 cl ->
+      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Unbound_class_type_2 cl ->
+      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
+      Printtyp.longident cl
+  | Abbrev_type_clash (abbrev, actual, expected) ->
+      (* XXX Afficher une trace ? | Print a trace? *)
+      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
+      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
+       but is used with type@ %a@]"
+       Printtyp.type_expr abbrev
+       Printtyp.type_expr actual
+       Printtyp.type_expr expected
+  | Constructor_type_mismatch (c, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The expression \"new %s\" has type" c)
+        (function ppf ->
+           fprintf ppf "but is used with type")
+  | Virtual_class (cl, imm, mets, vals) ->
+      let print_mets ppf mets =
+        List.iter (function met -> fprintf ppf "@ %s" met) mets in
+      let missings =
+        match mets, vals with
+          [], _ -> "variables"
+        | _, [] -> "methods"
+        | _ -> "methods and variables"
+      in
+      let print_msg ppf =
+        if imm then fprintf ppf "This object has virtual %s" missings
+        else if cl then fprintf ppf "This class should be virtual"
+        else fprintf ppf "This class type should be virtual"
+      in
+      fprintf ppf
+        "@[%t.@ @[<2>The following %s are undefined :%a@]@]"
+        print_msg missings print_mets (mets @ vals)
+  | Parameter_arity_mismatch(lid, expected, provided) ->
+      fprintf ppf
+        "@[The class constructor %a@ expects %i type argument(s),@ \
+           but is here applied to %i type argument(s)@]"
+        Printtyp.longident lid expected provided
+  | Parameter_mismatch trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The type parameter")
+        (function ppf ->
+           fprintf ppf "does not meet its constraint: it should be")
+  | Bad_parameters (id, params, cstrs) ->
+      Printtyp.reset_and_mark_loops_list [params; cstrs];
+      fprintf ppf
+        "@[The abbreviation %a@ is used with parameters@ %a@ \
+           which are incompatible with constraints@ %a@]"
+        Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs
+  | Class_match_failure error ->
+      Includeclass.report_error ppf error
+  | Unbound_val lab ->
+      fprintf ppf "Unbound instance variable %s" lab
+  | Unbound_type_var (printer, reason) ->
+      let print_common ppf kind ty0 real lab ty =
+        let ty1 =
+          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
+        List.iter Printtyp.mark_loops [ty; ty1];
+        fprintf ppf
+          "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
+            kind lab Printtyp.type_expr ty Printtyp.type_expr ty0
+      in
+      let print_reason ppf = function
+      | Ctype.CC_Method (ty0, real, lab, ty) ->
+          print_common ppf "method" ty0 real lab ty
+      | Ctype.CC_Value (ty0, real, lab, ty) ->
+          print_common ppf "instance variable" ty0 real lab ty
+      in
+      Printtyp.reset ();
+      fprintf ppf
+        "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
+              @[%a@]@]"
+       printer print_reason reason
+  | Make_nongen_seltype ty ->
+      fprintf ppf
+        "@[@[Self type should not occur in the non-generic type@;<1 2>\
+                %a@]@,\
+           It would escape the scope of its class@]"
+        Printtyp.type_scheme ty
+  | Non_generalizable_class (id, clty) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (Printtyp.class_declaration id) clty
+  | Cannot_coerce_self ty ->
+      fprintf ppf
+        "@[The type of self cannot be coerced to@ \
+           the type of the current class:@ %a.@.\
+           Some occurrences are contravariant@]"
+        Printtyp.type_scheme ty
+  | Non_collapsable_conjunction (id, clty, trace) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains non-collapsible conjunctive types in constraints@]"
+        (Printtyp.class_declaration id) clty;
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but actually has type")
+  | Mutability_mismatch (_lab, mut) ->
+      let mut1, mut2 =
+        if mut = Immutable then "mutable", "immutable"
+        else "immutable", "mutable" in
+      fprintf ppf
+        "@[The instance variable is %s;@ it cannot be redefined as %s@]"
+        mut1 mut2
+  | No_overriding (_, "") ->
+      fprintf ppf "@[This inheritance does not override any method@ %s@]"
+        "instance variable"
+  | No_overriding (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+  | Duplicate (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+                    kind name
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
new file mode 100644
index 00000000..1735bf9e
--- /dev/null
+++ b/typing/typeclass.mli
@@ -0,0 +1,124 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Types
+open Format
+
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
+val class_declarations:
+  Env.t -> Parsetree.class_declaration list ->
+  Typedtree.class_declaration class_info list * Env.t
+
+(*
+and class_declaration =
+  (class_expr, Types.class_declaration) class_infos
+*)
+
+val class_descriptions:
+  Env.t -> Parsetree.class_description list ->
+  Typedtree.class_description class_info list * Env.t
+
+(*
+and class_description =
+  (class_type, unit) class_infos
+*)
+
+val class_type_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
+
+(*
+and class_type_declaration =
+  (class_type, Types.class_type_declaration) class_infos
+*)
+
+val approx_class_declarations:
+  Env.t -> Parsetree.class_description list -> class_type_info list
+
+val virtual_methods: Types.class_signature -> label list
+
+(*
+val type_classes :
+           bool ->
+           ('a -> Types.type_expr) ->
+           (Env.t -> 'a -> 'b * Types.class_type) ->
+           Env.t ->
+           'a Parsetree.class_infos list ->
+  (  Ident.t * Types.class_declaration *
+     Ident.t * Types.class_type_declaration *
+     Ident.t * Types.type_declaration *
+     Ident.t * Types.type_declaration *
+     int * string list * 'b * 'b Typedtree.class_infos)
+           list * Env.t
+*)
+
+type error =
+    Unconsistent_constraint of (type_expr * type_expr) list
+  | Field_type_mismatch of string * string * (type_expr * type_expr) list
+  | Structure_expected of class_type
+  | Cannot_apply of class_type
+  | Apply_wrong_label of arg_label
+  | Pattern_type_clash of type_expr
+  | Repeated_parameter
+  | Unbound_class_2 of Longident.t
+  | Unbound_class_type_2 of Longident.t
+  | Abbrev_type_clash of type_expr * type_expr * type_expr
+  | Constructor_type_mismatch of string * (type_expr * type_expr) list
+  | Virtual_class of bool * bool * string list * string list
+  | Parameter_arity_mismatch of Longident.t * int * int
+  | Parameter_mismatch of (type_expr * type_expr) list
+  | Bad_parameters of Ident.t * type_expr * type_expr
+  | Class_match_failure of Ctype.class_match_failure list
+  | Unbound_val of string
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
+  | Make_nongen_seltype of type_expr
+  | Non_generalizable_class of Ident.t * Types.class_declaration
+  | 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
+  | Mutability_mismatch of string * mutable_flag
+  | No_overriding of string * string
+  | Duplicate of string * string
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error : Env.t -> formatter -> error -> unit
diff --git a/typing/typecore.ml b/typing/typecore.ml
new file mode 100644
index 00000000..f80b81be
--- /dev/null
+++ b/typing/typecore.ml
@@ -0,0 +1,4464 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking for the core language *)
+
+open Misc
+open Asttypes
+open Parsetree
+open Types
+open Typedtree
+open Btype
+open Ctype
+
+type error =
+    Polymorphic_label of Longident.t
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * (type_expr * type_expr) list
+  | Pattern_type_clash of (type_expr * type_expr) list
+  | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of (type_expr * type_expr) list
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expr * string * Path.t * string * string list
+  | Name_type_mismatch of
+      string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of bool * string
+  | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * (type_expr * type_expr) list * bool
+  | Too_many_arguments of bool * type_expr
+  | Abstract_wrong_label of arg_label * type_expr
+  | Scoping_let_module of string * type_expr
+  | Masked_instance_variable of Longident.t
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Recursive_local_constraint of (type_expr * type_expr) list
+  | Unexpected_existential
+  | Unqualified_gadt_pattern of Path.t * string
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_below_toplevel
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+(* Forward declaration, to be filled in by Typemod.type_module *)
+
+let type_module =
+  ref ((fun _env _md -> assert false) :
+       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
+
+(* Forward declaration, to be filled in by Typemod.type_open *)
+
+let type_open =
+  ref (fun _ -> assert false)
+
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
+
+(* 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 ->
+         Typedtree.class_structure * Types.class_signature * string list)
+
+(*
+  Saving and outputting type information.
+  We keep these function names short, because they have to be
+  called each time we create a record of type [Typedtree.expression]
+  or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
+  Stypes.record (Stypes.Ti_expr node);
+  node
+;;
+let rp node =
+  Cmt_format.add_saved_type (Cmt_format.Partial_pattern node);
+  Stypes.record (Stypes.Ti_pat node);
+  node
+;;
+
+
+type recarg =
+  | Allowed
+  | Required
+  | Rejected
+
+
+let case lhs rhs =
+  {c_lhs = lhs; c_guard = None; c_rhs = rhs}
+
+(* Upper approximation of free identifiers on the parse tree *)
+
+let iter_expression f e =
+
+  let rec expr e =
+    f e;
+    match e.pexp_desc with
+    | Pexp_extension _ (* we don't iterate under extension point *)
+    | Pexp_ident _
+    | Pexp_new _
+    | Pexp_constant _ -> ()
+    | Pexp_function pel -> List.iter case pel
+    | Pexp_fun (_, eo, _, e) -> may expr eo; expr e
+    | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
+    | Pexp_let (_, pel, e) ->  expr e; List.iter binding pel
+    | Pexp_match (e, pel)
+    | Pexp_try (e, pel) -> expr e; List.iter case pel
+    | Pexp_array el
+    | Pexp_tuple el -> List.iter expr el
+    | Pexp_construct (_, eo)
+    | Pexp_variant (_, eo) -> may expr eo
+    | Pexp_record (iel, eo) ->
+        may expr eo; List.iter (fun (_, e) -> expr e) iel
+    | Pexp_open (_, _, e)
+    | Pexp_newtype (_, e)
+    | Pexp_poly (e, _)
+    | Pexp_lazy e
+    | Pexp_assert e
+    | Pexp_setinstvar (_, e)
+    | Pexp_send (e, _)
+    | Pexp_constraint (e, _)
+    | Pexp_coerce (e, _, _)
+    | Pexp_letexception (_, e)
+    | Pexp_field (e, _) -> expr e
+    | Pexp_while (e1, e2)
+    | Pexp_sequence (e1, e2)
+    | Pexp_setfield (e1, _, e2) -> expr e1; expr e2
+    | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo
+    | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3
+    | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel
+    | Pexp_letmodule (_, me, e) -> expr e; module_expr me
+    | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
+    | Pexp_pack me -> module_expr me
+    | Pexp_unreachable -> ()
+
+  and case {pc_lhs = _; pc_guard; pc_rhs} =
+    may expr pc_guard;
+    expr pc_rhs
+
+  and binding x =
+    expr x.pvb_expr
+
+  and module_expr me =
+    match me.pmod_desc with
+    | Pmod_extension _
+    | Pmod_ident _ -> ()
+    | Pmod_structure str -> List.iter structure_item str
+    | Pmod_constraint (me, _)
+    | Pmod_functor (_, _, me) -> module_expr me
+    | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
+    | Pmod_unpack e -> expr e
+
+
+  and structure_item str =
+    match str.pstr_desc with
+    | Pstr_eval (e, _) -> expr e
+    | Pstr_value (_, pel) -> List.iter binding pel
+    | Pstr_primitive _
+    | Pstr_type _
+    | Pstr_typext _
+    | Pstr_exception _
+    | Pstr_modtype _
+    | Pstr_open _
+    | Pstr_class_type _
+    | Pstr_attribute _
+    | Pstr_extension _ -> ()
+    | Pstr_include {pincl_mod = me}
+    | Pstr_module {pmb_expr = me} -> module_expr me
+    | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
+    | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
+
+  and class_expr ce =
+    match ce.pcl_desc with
+    | Pcl_constr _ -> ()
+    | Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs
+    | Pcl_fun (_, eo, _,  ce) -> may expr eo; class_expr ce
+    | Pcl_apply (ce, lel) ->
+        class_expr ce; List.iter (fun (_, e) -> expr e) lel
+    | Pcl_let (_, pel, ce) ->
+        List.iter binding pel; class_expr ce
+    | Pcl_constraint (ce, _) -> class_expr ce
+    | Pcl_extension _ -> ()
+
+  and class_field cf =
+    match cf.pcf_desc with
+    | Pcf_inherit (_, ce, _) -> class_expr ce
+    | Pcf_val (_, _, Cfk_virtual _)
+    | Pcf_method (_, _, Cfk_virtual _ ) | Pcf_constraint _ -> ()
+    | Pcf_val (_, _, Cfk_concrete (_, e))
+    | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e
+    | Pcf_initializer e -> expr e
+    | Pcf_attribute _ | Pcf_extension _ -> ()
+
+  in
+  expr e
+
+
+let all_idents_cases el =
+  let idents = Hashtbl.create 8 in
+  let f = function
+    | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} ->
+        Hashtbl.replace idents id ()
+    | _ -> ()
+  in
+  List.iter
+    (fun cp ->
+      may (iter_expression f) cp.pc_guard;
+      iter_expression f cp.pc_rhs
+    )
+    el;
+  Hashtbl.fold (fun x () rest -> x :: rest) idents []
+
+
+(* Typing of constants *)
+
+let type_constant = function
+    Const_int _ -> instance_def Predef.type_int
+  | Const_char _ -> instance_def Predef.type_char
+  | Const_string _ -> instance_def Predef.type_string
+  | Const_float _ -> instance_def Predef.type_float
+  | Const_int32 _ -> instance_def Predef.type_int32
+  | Const_int64 _ -> instance_def Predef.type_int64
+  | Const_nativeint _ -> instance_def Predef.type_nativeint
+
+let constant : Parsetree.constant -> (Asttypes.constant, error) result =
+  function
+  | Pconst_integer (i,None) ->
+     begin
+       try Ok (Const_int (Misc.Int_literal_converter.int i))
+       with Failure _ -> Error (Literal_overflow "int")
+     end
+  | Pconst_integer (i,Some 'l') ->
+     begin
+       try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
+       with Failure _ -> Error (Literal_overflow "int32")
+     end
+  | Pconst_integer (i,Some 'L') ->
+     begin
+       try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
+       with Failure _ -> Error (Literal_overflow "int64")
+     end
+  | Pconst_integer (i,Some 'n') ->
+     begin
+       try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
+       with Failure _ -> Error (Literal_overflow "nativeint")
+     end
+  | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
+  | Pconst_char c -> Ok (Const_char c)
+  | Pconst_string (s,d) -> Ok (Const_string (s,d))
+  | Pconst_float (f,None)-> Ok (Const_float f)
+  | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
+
+let constant_or_raise env loc cst =
+  match constant cst with
+  | Ok c -> c
+  | Error err -> raise (Error (loc, env, err))
+
+(* Specific version of type_option, using newty rather than newgenty *)
+
+let type_option ty =
+  newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+
+let mkexp exp_desc exp_type exp_loc exp_env =
+  { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
+
+let option_none ty loc =
+  let lid = Longident.Lident "None"
+  and env = Env.initial_safe_string in
+  let cnone = Env.lookup_constructor lid env in
+  mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
+
+let option_some texp =
+  let lid = Longident.Lident "Some" in
+  let csome = Env.lookup_constructor lid Env.initial_safe_string in
+  mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
+    (type_option texp.exp_type) texp.exp_loc texp.exp_env
+
+let extract_option_type env ty =
+  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+    when Path.same path Predef.path_option -> ty
+  | _ -> assert false
+
+let extract_concrete_record env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+  | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
+  | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
+  | _ -> raise Not_found
+
+let extract_label_names env ty =
+  try
+    let (_, _,fields) = extract_concrete_record env ty in
+    List.map (fun l -> l.Types.ld_id) fields
+  with Not_found ->
+    assert false
+
+(* Typing of patterns *)
+
+(* unification inside type_pat*)
+let unify_pat_types loc env ty ty' =
+  try
+    unify env ty ty'
+  with
+    Unify trace ->
+      raise(Error(loc, env, Pattern_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(Error(loc, env, Expr_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let newtype_level = ref None
+let get_newtype_level () =
+  match !newtype_level with
+    Some y -> y
+  | None -> assert false
+
+let unify_pat_types_gadt loc env ty ty' =
+  let newtype_level =
+    match !newtype_level with
+    | None -> assert false
+    | Some x -> x
+  in
+  try
+    unify_gadt ~newtype_level env ty ty'
+  with
+    Unify trace ->
+      raise(Error(loc, !env, Pattern_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
+  | Unification_recursive_abbrev trace ->
+      raise(Error(loc, !env, Recursive_local_constraint trace))
+
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+
+let unify_pat env pat expected_ty =
+  unify_pat_types pat.pat_loc env pat.pat_type expected_ty
+
+(* make all Reither present in open variants *)
+let finalize_variant pat =
+  match pat.pat_desc with
+    Tpat_variant(tag, opat, r) ->
+      let row =
+        match expand_head pat.pat_env pat.pat_type with
+          {desc = Tvariant row} -> r := row; row_repr row
+        | _ -> assert false
+      in
+      begin match row_field tag row with
+      | Rabsent -> () (* assert false *)
+      | Reither (true, [], _, e) when not row.row_closed ->
+          set_row_field e (Rpresent None)
+      | Reither (false, ty::tl, _, e) when not row.row_closed ->
+          set_row_field e (Rpresent (Some ty));
+          begin match opat with None -> assert false
+          | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
+          end
+      | Reither (c, _l, true, e) when not (row_fixed row) ->
+          set_row_field e (Reither (c, [], false, ref None))
+      | _ -> ()
+      end;
+      (* Force check of well-formedness   WHY? *)
+      (* unify_pat pat.pat_env pat
+        (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+                        row_bound=(); row_fixed=false; row_name=None})); *)
+  | _ -> ()
+
+let rec iter_pattern f p =
+  f p;
+  iter_pattern_desc (iter_pattern f) p.pat_desc
+
+let has_variants p =
+  try
+    iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ())
+      p;
+    false
+  with Exit ->
+    true
+
+
+(* pattern environment *)
+let pattern_variables = ref ([] :
+ (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list)
+let pattern_force = ref ([] : (unit -> unit) list)
+let pattern_scope = ref (None : Annot.ident option);;
+let allow_modules = ref false
+let module_variables = ref ([] : (string loc * Location.t) list)
+let reset_pattern scope allow =
+  pattern_variables := [];
+  pattern_force := [];
+  pattern_scope := scope;
+  allow_modules := allow;
+  module_variables := [];
+;;
+
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
+  if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt)
+      !pattern_variables
+  then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
+  let id = Ident.create name.txt in
+  pattern_variables :=
+    (id, ty, name, loc, is_as_variable) :: !pattern_variables;
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then
+      raise (Error (loc, Env.empty, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end else
+    (* moved to genannot *)
+    may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s)))
+        !pattern_scope;
+  id
+
+let sort_pattern_variables vs =
+  List.sort
+    (fun (x,_,_,_,_) (y,_,_,_,_) ->
+      Pervasives.compare (Ident.name x) (Ident.name y))
+    vs
+
+let enter_orpat_variables loc env  p1_vs p2_vs =
+  (* unify_vars operate on sorted lists *)
+
+  let p1_vs = sort_pattern_variables p1_vs
+  and p2_vs = sort_pattern_variables p2_vs in
+
+  let rec unify_vars p1_vs p2_vs =
+    let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in
+    match p1_vs, p2_vs with
+      | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2
+        when Ident.equal x1 x2 ->
+          if x1==x2 then
+            unify_vars rem1 rem2
+          else begin
+            begin try
+              unify env t1 t2
+            with
+            | Unify trace ->
+                raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
+            end;
+          (x2,x1)::unify_vars rem1 rem2
+          end
+      | [],[] -> []
+      | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars (x, [])))
+      | [],(y,_,_,_,_)::_  -> raise (Error (loc, env, Orpat_vars (y, [])))
+      | (x,_,_,_,_)::_, (y,_,_,_,_)::_ ->
+          let err =
+            if Ident.name x < Ident.name y
+            then Orpat_vars (x, vars p2_vs)
+            else Orpat_vars (y, vars p1_vs) in
+          raise (Error (loc, env, err)) in
+  unify_vars p1_vs p2_vs
+
+let rec build_as_type env p =
+  match p.pat_desc with
+    Tpat_alias(p1,_, _) -> build_as_type env p1
+  | Tpat_tuple pl ->
+      let tyl = List.map (build_as_type env) pl in
+      newty (Ttuple tyl)
+  | Tpat_construct(_, cstr, pl) ->
+      let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
+      if keep then p.pat_type else
+      let tyl = List.map (build_as_type env) pl in
+      let ty_args, ty_res = instance_constructor cstr in
+      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
+        (List.combine pl tyl) ty_args;
+      ty_res
+  | Tpat_variant(l, p', _) ->
+      let ty = may_map (build_as_type env) p' in
+      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+                      row_bound=(); row_name=None;
+                      row_fixed=false; row_closed=false})
+  | Tpat_record (lpl,_) ->
+      let lbl = snd3 (List.hd lpl) in
+      if lbl.lbl_private = Private then p.pat_type else
+      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;
+        let refinable =
+          lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
+          match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
+        if refinable 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
+          unify env ty_arg ty_arg';
+          unify_pat env p ty_res'
+        end in
+      Array.iter do_label lbl.lbl_all;
+      ty
+  | Tpat_or(p1, p2, row) ->
+      begin match row with
+        None ->
+          let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
+          unify_pat env {p2 with pat_type = ty2} ty1;
+          ty1
+      | Some row ->
+          let row = row_repr row in
+          newty (Tvariant{row with row_closed=false; row_more=newvar()})
+      end
+  | Tpat_any | Tpat_var _ | Tpat_constant _
+  | Tpat_array _ | Tpat_lazy _ -> p.pat_type
+
+let build_or_pat env loc lid =
+  let path, decl = Typetexp.find_type env lid.loc lid.txt
+  in
+  let tyl = List.map (fun _ -> newvar()) decl.type_params in
+  let row0 =
+    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    match ty.desc with
+      Tvariant row when static_row row -> row
+    | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  in
+  let pats, fields =
+    List.fold_left
+      (fun (pats,fields) (l,f) ->
+        match row_field_repr f with
+          Rpresent None ->
+            (l,None) :: pats,
+            (l, Reither(true,[], true, ref None)) :: fields
+        | Rpresent (Some ty) ->
+            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                      pat_type=ty; pat_extra=[]; pat_attributes=[]})
+            :: pats,
+            (l, Reither(false, [ty], true, ref None)) :: fields
+        | _ -> pats, fields)
+      ([],[]) (row_repr row0).row_fields in
+  let row =
+    { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
+      row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
+  in
+  let ty = newty (Tvariant row) in
+  let gloc = {loc with Location.loc_ghost=true} in
+  let row' = ref {row with row_more=newvar()} in
+  let pats =
+    List.map
+      (fun (l,p) ->
+        {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
+         pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
+      pats
+  in
+  match pats with
+    [] -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
+  | pat :: pats ->
+      let r =
+        List.fold_left
+          (fun pat pat0 ->
+            {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
+             pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
+          pat pats in
+      (path, rp { r with pat_loc = loc },ty)
+
+(* Type paths *)
+
+let rec expand_path env p =
+  let decl =
+    try Some (Env.find_type p env) with Not_found -> None
+  in
+  match decl with
+    Some {type_manifest = Some ty} ->
+      begin match repr ty with
+        {desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> p
+         (* PR#6394: recursive module may introduce incoherent manifest *)
+      end
+  | _ ->
+      let p' = Env.normalize_path None env p in
+      if Path.same p p' then p else expand_path env p'
+
+let compare_type_path env tpath1 tpath2 =
+  Path.same (expand_path env tpath1) (expand_path env tpath2)
+
+(* Records *)
+let label_of_kind kind =
+  if kind = "record" then "field" else "constructor"
+
+module NameChoice(Name : sig
+  type t
+  val type_kind: string
+  val get_name: t -> string
+  val get_type: t -> type_expr
+  val get_descrs: Env.type_descriptions -> t list
+  val unbound_name_error: Env.t -> Longident.t loc -> 'a
+  val in_env: t -> bool
+end) = struct
+  open Name
+
+  let get_type_path d =
+    match (repr (get_type d)).desc with
+    | Tconstr(p, _, _) -> p
+    | _ -> assert false
+
+  let lookup_from_type env tpath lid =
+    let descrs = get_descrs (Env.find_type_descrs tpath env) in
+    Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env);
+    match lid.txt with
+      Longident.Lident s -> begin
+        try
+          List.find (fun nd -> get_name nd = s) descrs
+        with Not_found ->
+          let names = List.map get_name descrs in
+          raise (Error (lid.loc, env,
+                        Wrong_name ("", newvar (), type_kind, tpath, s, names)))
+      end
+    | _ -> raise Not_found
+
+  let rec unique eq acc = function
+      [] -> List.rev acc
+    | x :: rem ->
+        if List.exists (eq x) acc then unique eq acc rem
+        else unique eq (x :: acc) rem
+
+  let ambiguous_types env lbl others =
+    let tpath = get_type_path lbl in
+    let others =
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
+    let tpaths = unique (compare_type_path env) [tpath] others in
+    match tpaths with
+      [_] -> []
+    | _ -> List.map Printtyp.string_of_path tpaths
+
+  let disambiguate_by_type env tpath lbls =
+    let check_type (lbl, _) =
+      let lbl_tpath = get_type_path lbl in
+      compare_type_path env tpath lbl_tpath
+    in
+    List.find check_type lbls
+
+  let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ())
+      ?scope lid env opath lbls =
+    let scope = match scope with None -> lbls | Some l -> l in
+    let lbl = match opath with
+      None ->
+        begin match lbls with
+          [] -> unbound_name_error env lid
+        | (lbl, use) :: rest ->
+            use ();
+            let paths = ambiguous_types env lbl rest in
+            if paths <> [] then
+              warn lid.loc
+                (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                          paths, false));
+            lbl
+        end
+    | Some(tpath0, tpath, pr) ->
+        let warn_pr () =
+          let label = label_of_kind type_kind in
+          warn lid.loc
+            (Warnings.Not_principal
+               ("this type-based " ^ label ^ " disambiguation"))
+        in
+        try
+          let lbl, use = disambiguate_by_type env tpath scope in
+          use ();
+          if not pr then begin
+            (* Check if non-principal type is affecting result *)
+            match lbls with
+              [] -> warn_pr ()
+            | (lbl', _use') :: rest ->
+                let lbl_tpath = get_type_path lbl' in
+                if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
+                else
+                  let paths = ambiguous_types env lbl rest in
+                  if paths <> [] then
+                    warn lid.loc
+                      (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                                paths, false))
+          end;
+          lbl
+        with Not_found -> try
+          let lbl = lookup_from_type env tpath lid in
+          check_lk tpath lbl;
+          if in_env lbl then
+          begin
+          let s = Printtyp.string_of_path tpath in
+          warn lid.loc
+            (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));
+          end;
+          if not pr then warn_pr ();
+          lbl
+        with Not_found ->
+          if lbls = [] then unbound_name_error env lid else
+          let tp = (tpath0, expand_path env tpath) in
+          let tpl =
+            List.map
+              (fun (lbl, _) ->
+                let tp0 = get_type_path lbl in
+                let tp = expand_path env tp0 in
+                  (tp0, tp))
+              lbls
+          in
+          raise (Error (lid.loc, env,
+                        Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
+    in
+    if in_env lbl then
+    begin match scope with
+      (lab1,_)::_ when lab1 == lbl -> ()
+    | _ ->
+        Location.prerr_warning lid.loc
+          (Warnings.Disambiguated_name(get_name lbl))
+    end;
+    lbl
+end
+
+let wrap_disambiguate kind ty f x =
+  try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) ->
+    raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names)))
+
+module Label = NameChoice (struct
+  type t = label_description
+  let type_kind = "record"
+  let get_name lbl = lbl.lbl_name
+  let get_type lbl = lbl.lbl_res
+  let get_descrs = snd
+  let unbound_name_error = Typetexp.unbound_label_error
+  let in_env lbl =
+    match lbl.lbl_repres with
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension -> false
+end)
+
+let disambiguate_label_by_ids keep closed ids labels =
+  let check_ids (lbl, _) =
+    let lbls = Hashtbl.create 8 in
+    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+    List.for_all (Hashtbl.mem lbls) ids
+  and check_closed (lbl, _) =
+    (not closed || List.length ids = Array.length lbl.lbl_all)
+  in
+  let labels' = List.filter check_ids labels in
+  if keep && labels' = [] then (false, labels) else
+  let labels'' = List.filter check_closed labels' in
+  if keep && labels'' = [] then (false, labels') else (true, labels'')
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env opath lid_a_list =
+  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+  let w_pr = ref false and w_amb = ref []
+  and w_scope = ref [] and w_scope_ty = ref "" in
+  let warn loc msg =
+    let open Warnings in
+    match msg with
+    | Not_principal _ -> w_pr := true
+    | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
+    | Name_out_of_scope(ty, [s], _) ->
+        w_scope := s :: !w_scope; w_scope_ty := ty
+    | _ -> Location.prerr_warning loc msg
+  in
+  let process_label lid =
+    (* Strategy for each field:
+       * collect all the labels in scope for that name
+       * if the type is known and principal, just eventually warn
+         if the real label was not in scope
+       * fail if there is no known type and no label found
+       * otherwise use other fields to reduce the list of candidates
+       * if there is no known type reduce it incrementally, so that
+         there is still at least one candidate (for error message)
+       * if the reduced list is valid, call Label.disambiguate
+     *)
+    let scope = Typetexp.find_all_labels env lid.loc lid.txt in
+    if opath = None && scope = [] then
+      Typetexp.unbound_label_error env lid;
+    let (ok, labels) =
+      match opath with
+        Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
+      | _  -> disambiguate_label_by_ids (opath=None) closed ids scope
+    in
+    if ok then Label.disambiguate lid env opath labels ~warn ~scope
+          else fst (List.hd labels) (* will fail later *)
+  in
+  let lbl_a_list =
+    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+  if !w_pr then
+    Location.prerr_warning loc
+      (Warnings.Not_principal "this type-based record disambiguation")
+  else begin
+    match List.rev !w_amb with
+      (_,types)::_ as amb ->
+        let paths =
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
+        let path = List.hd paths in
+        if List.for_all (compare_type_path env path) (List.tl paths) then
+          Location.prerr_warning loc
+            (Warnings.Ambiguous_name (List.map fst amb, types, true))
+        else
+          List.iter
+            (fun (s,l) -> Location.prerr_warning loc
+                (Warnings.Ambiguous_name ([s],l,false)))
+            amb
+    | _ -> ()
+  end;
+  if !w_scope <> [] then
+    Location.prerr_warning loc
+      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+  lbl_a_list
+
+let rec find_record_qual = function
+  | [] -> None
+  | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
+  | _ :: rest -> find_record_qual rest
+
+let map_fold_cont f xs k =
+  List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
+    xs (fun ys -> k (List.rev ys)) []
+
+let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k =
+  let lbl_a_list =
+    match lid_a_list, labels with
+      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+        (* Special case for rebuilt syntax trees *)
+        List.map
+          (function lid, a -> match lid.txt with
+            Longident.Lident s -> lid, Hashtbl.find labels s, a
+          | _ -> assert false)
+          lid_a_list
+    | _ ->
+        let lid_a_list =
+          match find_record_qual lid_a_list with
+            None -> lid_a_list
+          | Some modname ->
+              List.map
+                (fun (lid, a as lid_a) ->
+                  match lid.txt with Longident.Lident s ->
+                    {lid with txt=Longident.Ldot (modname, s)}, a
+                  | _ -> lid_a)
+                lid_a_list
+        in
+        disambiguate_lid_a_list loc closed env opath lid_a_list
+  in
+  (* Invariant: records are sorted in the typed tree *)
+  let lbl_a_list =
+    List.sort
+      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      lbl_a_list
+  in
+  map_fold_cont type_lbl_a lbl_a_list k
+;;
+
+(* Checks over the labels mentioned in a record pattern:
+   no duplicate definitions (error); properly closed (warning) *)
+
+let check_recordpat_labels loc lbl_pat_list closed =
+  match lbl_pat_list with
+  | [] -> ()                            (* should not happen *)
+  | (_, label1, _) :: _ ->
+      let all = label1.lbl_all in
+      let defined = Array.make (Array.length all) false in
+      let check_defined (_, label, _) =
+        if defined.(label.lbl_pos)
+        then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
+        else defined.(label.lbl_pos) <- true in
+      List.iter check_defined lbl_pat_list;
+      if closed = Closed
+      && Warnings.is_active (Warnings.Non_closed_record_pattern "")
+      then begin
+        let undefined = ref [] in
+        for i = 0 to Array.length all - 1 do
+          if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
+        done;
+        if !undefined <> [] then begin
+          let u = String.concat ", " (List.rev !undefined) in
+          Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)
+        end
+      end
+
+(* Constructors *)
+
+module Constructor = NameChoice (struct
+  type t = constructor_description
+  let type_kind = "variant"
+  let get_name cstr = cstr.cstr_name
+  let get_type cstr = cstr.cstr_res
+  let get_descrs = fst
+  let unbound_name_error = Typetexp.unbound_constructor_error
+  let in_env _ = true
+end)
+
+(* unification of a type with a tconstr with
+   freshly created arguments *)
+let unify_head_only loc env ty constr =
+  let (_, ty_res) = instance_constructor constr in
+  match (repr ty_res).desc with
+  | Tconstr(p,args,m) ->
+      ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
+      enforce_constraints env ty_res;
+      unify_pat_types loc env ty_res ty
+  | _ -> assert false
+
+(* Typing of patterns *)
+
+(* Remember current state for backtracking.
+   No variable information, as we only backtrack on
+   patterns without variables (cf. assert statements). *)
+type state =
+ { snapshot: Btype.snapshot;
+   levels: Ctype.levels;
+   env: Env.t; }
+let save_state env =
+  { snapshot = Btype.snapshot ();
+    levels = Ctype.save_levels ();
+    env = !env; }
+let set_state s env =
+  Btype.backtrack s.snapshot;
+  Ctype.set_levels s.levels;
+  env := s.env
+
+(* type_pat does not generate local constraints inside or patterns *)
+type type_pat_mode =
+  | Normal
+  | Splitting_or   (* splitting an or-pattern *)
+  | Inside_or      (* inside a non-split or-pattern *)
+  | Split_or       (* always split or-patterns *)
+
+exception Need_backtrack
+
+(* type_pat propagates the expected type as well as maps for
+   constructors and labels.
+   Unification may update the typing environment. *)
+(* constrs <> None => called from parmatch: backtrack on or-patterns
+   explode > 0 => explode Ppat_any for gadts *)
+let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
+    sp expected_ty k =
+  let mode' = if mode = Splitting_or then Normal else mode in
+  let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode')
+      ?(explode=explode) ?(env=env) =
+    type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env in
+  let loc = sp.ppat_loc in
+  let rp k x : pattern = if constrs = None then k (rp x) else k x in
+  match sp.ppat_desc with
+    Ppat_any ->
+      let k' d = rp k {
+        pat_desc = d;
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in
+      if explode > 0 then
+        let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in
+        if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else
+        if mode = Inside_or then raise Need_backtrack else
+        let explode =
+          match sp.ppat_desc with
+            Parsetree.Ppat_or _ -> explode - 5
+          | _ -> explode - 1
+        in
+        type_pat ~constrs:(Some constrs) ~labels:(Some labels)
+          ~explode sp expected_ty k
+      else k' Tpat_any
+  | Ppat_var name ->
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then Ident.create name.txt else
+        enter_variable loc name expected_ty
+      in
+      rp k {
+        pat_desc = Tpat_var (id, name);
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      assert (constrs = None);
+      let id = enter_variable loc name expected_ty ~is_module:true in
+      rp k {
+        pat_desc = Tpat_var (id, name);
+        pat_loc = sp.ppat_loc;
+        pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
+        pat_type = expected_ty;
+        pat_attributes = [];
+        pat_env = !env }
+  | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
+                    ({ptyp_desc=Ptyp_poly _} as sty)) ->
+      (* explicitly polymorphic type *)
+      assert (constrs = None);
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let ty = cty.ctyp_type in
+      unify_pat_types lloc !env ty expected_ty;
+      pattern_force := force :: !pattern_force;
+      begin match ty.desc with
+      | Tpoly (body, tyl) ->
+          begin_def ();
+          let _, ty' = instance_poly ~keep_names:true false tyl body in
+          end_def ();
+          generalize ty';
+          let id = enter_variable lloc name ty' in
+          rp k {
+            pat_desc = Tpat_var (id, name);
+            pat_loc = lloc;
+            pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
+            pat_type = ty;
+            pat_attributes = [];
+            pat_env = !env
+          }
+      | _ -> assert false
+      end
+  | Ppat_alias(sq, name) ->
+      assert (constrs = None);
+      type_pat sq expected_ty (fun q ->
+        begin_def ();
+        let ty_var = build_as_type !env q in
+        end_def ();
+        generalize ty_var;
+        let id = enter_variable ~is_as_variable:true loc name ty_var in
+        rp k {
+          pat_desc = Tpat_alias(q, id, name);
+          pat_loc = loc; pat_extra=[];
+          pat_type = q.pat_type;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env })
+  | Ppat_constant cst ->
+      let cst = constant_or_raise !env loc cst in
+      unify_pat_types loc !env (type_constant cst) expected_ty;
+      rp k {
+        pat_desc = Tpat_constant cst;
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+  | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
+      let open Ast_helper.Pat in
+      let gloc = {loc with Location.loc_ghost=true} in
+      let rec loop c1 c2 =
+        if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
+        else
+          or_ ~loc:gloc
+            (constant ~loc:gloc (Pconst_char c1))
+            (loop (Char.chr(Char.code c1 + 1)) c2)
+      in
+      let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
+      let p = {p with ppat_loc=loc} in
+      type_pat ~explode:0 p expected_ty k
+        (* TODO: record 'extra' to remember about interval *)
+  | Ppat_interval _ ->
+      raise (Error (loc, !env, Invalid_interval))
+  | Ppat_tuple spl ->
+      assert (List.length spl >= 2);
+      let spl_ann = List.map (fun p -> (p,newvar ())) spl in
+      let ty = newty (Ttuple(List.map snd spl_ann)) in
+      unify_pat_types loc !env ty expected_ty;
+      map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl ->
+        rp k {
+        pat_desc = Tpat_tuple pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_construct(lid, sarg) ->
+      let opath =
+        try
+          let (p0, p, _) = extract_concrete_variant !env expected_ty in
+            Some (p0, p, true)
+        with Not_found -> None
+      in
+      let candidates =
+        match lid.txt, constrs with
+          Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
+            [Hashtbl.find constrs s, (fun () -> ())]
+        | _ ->  Typetexp.find_all_constructors !env lid.loc lid.txt
+      in
+      let check_lk tpath constr =
+        if constr.cstr_generalized then
+          raise (Error (lid.loc, !env,
+                        Unqualified_gadt_pattern (tpath, constr.cstr_name)))
+      in
+      let constr =
+        wrap_disambiguate "This variant pattern is expected to have" expected_ty
+          (Constructor.disambiguate lid !env opath ~check_lk) candidates
+      in
+      if constr.cstr_generalized && constrs <> None && mode = Inside_or
+      then raise Need_backtrack;
+      Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
+      Builtin_attributes.check_deprecated loc constr.cstr_attributes
+        constr.cstr_name;
+      if no_existentials && constr.cstr_existentials <> [] then
+        raise (Error (loc, !env, Unexpected_existential));
+      (* if constructor is gadt, we must verify that the expected type has the
+         correct head *)
+      if constr.cstr_generalized then
+        unify_head_only loc !env expected_ty constr;
+      let sargs =
+        match sarg with
+          None -> []
+        | Some {ppat_desc = Ppat_tuple spl} when
+            constr.cstr_arity > 1 ||
+            Builtin_attributes.explicit_arity sp.ppat_attributes
+          -> spl
+        | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
+            if constr.cstr_arity = 0 then
+              Location.prerr_warning sp.ppat_loc
+                                     Warnings.Wildcard_arg_to_constant_constr;
+            replicate_list sp constr.cstr_arity
+        | Some sp -> [sp] in
+      begin match sargs with
+      | [{ppat_desc = Ppat_constant _} as sp]
+        when Builtin_attributes.warn_on_literal_pattern
+            constr.cstr_attributes ->
+          Location.prerr_warning sp.ppat_loc
+            Warnings.Fragile_literal_pattern
+      | _ -> ()
+      end;
+      if List.length sargs <> constr.cstr_arity then
+        raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
+                                     constr.cstr_arity, List.length sargs)));
+      let (ty_args, ty_res) =
+        instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
+      in
+      (* PR#7214: do not use gadt unification for toplevel lets *)
+      if not constr.cstr_generalized || mode = Inside_or || no_existentials
+      then unify_pat_types loc !env ty_res expected_ty
+      else unify_pat_types_gadt loc env ty_res expected_ty;
+
+      let rec check_non_escaping p =
+        match p.ppat_desc with
+        | Ppat_or (p1, p2) ->
+            check_non_escaping p1;
+            check_non_escaping p2
+        | Ppat_alias (p, _) ->
+            check_non_escaping p
+        | Ppat_constraint _ ->
+            raise (Error (p.ppat_loc, !env, Inlined_record_escape))
+        | _ ->
+            ()
+      in
+      if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;
+
+      map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args)
+      (fun args ->
+        rp k {
+          pat_desc=Tpat_construct(lid, constr, args);
+          pat_loc = loc; pat_extra=[];
+          pat_type = expected_ty;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env })
+  | Ppat_variant(l, sarg) ->
+      let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in
+      let row = { row_fields =
+                    [l, Reither(sarg = None, arg_type, true, ref None)];
+                  row_bound = ();
+                  row_closed = false;
+                  row_more = newvar ();
+                  row_fixed = false;
+                  row_name = None } in
+      unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
+      let k arg =
+        rp k {
+        pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
+        pat_loc = loc; pat_extra=[];
+        pat_type =  expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in begin
+        (* PR#6235: propagate type information *)
+        match sarg, arg_type with
+          Some p, [ty] -> type_pat p ty (fun p -> k (Some p))
+        | _            -> k None
+      end
+  | Ppat_record(lid_sp_list, closed) ->
+      assert (lid_sp_list <> []);
+      let opath, record_ty =
+        try
+          let (p0, p,_) = extract_concrete_record !env expected_ty in
+          Some (p0, p, true), expected_ty
+        with Not_found -> None, newvar ()
+      in
+      let type_label_pat (label_lid, label, sarg) k =
+        begin_def ();
+        let (vars, ty_arg, ty_res) = instance_label false label in
+        if vars = [] then end_def ();
+        begin try
+          unify_pat_types loc !env ty_res record_ty
+        with Unify trace ->
+          raise(Error(label_lid.loc, !env,
+                      Label_mismatch(label_lid.txt, trace)))
+        end;
+        type_pat sarg ty_arg (fun arg ->
+          if vars <> [] then begin
+            end_def ();
+            generalize ty_arg;
+            List.iter generalize vars;
+            let instantiated tv =
+              let tv = expand_head !env tv in
+              not (is_Tvar tv) || tv.level <> generic_level in
+            if List.exists instantiated vars then
+              raise
+                (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt))
+          end;
+          k (label_lid, label, arg))
+      in
+      let k' k lbl_pat_list =
+        check_recordpat_labels loc lbl_pat_list closed;
+        unify_pat_types loc !env record_ty expected_ty;
+        rp k {
+        pat_desc = Tpat_record (lbl_pat_list, closed);
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
+      in
+      if constrs = None then
+        k (wrap_disambiguate "This record pattern is expected to have"
+             expected_ty
+             (type_label_a_list ?labels loc false !env type_label_pat opath
+                lid_sp_list)
+             (k' (fun x -> x)))
+      else
+        type_label_a_list ?labels loc false !env type_label_pat opath
+          lid_sp_list (k' k)
+  | Ppat_array spl ->
+      let ty_elt = newvar() in
+      unify_pat_types
+        loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
+      let spl_ann = List.map (fun p -> (p,newvar())) spl in
+      map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl ->
+        rp k {
+        pat_desc = Tpat_array pl;
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_or(sp1, sp2) ->
+      let state = save_state env in
+      begin match
+        if mode = Split_or || mode = Splitting_or then raise Need_backtrack;
+        let initial_pattern_variables = !pattern_variables in
+        let initial_module_variables = !module_variables in
+        let p1 =
+          try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x))
+          with Need_backtrack -> None in
+        let p1_variables = !pattern_variables in
+        let p1_module_variables = !module_variables in
+        pattern_variables := initial_pattern_variables;
+        module_variables := initial_module_variables;
+        let p2 =
+          try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x))
+          with Need_backtrack -> None in
+        let p2_variables = !pattern_variables in
+        match p1, p2 with
+          None, None -> raise Need_backtrack
+        | Some p, None | None, Some p -> p (* no variables in this case *)
+        | Some p1, Some p2 ->
+        let alpha_env =
+          enter_orpat_variables loc !env p1_variables p2_variables in
+        pattern_variables := p1_variables;
+        module_variables := p1_module_variables;
+        { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
+          pat_loc = loc; pat_extra=[];
+          pat_type = expected_ty;
+          pat_attributes = sp.ppat_attributes;
+          pat_env = !env }
+      with
+        p -> rp k p
+      | exception Need_backtrack when mode <> Inside_or ->
+          assert (constrs <> None);
+          set_state state env;
+          let mode =
+            if mode = Split_or then mode else Splitting_or in
+          try type_pat ~mode sp1 expected_ty k with Error _ ->
+            set_state state env;
+            type_pat ~mode sp2 expected_ty k
+      end
+  | Ppat_lazy sp1 ->
+      let nv = newvar () in
+      unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv))
+        expected_ty;
+      (* do not explode under lazy: PR#7421 *)
+      type_pat ~explode:0 sp1 nv (fun p1 ->
+        rp k {
+        pat_desc = Tpat_lazy p1;
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env })
+  | Ppat_constraint(sp, sty) ->
+      (* Separate when not already separated by !principal *)
+      let separate = true in
+      if separate then begin_def();
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let ty = cty.ctyp_type in
+      let ty, expected_ty' =
+        if separate then begin
+          end_def();
+          generalize_structure ty;
+          instance !env ty, instance !env ty
+        end else ty, ty
+      in
+      unify_pat_types loc !env ty expected_ty;
+      type_pat sp expected_ty' (fun p ->
+        (*Format.printf "%a@.%a@."
+          Printtyp.raw_type_expr ty
+          Printtyp.raw_type_expr p.pat_type;*)
+        pattern_force := force :: !pattern_force;
+        let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
+        let p =
+          if not separate then p else
+          match p.pat_desc with
+            Tpat_var (id,s) ->
+              {p with pat_type = ty;
+               pat_desc = Tpat_alias
+                 ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+               pat_extra = [extra];
+             }
+          | _ -> {p with pat_type = ty;
+                  pat_extra = extra :: p.pat_extra}
+        in k p)
+  | Ppat_type lid ->
+      let (path, p,ty) = build_or_pat !env loc lid in
+      unify_pat_types loc !env ty expected_ty;
+      k { p with pat_extra =
+        (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      let new_env = ref new_env in
+      type_pat ~env:new_env p expected_ty ( fun p ->
+        env := Env.copy_local !env ~from:!new_env;
+        k { p with pat_extra =( Tpat_open (path,lid,!new_env),
+                            loc, sp.ppat_attributes) :: p.pat_extra }
+      )
+  | Ppat_exception _ ->
+      raise (Error (loc, !env, Exception_pattern_below_toplevel))
+  | Ppat_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal)
+    ?(explode=0) ?(lev=get_current_level()) env sp expected_ty =
+  newtype_level := Some lev;
+  try
+    let r =
+      type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
+        ~mode ~explode ~env sp expected_ty (fun x -> x) in
+    iter_pattern (fun p -> p.pat_env <- !env) r;
+    newtype_level := None;
+    r
+  with e ->
+    newtype_level := None;
+    raise e
+
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p =
+  let env = ref env in
+  let state = save_state env in
+  try
+    reset_pattern None true;
+    let typed_p =
+      Ctype.with_passive_variants
+        (type_pat ~allow_existentials:true ~lev
+           ~constrs ~labels ?mode ?explode env p)
+        expected_ty
+    in
+    set_state state env;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with Error _ ->
+    set_state state env;
+    None
+
+let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
+  let explode = match cases with [_] -> 5 | _ -> 0 in
+  Parmatch.check_partial_gadt
+    (partial_pred ~lev ~explode env expected_ty) loc cases
+
+let check_unused ?(lev=get_current_level ()) env expected_ty cases =
+  Parmatch.check_unused
+    (fun refute constrs labels spat ->
+      match
+        partial_pred ~lev ~mode:Split_or ~explode:5
+          env expected_ty constrs labels spat
+      with
+        Some pat when refute ->
+          raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
+      | r -> r)
+    cases
+
+let add_pattern_variables ?check ?check_as env =
+  let pv = get_ref pattern_variables in
+  (List.fold_right
+     (fun (id, ty, _name, loc, as_var) env ->
+       let check = if as_var then check_as else check in
+       Env.add_value ?check id
+         {val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+          val_attributes = [];
+         } env
+     )
+     pv env,
+   get_ref module_variables)
+
+let type_pattern ~lev env spat scope expected_ty =
+  reset_pattern scope true;
+  let new_env = ref env in
+  let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
+  let new_env, unpacks =
+    add_pattern_variables !new_env
+      ~check:(fun s -> Warnings.Unused_var_strict s)
+      ~check_as:(fun s -> Warnings.Unused_var s) in
+  (pat, new_env, get_ref pattern_force, unpacks)
+
+let type_pattern_list env spatl scope expected_tys allow =
+  reset_pattern scope allow;
+  let new_env = ref env in
+  let patl = List.map2 (type_pat new_env) spatl expected_tys in
+  let new_env, unpacks = add_pattern_variables !new_env in
+  (patl, new_env, get_ref pattern_force, unpacks)
+
+let type_class_arg_pattern cl_num val_env met_env l spat =
+  reset_pattern None false;
+  let nv = newvar () in
+  let pat = type_pat (ref val_env) spat nv in
+  if has_variants pat then begin
+    Parmatch.pressure_variants val_env [pat];
+    iter_pattern finalize_variant pat
+  end;
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  if is_optional l then unify_pat val_env pat (type_option (newvar ()));
+  let (pv, met_env) =
+    List.fold_right
+      (fun (id, ty, name, loc, as_var) (pv, env) ->
+         let check s =
+           if as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
+         let id' = Ident.create (Ident.name id) in
+         ((id', name, id, ty)::pv,
+          Env.add_value id' {val_type = ty;
+                             val_kind = Val_ivar (Immutable, cl_num);
+                             val_attributes = [];
+                             Types.val_loc = loc;
+                            } ~check
+            env))
+      !pattern_variables ([], met_env)
+  in
+  let val_env, _ = add_pattern_variables val_env in
+  (pat, pv, val_env, met_env)
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
+  let open Ast_helper in
+  let spat =
+    Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
+                        mknoloc ("selfpat-" ^ cl_num)))
+  in
+  reset_pattern None false;
+  let nv = newvar() in
+  let pat = type_pat (ref val_env) spat nv in
+  List.iter (fun f -> f()) (get_ref pattern_force);
+  let meths = ref Meths.empty in
+  let vars = ref Vars.empty in
+  let pv = !pattern_variables in
+  pattern_variables := [];
+  let (val_env, met_env, par_env) =
+    List.fold_right
+      (fun (id, ty, _name, loc, as_var) (val_env, met_env, par_env) ->
+         (Env.add_value id {val_type = ty;
+                            val_kind = Val_unbound;
+                            val_attributes = [];
+                            Types.val_loc = loc;
+                           } val_env,
+          Env.add_value id {val_type = ty;
+                            val_kind = Val_self (meths, vars, cl_num, privty);
+                            val_attributes = [];
+                            Types.val_loc = loc;
+                           }
+            ~check:(fun s -> if as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
+            met_env,
+          Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                            val_attributes = [];
+                            Types.val_loc = loc;
+                           } par_env))
+      pv (val_env, met_env, par_env)
+  in
+  (pat, meths, vars, val_env, met_env, par_env)
+
+let delayed_checks = ref []
+let reset_delayed_checks () = delayed_checks := []
+let add_delayed_check f =
+  delayed_checks := (f, Warnings.backup ()) :: !delayed_checks
+
+let force_delayed_checks () =
+  (* checks may change type levels *)
+  let snap = Btype.snapshot () in
+  let w_old = Warnings.backup () in
+  List.iter
+    (fun (f, w) -> Warnings.restore w; f ())
+    (List.rev !delayed_checks);
+  Warnings.restore w_old;
+  reset_delayed_checks ();
+  Btype.backtrack snap
+
+let rec final_subexpression sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e)
+  | Pexp_sequence (_, e)
+  | Pexp_try (e, _)
+  | Pexp_ifthenelse (_, e, _)
+  | Pexp_match (_, {pc_rhs=e} :: _)
+    -> final_subexpression e
+  | _ -> sexp
+
+(* Generalization criterion for expressions *)
+
+let rec is_nonexpansive exp =
+  match exp.exp_desc with
+    Texp_ident(_,_,_) -> true
+  | Texp_constant _ -> true
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
+      List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
+      is_nonexpansive body
+  | Texp_function _ -> true
+  | Texp_apply(e, (_,None)::el) ->
+      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
+  | Texp_match(e, cases, [], _) ->
+      is_nonexpansive e &&
+      List.for_all
+        (fun {c_lhs = _; c_guard; c_rhs} ->
+           is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
+        ) cases
+  | Texp_tuple el ->
+      List.for_all is_nonexpansive el
+  | Texp_construct( _, _, el) ->
+      List.for_all is_nonexpansive el
+  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
+  | Texp_array [] -> true
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
+      is_nonexpansive ifso && is_nonexpansive_opt ifnot
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
+      true
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (fun field -> match field.cf_desc with
+            Tcf_method _ -> true
+          | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
+              incr count; is_nonexpansive e
+          | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
+              incr count; true
+          | Tcf_initializer e -> is_nonexpansive e
+          | Tcf_constraint _ -> true
+          | Tcf_inherit _ -> false
+          | Tcf_attribute _ -> true)
+        fields &&
+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
+  | Texp_letmodule (_, _, mexp, e) ->
+      is_nonexpansive_mod mexp && is_nonexpansive e
+  | Texp_pack mexp ->
+      is_nonexpansive_mod mexp
+  | _ -> false
+
+and is_nonexpansive_mod mexp =
+  match mexp.mod_desc with
+  | Tmod_ident _ -> true
+  | Tmod_functor _ -> true
+  | Tmod_unpack (e, _) -> is_nonexpansive e
+  | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
+  | Tmod_structure str ->
+      List.for_all
+        (fun item -> match item.str_desc with
+          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
+          | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _  -> true
+          | Tstr_value (_, pat_exp_list) ->
+              List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
+          | Tstr_module {mb_expr=m;_}
+          | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
+          | Tstr_recmodule id_mod_list ->
+              List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
+                id_mod_list
+          | Tstr_exception {ext_kind = Text_decl _} ->
+              false (* true would be unsound *)
+          | Tstr_exception {ext_kind = Text_rebind _} -> true
+          | Tstr_typext te ->
+              List.for_all
+                (function {ext_kind = Text_decl _} -> false
+                        | {ext_kind = Text_rebind _} -> true)
+                te.tyext_constructors
+          | Tstr_class _ -> false (* could be more precise *)
+          | Tstr_attribute _ -> true
+        )
+        str.str_items
+  | Tmod_apply _ -> false
+
+and is_nonexpansive_opt = function
+    None -> true
+  | Some e -> is_nonexpansive e
+
+(* Approximate the type of an expression, for better recursion *)
+
+let rec approx_type env sty =
+  match sty.ptyp_desc with
+    Ptyp_arrow (p, _, sty) ->
+      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow (p, ty1, approx_type env sty, Cok))
+  | Ptyp_tuple args ->
+      newty (Ttuple (List.map (approx_type env) args))
+  | Ptyp_constr (lid, ctl) ->
+      begin try
+        let path = Env.lookup_type lid.txt env in
+        let decl = Env.find_type path env in
+        if List.length ctl <> decl.type_arity then raise Not_found;
+        let tyl = List.map (approx_type env) ctl in
+        newconstr path tyl
+      with Not_found -> newvar ()
+      end
+  | Ptyp_poly (_, sty) ->
+      approx_type env sty
+  | _ -> newvar ()
+
+let rec type_approx env sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e) -> type_approx env e
+  | Pexp_fun (p, _, _, e) ->
+      let ty = if is_optional p then type_option (newvar ()) else newvar () in
+      newty (Tarrow(p, ty, type_approx env e, Cok))
+  | Pexp_function ({pc_rhs=e}::_) ->
+      newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
+  | Pexp_try (e, _) -> type_approx env e
+  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+  | Pexp_ifthenelse (_,e,_) -> type_approx env e
+  | Pexp_sequence (_,e) -> type_approx env e
+  | Pexp_constraint (e, sty) ->
+      let ty = type_approx env e in
+      let ty1 = approx_type env sty in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
+      end;
+      ty1
+  | Pexp_coerce (e, sty1, sty2) ->
+      let approx_ty_opt = function
+        | None -> newvar ()
+        | Some sty -> approx_type env sty
+      in
+      let ty = type_approx env e
+      and ty1 = approx_ty_opt sty1
+      and ty2 = approx_type env sty2 in
+      begin try unify env ty ty1 with Unify trace ->
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
+      end;
+      ty2
+  | _ -> newvar ()
+
+(* List labels in a function type, and whether return type is a variable *)
+let rec list_labels_aux env visited ls ty_fun =
+  let ty = expand_head env ty_fun in
+  if List.memq ty visited then
+    List.rev ls, false
+  else match ty.desc with
+    Tarrow (l, _, ty_res, _) ->
+      list_labels_aux env (ty::visited) (l::ls) ty_res
+  | _ ->
+      List.rev ls, is_Tvar ty
+
+let list_labels env ty =
+  wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
+
+(* Check that all univars are safe in a type *)
+let check_univars env expans kind exp ty_expected vars =
+  if expans && not (is_nonexpansive exp) then
+    generalize_expansive env exp.exp_type;
+  (* need to expand twice? cf. Ctype.unify2 *)
+  let vars = List.map (expand_head env) vars in
+  let vars = List.map (expand_head env) vars in
+  let vars' =
+    List.filter
+      (fun t ->
+        let t = repr t in
+        generalize t;
+        match t.desc with
+          Tvar name when t.level = generic_level ->
+            log_type t; t.desc <- Tunivar name; true
+        | _ -> false)
+      vars in
+  if List.length vars = List.length vars' then () else
+  let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
+  and ty_expected = repr ty_expected in
+  raise (Error (exp.exp_loc, env,
+                Less_general(kind, [ty, ty; ty_expected, ty_expected])))
+
+(* Check that a type is not a function *)
+let check_application_result env statement exp =
+  let loc = exp.exp_loc in
+  match (expand_head env exp.exp_type).desc with
+  | Tarrow _ ->
+      Location.prerr_warning exp.exp_loc Warnings.Partial_application
+  | Tvar _ -> ()
+  | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+  | _ ->
+      if statement then
+        Location.prerr_warning loc Warnings.Statement_type
+
+(* Check that a type is generalizable at some level *)
+let generalizable level ty =
+  let rec check ty =
+    let ty = repr ty in
+    if ty.level < lowest_level then () else
+    if ty.level <= level then raise Exit else
+    (mark_type_node ty; iter_type_expr check ty)
+  in
+  try check ty; unmark_type ty; true
+  with Exit -> unmark_type ty; false
+
+(* Hack to allow coercion of self. Will clean-up later. *)
+let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
+
+(* Helpers for packaged modules. *)
+let create_package_type loc env (p, l) =
+  let s = !Typetexp.transl_modtype_longident loc env p in
+  let fields = List.map (fun (name, ct) ->
+                           name, Typetexp.transl_simple_type env false ct) l in
+  let ty = newty (Tpackage (s,
+                    List.map fst l,
+                   List.map (fun (_, cty) -> cty.ctyp_type) fields))
+  in
+   (s, fields, ty)
+
+ let wrap_unpacks sexp unpacks =
+   let open Ast_helper in
+   List.fold_left
+     (fun sexp (name, loc) ->
+       Exp.letmodule ~loc:sexp.pexp_loc ~attrs:[mknoloc "#modulepat",PStr []]
+         name
+         (Mod.unpack ~loc
+            (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
+                                            name.loc)))
+         sexp
+     )
+    sexp unpacks
+
+(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      match ty.desc with
+        Tvariant row ->
+          let row = row_repr row in
+          if not row.row_fixed then
+            List.iter
+              (fun (_,f) ->
+                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+              row.row_fields;
+          iter_row loop row
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  try loop ty; unmark_type ty; false
+  with Exit -> unmark_type ty; true
+
+let iter_ppat f p =
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
+  | Ppat_extension _
+  | Ppat_type _ | Ppat_unpack _ -> ()
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
+  | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
+
+let contains_polymorphic_variant p =
+  let rec loop p =
+    match p.ppat_desc with
+      Ppat_variant _ | Ppat_type _ -> raise Exit
+    | _ -> iter_ppat loop p
+  in
+  try loop p; false with Exit -> true
+
+let contains_gadt env p =
+  let rec loop env p =
+    match p.ppat_desc with
+      | Ppat_construct (lid, _) ->
+        begin try
+          let cstrs = Env.lookup_all_constructors lid.txt env in
+          List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
+            cstrs
+        with Not_found -> ()
+        end; iter_ppat (loop env) p
+      | Ppat_open (lid,sub_p) ->
+        let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in
+        loop new_env sub_p
+    | _ -> iter_ppat (loop env) p
+  in
+  try loop env p; false with Exit -> true
+
+let check_absent_variant env =
+  iter_pattern
+    (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
+      let row = row_repr !row in
+      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+          row.row_fields
+      || not row.row_fixed && not (static_row row)  (* same as Ctype.poly *)
+      then () else
+      let ty_arg =
+        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+                  row_more = newvar (); row_bound = ();
+                  row_closed = false; row_fixed = false; row_name = None} in
+      (* Should fail *)
+      unify_pat env {pat with pat_type = newty (Tvariant row')}
+                    (correct_levels pat.pat_type)
+      | _ -> ())
+
+(* Duplicate types of values in the environment *)
+(* XXX Should we do something about global type variables too? *)
+
+let duplicate_ident_types caselist env =
+  let caselist =
+    List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
+  let idents = all_idents_cases caselist in
+  let upd desc = {desc with val_type = correct_levels desc.val_type} in
+  (* Be careful not the mark the original value as being used, and
+     to keep the same internal 'slot' to track unused opens. *)
+  List.fold_left (fun env s -> Env.update_value s upd env) env idents
+
+
+(* Getting proper location of already typed expressions.
+
+   Used to avoid confusing locations on type error messages in presence of
+   type constraints.
+   For example:
+
+       (* Before patch *)
+       # let x : string = (5 : int);;
+                           ^
+       (* After patch *)
+       # let x : string = (5 : int);;
+                          ^^^^^^^^^
+*)
+let proper_exp_loc exp =
+  let rec aux = function
+    | [] -> exp.exp_loc
+    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
+    | _ :: rest -> aux rest
+  in
+  aux exp.exp_extra
+
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+    [] -> Ident.create default
+  | {c_lhs=p; _} :: rem ->
+      match p.pat_desc with
+        Tpat_var (id, _) -> id
+      | Tpat_alias(_, id, _) -> id
+      | _ -> name_pattern default rem
+
+(* Typing of expressions *)
+
+let unify_exp env exp expected_ty =
+  let loc = proper_exp_loc exp in
+  unify_exp_types loc env exp.exp_type expected_ty
+
+let rec type_exp ?recarg env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect ?recarg env sexp (newvar ())
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+and type_expect ?in_function ?recarg env sexp ty_expected =
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  Builtin_attributes.warning_enter_scope ();
+  Builtin_attributes.warning_attribute sexp.pexp_attributes;
+  let exp = type_expect_ ?in_function ?recarg env sexp ty_expected in
+  Builtin_attributes.warning_leave_scope ();
+  Cmt_format.set_saved_types
+    (Cmt_format.Partial_expression exp :: previous_saved_types);
+  exp
+
+and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
+  let loc = sexp.pexp_loc in
+  (* Record the expression type before unifying it with the expected type *)
+  let rue exp =
+    unify_exp env (re exp) (instance env ty_expected);
+    exp
+  in
+  match sexp.pexp_desc with
+  | Pexp_ident lid ->
+      begin
+        let (path, desc) = Typetexp.find_value env lid.loc lid.txt in
+        if !Clflags.annotations then begin
+          let dloc = desc.Types.val_loc in
+          let annot =
+            if dloc.Location.loc_ghost then Annot.Iref_external
+            else Annot.Iref_internal dloc
+          in
+          let name = Path.name ~paren:Oprint.parenthesized_ident path in
+          Stypes.record (Stypes.An_ident (loc, name, annot))
+        end;
+        let is_recarg =
+          match (repr desc.val_type).desc with
+          | Tconstr(p, _, _) -> Path.is_constructor_typath p
+          | _ -> false
+        in
+
+        begin match is_recarg, recarg, (repr desc.val_type).desc with
+        | _, Allowed, _
+        | true, Required, _
+        | false, Rejected, _
+          -> ()
+        | true, Rejected, _
+        | false, Required, (Tvar _ | Tconstr _) ->
+            raise (Error (loc, env, Inlined_record_escape))
+        | false, Required, _  ->
+            () (* will fail later *)
+        end;
+        rue {
+          exp_desc =
+            begin match desc.val_kind with
+              Val_ivar (_, cl_num) ->
+                let (self_path, _) =
+                  Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
+                in
+                Texp_instvar(self_path, path,
+                             match lid.txt with
+                                 Longident.Lident txt -> { txt; loc = lid.loc }
+                               | _ -> assert false)
+            | Val_self (_, _, cl_num, _) ->
+                let (path, _) =
+                  Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
+                in
+                Texp_ident(path, lid, desc)
+            | Val_unbound ->
+                raise(Error(loc, env, Masked_instance_variable lid.txt))
+            (*| Val_prim _ ->
+                let p = Env.normalize_path (Some loc) env path in
+                Env.add_required_global (Path.head p);
+                Texp_ident(path, lid, desc)*)
+            | _ ->
+                Texp_ident(path, lid, desc)
+          end;
+          exp_loc = loc; exp_extra = [];
+          exp_type = instance env desc.val_type;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      end
+  | Pexp_constant(Pconst_string (str, _) as cst) -> (
+    let cst = constant_or_raise env loc cst in
+    (* Terrible hack for format strings *)
+    let ty_exp = expand_head env ty_expected in
+    let fmt6_path =
+      Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
+                  "format6", 0)) in
+    let is_format = match ty_exp.desc with
+      | Tconstr(path, _, _) when Path.same path fmt6_path ->
+        if !Clflags.principal && ty_exp.level <> generic_level then
+          Location.prerr_warning loc
+            (Warnings.Not_principal "this coercion to format6");
+        true
+      | _ -> false
+    in
+    if is_format then
+      let format_parsetree =
+        { (type_format loc str env) with pexp_loc = sexp.pexp_loc }  in
+      type_expect ?in_function env format_parsetree ty_expected
+    else
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance_def Predef.type_string;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  )
+  | Pexp_constant cst ->
+      let cst = constant_or_raise env loc cst in
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc; exp_extra = [];
+        exp_type = type_constant cst;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_let(Nonrecursive,
+             [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
+    when contains_gadt env spat ->
+    (* TODO: allow non-empty attributes? *)
+      type_expect ?in_function env
+        {sexp with
+         pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
+        ty_expected
+  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
+      let scp =
+        match sexp.pexp_attributes, rec_flag with
+        | [{txt="#default"},_], _ -> None
+        | _, Recursive -> Some (Annot.Idef loc)
+        | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
+      in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let env rec_flag spat_sexp_list scp true in
+      let body =
+        type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_fun (l, Some default, spat, sbody) ->
+      assert(is_optional l); (* default allowed only with optional argument *)
+      let open Ast_helper in
+      let default_loc = default.pexp_loc in
+      let scases = [
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
+             (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
+          (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+
+        Exp.case
+          (Pat.construct ~loc:default_loc
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
+             None)
+          default;
+       ]
+      in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
+      let smatch =
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          scases
+      in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
+      let body =
+        Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
+          [Vb.mk spat smatch] sbody
+      in
+      type_function ?in_function loc sexp.pexp_attributes env ty_expected
+        l [Exp.case pat body]
+  | Pexp_fun (l, None, spat, sbody) ->
+      type_function ?in_function loc sexp.pexp_attributes env ty_expected
+        l [Ast_helper.Exp.case spat sbody]
+  | Pexp_function caselist ->
+      type_function ?in_function
+        loc sexp.pexp_attributes env ty_expected Nolabel caselist
+  | Pexp_apply(sfunct, sargs) ->
+      assert (sargs <> []);
+      begin_def (); (* one more level for non-returning functions *)
+      if !Clflags.principal then begin_def ();
+      let funct = type_exp env sfunct in
+      if !Clflags.principal then begin
+          end_def ();
+          generalize_structure funct.exp_type
+        end;
+      let rec lower_args seen ty_fun =
+        let ty = expand_head env ty_fun in
+        if List.memq ty seen then () else
+        match ty.desc with
+          Tarrow (_l, ty_arg, ty_fun, _com) ->
+            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
+            lower_args (ty::seen) ty_fun
+        | _ -> ()
+      in
+      let ty = instance env funct.exp_type in
+      end_def ();
+      wrap_trace_gadt_instances env (lower_args []) ty;
+      begin_def ();
+      let (args, ty_res) = type_application env funct sargs in
+      end_def ();
+      unify_var env (newvar()) funct.exp_type;
+      rue {
+        exp_desc = Texp_apply(funct, args);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_res;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_match(sarg, caselist) ->
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type;
+      generalize arg.exp_type;
+      let rec split_cases vc ec = function
+        | [] -> List.rev vc, List.rev ec
+        | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest ->
+            split_cases vc ({c with pc_lhs = p} :: ec) rest
+        | c :: rest ->
+            split_cases (c :: vc) ec rest
+      in
+      let val_caselist, exn_caselist = split_cases [] [] caselist in
+      if val_caselist = [] && exn_caselist <> [] then
+        raise (Error (loc, env, No_value_clauses));
+      (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully
+         empty pattern matching can be generated by Camlp4 with its
+         revised syntax.  Let's accept it for backward compatibility. *)
+      let val_cases, partial =
+        type_cases env arg.exp_type ty_expected true loc val_caselist in
+      let exn_cases, _ =
+        type_cases env Predef.type_exn ty_expected false loc exn_caselist in
+      re {
+        exp_desc = Texp_match(arg, val_cases, exn_cases, partial);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance env ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_try(sbody, caselist) ->
+      let body = type_expect env sbody ty_expected in
+      let cases, _ =
+        type_cases env Predef.type_exn ty_expected false loc caselist in
+      re {
+        exp_desc = Texp_try(body, cases);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_tuple sexpl ->
+      assert (List.length sexpl >= 2);
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      unify_exp_types loc env to_unify ty_expected;
+      let expl =
+        List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
+      in
+      re {
+        exp_desc = Texp_tuple expl;
+        exp_loc = loc; exp_extra = [];
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_construct(lid, sarg) ->
+      type_construct env loc lid sarg ty_expected sexp.pexp_attributes
+  | Pexp_variant(l, sarg) ->
+      (* Keep sharing *)
+      let ty_expected0 = instance env ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc; exp_extra = [];
+                   exp_type = ty_expected0;
+                   exp_attributes = sexp.pexp_attributes;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = may_map (type_exp env) sarg in
+        let arg_type = may_map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc; exp_extra = [];
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = false;
+                                    row_name = None});
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      end
+  | Pexp_record(lid_sexp_list, opt_sexp) ->
+      assert (lid_sexp_list <> []);
+      let opt_exp =
+        match opt_sexp with
+          None -> None
+        | Some sexp ->
+            if !Clflags.principal then begin_def ();
+            let exp = type_exp ~recarg env sexp in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure exp.exp_type
+            end;
+            Some exp
+      in
+      let ty_record, opath =
+        let get_path ty =
+          try
+            let (p0, p,_) = extract_concrete_record env ty in
+            (* XXX level may be wrong *)
+            Some (p0, p, ty.level = generic_level || not !Clflags.principal)
+          with Not_found -> None
+        in
+        match get_path ty_expected with
+          None ->
+            begin match opt_exp with
+              None -> newvar (), None
+            | Some exp ->
+                match get_path exp.exp_type with
+                  None -> newvar (), None
+                | Some (_, p', _) as op ->
+                    let decl = Env.find_type p' env in
+                    begin_def ();
+                    let ty =
+                      newconstr p' (instance_list env decl.type_params) in
+                    end_def ();
+                    generalize_structure ty;
+                    ty, op
+            end
+        | op -> ty_expected, op
+      in
+      let closed = (opt_sexp = None) in
+      let lbl_exp_list =
+        wrap_disambiguate "This record expression is expected to have" ty_record
+          (type_label_a_list loc closed env
+             (fun e k -> k (type_label_exp true env loc ty_record e))
+             opath lid_sexp_list)
+          (fun x -> x)
+      in
+      unify_exp_types loc env ty_record (instance env ty_expected);
+
+      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+      (* note: check_duplicates would better be implemented in
+         type_label_a_list directly *)
+      let rec check_duplicates = function
+        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+          raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
+        | _ :: rem ->
+            check_duplicates rem
+        | [] -> ()
+      in
+      check_duplicates lbl_exp_list;
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(Error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
+            let ty_exp = instance env exp.exp_type in
+            let unify_kept lbl =
+              let _, ty_arg1, ty_res1 = instance_label false lbl in
+              unify_exp_types exp.exp_loc env ty_exp ty_res1;
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  (* do not connect result types for overridden labels *)
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                  let _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify env ty_arg1 ty_arg2;
+                  unify env (instance env ty_expected) ty_res2;
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
+      in
+      let num_fields =
+        match lbl_exp_list with [] -> assert false
+        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
+      let opt_exp =
+        if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+          (Location.prerr_warning loc Warnings.Useless_record_with; None)
+        else opt_exp
+      in
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
+      re {
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance env ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_field(srecord, lid) ->
+      let (record, label, _) = type_label_access env srecord lid in
+      let (_, ty_arg, ty_res) = instance_label false label in
+      unify_exp env record ty_res;
+      rue {
+        exp_desc = Texp_field(record, lid, label);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty_arg;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_setfield(srecord, lid, snewval) ->
+      let (record, label, opath) = type_label_access env srecord lid in
+      let ty_record = if opath = None then newvar () else record.exp_type in
+      let (label_loc, label, newval) =
+        type_label_exp false env loc ty_record (lid, label, snewval) in
+      unify_exp env record ty_record;
+      if label.lbl_mut = Immutable then
+        raise(Error(loc, env, Label_not_mutable lid.txt));
+      Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes
+        (Longident.last lid.txt);
+      rue {
+        exp_desc = Texp_setfield(record, label_loc, label, newval);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance_def Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_array(sargl) ->
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      unify_exp_types loc env to_unify ty_expected;
+      let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
+      re {
+        exp_desc = Texp_array argl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance env ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_ifthenelse(scond, sifso, sifnot) ->
+      let cond = type_expect env scond Predef.type_bool in
+      begin match sifnot with
+        None ->
+          let ifso = type_expect env sifso Predef.type_unit in
+          rue {
+            exp_desc = Texp_ifthenelse(cond, ifso, None);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | Some sifnot ->
+          let ifso = type_expect env sifso ty_expected in
+          let ifnot = type_expect env sifnot ty_expected in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+            exp_loc = loc; exp_extra = [];
+            exp_type = ifso.exp_type;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      end
+  | Pexp_sequence(sexp1, sexp2) ->
+      let exp1 = type_statement env sexp1 in
+      let exp2 = type_expect env sexp2 ty_expected in
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
+        exp_loc = loc; exp_extra = [];
+        exp_type = exp2.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_while(scond, sbody) ->
+      let cond = type_expect env scond Predef.type_bool in
+      let body = type_statement env sbody in
+      rue {
+        exp_desc = Texp_while(cond, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance_def Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_for(param, slow, shigh, dir, sbody) ->
+      let low = type_expect env slow Predef.type_int in
+      let high = type_expect env shigh Predef.type_int in
+      let id, new_env =
+        match param.ppat_desc with
+        | Ppat_any -> Ident.create "_for", env
+        | Ppat_var {txt} ->
+            Env.enter_value txt {val_type = instance_def Predef.type_int;
+                                 val_attributes = [];
+                                 val_kind = Val_reg; Types.val_loc = loc; } env
+              ~check:(fun s -> Warnings.Unused_for_index s)
+        | _ ->
+            raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
+      in
+      let body = type_statement new_env sbody in
+      rue {
+        exp_desc = Texp_for(id, param, low, high, dir, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance_def Predef.type_unit;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_constraint (sarg, sty) ->
+      let separate = true in (* always separate, 1% slowdown for lablgtk *)
+      if separate then begin_def ();
+      let cty = Typetexp.transl_simple_type env false sty in
+      let ty = cty.ctyp_type in
+      let (arg, ty') =
+        if separate then begin
+          end_def ();
+          generalize_structure ty;
+          (type_argument env sarg ty (instance env ty), instance env ty)
+        end else
+          (type_argument env sarg ty ty, ty)
+      in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra =
+          (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
+      }
+  | Pexp_coerce(sarg, sty, sty') ->
+      let separate = true in (* always separate, 1% slowdown for lablgtk *)
+      (* Also see PR#7199 for a problem with the following:
+         let separate = !Clflags.principal || Env.has_local_constraints env in*)
+      let (arg, ty',cty,cty') =
+        match sty with
+        | None ->
+            let (cty', force) =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            let ty' = cty'.ctyp_type in
+            if separate then begin_def ();
+            let arg = type_exp env sarg in
+            let gen =
+              if separate then begin
+                end_def ();
+                let tv = newvar () in
+                let gen = generalizable tv.level arg.exp_type in
+                (try unify_var env tv arg.exp_type with Unify trace ->
+                  raise(Error(arg.exp_loc, env, Expr_type_clash trace)));
+                gen
+              end else true
+            in
+            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+              Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
+              Tconstr(path',_,_) when Path.same path path' ->
+                (* prerr_endline "self coercion"; *)
+                r := loc :: !r;
+                force ()
+            | _ when free_variables ~env arg.exp_type = []
+                  && free_variables ~env ty' = [] ->
+                if not gen && (* first try a single coercion *)
+                  let snap = snapshot () in
+                  let ty, _b = enlarge_type env ty' in
+                  try
+                    force (); Ctype.unify env arg.exp_type ty; true
+                  with Unify _ ->
+                    backtrack snap; false
+                then ()
+                else begin try
+                  let force' = subtype env arg.exp_type ty' in
+                  force (); force' ();
+                  if not gen && !Clflags.principal then
+                    Location.prerr_warning loc
+                      (Warnings.Not_principal "this ground coercion");
+                with Subtype (tr1, tr2) ->
+                  (* prerr_endline "coercion failed"; *)
+                  raise(Error(loc, env, Not_subtype(tr1, tr2)))
+                end;
+            | _ ->
+                let ty, b = enlarge_type env ty' in
+                force ();
+                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
+                  raise(Error(sarg.pexp_loc, env,
+                        Coercion_failure(ty', full_expand env ty', trace, b)))
+                end
+            end;
+            (arg, ty', None, cty')
+        | Some sty ->
+            if separate then begin_def ();
+            let (cty, force) =
+              Typetexp.transl_simple_type_delayed env sty
+            and (cty', force') =
+              Typetexp.transl_simple_type_delayed env sty'
+            in
+            let ty = cty.ctyp_type in
+            let ty' = cty'.ctyp_type in
+            begin try
+              let force'' = subtype env ty ty' in
+              force (); force' (); force'' ()
+            with Subtype (tr1, tr2) ->
+              raise(Error(loc, env, Not_subtype(tr1, tr2)))
+            end;
+            if separate then begin
+              end_def ();
+              generalize_structure ty;
+              generalize_structure ty';
+              (type_argument env sarg ty (instance env ty),
+               instance env ty', Some cty, cty')
+            end else
+              (type_argument env sarg ty ty, ty', Some cty, cty')
+      in
+      rue {
+        exp_desc = arg.exp_desc;
+        exp_loc = arg.exp_loc;
+        exp_type = ty';
+        exp_attributes = arg.exp_attributes;
+        exp_env = env;
+        exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
+                       arg.exp_extra;
+      }
+  | Pexp_send (e, {txt=met}) ->
+      if !Clflags.principal then begin_def ();
+      let obj = type_exp env e in
+      let obj_meths = ref None in
+      begin try
+        let (meth, exp, typ) =
+          match obj.exp_desc with
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+              obj_meths := Some meths;
+              let (id, typ) =
+                filter_self_method env met Private meths privty
+              in
+              if is_Tvar (repr typ) then
+                Location.prerr_warning loc
+                  (Warnings.Undeclared_virtual_method met);
+              (Tmeth_val id, None, typ)
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+              let method_id =
+                begin try List.assoc met methods with Not_found ->
+                  let valid_methods = List.map fst methods in
+                  raise(Error(e.pexp_loc, env,
+                              Undefined_inherited_method (met, valid_methods)))
+                end
+              in
+              begin match
+                Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
+                Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
+              with
+                (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
+                (path, _) ->
+                  obj_meths := Some meths;
+                  let (_, typ) =
+                    filter_self_method env met Private meths privty
+                  in
+                  let method_type = newvar () in
+                  let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
+                  unify env obj_ty desc.val_type;
+                  unify env res_ty (instance env typ);
+                  let exp =
+                    Texp_apply({exp_desc =
+                                Texp_ident(Path.Pident method_id, lid,
+                                           {val_type = method_type;
+                                            val_kind = Val_reg;
+                                            val_attributes = [];
+                                            Types.val_loc = Location.none});
+                                exp_loc = loc; exp_extra = [];
+                                exp_type = method_type;
+                                exp_attributes = []; (* check *)
+                                exp_env = env},
+                          [ Nolabel,
+                            Some {exp_desc = Texp_ident(path, lid, desc);
+                                  exp_loc = obj.exp_loc; exp_extra = [];
+                                  exp_type = desc.val_type;
+                                  exp_attributes = []; (* check *)
+                                  exp_env = env}
+                          ])
+                  in
+                  (Tmeth_name met, Some (re {exp_desc = exp;
+                                             exp_loc = loc; exp_extra = [];
+                                             exp_type = typ;
+                                             exp_attributes = []; (* check *)
+                                             exp_env = env}), typ)
+              |  _ ->
+                  assert false
+              end
+          | _ ->
+              (Tmeth_name met, None,
+               filter_method env met Public obj.exp_type)
+        in
+        if !Clflags.principal then begin
+          end_def ();
+          generalize_structure typ;
+        end;
+        let typ =
+          match repr typ with
+            {desc = Tpoly (ty, [])} ->
+              instance env ty
+          | {desc = Tpoly (ty, tl); level = l} ->
+              if !Clflags.principal && l <> generic_level then
+                Location.prerr_warning loc
+                  (Warnings.Not_principal "this use of a polymorphic method");
+              snd (instance_poly false tl ty)
+          | {desc = Tvar _} as ty ->
+              let ty' = newvar () in
+              unify env (instance_def ty) (newty(Tpoly(ty',[])));
+              (* if not !Clflags.nolabels then
+                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
+              ty'
+          | _ ->
+              assert false
+        in
+        rue {
+          exp_desc = Texp_send(obj, meth, exp);
+          exp_loc = loc; exp_extra = [];
+          exp_type = typ;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env }
+      with Unify _ ->
+        let valid_methods =
+          match !obj_meths with
+          | Some meths ->
+             Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
+          | None ->
+             match (expand_head env obj.exp_type).desc with
+             | Tobject (fields, _) ->
+                let (fields, _) = Ctype.flatten_fields fields in
+                let collect_fields li (meth, meth_kind, _meth_ty) =
+                  if meth_kind = Fpresent then meth::li else li in
+                Some (List.fold_left collect_fields [] fields)
+             | _ -> None
+        in
+        raise(Error(e.pexp_loc, env,
+                    Undefined_method (obj.exp_type, met, valid_methods)))
+      end
+  | Pexp_new cl ->
+      let (cl_path, cl_decl) = Typetexp.find_class env cl.loc cl.txt in
+      begin match cl_decl.cty_new with
+          None ->
+            raise(Error(loc, env, Virtual_class cl.txt))
+        | Some ty ->
+            rue {
+              exp_desc = Texp_new (cl_path, cl, cl_decl);
+              exp_loc = loc; exp_extra = [];
+              exp_type = instance_def ty;
+              exp_attributes = sexp.pexp_attributes;
+              exp_env = env }
+        end
+  | Pexp_setinstvar (lab, snewval) ->
+      begin try
+        let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
+        match desc.val_kind with
+          Val_ivar (Mutable, cl_num) ->
+            let newval =
+              type_expect env snewval (instance env desc.val_type) in
+            let (path_self, _) =
+              Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
+            in
+            rue {
+              exp_desc = Texp_setinstvar(path_self, path, lab, newval);
+              exp_loc = loc; exp_extra = [];
+              exp_type = instance_def Predef.type_unit;
+              exp_attributes = sexp.pexp_attributes;
+              exp_env = env }
+        | Val_ivar _ ->
+            raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
+        | _ ->
+            raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt)))
+      with
+        Not_found ->
+          let collect_vars name _path val_desc li =
+            match val_desc.val_kind with
+            | Val_ivar (Mutable, _) -> name::li
+            | _ -> li in
+          let valid_vars = Env.fold_values collect_vars None env [] in
+          raise(Error(loc, env,
+                      Unbound_instance_variable (lab.txt, valid_vars)))
+      end
+  | Pexp_override lst ->
+      let _ =
+       List.fold_right
+        (fun (lab, _) l ->
+           if List.exists (fun l -> l.txt = lab.txt) l then
+             raise(Error(loc, env,
+                         Value_multiply_overridden lab.txt));
+           lab::l)
+        lst
+        [] in
+      begin match
+        try
+          Env.lookup_value (Longident.Lident "selfpat-*") env,
+          Env.lookup_value (Longident.Lident "self-*") env
+        with Not_found ->
+          raise(Error(loc, env, Outside_class))
+      with
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
+        (path_self, _) ->
+          let type_override (lab, snewval) =
+            begin try
+              let (id, _, _, ty) = Vars.find lab.txt !vars in
+              (Path.Pident id, lab, type_expect env snewval (instance env ty))
+            with
+              Not_found ->
+                let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
+                raise(Error(loc, env,
+                            Unbound_instance_variable (lab.txt, vars)))
+            end
+          in
+          let modifs = List.map type_override lst in
+          rue {
+            exp_desc = Texp_override(path_self, modifs);
+            exp_loc = loc; exp_extra = [];
+            exp_type = self_ty;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          assert false
+      end
+  | Pexp_letmodule(name, smodl, sbody) ->
+      let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
+      Ident.set_current_time ty.level;
+      let context = Typetexp.narrow () in
+      let modl = !type_module env smodl in
+      let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
+      Ctype.init_def(Ident.current_time());
+      Typetexp.widen context;
+      let body = type_expect new_env sbody ty_expected in
+      (* go back to original level *)
+      end_def ();
+      (* Unification of body.exp_type with the fresh variable ty
+         fails if and only if the prefix condition is violated,
+         i.e. if generative types rooted at id show up in the
+         type body.exp_type.  Thus, this unification enforces the
+         scoping condition on "let module". *)
+      begin try
+        Ctype.unify_var new_env ty body.exp_type
+      with Unify _ ->
+        raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
+      end;
+      re {
+        exp_desc = Texp_letmodule(id, name, modl, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = ty;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
+  | Pexp_assert (e) ->
+      let cond = type_expect env e Predef.type_bool in
+      let exp_type =
+        match cond.exp_desc with
+        | Texp_construct(_, {cstr_name="false"}, _) ->
+            instance env ty_expected
+        | _ ->
+            instance_def Predef.type_unit
+      in
+      rue {
+        exp_desc = Texp_assert cond;
+        exp_loc = loc; exp_extra = [];
+        exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_lazy e ->
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      unify_exp_types loc env to_unify ty_expected;
+      let arg = type_expect env e ty in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance env ty_expected;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env loc s in
+      rue {
+        exp_desc = Texp_object (desc, (*sign,*) meths);
+        exp_loc = loc; exp_extra = [];
+        exp_type = sign.csig_self;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env;
+      }
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty, cty =
+        match sty with None -> repr ty_expected, None
+        | Some sty ->
+            let sty = Ast_helper.Typ.force_poly sty in
+            let cty = Typetexp.transl_simple_type env false sty in
+            repr cty.ctyp_type, Some cty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        unify_exp_types loc env (instance env ty) (instance env ty_expected);
+      let exp =
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody ty' in
+            { exp with exp_type = instance env ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody ty'' in
+            end_def ();
+            check_univars env false "method" exp ty_expected vars;
+            { exp with exp_type = instance env ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            exp
+        | _ -> assert false
+      in
+      re { exp with exp_extra =
+             (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
+  | Pexp_newtype({txt=name}, sbody) ->
+      let ty = newvar () in
+      (* remember original level *)
+      begin_def ();
+      (* Create a fake abstract type declaration for name. *)
+      let level = get_current_level () in
+      let decl = {
+        type_params = [];
+        type_arity = 0;
+        type_kind = Type_abstract;
+        type_private = Public;
+        type_manifest = None;
+        type_variance = [];
+        type_newtype_level = Some (level, level);
+        type_loc = loc;
+        type_attributes = [];
+        type_immediate = false;
+        type_unboxed = unboxed_false_default_false;
+      }
+      in
+      Ident.set_current_time ty.level;
+      let (id, new_env) = Env.enter_type name decl env in
+      Ctype.init_def(Ident.current_time());
+
+      let body = type_exp new_env sbody in
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
+      let seen = Hashtbl.create 8 in
+      let rec replace t =
+        if Hashtbl.mem seen t.id then ()
+        else begin
+          Hashtbl.add seen t.id ();
+          match t.desc with
+          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+          | _ -> Btype.iter_type_expr replace t
+        end
+      in
+      let ety = Subst.type_expr Subst.identity body.exp_type in
+      replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
+
+      (* non-expansive if the body is non-expansive, so we don't introduce
+         any new extra node in the typed AST. *)
+      rue { body with exp_loc = loc; exp_type = ety;
+            exp_extra =
+            (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
+  | Pexp_pack m ->
+      let (p, nl) =
+        match Ctype.expand_head env (instance env ty_expected) with
+          {desc = Tpackage (p, nl, _tl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, nl)
+        | {desc = Tvar _} ->
+            raise (Error (loc, env, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, env, Not_a_packed_module ty_expected))
+      in
+      let (modl, tl') = !type_package env m p nl in
+      rue {
+        exp_desc = Texp_pack modl;
+        exp_loc = loc; exp_extra = [];
+        exp_type = newty (Tpackage (p, nl, tl'));
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+  | Pexp_open (ovf, lid, e) ->
+      let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
+      let exp = type_expect newenv e ty_expected in
+      { exp with
+        exp_extra = (Texp_open (ovf, path, lid, newenv), loc,
+                     sexp.pexp_attributes) ::
+                      exp.exp_extra;
+      }
+
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"
+                             |"extension_constructor"); _ },
+                    payload) ->
+      begin match payload with
+      | PStr [ { pstr_desc =
+                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
+               } ] ->
+          let path =
+            match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with
+            | Cstr_extension (path, _) -> path
+            | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
+          in
+          rue {
+            exp_desc = Texp_extension_constructor (lid, path);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance_def Predef.type_extension_constructor;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise (Error (loc, env, Invalid_extension_constructor_payload))
+      end
+  | Pexp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+  | Pexp_unreachable ->
+      re { exp_desc = Texp_unreachable;
+           exp_loc = loc; exp_extra = [];
+           exp_type = instance env ty_expected;
+           exp_attributes = sexp.pexp_attributes;
+           exp_env = env }
+
+and type_function ?in_function loc attrs env ty_expected l caselist =
+  let (loc_fun, ty_fun) =
+    match in_function with Some p -> p
+    | None -> (loc, instance env ty_expected)
+  in
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then begin_def ();
+  let (ty_arg, ty_res) =
+    try filter_arrow env (instance env ty_expected) l
+    with Unify _ ->
+      match expand_head env ty_expected with
+        {desc = Tarrow _} as ty ->
+          raise(Error(loc, env, Abstract_wrong_label(l, ty)))
+      | _ ->
+          raise(Error(loc_fun, env,
+                      Too_many_arguments (in_function <> None, ty_fun)))
+  in
+  let ty_arg =
+    if is_optional l then
+      let tv = newvar() in
+      begin
+        try unify env ty_arg (type_option tv)
+        with Unify _ -> assert false
+      end;
+      type_option tv
+    else ty_arg
+  in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  let cases, partial =
+    type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
+      true loc caselist in
+  let not_function ty =
+    let ls, tvar = list_labels env ty in
+    ls = [] && not tvar
+  in
+  if is_optional l && not_function ty_res then
+    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+      Warnings.Unerasable_optional_argument;
+  let param = name_pattern "param" cases in
+  re {
+    exp_desc = Texp_function { arg_label = l; param; cases; partial; };
+    exp_loc = loc; exp_extra = [];
+    exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+    exp_attributes = attrs;
+    exp_env = env }
+
+
+and type_label_access env srecord lid =
+  if !Clflags.principal then begin_def ();
+  let record = type_exp ~recarg:Allowed env srecord in
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure record.exp_type
+  end;
+  let ty_exp = record.exp_type in
+  let opath =
+    try
+      let (p0, p,_) = extract_concrete_record env ty_exp in
+      Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let labels = Typetexp.find_all_labels env lid.loc lid.txt in
+  let label =
+    wrap_disambiguate "This expression has" ty_exp
+      (Label.disambiguate lid env opath) labels in
+  (record, label, opath)
+
+(* Typing format strings for printing or reading.
+   These formats are used by functions in modules Printf, Format, and Scanf.
+   (Handling of * modifiers contributed by Thorsten Ohl.) *)
+
+and type_format loc str env =
+  let loc = {loc with Location.loc_ghost = true} in
+  try
+    CamlinternalFormatBasics.(CamlinternalFormat.(
+      let mk_exp_loc pexp_desc = {
+        pexp_desc = pexp_desc;
+        pexp_loc = loc;
+        pexp_attributes = [];
+      } and mk_lid_loc lid = {
+        txt = lid;
+        loc = loc;
+      } in
+      let mk_constr name args =
+        let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
+        let arg = match args with
+          | []          -> None
+          | [ e ]       -> Some e
+          | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
+        mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
+      let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
+      let mk_int n = mk_cst (Pconst_integer (string_of_int n, None))
+      and mk_string str = mk_cst (Pconst_string (str, None))
+      and mk_char chr = mk_cst (Pconst_char chr) in
+      let rec mk_formatting_lit fmting = match fmting with
+        | Close_box ->
+          mk_constr "Close_box" []
+        | Close_tag ->
+          mk_constr "Close_tag" []
+        | Break (org, ns, ni) ->
+          mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
+        | FFlush ->
+          mk_constr "FFlush" []
+        | Force_newline ->
+          mk_constr "Force_newline" []
+        | Flush_newline ->
+          mk_constr "Flush_newline" []
+        | Magic_size (org, sz) ->
+          mk_constr "Magic_size" [ mk_string org; mk_int sz ]
+        | Escaped_at ->
+          mk_constr "Escaped_at" []
+        | Escaped_percent ->
+          mk_constr "Escaped_percent" []
+        | Scan_indic c ->
+          mk_constr "Scan_indic" [ mk_char c ]
+      and mk_formatting_gen : type a b c d e f .
+          (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
+        fun fmting -> match fmting with
+        | Open_tag (Format (fmt', str')) ->
+          mk_constr "Open_tag" [ mk_format fmt' str' ]
+        | Open_box (Format (fmt', str')) ->
+          mk_constr "Open_box" [ mk_format fmt' str' ]
+      and mk_format : type a b c d e f .
+          (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
+          Parsetree.expression = fun fmt str ->
+        mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+      and mk_side side = match side with
+        | Left  -> mk_constr "Left"  []
+        | Right -> mk_constr "Right" []
+        | Zeros -> mk_constr "Zeros" []
+      and mk_iconv iconv = match iconv with
+        | Int_d  -> mk_constr "Int_d"  [] | Int_pd -> mk_constr "Int_pd" []
+        | Int_sd -> mk_constr "Int_sd" [] | Int_i  -> mk_constr "Int_i"  []
+        | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
+        | Int_x  -> mk_constr "Int_x"  [] | Int_Cx -> mk_constr "Int_Cx" []
+        | Int_X  -> mk_constr "Int_X"  [] | Int_CX -> mk_constr "Int_CX" []
+        | Int_o  -> mk_constr "Int_o"  [] | Int_Co -> mk_constr "Int_Co" []
+        | Int_u  -> mk_constr "Int_u"  []
+      and mk_fconv fconv = match fconv with
+        | Float_f  -> mk_constr "Float_f"  []
+        | Float_pf -> mk_constr "Float_pf" []
+        | Float_sf -> mk_constr "Float_sf" []
+        | Float_e  -> mk_constr "Float_e"  []
+        | Float_pe -> mk_constr "Float_pe" []
+        | Float_se -> mk_constr "Float_se" []
+        | Float_E  -> mk_constr "Float_E"  []
+        | Float_pE -> mk_constr "Float_pE" []
+        | Float_sE -> mk_constr "Float_sE" []
+        | Float_g  -> mk_constr "Float_g"  []
+        | Float_pg -> mk_constr "Float_pg" []
+        | Float_sg -> mk_constr "Float_sg" []
+        | Float_G  -> mk_constr "Float_G"  []
+        | Float_pG -> mk_constr "Float_pG" []
+        | Float_sG -> mk_constr "Float_sG" []
+        | Float_h  -> mk_constr "Float_h"  []
+        | Float_ph -> mk_constr "Float_ph" []
+        | Float_sh -> mk_constr "Float_sh" []
+        | Float_H  -> mk_constr "Float_H"  []
+        | Float_pH -> mk_constr "Float_pH" []
+        | Float_sH -> mk_constr "Float_sH" []
+        | Float_F  -> mk_constr "Float_F"  []
+      and mk_counter cnt = match cnt with
+        | Line_counter  -> mk_constr "Line_counter"  []
+        | Char_counter  -> mk_constr "Char_counter"  []
+        | Token_counter -> mk_constr "Token_counter" []
+      and mk_int_opt n_opt = match n_opt with
+        | None ->
+          let lid_loc = mk_lid_loc (Longident.Lident "None") in
+          mk_exp_loc (Pexp_construct (lid_loc, None))
+        | Some n ->
+          let lid_loc = mk_lid_loc (Longident.Lident "Some") in
+          mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
+      and mk_fmtty : type a b c d e f g h i j k l .
+          (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
+          =
+      fun fmtty -> match fmtty with
+        | Char_ty rest      -> mk_constr "Char_ty"      [ mk_fmtty rest ]
+        | String_ty rest    -> mk_constr "String_ty"    [ mk_fmtty rest ]
+        | Int_ty rest       -> mk_constr "Int_ty"       [ mk_fmtty rest ]
+        | Int32_ty rest     -> mk_constr "Int32_ty"     [ mk_fmtty rest ]
+        | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
+        | Int64_ty rest     -> mk_constr "Int64_ty"     [ mk_fmtty rest ]
+        | Float_ty rest     -> mk_constr "Float_ty"     [ mk_fmtty rest ]
+        | Bool_ty rest      -> mk_constr "Bool_ty"      [ mk_fmtty rest ]
+        | Alpha_ty rest     -> mk_constr "Alpha_ty"     [ mk_fmtty rest ]
+        | Theta_ty rest     -> mk_constr "Theta_ty"     [ mk_fmtty rest ]
+        | Any_ty rest       -> mk_constr "Any_ty"       [ mk_fmtty rest ]
+        | Reader_ty rest    -> mk_constr "Reader_ty"    [ mk_fmtty rest ]
+        | Ignored_reader_ty rest ->
+          mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
+        | Format_arg_ty (sub_fmtty, rest) ->
+          mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
+        | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
+          mk_constr "Format_subst_ty"
+            [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
+        | End_of_fmtty -> mk_constr "End_of_fmtty" []
+      and mk_ignored : type a b c d e f .
+          (a, b, c, d, e, f) ignored -> Parsetree.expression =
+      fun ign -> match ign with
+        | Ignored_char ->
+          mk_constr "Ignored_char" []
+        | Ignored_caml_char ->
+          mk_constr "Ignored_caml_char" []
+        | Ignored_string pad_opt ->
+          mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
+        | Ignored_caml_string pad_opt ->
+          mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
+        | Ignored_int (iconv, pad_opt) ->
+          mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int32 (iconv, pad_opt) ->
+          mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_nativeint (iconv, pad_opt) ->
+          mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_int64 (iconv, pad_opt) ->
+          mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
+        | Ignored_float (pad_opt, prec_opt) ->
+          mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
+        | Ignored_bool ->
+          mk_constr "Ignored_bool" []
+        | Ignored_format_arg (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_format_subst (pad_opt, fmtty) ->
+          mk_constr "Ignored_format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty ]
+        | Ignored_reader ->
+          mk_constr "Ignored_reader" []
+        | Ignored_scan_char_set (width_opt, char_set) ->
+          mk_constr "Ignored_scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set ]
+        | Ignored_scan_get_counter counter ->
+          mk_constr "Ignored_scan_get_counter" [
+            mk_counter counter
+          ]
+        | Ignored_scan_next_char ->
+          mk_constr "Ignored_scan_next_char" []
+      and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
+      fun pad -> match pad with
+        | No_padding         -> mk_constr "No_padding" []
+        | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
+        | Arg_padding s      -> mk_constr "Arg_padding" [ mk_side s ]
+      and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
+      fun prec -> match prec with
+        | No_precision    -> mk_constr "No_precision" []
+        | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
+        | Arg_precision   -> mk_constr "Arg_precision" []
+      and mk_fmt : type a b c d e f .
+          (a, b, c, d, e, f) fmt -> Parsetree.expression =
+      fun fmt -> match fmt with
+        | Char rest ->
+          mk_constr "Char" [ mk_fmt rest ]
+        | Caml_char rest ->
+          mk_constr "Caml_char" [ mk_fmt rest ]
+        | String (pad, rest) ->
+          mk_constr "String" [ mk_padding pad; mk_fmt rest ]
+        | Caml_string (pad, rest) ->
+          mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
+        | Int (iconv, pad, prec, rest) ->
+          mk_constr "Int" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int32 (iconv, pad, prec, rest) ->
+          mk_constr "Int32" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Nativeint (iconv, pad, prec, rest) ->
+          mk_constr "Nativeint" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Int64 (iconv, pad, prec, rest) ->
+          mk_constr "Int64" [
+            mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Float (fconv, pad, prec, rest) ->
+          mk_constr "Float" [
+            mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
+        | Bool rest ->
+          mk_constr "Bool" [ mk_fmt rest ]
+        | Flush rest ->
+          mk_constr "Flush" [ mk_fmt rest ]
+        | String_literal (s, rest) ->
+          mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
+        | Char_literal (c, rest) ->
+          mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
+        | Format_arg (pad_opt, fmtty, rest) ->
+          mk_constr "Format_arg" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Format_subst (pad_opt, fmtty, rest) ->
+          mk_constr "Format_subst" [
+            mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
+        | Alpha rest ->
+          mk_constr "Alpha" [ mk_fmt rest ]
+        | Theta rest ->
+          mk_constr "Theta" [ mk_fmt rest ]
+        | Formatting_lit (fmting, rest) ->
+          mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
+        | Formatting_gen (fmting, rest) ->
+          mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
+        | Reader rest ->
+          mk_constr "Reader" [ mk_fmt rest ]
+        | Scan_char_set (width_opt, char_set, rest) ->
+          mk_constr "Scan_char_set" [
+            mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
+        | Scan_get_counter (cnt, rest) ->
+          mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
+        | Scan_next_char rest ->
+          mk_constr "Scan_next_char" [ mk_fmt rest ]
+        | Ignored_param (ign, rest) ->
+          mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
+        | End_of_format ->
+          mk_constr "End_of_format" []
+        | Custom _ ->
+          (* Custom formatters have no syntax so they will never appear
+             in formats parsed from strings. *)
+          assert false
+      in
+      let legacy_behavior = not !Clflags.strict_formats in
+      let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
+      mk_constr "Format" [ mk_fmt fmt; mk_string str ]
+    ))
+  with Failure msg ->
+    raise (Error (loc, env, Invalid_format msg))
+
+and type_label_exp create env loc ty_expected
+          (lid, label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
+  begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (vars, ty_arg, ty_res) = instance_label true label in
+  if separate then begin
+    end_def ();
+    (* Generalize label information *)
+    generalize_structure ty_arg;
+    generalize_structure ty_res
+  end;
+  begin try
+    unify env (instance_def ty_res) (instance env ty_expected)
+  with Unify trace ->
+    raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance_def ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
+  end;
+  if label.lbl_private = Private then
+    if create then
+      raise (Error(loc, env, Private_type ty_expected))
+    else
+      raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+  let arg =
+    let snap = if vars = [] then None else Some (Btype.snapshot ()) in
+    let arg = type_argument env sarg ty_arg (instance env ty_arg) in
+    end_def ();
+    try
+      check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
+      arg
+    with exn when not (is_nonexpansive arg) -> try
+      (* Try to retype without propagating ty_arg, cf PR#4862 *)
+      may Btype.backtrack snap;
+      begin_def ();
+      let arg = type_exp env sarg in
+      end_def ();
+      generalize_expansive env arg.exp_type;
+      unify_exp env arg ty_arg;
+      check_univars env false "field value" arg label.lbl_arg vars;
+      arg
+    with Error (_, _, Less_general _) as e -> raise e
+    | _ -> raise exn    (* In case of failure return the first error *)
+  in
+  (lid, label, {arg with exp_type = instance env arg.exp_type})
+
+and type_argument ?recarg env sarg ty_expected' ty_expected =
+  (* ty_expected' may be generic *)
+  let no_labels ty =
+    let ls, tvar = list_labels env ty in
+    not tvar && List.for_all ((=) Nolabel) ls
+  in
+  let rec is_inferred sexp =
+    match sexp.pexp_desc with
+      Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
+    | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
+    | Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e
+    | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
+    | _ -> false
+  in
+  match expand_head env ty_expected' with
+    {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}
+    when is_inferred sarg ->
+      (* apply optional arguments when expected type is "" *)
+      (* we must be very careful about not breaking the semantics *)
+      if !Clflags.principal then begin_def ();
+      let texp = type_exp env sarg in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure texp.exp_type
+      end;
+      let rec make_args args ty_fun =
+        match (expand_head env ty_fun).desc with
+        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
+            let ty = option_none (instance env ty_arg) sarg.pexp_loc in
+            make_args ((l, Some ty) :: args) ty_fun
+        | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
+            List.rev args, ty_fun, no_labels ty_res'
+        | Tvar _ ->  List.rev args, ty_fun, false
+        |  _ -> [], texp.exp_type, false
+      in
+      let args, ty_fun', simple_res = make_args [] texp.exp_type in
+      let warn = !Clflags.principal &&
+        (lv <> generic_level || (repr ty_fun').level <> generic_level)
+      and texp = {texp with exp_type = instance env texp.exp_type}
+      and ty_fun = instance env ty_fun' in
+      if not (simple_res || no_labels ty_res) then begin
+        unify_exp env texp ty_expected;
+        texp
+      end else begin
+      unify_exp env {texp with exp_type = ty_fun} ty_expected;
+      if args = [] then texp else
+      (* eta-expand to avoid side effects *)
+      let var_pair name ty =
+        let id = Ident.create name in
+        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+         pat_attributes = [];
+         pat_loc = Location.none; pat_env = env},
+        {exp_type = ty; exp_loc = Location.none; exp_env = env;
+         exp_extra = []; exp_attributes = [];
+         exp_desc =
+         Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
+                    {val_type = ty; val_kind = Val_reg;
+                     val_attributes = [];
+                     Types.val_loc = Location.none})}
+      in
+      let eta_pat, eta_var = var_pair "eta" ty_arg in
+      let func texp =
+        let e =
+          {texp with exp_type = ty_res; exp_desc =
+           Texp_apply
+             (texp,
+              args @ [Nolabel, Some eta_var])}
+        in
+        let cases = [case eta_pat e] in
+        let param = name_pattern "param" cases in
+        { texp with exp_type = ty_fun; exp_desc =
+          Texp_function { arg_label = Nolabel; param; cases;
+            partial = Total; } }
+      in
+      Location.prerr_warning texp.exp_loc
+        (Warnings.Eliminated_optional_arguments
+           (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
+      if warn then Location.prerr_warning texp.exp_loc
+          (Warnings.Without_principality "eliminated optional argument");
+      if is_nonexpansive texp then func texp else
+      (* let-expand to have side effects *)
+      let let_pat, let_var = var_pair "arg" texp.exp_type in
+      re { texp with exp_type = ty_fun; exp_desc =
+           Texp_let (Nonrecursive,
+                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
+                       vb_loc=Location.none;
+                      }],
+                     func let_var) }
+      end
+  | _ ->
+      let texp = type_expect ?recarg env sarg ty_expected' in
+      unify_exp env texp ty_expected;
+      texp
+
+and type_application env funct sargs =
+  (* funct.exp_type may be generic *)
+  let result_type omitted ty_fun =
+    List.fold_left
+      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
+      ty_fun omitted
+  in
+  let has_label l ty_fun =
+    let ls, tvar = list_labels env ty_fun in
+    tvar || List.mem l ls
+  in
+  let ignored = ref [] in
+  let rec type_unknown_args
+      (args :
+      (Asttypes.arg_label * (unit -> Typedtree.expression) option) list)
+    omitted ty_fun = function
+      [] ->
+        (List.map
+            (function l, None -> l, None
+                | l, Some f -> l, Some (f ()))
+           (List.rev args),
+         instance env (result_type omitted ty_fun))
+    | (l1, sarg1) :: sargl ->
+        let (ty1, ty2) =
+          let ty_fun = expand_head env ty_fun in
+          match ty_fun.desc with
+            Tvar _ ->
+              let t1 = newvar () and t2 = newvar () in
+              let not_identity = function
+                  Texp_ident(_,_,{val_kind=Val_prim
+                                  {Primitive.prim_name="%identity"}}) ->
+                    false
+                | _ -> true
+              in
+              if ty_fun.level >= t1.level && not_identity funct.exp_desc then
+                Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
+              unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
+              (t1, t2)
+          | Tarrow (l,t1,t2,_) when l = l1
+            || !Clflags.classic && l1 = Nolabel && not (is_optional l) ->
+              (t1, t2)
+          | td ->
+              let ty_fun =
+                match td with Tarrow _ -> newty td | _ -> ty_fun in
+              let ty_res = result_type (omitted @ !ignored) ty_fun in
+              match ty_res.desc with
+                Tarrow _ ->
+                  if (!Clflags.classic || not (has_label l1 ty_fun)) then
+                    raise (Error(sarg1.pexp_loc, env,
+                                 Apply_wrong_label(l1, ty_res)))
+                  else
+                    raise (Error(funct.exp_loc, env, Incoherent_label_order))
+              | _ ->
+                  raise(Error(funct.exp_loc, env, Apply_non_function
+                                (expand_head env funct.exp_type)))
+        in
+        let optional = is_optional l1 in
+        let arg1 () =
+          let arg1 = type_expect env sarg1 ty1 in
+          if optional then
+            unify_exp env arg1 (type_option(newvar()));
+          arg1
+        in
+        type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl
+  in
+  let ignore_labels =
+    !Clflags.classic ||
+    begin
+      let ls, tvar = list_labels env funct.exp_type in
+      not tvar &&
+      let labels = List.filter (fun l -> not (is_optional l)) ls in
+      List.length labels = List.length sargs &&
+      List.for_all (fun (l,_) -> l = Nolabel) sargs &&
+      List.exists (fun l -> l <> Nolabel) labels &&
+      (Location.prerr_warning
+         funct.exp_loc
+         (Warnings.Labels_omitted
+            (List.map Printtyp.string_of_label
+                      (List.filter ((<>) Nolabel) labels)));
+       true)
+    end
+  in
+  let warned = ref false in
+  let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
+      when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
+        let may_warn loc w =
+          if not !warned && !Clflags.principal && lv <> generic_level
+          then begin
+            warned := true;
+            Location.prerr_warning loc w
+          end
+        in
+        let name = label_name l
+        and optional = is_optional l in
+        let sargs, more_sargs, arg =
+          if ignore_labels && not (is_optional l) then begin
+            (* In classic mode, omitted = [] *)
+            match sargs, more_sargs with
+              (l', sarg0) :: _, _ ->
+                raise(Error(sarg0.pexp_loc, env,
+                            Apply_wrong_label(l', ty_old)))
+            | _, (l', sarg0) :: more_sargs ->
+                if l <> l' && l' <> Nolabel then
+                  raise(Error(sarg0.pexp_loc, env,
+                              Apply_wrong_label(l', ty_fun')))
+                else
+                  ([], more_sargs,
+                   Some (fun () -> type_argument env sarg0 ty ty0))
+            | _ ->
+                assert false
+          end else try
+            let (l', sarg0, sargs, more_sargs) =
+              try
+                let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
+                if sargs1 <> [] then
+                  may_warn sarg0.pexp_loc
+                    (Warnings.Not_principal "commuting this argument");
+                (l', sarg0, sargs1 @ sargs2, more_sargs)
+              with Not_found ->
+                let (l', sarg0, sargs1, sargs2) =
+                  extract_label name more_sargs in
+                if sargs1 <> [] || sargs <> [] then
+                  may_warn sarg0.pexp_loc
+                    (Warnings.Not_principal "commuting this argument");
+                (l', sarg0, sargs @ sargs1, sargs2)
+            in
+            if not optional && is_optional l' then
+              Location.prerr_warning sarg0.pexp_loc
+                (Warnings.Nonoptional_label (Printtyp.string_of_label l));
+            sargs, more_sargs,
+            if not optional || is_optional l' then
+              Some (fun () -> type_argument env sarg0 ty ty0)
+            else begin
+              may_warn sarg0.pexp_loc
+                (Warnings.Not_principal "using an optional argument here");
+              Some (fun () -> option_some (type_argument env sarg0
+                                             (extract_option_type env ty)
+                                             (extract_option_type env ty0)))
+            end
+          with Not_found ->
+            sargs, more_sargs,
+            if optional &&
+              (List.mem_assoc Nolabel sargs
+               || List.mem_assoc Nolabel more_sargs)
+            then begin
+              may_warn funct.exp_loc
+                (Warnings.Without_principality "eliminated optional argument");
+              ignored := (l,ty,lv) :: !ignored;
+              Some (fun () -> option_none (instance env ty) Location.none)
+            end else begin
+              may_warn funct.exp_loc
+                (Warnings.Without_principality "commuted an argument");
+              None
+            end
+        in
+        let omitted =
+          if arg = None then (l,ty,lv) :: omitted else omitted in
+        let ty_old = if sargs = [] then ty_fun else ty_old in
+        type_args ((l,arg)::args) omitted ty_fun ty_fun0
+          ty_old sargs more_sargs
+    | _ ->
+        match sargs with
+          (l, sarg0) :: _ when ignore_labels ->
+            raise(Error(sarg0.pexp_loc, env,
+                        Apply_wrong_label(l, ty_old)))
+        | _ ->
+            type_unknown_args args omitted ty_fun0
+              (sargs @ more_sargs)
+  in
+  let is_ignore funct =
+    match funct.exp_desc with
+      Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) ->
+        (try ignore (filter_arrow env (instance env funct.exp_type) Nolabel);
+             true
+        with Unify _ -> false)
+    | _ -> false
+  in
+  match sargs with
+    (* Special case for ignore: avoid discarding warning *)
+    [Nolabel, sarg] when is_ignore funct ->
+      let ty_arg, ty_res =
+        filter_arrow env (instance env funct.exp_type) Nolabel
+      in
+      let exp = type_expect env sarg ty_arg in
+      begin match (expand_head env exp.exp_type).desc with
+      | Tarrow _ ->
+          Location.prerr_warning exp.exp_loc Warnings.Partial_application
+      | Tvar _ ->
+          add_delayed_check (fun () -> check_application_result env false exp)
+      | _ -> ()
+      end;
+      ([Nolabel, Some exp], ty_res)
+  | _ ->
+      let ty = funct.exp_type in
+      if ignore_labels then
+        type_args [] [] ty (instance env ty) ty [] sargs
+      else
+        type_args [] [] ty (instance env ty) ty sargs []
+
+and type_construct env loc lid sarg ty_expected attrs =
+  let opath =
+    try
+      let (p0, p,_) = extract_concrete_variant env ty_expected in
+      Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+  let constr =
+    wrap_disambiguate "This variant expression is expected to have" ty_expected
+      (Constructor.disambiguate lid env opath) constrs in
+  Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
+  Builtin_attributes.check_deprecated loc constr.cstr_attributes
+    constr.cstr_name;
+  let sargs =
+    match sarg with
+      None -> []
+    | Some {pexp_desc = Pexp_tuple sel} when
+        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
+      -> sel
+    | Some se -> [se] in
+  if List.length sargs <> constr.cstr_arity then
+    raise(Error(loc, env, Constructor_arity_mismatch
+                  (lid.txt, constr.cstr_arity, List.length sargs)));
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
+  let (ty_args, ty_res) = instance_constructor constr in
+  let texp =
+    re {
+      exp_desc = Texp_construct(lid, constr, []);
+      exp_loc = loc; exp_extra = [];
+      exp_type = ty_res;
+      exp_attributes = attrs;
+      exp_env = env } in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    unify_exp env {texp with exp_type = instance_def ty_res}
+                  (instance env ty_expected);
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list env (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance env ty_expected);
+  let recarg =
+    match constr.cstr_inlined with
+    | None -> Rejected
+    | Some _ ->
+        begin match sargs with
+        | [{pexp_desc =
+              Pexp_ident _ |
+              Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
+            Required
+        | _ ->
+            raise (Error(loc, env, Inlined_record_expected))
+        end
+  in
+  let args =
+    List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
+      (List.combine ty_args ty_args0) in
+  if constr.cstr_private = Private then
+    raise(Error(loc, env, Private_type ty_res));
+  (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
+  { texp with
+    exp_desc = Texp_construct(lid, constr, args) }
+
+(* Typing of statements (expressions whose values are discarded) *)
+
+and type_statement env sexp =
+  let loc = (final_subexpression sexp).pexp_loc in
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level then
+      Location.prerr_warning loc Warnings.Nonreturning_statement;
+  if !Clflags.strict_sequence then
+    let expected_ty = instance_def Predef.type_unit in
+    unify_exp env exp expected_ty;
+    exp
+  else begin
+    begin match ty.desc with
+    | Tarrow _ ->
+        Location.prerr_warning loc Warnings.Partial_application
+    | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+    | Tvar _ ->
+        add_delayed_check (fun () -> check_application_result env true exp)
+    | _ ->
+        Location.prerr_warning loc Warnings.Statement_type
+    end;
+    unify_var env tv ty;
+    exp
+  end
+
+(* Typing of match cases *)
+
+and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
+  (* ty_arg is _fully_ generalized *)
+  let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
+  let contains_polyvars = List.exists contains_polymorphic_variant patterns in
+  let erase_either = contains_polyvars && contains_variant_either ty_arg
+  and has_gadts = List.exists (contains_gadt env) patterns in
+(*  prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
+  let ty_arg =
+    if (has_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  and ty_res, env =
+    if has_gadts && not !Clflags.principal then
+      correct_levels ty_res, duplicate_ident_types caselist env
+    else ty_res, env
+  in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let init_env () =
+    (* raise level for existentials *)
+    begin_def ();
+    Ident.set_current_time (get_current_level ());
+    let lev = Ident.current_time () in
+    Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
+    (lev, Env.add_gadt_instance_level lev env)
+  in
+  let lev, env =
+    if has_gadts then init_env () else (get_current_level (), env)
+  in
+(*  if has_gadts then
+    Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
+  (* Do we need to propagate polymorphism *)
+  let propagate =
+    !Clflags.principal || has_gadts || (repr ty_arg).level = generic_level ||
+    match caselist with
+      [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true in
+  if propagate then begin_def (); (* propagation of the argument *)
+  let ty_arg' = newvar () in
+  let pattern_force = ref [] in
+(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
+  let pat_env_list =
+    List.map
+      (fun {pc_lhs; pc_guard; pc_rhs} ->
+        let loc =
+          let open Location in
+          match pc_guard with
+          | None -> pc_rhs.pexp_loc
+          | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
+        in
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
+        let scope = Some (Annot.Idef loc) in
+        let (pat, ext_env, force, unpacks) =
+          let partial =
+            if !Clflags.principal || erase_either
+            then Some false else None in
+          let ty_arg = instance ?partial env ty_arg in
+          type_pattern ~lev env pc_lhs scope ty_arg
+        in
+        pattern_force := force @ !pattern_force;
+        let pat =
+          if !Clflags.principal then begin
+            end_def ();
+            iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
+            { pat with pat_type = instance env pat.pat_type }
+          end else pat
+        in
+        (pat, (ext_env, unpacks)))
+      caselist in
+  (* Unify cases (delayed to keep it order-free) *)
+  let patl = List.map fst pat_env_list in
+  List.iter (fun pat -> unify_pat env pat ty_arg') patl;
+  (* Check for polymorphic variants to close *)
+  if List.exists has_variants patl then begin
+    Parmatch.pressure_variants env patl;
+    List.iter (iter_pattern finalize_variant) patl
+  end;
+  (* `Contaminating' unifications start here *)
+  List.iter (fun f -> f()) !pattern_force;
+  (* Post-processing and generalization *)
+  let unify_pats ty = List.iter (fun pat -> unify_pat env pat ty) patl in
+  if propagate then begin
+    List.iter
+      (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl;
+    unify_pats (instance env ty_arg);
+    end_def ();
+    List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
+  end
+  else if erase_either then unify_pats (instance env ty_arg);
+  (* type bodies *)
+  let in_function = if List.length caselist = 1 then in_function else None in
+  let cases =
+    List.map2
+      (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
+        let sexp = wrap_unpacks pc_rhs unpacks in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true env ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt env pc_lhs then correct_levels ty_res
+          else ty_res in
+(*        Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
+          Printtyp.raw_type_expr ty_res'; *)
+        let guard =
+          match pc_guard with
+          | None -> None
+          | Some scond ->
+              Some
+                (type_expect ext_env (wrap_unpacks scond unpacks)
+                   Predef.type_bool)
+        in
+        let exp = type_expect ?in_function ext_env sexp ty_res' in
+        {
+         c_lhs = pat;
+         c_guard = guard;
+         c_rhs = {exp with exp_type = instance env ty_res'}
+        }
+      )
+      pat_env_list caselist
+  in
+  if !Clflags.principal || has_gadts then begin
+    let ty_res' = instance env ty_res in
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
+  end;
+  let do_init = has_gadts || needs_exhaust_check in
+  let lev, env =
+    if do_init && not has_gadts then init_env () else lev, env in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg
+    else ty_arg
+  in
+  let partial =
+    if partial_flag then
+      check_partial ~lev env ty_arg_check loc cases
+    else
+      Partial
+  in
+  let unused_check () =
+    List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
+      pat_env_list;
+    check_unused ~lev env (instance env ty_arg_check) cases ;
+    Parmatch.check_ambiguous_bindings cases
+  in
+  if contains_polyvars || do_init then
+    add_delayed_check unused_check
+  else
+    unused_check ();
+  (* Check for unused cases, do not delay because of gadts *)
+  if do_init then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance env ty_res) (newvar ()) ;
+  end;
+  cases, partial
+
+(* Typing of let bindings *)
+
+and type_let ?(check = fun s -> Warnings.Unused_var s)
+             ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    env rec_flag spat_sexp_list scope allow =
+  let open Ast_helper in
+  begin_def();
+  if !Clflags.principal then begin_def ();
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [{pvb_expr={pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=_} ->
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_coerce (_, _, sty)
+        | _, Pexp_constraint (_, sty) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            Pat.constraint_
+              ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+              spat
+              sty
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, unpacks) =
+    type_pattern_list env spatl scope nvs allow in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
+    List.iter2
+      (fun pat binding ->
+        let pat =
+          match pat.pat_type.desc with
+          | Tpoly (ty, tl) ->
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
+          | _ -> pat
+        in unify_pat env pat (type_approx env binding.pvb_expr))
+      pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        iter_pattern finalize_variant pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
+  let pat_list =
+    if !Clflags.principal then begin
+      end_def ();
+      List.map
+        (fun pat ->
+          iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
+          {pat with pat_type = instance env pat.pat_type})
+        pat_list
+    end else pat_list in
+  (* Only bind pattern variables after generalizing *)
+  List.iter (fun f -> f()) force;
+  let exp_env =
+    if is_recursive then new_env else env in
+
+  let current_slot = ref None in
+  let rec_needed = ref false in
+  let warn_unused =
+    Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
+    (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))
+  in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = None),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map
+      (fun pat ->
+        if not warn_unused then pat, None
+        else
+          let some_used = ref false in
+            (* has one of the identifier of this pattern been used? *)
+          let slot = ref [] in
+          List.iter
+            (fun id ->
+              let vd = Env.find_value (Path.Pident id) new_env in
+              (* note: Env.find_value does not trigger the value_used event *)
+              let name = Ident.name id in
+              let used = ref false in
+              if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                add_delayed_check
+                  (fun () ->
+                    if not !used then
+                      Location.prerr_warning vd.Types.val_loc
+                        ((if !some_used then check_strict else check) name)
+                  );
+              Env.set_value_used_callback
+                name vd
+                (fun () ->
+                  match !current_slot with
+                  | Some slot ->
+                      slot := (name, vd) :: !slot; rec_needed := true
+                  | None ->
+                      List.iter
+                        (fun (name, vd) -> Env.mark_value_used env name vd)
+                        (get_ref slot);
+                      used := true;
+                      some_used := true
+                )
+            )
+            (Typedtree.pat_bound_idents pat);
+          pat, Some slot
+        )
+      pat_list
+  in
+  let exp_list =
+    List.map2
+      (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
+        let sexp =
+          if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
+        if is_recursive then current_slot := slot;
+        match pat.pat_type.desc with
+        | Tpoly (ty, tl) ->
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
+            let exp =
+              Builtin_attributes.with_warning_attribute pvb_attributes
+                  (fun () -> type_expect exp_env sexp ty')
+            in
+            end_def ();
+            check_univars env true "definition" exp pat.pat_type vars;
+            {exp with exp_type = instance env exp.exp_type}
+        | _ ->
+            Builtin_attributes.with_warning_attribute pvb_attributes (fun () ->
+              type_expect exp_env sexp pat.pat_type))
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
+  if is_recursive && not !rec_needed
+  && Warnings.is_active Warnings.Unused_rec_flag then begin
+    let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
+    (* See PR#6677 *)
+    Builtin_attributes.with_warning_attribute pvb_attributes
+      (fun () ->
+         Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
+      )
+  end;
+  List.iter2
+    (fun pat exp ->
+      ignore(check_partial env pat.pat_type pat.pat_loc [case pat exp]))
+    pat_list exp_list;
+  end_def();
+  List.iter2
+    (fun pat exp ->
+       if not (is_nonexpansive exp) then
+         iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
+    pat_list exp_list;
+  List.iter
+    (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
+    pat_list;
+  let l = List.combine pat_list exp_list in
+  let l =
+    List.map2
+      (fun (p, e) pvb ->
+        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
+         vb_loc=pvb.pvb_loc;
+        })
+      l spat_sexp_list
+  in
+  (l, new_env, unpacks)
+
+(* Typing of toplevel bindings *)
+
+let type_binding env rec_flag spat_sexp_list scope =
+  Typetexp.reset_type_variables();
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      env rec_flag spat_sexp_list scope false
+  in
+  (pat_exp_list, new_env)
+
+let type_let env rec_flag spat_sexp_list scope =
+  let (pat_exp_list, new_env, _unpacks) =
+    type_let env rec_flag spat_sexp_list scope false in
+  (pat_exp_list, new_env)
+
+(* Typing of toplevel expressions *)
+
+let type_expression env sexp =
+  Typetexp.reset_type_variables();
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type;
+  generalize exp.exp_type;
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (_path, desc) = Env.lookup_value lid.txt env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
+
+(* Error report *)
+
+let spellcheck ppf unbound_name valid_names =
+  Misc.did_you_mean ppf (fun () ->
+    Misc.spellcheck valid_names unbound_name
+  )
+
+let spellcheck_idents ppf unbound valid_idents =
+  spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)
+
+open Format
+open Printtyp
+
+let report_error env ppf = function
+  | Polymorphic_label lid ->
+      fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
+        longident lid "You cannot instantiate it in a pattern."
+  | Constructor_arity_mismatch(lid, expected, provided) ->
+      fprintf ppf
+       "@[The constructor %a@ expects %i argument(s),@ \
+        but is applied here to %i argument(s)@]"
+       longident lid expected provided
+  | Label_mismatch(lid, trace) ->
+      report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type")
+  | Pattern_type_clash trace ->
+      report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "This pattern matches values of type")
+        (function ppf ->
+          fprintf ppf "but a pattern was expected which matches values of type")
+  | Or_pattern_type_clash (id, trace) ->
+      report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "The variable %s on the left-hand side of this \
+                       or-pattern has type" (Ident.name id))
+        (function ppf ->
+          fprintf ppf "but on the right-hand side it has type")
+  | Multiply_bound_variable name ->
+      fprintf ppf "Variable %s is bound several times in this matching" name
+  | Orpat_vars (id, valid_idents) ->
+      fprintf ppf "Variable %s must occur on both sides of this | pattern"
+        (Ident.name id);
+      spellcheck_idents ppf id valid_idents
+  | Expr_type_clash trace ->
+      report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This expression has type")
+        (function ppf ->
+           fprintf ppf "but an expression was expected of type")
+  | Apply_non_function typ ->
+      reset_and_mark_loops typ;
+      begin match (repr typ).desc with
+        Tarrow _ ->
+          fprintf ppf "@[@[<2>This function has type@ %a@]"
+            type_expr typ;
+          fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]"
+                      "maybe you forgot a `;'."
+      | _ ->
+          fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]"
+            type_expr typ
+            "This is not a function; it cannot be applied."
+      end
+  | Apply_wrong_label (l, ty) ->
+      let print_label ppf = function
+        | Nolabel -> fprintf ppf "without label"
+        | l ->
+            fprintf ppf "with label %s" (prefixed_label_name l)
+      in
+      reset_and_mark_loops ty;
+      fprintf ppf
+        "@[@[<2>The function applied to this argument has type@ %a@]@.\
+          This argument cannot be applied %a@]"
+        type_expr ty print_label l
+  | Label_multiply_defined s ->
+      fprintf ppf "The record field label %s is defined several times" s
+  | Label_missing labels ->
+      let print_labels ppf =
+        List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+      fprintf ppf "@[Some record fields are undefined:%a@]"
+        print_labels labels
+  | Label_not_mutable lid ->
+      fprintf ppf "The record field %a is not mutable" longident lid
+  | Wrong_name (eorp, ty, kind, p, name, valid_names) ->
+      reset_and_mark_loops ty;
+      if Path.is_constructor_typath p then begin
+        fprintf ppf "@[The field %s is not part of the record \
+                     argument for the %a constructor@]"
+          name
+          path p;
+      end else begin
+      fprintf ppf "@[@[<2>%s type@ %a@]@ "
+        eorp type_expr ty;
+      fprintf ppf "The %s %s does not belong to type %a@]"
+        (label_of_kind kind)
+        name (*kind*) path p;
+       end;
+      spellcheck ppf name valid_names;
+  | Name_type_mismatch (kind, lid, tp, tpl) ->
+      let name = label_of_kind kind in
+      report_ambiguous_type_error ppf env tp tpl
+        (function ppf ->
+           fprintf ppf "The %s %a@ belongs to the %s type"
+             name longident lid kind)
+        (function ppf ->
+           fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+             name longident lid kind)
+        (function ppf ->
+           fprintf ppf "but a %s was expected belonging to the %s type"
+             name kind)
+  | Invalid_format msg ->
+      fprintf ppf "%s" msg
+  | Undefined_method (ty, me, valid_methods) ->
+      reset_and_mark_loops ty;
+      fprintf ppf
+        "@[@[This expression has type@;<1 2>%a@]@,\
+         It has no method %s@]" type_expr ty me;
+      begin match valid_methods with
+        | None -> ()
+        | Some valid_methods -> spellcheck ppf me valid_methods
+      end
+  | Undefined_inherited_method (me, valid_methods) ->
+      fprintf ppf "This expression has no method %s" me;
+      spellcheck ppf me valid_methods;
+  | Virtual_class cl ->
+      fprintf ppf "Cannot instantiate the virtual class %a"
+        longident cl
+  | Unbound_instance_variable (var, valid_vars) ->
+      fprintf ppf "Unbound instance variable %s" var;
+      spellcheck ppf var valid_vars;
+  | Instance_variable_not_mutable (b, v) ->
+      if b then
+        fprintf ppf "The instance variable %s is not mutable" v
+      else
+        fprintf ppf "The value %s is not an instance variable" v
+  | Not_subtype(tr1, tr2) ->
+      report_subtyping_error ppf env tr1 "is not a subtype of" tr2
+  | Outside_class ->
+      fprintf ppf "This object duplication occurs outside a method definition"
+  | Value_multiply_overridden v ->
+      fprintf ppf "The instance variable %s is overridden several times" v
+  | Coercion_failure (ty, ty', trace, b) ->
+      report_unification_error ppf env trace
+        (function ppf ->
+           let ty, ty' = prepare_expansion (ty, ty') in
+           fprintf ppf
+             "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
+           (type_expansion ty) ty')
+        (function ppf ->
+           fprintf ppf "but is here used with type");
+      if b then
+        fprintf ppf ".@.@[%s@ %s@]"
+          "This simple coercion was not fully general."
+          "Consider using a double coercion."
+  | Too_many_arguments (in_function, ty) ->
+      reset_and_mark_loops ty;
+      if in_function then begin
+        fprintf ppf "This function expects too many arguments,@ ";
+        fprintf ppf "it should have type@ %a"
+          type_expr ty
+      end else begin
+        fprintf ppf "This expression should not be a function,@ ";
+        fprintf ppf "the expected type is@ %a"
+          type_expr ty
+      end
+  | Abstract_wrong_label (l, ty) ->
+      let label_mark = function
+        | Nolabel -> "but its first argument is not labelled"
+        | l -> sprintf "but its first argument is labelled %s"
+                       (prefixed_label_name l) in
+      reset_and_mark_loops ty;
+      fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]"
+      type_expr ty (label_mark l)
+  | Scoping_let_module(id, ty) ->
+      reset_and_mark_loops ty;
+      fprintf ppf
+       "This `let module' expression has type@ %a@ " type_expr ty;
+      fprintf ppf
+       "In this type, the locally bound module name %s escapes its scope" id
+  | Masked_instance_variable lid ->
+      fprintf ppf
+        "The instance variable %a@ \
+         cannot be accessed from the definition of another instance variable"
+        longident lid
+  | Private_type ty ->
+      fprintf ppf "Cannot create values of the private type %a" type_expr ty
+  | Private_label (lid, ty) ->
+      fprintf ppf "Cannot assign field %a of the private type %a"
+        longident lid type_expr ty
+  | Not_a_variant_type lid ->
+      fprintf ppf "The type %a@ is not a variant type" longident lid
+  | Incoherent_label_order ->
+      fprintf ppf "This function is applied to arguments@ ";
+      fprintf ppf "in an order different from other calls.@ ";
+      fprintf ppf "This is only allowed when the real type is known."
+  | Less_general (kind, trace) ->
+      report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "This %s has type" kind)
+        (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      fprintf ppf "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      fprintf ppf
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is packed module, but the expected type is@ %a"
+        type_expr ty
+  | Recursive_local_constraint trace ->
+      report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "Recursive local constraint when unifying")
+        (function ppf ->
+           fprintf ppf "with")
+  | Unexpected_existential ->
+      fprintf ppf
+        "Unexpected existential"
+  | Unqualified_gadt_pattern (tpath, name) ->
+      fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
+        name path tpath
+        "must be qualified in this pattern"
+  | Invalid_interval ->
+      fprintf ppf "@[Only character intervals are supported in patterns.@]"
+  | Invalid_for_loop_index ->
+      fprintf ppf
+        "@[Invalid for-loop index: only variables and _ are allowed.@]"
+  | No_value_clauses ->
+      fprintf ppf
+        "None of the patterns in this 'match' expression match values."
+  | Exception_pattern_below_toplevel ->
+      fprintf ppf
+        "@[Exception patterns must be at the top level of a match case.@]"
+  | Inlined_record_escape ->
+      fprintf ppf
+        "@[This form is not allowed as the type of the inlined record could \
+         escape.@]"
+  | Inlined_record_expected ->
+      fprintf ppf
+        "@[This constructor expects an inlined record argument.@]"
+  | Unrefuted_pattern pat ->
+      fprintf ppf
+        "@[%s@ %s@ %a@]"
+        "This match case could not be refuted."
+        "Here is an example of a value that would reach it:"
+        Parmatch.top_pretty pat
+  | Invalid_extension_constructor_payload ->
+      fprintf ppf
+        "Invalid [%%extension_constructor] payload, a constructor is expected."
+  | Not_an_extension_constructor ->
+      fprintf ppf
+        "This constructor is not an extension constructor."
+  | Literal_overflow ty ->
+      fprintf ppf "Integer literal exceeds the range of representable \
+                   integers of type %s" ty
+  | Unknown_literal (n, m) ->
+      fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m
+
+
+let report_error env ppf err =
+  wrap_printing_env env (fun () -> report_error env ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
+
+let () =
+  Env.add_delayed_check_forward := add_delayed_check
+
+(* drop ?recarg argument from the external API *)
+let type_expect ?in_function env e ty = type_expect ?in_function env e ty
+let type_exp env e = type_exp env e
+let type_argument env e t1 t2 = type_argument env e t1 t2
diff --git a/typing/typecore.mli b/typing/typecore.mli
new file mode 100644
index 00000000..7b64ee34
--- /dev/null
+++ b/typing/typecore.mli
@@ -0,0 +1,152 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Type inference for the core language *)
+
+open Asttypes
+open Types
+open Format
+
+val is_nonexpansive: Typedtree.expression -> bool
+
+val type_binding:
+        Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Annot.ident option ->
+          Typedtree.value_binding list * Env.t
+val type_let:
+        Env.t -> rec_flag ->
+          Parsetree.value_binding list ->
+          Annot.ident option ->
+          Typedtree.value_binding list * Env.t
+val type_expression:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_class_arg_pattern:
+        string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
+        Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list *
+        Env.t * Env.t
+val type_self_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 * Asttypes.virtual_flag * type_expr)
+            Vars.t ref *
+        Env.t * Env.t * Env.t
+val check_partial:
+        ?lev:int -> Env.t -> type_expr ->
+        Location.t -> Typedtree.case list -> Typedtree.partial
+val type_expect:
+        ?in_function:(Location.t * type_expr) ->
+        Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
+val type_exp:
+        Env.t -> Parsetree.expression -> Typedtree.expression
+val type_approx:
+        Env.t -> Parsetree.expression -> type_expr
+val type_argument:
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
+
+val option_some: Typedtree.expression -> Typedtree.expression
+val option_none: type_expr -> Location.t -> Typedtree.expression
+val extract_option_type: Env.t -> type_expr -> type_expr
+val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
+val generalizable: int -> type_expr -> bool
+val reset_delayed_checks: unit -> unit
+val force_delayed_checks: unit -> unit
+
+val name_pattern : string -> Typedtree.case list -> Ident.t
+
+val self_coercion : (Path.t * Location.t list ref) list ref
+
+type error =
+    Polymorphic_label of Longident.t
+  | Constructor_arity_mismatch of Longident.t * int * int
+  | Label_mismatch of Longident.t * (type_expr * type_expr) list
+  | Pattern_type_clash of (type_expr * type_expr) list
+  | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
+  | Multiply_bound_variable of string
+  | Orpat_vars of Ident.t * Ident.t list
+  | Expr_type_clash of (type_expr * type_expr) list
+  | Apply_non_function of type_expr
+  | Apply_wrong_label of arg_label * type_expr
+  | Label_multiply_defined of string
+  | Label_missing of Ident.t list
+  | Label_not_mutable of Longident.t
+  | Wrong_name of string * type_expr * string * Path.t * string * string list
+  | Name_type_mismatch of
+      string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
+  | Invalid_format of string
+  | Undefined_method of type_expr * string * string list option
+  | Undefined_inherited_method of string * string list
+  | Virtual_class of Longident.t
+  | Private_type of type_expr
+  | Private_label of Longident.t * type_expr
+  | Unbound_instance_variable of string * string list
+  | Instance_variable_not_mutable of bool * string
+  | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
+  | Outside_class
+  | Value_multiply_overridden of string
+  | Coercion_failure of
+      type_expr * type_expr * (type_expr * type_expr) list * bool
+  | Too_many_arguments of bool * type_expr
+  | Abstract_wrong_label of arg_label * type_expr
+  | Scoping_let_module of string * type_expr
+  | Masked_instance_variable of Longident.t
+  | Not_a_variant_type of Longident.t
+  | Incoherent_label_order
+  | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Recursive_local_constraint of (type_expr * type_expr) list
+  | Unexpected_existential
+  | Unqualified_gadt_pattern of Path.t * string
+  | Invalid_interval
+  | Invalid_for_loop_index
+  | No_value_clauses
+  | Exception_pattern_below_toplevel
+  | Inlined_record_escape
+  | Inlined_record_expected
+  | Unrefuted_pattern of Typedtree.pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
+  | Literal_overflow of string
+  | Unknown_literal of string * char
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: Env.t -> formatter -> error -> unit
+ (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
+
+(* 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 Typemod.type_open *)
+val type_open:
+    (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t)
+    ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * Types.class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
+  Typedtree.module_expr * type_expr list) ref
+
+val create_package_type : Location.t -> Env.t ->
+  Longident.t * (Longident.t * Parsetree.core_type) list ->
+  Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr
+
+val constant: Parsetree.constant -> (Asttypes.constant, error) result
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
new file mode 100644
index 00000000..4872da67
--- /dev/null
+++ b/typing/typedecl.ml
@@ -0,0 +1,2118 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*  Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**** Typing of type definitions ****)
+
+open Misc
+open Asttypes
+open Parsetree
+open Primitive
+open Types
+open Typetexp
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch list
+  | Constraint_failed of type_expr * type_expr
+  | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
+  | Type_clash of Env.t * (type_expr * type_expr) list
+  | Parameters_differ of Path.t * type_expr * type_expr
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Not_open_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch list
+  | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool)
+  | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Varying_anonymous
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Bad_immediate_attribute
+  | Bad_unboxed_attribute of string
+  | Wrong_unboxed_type_float
+  | Boxed_and_unboxed
+
+open Typedtree
+
+exception Error of Location.t * error
+
+(* Note: do not factor the branches in the following pattern-matching:
+   the records must be constants for the compiler to do sharing on them.
+*)
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed, !Clflags.unboxed_types with
+  | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false, _ -> unboxed_false_default_false
+  | false, true, _ -> unboxed_true_default_false
+  | false, false, false -> unboxed_false_default_true
+  | false, false, true -> unboxed_true_default_true
+
+(* Enter all declared types in the environment as abstract types *)
+
+let enter_type rec_flag env sdecl id =
+  let needed =
+    match rec_flag with
+    | Asttypes.Nonrecursive -> Btype.is_row_name (Ident.name id)
+    | Asttypes.Recursive -> true
+  in
+  if not needed then env else
+  let decl =
+    { type_params =
+        List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
+      type_arity = List.length sdecl.ptype_params;
+      type_kind = Type_abstract;
+      type_private = sdecl.ptype_private;
+      type_manifest =
+        begin match sdecl.ptype_manifest with None -> None
+        | Some _ -> Some(Ctype.newvar ()) end;
+      type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = false;
+      type_unboxed = unboxed_false_default_false;
+    }
+  in
+  Env.add_type ~check:true id decl env
+
+let update_type temp_env env id loc =
+  let path = Path.Pident id in
+  let decl = Env.find_type path temp_env in
+  match decl.type_manifest with None -> ()
+  | Some ty ->
+      let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+      try Ctype.unify env (Ctype.newconstr path params) ty
+      with Ctype.Unify trace ->
+        raise (Error(loc, Type_clash (env, trace)))
+
+(* We use the Ctype.expand_head_opt version of expand_head to get access
+   to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then None else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> Some ty
+    | {type_unboxed = {unboxed = false}} -> Some ty
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], _)
+       | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
+       | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
+
+         -> get_unboxed_type_representation env
+             (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | {type_kind=Type_abstract} -> None
+          (* This case can occur when checking a recursive unboxed type
+             declaration. *)
+    | _ -> assert false (* only the above can be unboxed *)
+    end
+  | _ -> Some ty
+
+let get_unboxed_type_representation env ty =
+  (* Do not give too much fuel: PR#7424 *)
+  get_unboxed_type_representation env ty 100
+;;
+
+(* Determine if a type's values are represented by floats at run-time. *)
+let is_float env ty =
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
+  | _ -> false
+
+(* Determine if a type definition defines a fixed type. (PW) *)
+let is_fixed_type sd =
+  let rec has_row_var sty =
+    match sty.ptyp_desc with
+      Ptyp_alias (sty, _) -> has_row_var sty
+    | Ptyp_class _
+    | Ptyp_object (_, Open)
+    | Ptyp_variant (_, Open, _)
+    | Ptyp_variant (_, Closed, Some _) -> true
+    | _ -> false
+  in
+  match sd.ptype_manifest with
+    None -> false
+  | Some sty ->
+      sd.ptype_kind = Ptype_abstract &&
+      sd.ptype_private = Private &&
+      has_row_var sty
+
+(* Set the row variable in a fixed type *)
+let set_fixed_row env loc p decl =
+  let tm =
+    match decl.type_manifest with
+      None -> assert false
+    | Some t -> Ctype.expand_head env t
+  in
+  let rv =
+    match tm.desc with
+      Tvariant row ->
+        let row = Btype.row_repr row in
+        tm.desc <- Tvariant {row with row_fixed = true};
+        if Btype.static_row row then Btype.newgenty Tnil
+        else row.row_more
+    | Tobject (ty, _) ->
+        snd (Ctype.flatten_fields ty)
+    | _ ->
+        raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+  in
+  if not (Btype.is_Tvar rv) then
+    raise (Error (loc, Bad_fixed_type "has no row variable"));
+  rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
+
+(* Translate one type declaration *)
+
+module StringSet =
+  Set.Make(struct
+    type t = string
+    let compare (x:t) y = compare x y
+  end)
+
+let make_params env params =
+  let make_param (sty, v) =
+    try
+      (transl_type_param env sty, v)
+    with Already_bound ->
+      raise(Error(sty.ptyp_loc, Repeated_parameter))
+  in
+    List.map make_param params
+
+let transl_labels env closed lbls =
+  assert (lbls <> []);
+  let all_labels = ref StringSet.empty in
+  List.iter
+    (fun {pld_name = {txt=name; loc}} ->
+       if StringSet.mem name !all_labels then
+         raise(Error(loc, Duplicate_label name));
+       all_labels := StringSet.add name !all_labels)
+    lbls;
+  let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
+          pld_attributes=attrs} =
+    let arg = Ast_helper.Typ.force_poly arg in
+    let cty = transl_simple_type env closed arg in
+    {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut;
+     ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+  in
+  let lbls = List.map mk lbls in
+  let lbls' =
+    List.map
+      (fun ld ->
+         let ty = ld.ld_type.ctyp_type in
+         let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
+         {Types.ld_id = ld.ld_id;
+          ld_mutable = ld.ld_mutable;
+          ld_type = ty;
+          ld_loc = ld.ld_loc;
+          ld_attributes = ld.ld_attributes
+         }
+      )
+      lbls in
+  lbls, lbls'
+
+let transl_constructor_arguments env closed = function
+  | Pcstr_tuple l ->
+      let l = List.map (transl_simple_type env closed) l in
+      Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
+      Cstr_tuple l
+  | Pcstr_record l ->
+      let lbls, lbls' = transl_labels env closed l in
+      Types.Cstr_record lbls',
+      Cstr_record lbls
+
+let make_constructor env type_path type_params sargs sret_type =
+  match sret_type with
+  | None ->
+      let args, targs =
+        transl_constructor_arguments env true sargs
+      in
+        targs, None, args, None
+  | Some sret_type ->
+      (* if it's a generalized constructor we must first narrow and
+         then widen so as to not introduce any new constraints *)
+      let z = narrow () in
+      reset_type_variables ();
+      let args, targs =
+        transl_constructor_arguments env false sargs
+      in
+      let tret_type = transl_simple_type env false sret_type in
+      let ret_type = tret_type.ctyp_type in
+      begin
+        match (Ctype.repr ret_type).desc with
+          Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | _ ->
+            raise (Error (sret_type.ptyp_loc, Constraint_failed
+                            (ret_type, Ctype.newconstr type_path type_params)))
+      end;
+      widen z;
+      targs, Some tret_type, args, Some ret_type
+
+(* Check that the variable [id] is present in the [univ] list. *)
+let check_type_var loc univ id =
+  let f t = (Btype.repr t).id = id in
+  if not (List.exists f univ) then raise (Error (loc, Wrong_unboxed_type_float))
+
+(* Check that all the variables found in [ty] are in [univ].
+   Because [ty] is the argument to an abstract type, the representation
+   of that abstract type could be any subexpression of [ty], in particular
+   any type variable present in [ty].
+*)
+let rec check_unboxed_abstract_arg loc univ ty =
+  match ty.desc with
+  | Tvar _ -> check_type_var loc univ ty.id
+  | Tarrow (_, t1, t2, _)
+  | Tfield (_, _, t1, t2) ->
+    check_unboxed_abstract_arg loc univ t1;
+    check_unboxed_abstract_arg loc univ t2
+  | Ttuple args
+  | Tconstr (_, args, _)
+  | Tpackage (_, _, args) ->
+    List.iter (check_unboxed_abstract_arg loc univ) args
+  | Tobject (fields, r) ->
+    check_unboxed_abstract_arg loc univ fields;
+    begin match !r with
+    | None -> ()
+    | Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
+    end
+  | Tnil
+  | Tunivar _ -> ()
+  | Tlink e -> check_unboxed_abstract_arg loc univ e
+  | Tsubst _ -> assert false
+  | Tvariant { row_fields; row_more; row_name } ->
+    List.iter (check_unboxed_abstract_row_field loc univ) row_fields;
+    check_unboxed_abstract_arg loc univ row_more;
+    begin match row_name with
+    | None -> ()
+    | Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
+    end
+  | Tpoly (t, _) -> check_unboxed_abstract_arg loc univ t
+
+and check_unboxed_abstract_row_field loc univ (_, field) =
+  match field with
+  | Rpresent (Some ty) -> check_unboxed_abstract_arg loc univ ty
+  | Reither (_, args, _, r) ->
+    List.iter (check_unboxed_abstract_arg loc univ) args;
+    begin match !r with
+    | None -> ()
+    | Some f -> check_unboxed_abstract_row_field loc univ ("", f)
+    end
+  | Rabsent
+  | Rpresent None -> ()
+
+(* Check that the argument to a GADT constructor is compatible with unboxing
+   the type, given the universal parameters of the type. *)
+let rec check_unboxed_gadt_arg loc univ env ty =
+  match get_unboxed_type_representation env ty with
+  | Some {desc = Tvar _; id} -> check_type_var loc univ id
+  | Some {desc = Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil
+                 | Tvariant _; _} ->
+    ()
+    (* A comment in [Translcore.transl_exp0] claims the above cannot be
+       represented by floats. *)
+  | Some {desc = Tconstr (p, args, _); _} ->
+    let tydecl = Env.find_type p env in
+    assert (not tydecl.type_unboxed.unboxed);
+    if tydecl.type_kind = Type_abstract then
+      List.iter (check_unboxed_abstract_arg loc univ) args
+  | Some {desc = Tfield _ | Tlink _ | Tsubst _; _} -> assert false
+  | Some {desc = Tunivar _; _} -> ()
+  | Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc univ env t2
+  | None -> ()
+      (* This case is tricky: the argument is another (or the same) type
+         in the same recursive definition. In this case we don't have to
+         check because we will also check that other type for correctness. *)
+
+let transl_declaration env sdecl id =
+  (* Bind type parameters *)
+  reset_type_variables();
+  Ctype.begin_def ();
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let cstrs = List.map
+    (fun (sty, sty', loc) ->
+      transl_simple_type env false sty,
+      transl_simple_type env false sty', loc)
+    sdecl.ptype_cstrs
+  in
+  let raw_status = get_unboxed_from_attributes sdecl in
+  if raw_status.unboxed && not raw_status.default then begin
+    match sdecl.ptype_kind with
+    | Ptype_abstract ->
+        raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                      "it is abstract"))
+    | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has no argument"))
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] -> ()
+    | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has more than one argument"))
+    | Ptype_variant [{pcd_args = Pcstr_record
+                        [{pld_mutable=Immutable; _}]; _}] -> ()
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable"))
+    | Ptype_variant [{pcd_args = Pcstr_record _; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has more than one argument"))
+    | Ptype_variant _ ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it has more than one constructor"))
+    | Ptype_record [{pld_mutable=Immutable; _}] -> ()
+    | Ptype_record [{pld_mutable=Mutable; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it is mutable"))
+    | Ptype_record _ ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it has more than one field"))
+    | Ptype_open ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "extensible variant types cannot be unboxed"))
+  end;
+  let unboxed_status =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+      | Ptype_variant [{pcd_args = Pcstr_record
+                          [{pld_mutable = Immutable; _}]; _}]
+      | Ptype_record [{pld_mutable = Immutable; _}] ->
+    raw_status
+    | _ -> (* The type is not unboxable, mark it as boxed *)
+      unboxed_false_default_false
+  in
+  let unbox = unboxed_status.unboxed in
+  let (tkind, kind) =
+    match sdecl.ptype_kind with
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_variant scstrs ->
+        assert (scstrs <> []);
+        let all_constrs = ref StringSet.empty in
+        List.iter
+          (fun {pcd_name = {txt = name}} ->
+            if StringSet.mem name !all_constrs then
+              raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
+            all_constrs := StringSet.add name !all_constrs)
+          scstrs;
+        if List.length
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
+          raise(Error(sdecl.ptype_loc, Too_many_constructors));
+        let make_cstr scstr =
+          let name = Ident.create scstr.pcd_name.txt in
+          let targs, tret_type, args, ret_type =
+            make_constructor env (Path.Pident id) params
+                             scstr.pcd_args scstr.pcd_res
+          in
+          if unbox then begin
+            (* Cannot unbox a type when the argument can be both float and
+               non-float because it interferes with the dynamic float array
+               optimization. This can only happen when the type is a GADT
+               and the argument is an existential type variable or an
+               unboxed (or abstract) type constructor applied to some
+               existential type variable. Of course we also have to rule
+               out any abstract type constructor applied to anything that
+               might be an existential type variable.
+               There is a difficulty with existential variables created
+               out of thin air (rather than bound by the declaration).
+               See PR#7511 and GPR#1133 for details. *)
+            match Datarepr.constructor_existentials args ret_type with
+            | _, [] -> ()
+            | [argty], _ex ->
+                check_unboxed_gadt_arg sdecl.ptype_loc params env argty
+            | _ -> assert false
+          end;
+          let tcstr =
+            { cd_id = name;
+              cd_name = scstr.pcd_name;
+              cd_args = targs;
+              cd_res = tret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+          let cstr =
+            { Types.cd_id = name;
+              cd_args = args;
+              cd_res = ret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+            tcstr, cstr
+        in
+        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+          Ttype_variant tcstrs, Type_variant cstrs
+      | Ptype_record lbls ->
+          let lbls, lbls' = transl_labels env true lbls in
+          let rep =
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            then Record_float
+            else Record_regular
+          in
+          Ttype_record lbls, Type_record(lbls', rep)
+      | Ptype_open -> Ttype_open, Type_open
+      in
+    let (tman, man) = match sdecl.ptype_manifest with
+        None -> None, None
+      | Some sty ->
+        let no_row = not (is_fixed_type sdecl) in
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+    in
+    let decl =
+      { type_params = params;
+        type_arity = List.length params;
+        type_kind = kind;
+        type_private = sdecl.ptype_private;
+        type_manifest = man;
+        type_variance = List.map (fun _ -> Variance.full) params;
+        type_newtype_level = None;
+        type_loc = sdecl.ptype_loc;
+        type_attributes = sdecl.ptype_attributes;
+        type_immediate = false;
+        type_unboxed = unboxed_status;
+      } in
+
+  (* Check constraints *)
+    List.iter
+      (fun (cty, cty', loc) ->
+        let ty = cty.ctyp_type in
+        let ty' = cty'.ctyp_type in
+        try Ctype.unify env ty ty' with Ctype.Unify tr ->
+          raise(Error(loc, Inconsistent_constraint (env, tr))))
+      cstrs;
+    Ctype.end_def ();
+  (* Add abstract row *)
+    if is_fixed_type sdecl then begin
+      let p =
+        try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
+        with Not_found -> assert false in
+      set_fixed_row env sdecl.ptype_loc p decl
+    end;
+  (* Check for cyclic abbreviations *)
+    begin match decl.type_manifest with None -> ()
+      | Some ty ->
+        if Ctype.cyclic_abbrev env id ty then
+          raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt));
+    end;
+    {
+      typ_id = id;
+      typ_name = sdecl.ptype_name;
+      typ_params = tparams;
+      typ_type = decl;
+      typ_cstrs = cstrs;
+      typ_loc = sdecl.ptype_loc;
+      typ_manifest = tman;
+      typ_kind = tkind;
+      typ_private = sdecl.ptype_private;
+      typ_attributes = sdecl.ptype_attributes;
+    }
+
+(* Generalize a type declaration *)
+
+let generalize_decl decl =
+  List.iter Ctype.generalize decl.type_params;
+  Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
+  begin match decl.type_manifest with
+  | None    -> ()
+  | Some ty -> Ctype.generalize ty
+  end
+
+(* Check that all constraints are enforced *)
+
+module TypeSet = Btype.TypeSet
+module TypeMap = Btype.TypeMap
+
+let rec check_constraints_rec env loc visited ty =
+  let ty = Ctype.repr ty in
+  if TypeSet.mem ty !visited then () else begin
+  visited := TypeSet.add ty !visited;
+  match ty.desc with
+  | Tconstr (path, args, _) ->
+      let args' = List.map (fun _ -> Ctype.newvar ()) args in
+      let ty' = Ctype.newconstr path args' in
+      begin try Ctype.enforce_constraints env ty'
+      with Ctype.Unify _ -> assert false
+      | Not_found -> raise (Error(loc, Unavailable_type_constructor path))
+      end;
+      if not (Ctype.matches env ty ty') then
+        raise (Error(loc, Constraint_failed (ty, ty')));
+      List.iter (check_constraints_rec env loc visited) args
+  | Tpoly (ty, tl) ->
+      let _, ty = Ctype.instance_poly false tl ty in
+      check_constraints_rec env loc visited ty
+  | _ ->
+      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+  end
+
+module SMap = Map.Make(String)
+
+let check_constraints_labels env visited l pl =
+  let rec get_loc name = function
+      [] -> assert false
+    | pld :: tl ->
+        if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
+        else get_loc name tl
+  in
+  List.iter
+    (fun {Types.ld_id=name; ld_type=ty} ->
+       check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
+    l
+
+let check_constraints env sdecl (_, decl) =
+  let visited = ref TypeSet.empty in
+  begin match decl.type_kind with
+  | Type_abstract -> ()
+  | Type_variant l ->
+      let find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      let pl_index =
+        let foldf acc x =
+          SMap.add x.pcd_name.txt x acc
+        in
+        List.fold_left foldf SMap.empty pl
+      in
+      List.iter
+        (fun {Types.cd_id=name; cd_args; cd_res} ->
+          let {pcd_args; pcd_res; _} =
+            try SMap.find (Ident.name name) pl_index
+            with Not_found -> assert false in
+          begin match cd_args, pcd_args with
+          | Cstr_tuple tyl, Pcstr_tuple styl ->
+              List.iter2
+                (fun sty ty ->
+                   check_constraints_rec env sty.ptyp_loc visited ty)
+                styl tyl
+          | Cstr_record tyl, Pcstr_record styl ->
+              check_constraints_labels env visited tyl styl
+          | _ -> assert false
+          end;
+          match pcd_res, cd_res with
+          | Some sr, Some r ->
+              check_constraints_rec env sr.ptyp_loc visited r
+          | _ ->
+              () )
+        l
+  | Type_record (l, _) ->
+      let find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
+      in
+      let pl = find_pl sdecl.ptype_kind in
+      check_constraints_labels env visited l pl
+  | Type_open -> ()
+  end;
+  begin match decl.type_manifest with
+  | None -> ()
+  | Some ty ->
+      let sty =
+        match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
+      in
+      check_constraints_rec env sty.ptyp_loc visited ty
+  end
+
+(*
+   If both a variant/record definition and a type equation are given,
+   need to check that the equation refers to a type of the same kind
+   with the same constructors and labels.
+*)
+let check_coherence env loc id decl =
+  match decl with
+    { type_kind = (Type_variant _ | Type_record _| Type_open);
+      type_manifest = Some ty } ->
+      begin match (Ctype.repr ty).desc with
+        Tconstr(path, args, _) ->
+          begin try
+            let decl' = Env.find_type path env in
+            let err =
+              if List.length args <> List.length decl.type_params
+              then [Includecore.Arity]
+              else if not (Ctype.equal env false args decl.type_params)
+              then [Includecore.Constraint]
+              else
+                Includecore.type_declarations ~equality:true env
+                  (Path.last path)
+                  decl'
+                  id
+                  (Subst.type_declaration
+                     (Subst.add_type id path Subst.identity) decl)
+            in
+            if err <> [] then
+              raise(Error(loc, Definition_mismatch (ty, err)))
+          with Not_found ->
+            raise(Error(loc, Unavailable_type_constructor path))
+          end
+      | _ -> raise(Error(loc, Definition_mismatch (ty, [])))
+      end
+  | _ -> ()
+
+let check_abbrev env sdecl (id, decl) =
+  check_coherence env sdecl.ptype_loc id decl
+
+(* Check that recursion is well-founded *)
+
+let check_well_founded env loc path to_check ty =
+  let visited = ref TypeMap.empty in
+  let rec check ty0 parents ty =
+    let ty = Btype.repr ty in
+    if TypeSet.mem ty parents then begin
+      (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
+      if match ty0.desc with
+      | Tconstr (p, _, _) -> Path.same p path
+      | _ -> false
+      then raise (Error (loc, Recursive_abbrev (Path.name path)))
+      else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
+    end;
+    let (fini, parents) =
+      try
+        let prev = TypeMap.find ty !visited in
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
+      with Not_found ->
+        (false, parents)
+    in
+    if fini then () else
+    let rec_ok =
+      match ty.desc with
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then may raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
+          let ty' = Ctype.try_expand_once_opt env ty in
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> may raise arg_exn
+        end
+    | _ -> may raise arg_exn
+  in
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Unify _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
+
+let check_well_founded_manifest env loc path decl =
+  if decl.type_manifest = None then () else
+  let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
+  check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)
+
+let check_well_founded_decl env loc path decl to_check =
+  let open Btype in
+  let it =
+    {type_iterators with
+     it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
+  it.it_type_declaration it (Ctype.instance_declaration decl)
+
+(* Check for ill-defined abbrevs *)
+
+let check_recursion env loc path decl to_check =
+  (* to_check is true for potentially mutually recursive paths.
+     (path, decl) is the type declaration to be checked. *)
+
+  if decl.type_params = [] then () else
+
+  let visited = ref [] in
+
+  let rec check_regular cpath args prev_exp ty =
+    let ty = Ctype.repr ty in
+    if not (List.memq ty !visited) then begin
+      visited := ty :: !visited;
+      match ty.desc with
+      | Tconstr(path', args', _) ->
+          if Path.same path path' then begin
+            if not (Ctype.equal env false args args') then
+              raise (Error(loc,
+                     Parameters_differ(cpath, ty, Ctype.newconstr path args)))
+          end
+          (* Attempt to expand a type abbreviation if:
+              1- [to_check path'] holds
+                 (otherwise the expansion cannot involve [path]);
+              2- we haven't expanded this type constructor before
+                 (otherwise we could loop if [path'] is itself
+                 a non-regular abbreviation). *)
+          else if to_check path' && not (List.mem path' prev_exp) then begin
+            try
+              (* Attempt expansion *)
+              let (params0, body0, _) = Env.find_type_expansion path' env in
+              let (params, body) =
+                Ctype.instance_parameterized_type params0 body0 in
+              begin
+                try List.iter2 (Ctype.unify env) params args'
+                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 -> ()
+          end;
+          List.iter (check_regular cpath args prev_exp) args'
+      | Tpoly (ty, tl) ->
+          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
+          check_regular cpath args prev_exp ty
+      | _ ->
+          Btype.iter_type_expr (check_regular cpath args prev_exp) ty
+    end in
+
+  Misc.may
+    (fun body ->
+      let (args, body) =
+        Ctype.instance_parameterized_type
+          ~keep_names:true decl.type_params body in
+      check_regular path args [] body)
+    decl.type_manifest
+
+let check_abbrev_recursion env id_loc_list to_check tdecl =
+  let decl = tdecl.typ_type in
+  let id = tdecl.typ_id in
+  check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check
+
+(* Compute variance *)
+
+let get_variance ty visited =
+  try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+  let rec compute_variance_rec vari ty =
+    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
+    let ty = Ctype.repr ty in
+    let vari' = get_variance ty visited in
+    if Variance.subset vari vari' then () else
+    let vari = Variance.union vari vari' in
+    visited := TypeMap.add ty vari !visited;
+    let compute_same = compute_variance_rec vari in
+    match ty.desc with
+      Tarrow (_, ty1, ty2, _) ->
+        let open Variance in
+        let v = conjugate vari in
+        let v1 =
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
+        in
+        compute_variance_rec v1 ty1;
+        compute_same ty2
+    | Ttuple tl ->
+        List.iter compute_same tl
+    | Tconstr (path, tl, _) ->
+        let open Variance in
+        if tl = [] then () else begin
+          try
+            let decl = Env.find_type path env in
+            let cvari f = mem f vari in
+            List.iter2
+              (fun ty v ->
+                let cv f = mem f v in
+                let strict =
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+                in
+                if strict then compute_variance_rec full ty else
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
+                let v1 =
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
+                and weak =
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
+                in
+                let v2 = set May_weak weak v1 in
+                compute_variance_rec v2 ty)
+              tl decl.type_variance
+          with Not_found ->
+            List.iter (compute_variance_rec may_inv) tl
+        end
+    | Tobject (ty, _) ->
+        compute_same ty
+    | Tfield (_, _, ty1, ty2) ->
+        compute_same ty1;
+        compute_same ty2
+    | Tsubst ty ->
+        compute_same ty
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        List.iter
+          (fun (_,f) ->
+            match Btype.row_field_repr f with
+              Rpresent (Some ty) ->
+                compute_same ty
+            | Reither (_, tyl, _, _) ->
+                let open Variance in
+                let upper =
+                  List.fold_left (fun s f -> set f true s)
+                    null [May_pos; May_neg; May_weak]
+                in
+                let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
+                List.iter (compute_variance_rec v) tyl
+            | _ -> ())
+          row.row_fields;
+        compute_same row.row_more
+    | Tpoly (ty, _) ->
+        compute_same ty
+    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+    | Tpackage (_, _, tyl) ->
+        let v =
+          Variance.(if mem Pos vari || mem Neg vari then full else may_inv)
+        in
+        List.iter (compute_variance_rec v) tyl
+  in
+  compute_variance_rec vari ty
+
+let make p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let compute_variance_type env check (required, loc) decl tyl =
+  (* Requirements *)
+  let required =
+    List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
+      required
+  in
+  (* Prepare *)
+  let params = List.map Btype.repr decl.type_params in
+  let tvl = ref TypeMap.empty in
+  (* Compute occurences in body *)
+  let open Variance in
+  List.iter
+    (fun (cn,ty) ->
+      compute_variance env tvl (if cn then full else covariant) ty)
+    tyl;
+  if check then begin
+    (* Check variance of parameters *)
+    let pos = ref 0 in
+    List.iter2
+      (fun ty (c, n, i) ->
+        incr pos;
+        let var = get_variance ty tvl in
+        let (co,cn) = get_upper var and ij = mem Inj var in
+        if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
+        then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i)))))
+      params required;
+    (* Check propagation from constrained parameters *)
+    let args = Btype.newgenty (Ttuple params) in
+    let fvl = Ctype.free_variables args in
+    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+    (* If there are no extra variables there is nothing to do *)
+    if fvl = [] then () else
+    let tvl2 = ref TypeMap.empty in
+    List.iter2
+      (fun ty (p,n,_) ->
+        if Btype.is_Tvar ty then () else
+        let v =
+          if p then if n then full else covariant else conjugate covariant in
+        compute_variance env tvl2 v ty)
+      params required;
+    let visited = ref TypeSet.empty in
+    let rec check ty =
+      let ty = Ctype.repr ty in
+      if TypeSet.mem ty !visited then () else
+      let visited' = TypeSet.add ty !visited in
+      visited := visited';
+      let v1 = get_variance ty tvl in
+      let snap = Btype.snapshot () in
+      let v2 =
+        TypeMap.fold
+          (fun t vt v ->
+            if Ctype.equal env false [ty] [t] then union vt v else v)
+          !tvl2 null in
+      Btype.backtrack snap;
+      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+      if c1 && not c2 || n1 && not n2 then
+        if List.memq ty fvl then
+          let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in
+          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+        else
+          Btype.iter_type_expr check ty
+    in
+    List.iter (fun (_,ty) -> check ty) tyl;
+  end;
+  List.map2
+    (fun ty (p, n, i) ->
+      let v = get_variance ty tvl in
+      let tr = decl.type_private in
+      (* Use required variance where relevant *)
+      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+      let (p, n) =
+        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+        else (false, false) (* only check *)
+      and i = concr  || i && tr = Private in
+      let v = union v (make p n i) in
+      let v =
+        if not concr then v else
+        if mem Pos v && mem Neg v then full else
+        if Btype.is_Tvar ty then v else
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
+      in
+      if decl.type_kind = Type_abstract && tr = Public then v else
+      set May_weak (mem May_neg v) v)
+    params required
+
+let add_false = List.map (fun ty -> false, ty)
+
+(* A parameter is constrained if either is is instantiated,
+   or it is a variable appearing in another parameter *)
+let constrained vars ty =
+  match ty.desc with
+  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
+  | _ -> true
+
+let for_constr = function
+  | Types.Cstr_tuple l -> add_false l
+  | Types.Cstr_record l ->
+      List.map
+        (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
+        l
+
+let compute_variance_gadt env check (required, loc as rloc) decl
+    (tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env check rloc {decl with type_private = Private}
+        (for_constr tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (_, tyl, _)} ->
+          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+          let tyl = List.map Ctype.repr tyl in
+          let fvl = List.map (Ctype.free_variables ?env:None) tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n,_) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (for_constr tl)
+      | _ -> assert false
+
+let compute_variance_extension env check decl ext rloc =
+  compute_variance_gadt env check rloc
+    {decl with type_params = ext.ext_type_params}
+    (ext.ext_args, ext.ext_ret_type)
+
+let compute_variance_decl env check decl (required, _ as rloc) =
+  if (decl.type_kind = Type_abstract || decl.type_kind = Type_open)
+       && decl.type_manifest = None then
+    List.map
+      (fun (c, n, i) ->
+        make (not n) (not c) (decl.type_kind <> Type_abstract || i))
+      required
+  else
+  let mn =
+    match decl.type_manifest with
+      None -> []
+    | Some ty -> [false, ty]
+  in
+  match decl.type_kind with
+    Type_abstract | Type_open ->
+      compute_variance_type env check rloc decl mn
+  | Type_variant tll ->
+      if List.for_all (fun c -> c.Types.cd_res = None) tll then
+        compute_variance_type env check rloc decl
+          (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args)
+                                tll))
+      else begin
+        let mn =
+          List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in
+        let tll =
+          mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in
+        match List.map (compute_variance_gadt env check rloc decl) tll with
+        | vari :: rem ->
+            let varl = List.fold_left (List.map2 Variance.union) vari rem in
+            List.map
+              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+              varl
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env check rloc decl
+        (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
+             (ld_mutable = Mutable, ld_type)) ftl)
+
+let is_hash id =
+  let s = Ident.name id in
+  String.length s > 0 && s.[0] = '#'
+
+let marked_as_immediate decl =
+  Builtin_attributes.immediate decl.type_attributes
+
+let compute_immediacy env tdecl =
+  match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
+    | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
+    | (Type_record ([{ld_type = arg; _}], _), _)
+  when tdecl.type_unboxed.unboxed ->
+    begin match get_unboxed_type_representation env arg with
+    | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr)
+    | None -> false
+    end
+  | (Type_variant (_ :: _ as cstrs), _) ->
+    not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+  | (Type_abstract, Some(typ)) ->
+    not (Ctype.maybe_pointer_type env typ)
+  | (Type_abstract, None) -> marked_as_immediate tdecl
+  | _ -> false
+
+(* Computes the fixpoint for the variance and immediacy of type declarations *)
+
+let rec compute_properties_fixpoint env decls required variances immediacies =
+  let new_decls =
+    List.map2
+      (fun (id, decl) (variance, immediacy) ->
+         id, {decl with type_variance = variance; type_immediate = immediacy})
+      decls (List.combine variances immediacies)
+  in
+  let new_env =
+    List.fold_right
+      (fun (id, decl) env -> Env.add_type ~check:true id decl env)
+      new_decls env
+  in
+  let new_variances =
+    List.map2
+      (fun (_id, decl) -> compute_variance_decl new_env false decl)
+      new_decls required
+  in
+  let new_variances =
+    List.map2 (List.map2 Variance.union) new_variances variances in
+  let new_immediacies =
+    List.map
+      (fun (_id, decl) -> compute_immediacy new_env decl)
+      new_decls
+  in
+  if new_variances <> variances || new_immediacies <> immediacies then
+    compute_properties_fixpoint env decls required new_variances new_immediacies
+  else begin
+    (* List.iter (fun (id, decl) ->
+      Printf.eprintf "%s:" (Ident.name id);
+      List.iter (fun (v : Variance.t) ->
+        Printf.eprintf " %x" (Obj.magic v : int))
+        decl.type_variance;
+      prerr_endline "")
+      new_decls; *)
+    List.iter (fun (_, decl) ->
+      if (marked_as_immediate decl) && (not decl.type_immediate) then
+        raise (Error (decl.type_loc, Bad_immediate_attribute))
+      else ())
+      new_decls;
+    List.iter2
+      (fun (id, decl) req -> if not (is_hash id) then
+        ignore (compute_variance_decl new_env true decl req))
+      new_decls required;
+    new_decls, new_env
+  end
+
+let init_variance (_id, decl) =
+  List.map (fun _ -> Variance.null) decl.type_params
+
+let add_injectivity =
+  List.map
+    (function
+      | Covariant -> (true, false, false)
+      | Contravariant -> (false, true, false)
+      | Invariant -> (false, false, false)
+    )
+
+(* for typeclass.ml *)
+let compute_variance_decls env cldecls =
+  let decls, required =
+    List.fold_right
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
+        let variance = List.map snd ci.ci_params in
+        (obj_id, obj_abbr) :: decls,
+        (add_injectivity variance, ci.ci_loc) :: req)
+      cldecls ([],[])
+  in
+  let (decls, _) =
+    compute_properties_fixpoint env decls required
+      (List.map init_variance decls)
+      (List.map (fun _ -> false) decls)
+  in
+  List.map2
+    (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+      let variance = decl.type_variance in
+      (decl, {cl_abbr with type_variance = variance},
+       {clty with cty_variance = variance},
+       {cltydef with clty_variance = variance}))
+    decls cldecls
+
+(* Check multiple declarations of labels/constructors *)
+
+let check_duplicates sdecl_list =
+  let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
+  List.iter
+    (fun sdecl -> match sdecl.ptype_kind with
+      Ptype_variant cl ->
+        List.iter
+          (fun pcd ->
+            try
+              let name' = Hashtbl.find constrs pcd.pcd_name.txt in
+              Location.prerr_warning pcd.pcd_loc
+                (Warnings.Duplicate_definitions
+                   ("constructor", pcd.pcd_name.txt, name',
+                    sdecl.ptype_name.txt))
+            with Not_found ->
+              Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
+          cl
+    | Ptype_record fl ->
+        List.iter
+          (fun {pld_name=cname;pld_loc=loc} ->
+            try
+              let name' = Hashtbl.find labels cname.txt in
+              Location.prerr_warning loc
+                (Warnings.Duplicate_definitions
+                   ("label", cname.txt, name', sdecl.ptype_name.txt))
+            with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
+          fl
+    | Ptype_abstract -> ()
+    | Ptype_open -> ())
+    sdecl_list
+
+(* Force recursion to go through id for private types*)
+let name_recursion sdecl id decl =
+  match decl with
+  | { type_kind = Type_abstract;
+      type_manifest = Some ty;
+      type_private = Private; } when is_fixed_type sdecl ->
+    let ty = Ctype.repr ty in
+    let ty' = Btype.newty2 ty.level ty.desc in
+    if Ctype.deep_occur ty ty' then
+      let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
+      Btype.link_type ty (Btype.newty2 ty.level td);
+      {decl with type_manifest = Some ty'}
+    else decl
+  | _ -> decl
+
+(* Translate a set of type declarations, mutually recursive or not *)
+let transl_type_decl env rec_flag sdecl_list =
+  (* Add dummy types for fixed rows *)
+  let fixed_types = List.filter is_fixed_type sdecl_list in
+  let sdecl_list =
+    List.map
+      (fun sdecl ->
+        let ptype_name =
+          mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in
+        {sdecl with
+         ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
+      fixed_types
+    @ sdecl_list
+  in
+
+  (* Create identifiers. *)
+  let id_list =
+    List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list
+  in
+  (*
+     Since we've introduced fresh idents, make sure the definition
+     level is at least the binding time of these events. Otherwise,
+     passing one of the recursively-defined type constrs as argument
+     to an abbreviation may fail.
+  *)
+  Ctype.init_def(Ident.current_time());
+  Ctype.begin_def();
+  (* Enter types. *)
+  let temp_env =
+    List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in
+  (* Translate each declaration. *)
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let id_slots id =
+    match rec_flag with
+    | Asttypes.Recursive when warn_unused ->
+        (* See typecore.ml for a description of the algorithm used
+             to detect unused declarations in a set of recursive definitions. *)
+        let slot = ref [] in
+        let td = Env.find_type (Path.Pident id) temp_env in
+        let name = Ident.name id in
+        Env.set_type_used_callback
+          name td
+          (fun old_callback ->
+             match !current_slot with
+             | Some slot -> slot := (name, td) :: !slot
+             | None ->
+                 List.iter (fun (name, d) -> Env.mark_type_used env name d)
+                   (get_ref slot);
+                 old_callback ()
+          );
+        id, Some slot
+    | Asttypes.Recursive | Asttypes.Nonrecursive ->
+        id, None
+  in
+  let transl_declaration name_sdecl (id, slot) =
+    current_slot := slot; transl_declaration temp_env name_sdecl id in
+  let tdecls =
+    List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
+  let decls =
+    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  current_slot := None;
+  (* Check for duplicates *)
+  check_duplicates sdecl_list;
+  (* Build the final env. *)
+  let newenv =
+    List.fold_right
+      (fun (id, decl) env -> Env.add_type ~check:true id decl env)
+      decls env
+  in
+  (* Update stubs *)
+  begin match rec_flag with
+    | Asttypes.Nonrecursive -> ()
+    | Asttypes.Recursive ->
+      List.iter2
+        (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc)
+        id_list sdecl_list
+  end;
+  (* Generalize type declarations. *)
+  Ctype.end_def();
+  List.iter (fun (_, decl) -> generalize_decl decl) decls;
+  (* Check for ill-formed abbrevs *)
+  let id_loc_list =
+    List.map2 (fun id sdecl -> (id, sdecl.ptype_loc))
+      id_list sdecl_list
+  in
+  List.iter (fun (id, decl) ->
+    check_well_founded_manifest newenv (List.assoc id id_loc_list)
+      (Path.Pident id) decl)
+    decls;
+  let to_check =
+    function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
+  List.iter (fun (id, decl) ->
+    check_well_founded_decl newenv (List.assoc id id_loc_list) (Path.Pident id)
+      decl to_check)
+    decls;
+  List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls;
+  (* Check that all type variable are closed *)
+  List.iter2
+    (fun sdecl tdecl ->
+      let decl = tdecl.typ_type in
+       match Ctype.closed_type_decl decl with
+         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+       | None   -> ())
+    sdecl_list tdecls;
+  (* Check that constraints are enforced *)
+  List.iter2 (check_constraints newenv) sdecl_list decls;
+  (* Name recursion *)
+  let decls =
+    List.map2 (fun sdecl (id, decl) -> id, name_recursion sdecl id decl)
+      sdecl_list decls
+  in
+  (* Add variances to the environment *)
+  let required =
+    List.map
+      (fun sdecl ->
+         add_injectivity (List.map snd sdecl.ptype_params),
+         sdecl.ptype_loc
+      )
+      sdecl_list
+  in
+  let final_decls, final_env =
+    compute_properties_fixpoint env decls required
+      (List.map init_variance decls)
+      (List.map (fun _ -> false) decls)
+  in
+  (* Check re-exportation *)
+  List.iter2 (check_abbrev final_env) sdecl_list final_decls;
+  (* Keep original declaration *)
+  let final_decls =
+    List.map2
+      (fun tdecl (_id2, decl) ->
+        { tdecl with typ_type = decl }
+      ) tdecls final_decls
+  in
+  (* Done *)
+  (final_decls, final_env)
+
+(* Translating type extensions *)
+
+let transl_extension_constructor env type_path type_params
+                                 typext_params priv sext =
+  let id = Ident.create sext.pext_name.txt in
+  let args, ret_type, kind =
+    match sext.pext_kind with
+      Pext_decl(sargs, sret_type) ->
+        let targs, tret_type, args, ret_type =
+          make_constructor env type_path typext_params
+            sargs sret_type
+        in
+          args, ret_type, Text_decl(targs, tret_type)
+    | Pext_rebind lid ->
+        let cdescr = Typetexp.find_constructor env lid.loc lid.txt in
+        let usage =
+          if cdescr.cstr_private = Private || priv = Public
+          then Env.Positive else Env.Privatize
+        in
+        Env.mark_constructor usage env (Longident.last lid.txt) cdescr;
+        let (args, cstr_res) = Ctype.instance_constructor cdescr in
+        let res, ret_type =
+          if cdescr.cstr_generalized then
+            let params = Ctype.instance_list env type_params in
+            let res = Ctype.newconstr type_path params in
+            let ret_type = Some (Ctype.newconstr type_path params) in
+              res, ret_type
+          else (Ctype.newconstr type_path typext_params), None
+        in
+        begin
+          try
+            Ctype.unify env cstr_res res
+          with Ctype.Unify trace ->
+            raise (Error(lid.loc,
+                     Rebind_wrong_type(lid.txt, env, trace)))
+        end;
+        (* Remove "_" names from parameters used in the constructor *)
+        if not cdescr.cstr_generalized then begin
+          let vars =
+            Ctype.free_variables (Btype.newgenty (Ttuple args))
+          in
+            List.iter
+              (function {desc = Tvar (Some "_")} as ty ->
+                          if List.memq ty vars then ty.desc <- Tvar None
+                        | _ -> ())
+              typext_params
+        end;
+        (* Ensure that constructor's type matches the type being extended *)
+        let cstr_type_path, cstr_type_params =
+          match cdescr.cstr_res.desc with
+            Tconstr (p, _, _) ->
+              let decl = Env.find_type p env in
+                p, decl.type_params
+          | _ -> assert false
+        in
+        let cstr_types =
+          (Btype.newgenty
+             (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
+          :: cstr_type_params
+        in
+        let ext_types =
+          (Btype.newgenty
+             (Tconstr(type_path, type_params, ref Mnil)))
+          :: type_params
+        in
+        if not (Ctype.equal env true cstr_types ext_types) then
+          raise (Error(lid.loc,
+                       Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
+        (* Disallow rebinding private constructors to non-private *)
+        begin
+          match cdescr.cstr_private, priv with
+            Private, Public ->
+              raise (Error(lid.loc, Rebind_private lid.txt))
+          | _ -> ()
+        end;
+        let path =
+          match cdescr.cstr_tag with
+            Cstr_extension(path, _) -> path
+          | _ -> assert false
+        in
+        let args =
+          match cdescr.cstr_inlined with
+          | None ->
+              Types.Cstr_tuple args
+          | Some decl ->
+              let tl =
+                match args with
+                | [ {desc=Tconstr(_, tl, _)} ] -> tl
+                | _ -> assert false
+              in
+              let decl = Ctype.instance_declaration decl in
+              assert (List.length decl.type_params = List.length tl);
+              List.iter2 (Ctype.unify env) decl.type_params tl;
+              let lbls =
+                match decl.type_kind with
+                | Type_record (lbls, Record_extension) -> lbls
+                | _ -> assert false
+              in
+              Types.Cstr_record lbls
+        in
+        args, ret_type, Text_rebind(path, lid)
+  in
+  let ext =
+    { ext_type_path = type_path;
+      ext_type_params = typext_params;
+      ext_args = args;
+      ext_ret_type = ret_type;
+      ext_private = priv;
+      Types.ext_loc = sext.pext_loc;
+      Types.ext_attributes = sext.pext_attributes; }
+  in
+    { ext_id = id;
+      ext_name = sext.pext_name;
+      ext_type = ext;
+      ext_kind = kind;
+      Typedtree.ext_loc = sext.pext_loc;
+      Typedtree.ext_attributes = sext.pext_attributes; }
+
+let transl_type_extension check_open env loc styext =
+  reset_type_variables();
+  Ctype.begin_def();
+  let (type_path, type_decl) =
+    let lid = styext.ptyext_path in
+    Typetexp.find_type env lid.loc lid.txt
+  in
+  begin
+    match type_decl.type_kind with
+      Type_open -> ()
+    | Type_abstract ->
+        if check_open then begin
+          try
+            let {pext_loc} =
+              List.find (function {pext_kind = Pext_decl _} -> true
+                                | {pext_kind = Pext_rebind _} -> false)
+                        styext.ptyext_constructors
+            in
+              raise (Error(pext_loc, Not_open_type type_path))
+          with Not_found -> ()
+        end
+    | _ -> raise (Error(loc, Not_extensible_type type_path))
+  end;
+  let type_variance =
+    List.map (fun v ->
+                let (co, cn) = Variance.get_upper v in
+                  (not cn, not co, false))
+             type_decl.type_variance
+  in
+  let err =
+    if type_decl.type_arity <> List.length styext.ptyext_params then
+      [Includecore.Arity]
+    else
+      if List.for_all2
+           (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
+           type_variance
+           (add_injectivity (List.map snd styext.ptyext_params))
+      then [] else [Includecore.Variance]
+  in
+  if err <> [] then
+    raise (Error(loc, Extension_mismatch (type_path, err)));
+  let ttype_params = make_params env styext.ptyext_params in
+  let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
+  List.iter2 (Ctype.unify_var env)
+    (Ctype.instance_list env type_decl.type_params)
+    type_params;
+  let constructors =
+    List.map (transl_extension_constructor env type_path
+               type_decl.type_params type_params styext.ptyext_private)
+      styext.ptyext_constructors
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  List.iter Ctype.generalize type_params;
+  List.iter
+    (fun ext ->
+       Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+       may Ctype.generalize ext.ext_type.ext_ret_type)
+    constructors;
+  (* Check that all type variable are closed *)
+  List.iter
+    (fun ext ->
+       match Ctype.closed_extension_constructor ext.ext_type with
+         Some ty ->
+           raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+       | None -> ())
+    constructors;
+  (* Check variances are correct *)
+  List.iter
+    (fun ext->
+      ignore (compute_variance_extension env true type_decl
+                ext.ext_type (type_variance, loc)))
+    constructors;
+  (* Add extension constructors to the environment *)
+  let newenv =
+    List.fold_left
+      (fun env ext ->
+         Env.add_extension ~check:true ext.ext_id ext.ext_type env)
+      env constructors
+  in
+  let tyext =
+    { tyext_path = type_path;
+      tyext_txt = styext.ptyext_path;
+      tyext_params = ttype_params;
+      tyext_constructors = constructors;
+      tyext_private = styext.ptyext_private;
+      tyext_attributes = styext.ptyext_attributes; }
+  in
+    (tyext, newenv)
+
+let transl_exception env sext =
+  reset_type_variables();
+  Ctype.begin_def();
+  let ext =
+    transl_extension_constructor env
+      Predef.path_exn [] [] Asttypes.Public sext
+  in
+  Ctype.end_def();
+  (* Generalize types *)
+  Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+  may Ctype.generalize ext.ext_type.ext_ret_type;
+  (* Check that all type variable are closed *)
+  begin match Ctype.closed_extension_constructor ext.ext_type with
+    Some ty ->
+      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+  | None -> ()
+  end;
+  let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in
+    ext, newenv
+
+type native_repr_attribute =
+  | Native_repr_attr_absent
+  | Native_repr_attr_present of native_repr_kind
+
+let get_native_repr_attribute attrs ~global_repr =
+  match
+    Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"]  attrs,
+    Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
+    global_repr
+  with
+  | None, None, None -> Native_repr_attr_absent
+  | None, None, Some repr -> Native_repr_attr_present repr
+  | Some _, None, None -> Native_repr_attr_present Unboxed
+  | None, Some _, None -> Native_repr_attr_present Untagged
+  | Some { Location.loc }, _, _
+  | _, Some { Location.loc }, _ ->
+    raise (Error (loc, Multiple_native_repr_attributes))
+
+let native_repr_of_type env kind ty =
+  match kind, (Ctype.expand_head_opt env ty).desc with
+  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
+    Some Untagged_int
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
+    Some Unboxed_float
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
+    Some (Unboxed_integer Pint32)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
+    Some (Unboxed_integer Pint64)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
+    Some (Unboxed_integer Pnativeint)
+  | _ ->
+    None
+
+(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
+   attribute in a strict sub-term. *)
+let error_if_has_deep_native_repr_attributes core_type =
+  let open Ast_iterator in
+  let this_iterator =
+    { default_iterator with typ = fun iterator core_type ->
+      begin
+        match
+          get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present kind ->
+           raise (Error (core_type.ptyp_loc,
+                         Deep_unbox_or_untag_attribute kind))
+        | Native_repr_attr_absent -> ()
+      end;
+      default_iterator.typ iterator core_type }
+  in
+  default_iterator.typ this_iterator core_type
+
+let make_native_repr env core_type ty ~global_repr =
+  error_if_has_deep_native_repr_attributes core_type;
+  match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
+  | Native_repr_attr_absent ->
+    Same_as_ocaml_repr
+  | Native_repr_attr_present kind ->
+    begin match native_repr_of_type env kind ty with
+    | None ->
+      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+    | Some repr -> repr
+    end
+
+let rec parse_native_repr_attributes env core_type ty ~global_repr =
+  match core_type.ptyp_desc, (Ctype.repr ty).desc,
+    get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
+  with
+  | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind  ->
+    raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
+    let repr_arg = make_native_repr env ct1 t1 ~global_repr in
+    let repr_args, repr_res =
+      parse_native_repr_attributes env ct2 t2 ~global_repr
+    in
+    (repr_arg :: repr_args, repr_res)
+  | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
+  | _ -> ([], make_native_repr env core_type ty ~global_repr)
+
+
+let check_unboxable env loc ty =
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  try match ty.desc with
+  | Tconstr (p, _, _) ->
+    let tydecl = Env.find_type p env in
+    if tydecl.type_unboxed.unboxed then
+      Location.prerr_warning loc
+        (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+  | _ -> ()
+  with Not_found -> ()
+
+(* Translate a value declaration *)
+let transl_value_decl env loc valdecl =
+  let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
+  let ty = cty.ctyp_type in
+  let v =
+  match valdecl.pval_prim with
+    [] when Env.is_in_signature env ->
+      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes }
+  | [] ->
+      raise (Error(valdecl.pval_loc, Val_in_structure))
+  | _ ->
+      let global_repr =
+        match
+          get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
+        with
+        | Native_repr_attr_present repr -> Some repr
+        | Native_repr_attr_absent -> None
+      in
+      let native_repr_args, native_repr_res =
+        parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
+      in
+      let prim =
+        Primitive.parse_declaration valdecl
+          ~native_repr_args
+          ~native_repr_res
+      in
+      if prim.prim_arity = 0 &&
+         (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
+        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
+      if !Clflags.native_code
+      && prim.prim_arity > 5
+      && prim.prim_native_name = ""
+      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      Btype.iter_type_expr (check_unboxable env loc) ty;
+      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes }
+  in
+  let (id, newenv) =
+    Env.enter_value valdecl.pval_name.txt v env
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+  in
+  let desc =
+    {
+     val_id = id;
+     val_name = valdecl.pval_name;
+     val_desc = cty; val_val = v;
+     val_prim = valdecl.pval_prim;
+     val_loc = valdecl.pval_loc;
+     val_attributes = valdecl.pval_attributes;
+    }
+  in
+  desc, newenv
+
+(* Translate a "with" constraint -- much simplified version of
+    transl_type_decl. *)
+let transl_with_constraint env id row_path orig_decl sdecl =
+  Env.mark_type_used env (Ident.name id) orig_decl;
+  reset_type_variables();
+  Ctype.begin_def();
+  let tparams = make_params env sdecl.ptype_params in
+  let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
+  let orig_decl = Ctype.instance_declaration orig_decl in
+  let arity_ok = List.length params = orig_decl.type_arity in
+  if arity_ok then
+    List.iter2 (Ctype.unify_var env) params orig_decl.type_params;
+  let constraints = List.map
+    (function (ty, ty', loc) ->
+       try
+         let cty = transl_simple_type env false ty in
+         let cty' = transl_simple_type env false ty' in
+         let ty = cty.ctyp_type in
+         let ty' = cty'.ctyp_type in
+         Ctype.unify env ty ty';
+         (cty, cty', loc)
+       with Ctype.Unify tr ->
+         raise(Error(loc, Inconsistent_constraint (env, tr))))
+    sdecl.ptype_cstrs
+  in
+  let no_row = not (is_fixed_type sdecl) in
+  let (tman, man) =  match sdecl.ptype_manifest with
+      None -> None, None
+    | Some sty ->
+        let cty = transl_simple_type env no_row sty in
+        Some cty, Some cty.ctyp_type
+  in
+  let priv =
+    if sdecl.ptype_private = Private then Private else
+    if arity_ok && orig_decl.type_kind <> Type_abstract
+    then orig_decl.type_private else sdecl.ptype_private
+  in
+  if arity_ok && orig_decl.type_kind <> Type_abstract
+  && sdecl.ptype_private = Private then
+    Location.prerr_warning sdecl.ptype_loc
+      (Warnings.Deprecated "spurious use of private");
+  let type_kind, type_unboxed =
+    if arity_ok && man <> None then
+      orig_decl.type_kind, orig_decl.type_unboxed
+    else
+      Type_abstract, unboxed_false_default_false
+  in
+  let decl =
+    { type_params = params;
+      type_arity = List.length params;
+      type_kind;
+      type_private = priv;
+      type_manifest = man;
+      type_variance = [];
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
+      type_attributes = sdecl.ptype_attributes;
+      type_immediate = false;
+      type_unboxed;
+    }
+  in
+  begin match row_path with None -> ()
+  | Some p -> set_fixed_row env sdecl.ptype_loc p decl
+  end;
+  begin match Ctype.closed_type_decl decl with None -> ()
+  | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+  end;
+  let decl = name_recursion sdecl id decl in
+  let type_variance =
+    compute_variance_decl env true decl
+      (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)
+  in
+  let type_immediate = compute_immediacy env decl in
+  let decl = {decl with type_variance; type_immediate} in
+  Ctype.end_def();
+  generalize_decl decl;
+  {
+    typ_id = id;
+    typ_name = sdecl.ptype_name;
+    typ_params = tparams;
+    typ_type = decl;
+    typ_cstrs = constraints;
+    typ_loc = sdecl.ptype_loc;
+    typ_manifest = tman;
+    typ_kind = Ttype_abstract;
+    typ_private = sdecl.ptype_private;
+    typ_attributes = sdecl.ptype_attributes;
+  }
+
+(* Approximate a type declaration: just make all types abstract *)
+
+let abstract_type_decl arity =
+  let rec make_params n =
+    if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
+  Ctype.begin_def();
+  let decl =
+    { type_params = make_params arity;
+      type_arity = arity;
+      type_kind = Type_abstract;
+      type_private = Public;
+      type_manifest = None;
+      type_variance = replicate_list Variance.full arity;
+      type_newtype_level = None;
+      type_loc = Location.none;
+      type_attributes = [];
+      type_immediate = false;
+      type_unboxed = unboxed_false_default_false;
+     } in
+  Ctype.end_def();
+  generalize_decl decl;
+  decl
+
+let approx_type_decl sdecl_list =
+  List.map
+    (fun sdecl ->
+      (Ident.create sdecl.ptype_name.txt,
+       abstract_type_decl (List.length sdecl.ptype_params)))
+    sdecl_list
+
+(* Variant of check_abbrev_recursion to check the well-formedness
+   conditions on type abbreviations defined within recursive modules. *)
+
+let check_recmod_typedecl env loc recmod_ids path decl =
+  (* recmod_ids is the list of recursively-defined module idents.
+     (path, decl) is the type declaration to be checked. *)
+  let to_check path =
+    List.exists (fun id -> Path.isfree id path) recmod_ids in
+  check_well_founded_decl env loc path decl to_check;
+  check_recursion env loc path decl to_check
+
+
+(**** Error report ****)
+
+open Format
+
+let explain_unbound_gen ppf tv tl typ kwd pr =
+  try
+    let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
+    let ty0 = (* Hack to force aliasing when needed *)
+      Btype.newgenty (Tobject(tv, ref None)) in
+    Printtyp.reset_and_mark_loops_list [typ ti; ty0];
+    fprintf ppf
+      ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]"
+      kwd pr ti Printtyp.type_expr tv
+  with Not_found -> ()
+
+let explain_unbound ppf tv tl typ kwd lab =
+  explain_unbound_gen ppf tv tl typ kwd
+    (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti))
+
+let explain_unbound_single ppf tv ty =
+  let trivial ty =
+    explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
+  match (Ctype.repr ty).desc with
+    Tobject(fi,_) ->
+      let (tl, rv) = Ctype.flatten_fields fi in
+      if rv == tv then trivial ty else
+      explain_unbound ppf tv tl (fun (_,_,t) -> t)
+        "method" (fun (lab,_,_) -> lab ^ ": ")
+  | Tvariant row ->
+      let row = Btype.row_repr row in
+      if row.row_more == tv then trivial ty else
+      explain_unbound ppf tv row.row_fields
+        (fun (_l,f) -> match Btype.row_field_repr f with
+          Rpresent (Some t) -> t
+        | Reither (_,[t],_,_) -> t
+        | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
+        | _ -> Btype.newgenty (Ttuple[]))
+        "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+  | _ -> trivial ty
+
+
+let tys_of_constr_args = function
+  | Types.Cstr_tuple tl -> tl
+  | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
+
+let report_error ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
+  | Duplicate_constructor s ->
+      fprintf ppf "Two constructors are named %s" s
+  | Too_many_constructors ->
+      fprintf ppf
+        "@[Too many non-constant constructors@ -- maximum is %i %s@]"
+        (Config.max_tag + 1) "non-constant constructors"
+  | Duplicate_label s ->
+      fprintf ppf "Two labels are named %s" s
+  | Recursive_abbrev s ->
+      fprintf ppf "The type abbreviation %s is cyclic" s
+  | Cycle_in_def (s, ty) ->
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf "@[The definition of %s contains a cycle:@ %a@]"
+        s Printtyp.type_expr ty
+  | Definition_mismatch (ty, errs) ->
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]"
+        "This variant or record definition" "does not match that of type"
+        Printtyp.type_expr ty
+        (Includecore.report_type_mismatch "the original" "this" "definition")
+        errs
+  | Constraint_failed (ty, ty') ->
+      Printtyp.reset_and_mark_loops ty;
+      Printtyp.mark_loops ty';
+      fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]"
+        "Constraints are not satisfied in this type."
+        Printtyp.type_expr ty Printtyp.type_expr ty'
+  | Parameters_differ (path, ty, ty') ->
+      Printtyp.reset_and_mark_loops ty;
+      Printtyp.mark_loops ty';
+      fprintf ppf
+        "@[In the definition of %s, type@ %a@ should be@ %a@]"
+        (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
+  | Inconsistent_constraint (env, trace) ->
+      fprintf ppf "The type constraints are not consistent.@.";
+      Printtyp.report_unification_error ppf env trace
+        (fun ppf -> fprintf ppf "Type")
+        (fun ppf -> fprintf ppf "is not compatible with type")
+  | Type_clash (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "This type constructor expands to type")
+        (function ppf ->
+           fprintf ppf "but is used here with type")
+  | Null_arity_external ->
+      fprintf ppf "External identifiers must be functions"
+  | Missing_native_external ->
+      fprintf ppf "@[An external function with more than 5 arguments \
+                   requires a second stub function@ \
+                   for native-code compilation@]"
+  | Unbound_type_var (ty, decl) ->
+      fprintf ppf "A type variable is unbound in this type declaration";
+      let ty = Ctype.repr ty in
+      begin match decl.type_kind, decl.type_manifest with
+      | Type_variant tl, _ ->
+          explain_unbound_gen ppf ty tl (fun c ->
+              let tl = tys_of_constr_args c.Types.cd_args in
+              Btype.newgenty (Ttuple tl)
+            )
+            "case" (fun ppf c ->
+                fprintf ppf
+                  "%s of %a" (Ident.name c.Types.cd_id)
+                  Printtyp.constructor_arguments c.Types.cd_args)
+      | Type_record (tl, _), _ ->
+          explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
+            "field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
+      | Type_abstract, Some ty' ->
+          explain_unbound_single ppf ty ty'
+      | _ -> ()
+      end
+  | Unbound_type_var_ext (ty, ext) ->
+      fprintf ppf "A type variable is unbound in this extension constructor";
+      let args = tys_of_constr_args ext.ext_args in
+      explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "")
+  | Not_open_type path ->
+      fprintf ppf "@[%s@ %a@]"
+        "Cannot extend type definition"
+        Printtyp.path path
+  | Not_extensible_type path ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "Type"
+        Printtyp.path path
+        "is not extensible"
+  | Extension_mismatch (path, errs) ->
+      fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]"
+        "This extension" "does not match the definition of type"
+        (Path.name path)
+        (Includecore.report_type_mismatch
+           "the type" "this extension" "definition")
+        errs
+  | Rebind_wrong_type (lid, env, trace) ->
+      Printtyp.report_unification_error ppf env trace
+        (function ppf ->
+          fprintf ppf "The constructor %a@ has type"
+            Printtyp.longident lid)
+        (function ppf ->
+           fprintf ppf "but was expected to be of type")
+  | Rebind_mismatch (lid, p, p') ->
+      fprintf ppf
+        "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
+        "The constructor" Printtyp.longident lid
+        "extends type" (Path.name p)
+        "whose declaration does not match"
+        "the declaration of type" (Path.name p')
+  | Rebind_private lid ->
+      fprintf ppf "@[%s@ %a@ %s@]"
+        "The constructor"
+        Printtyp.longident lid
+        "is private"
+  | Bad_variance (n, v1, v2) ->
+      let variance (p,n,i) =
+        let inj = if i then "injective " else "" in
+        match p, n with
+          true,  true  -> inj ^ "invariant"
+        | true,  false -> inj ^ "covariant"
+        | false, true  -> inj ^ "contravariant"
+        | false, false -> if inj = "" then "unrestricted" else inj
+      in
+      let suffix n =
+        let teen = (n mod 100)/10 = 1 in
+        match n mod 10 with
+        | 1 when not teen -> "st"
+        | 2 when not teen -> "nd"
+        | 3 when not teen -> "rd"
+        | _ -> "th"
+      in
+      if n = -1 then
+        fprintf ppf "@[%s@ %s@ It"
+          "In this definition, a type variable has a variance that"
+          "is not reflected by its occurrence in type parameters."
+      else if n = -2 then
+        fprintf ppf "@[%s@ %s@]"
+          "In this definition, a type variable cannot be deduced"
+          "from the type parameters."
+      else if n = -3 then
+        fprintf ppf "@[%s@ %s@ It"
+          "In this definition, a type variable has a variance that"
+          "cannot be deduced from the type parameters."
+      else
+        fprintf ppf "@[%s@ %s@ The %d%s type parameter"
+          "In this definition, expected parameter"
+          "variances are not satisfied."
+          n (suffix n);
+      if n <> -2 then
+        fprintf ppf " was expected to be %s,@ but it is %s.@]"
+          (variance v2) (variance v1)
+  | Unavailable_type_constructor p ->
+      fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+  | Bad_fixed_type r ->
+      fprintf ppf "This fixed type %s" r
+  | Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"
+  | Val_in_structure ->
+      fprintf ppf "Value declarations are only allowed in signatures"
+  | Multiple_native_repr_attributes ->
+      fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
+  | Cannot_unbox_or_untag_type Unboxed ->
+      fprintf ppf "Don't know how to unbox this type. Only float, int32, \
+                   int64 and nativeint can be unboxed"
+  | Cannot_unbox_or_untag_type Untagged ->
+      fprintf ppf "Don't know how to untag this type. Only int \
+                   can be untagged"
+  | Deep_unbox_or_untag_attribute kind ->
+      fprintf ppf
+        "The attribute '%s' should be attached to a direct argument or \
+         result of the primitive, it should not occur deeply into its type"
+        (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
+  | Bad_immediate_attribute ->
+      fprintf ppf "@[%s@ %s@]"
+        "Types marked with the immediate attribute must be"
+        "non-pointer types like int or bool"
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Wrong_unboxed_type_float ->
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
new file mode 100644
index 00000000..db4875f9
--- /dev/null
+++ b/typing/typedecl.mli
@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typing of type definitions and primitive definitions *)
+
+open Types
+open Format
+
+val transl_type_decl:
+    Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
+    Typedtree.type_declaration list * Env.t
+
+val transl_exception:
+    Env.t ->
+    Parsetree.extension_constructor -> Typedtree.extension_constructor * Env.t
+
+val transl_type_extension:
+    bool -> Env.t -> Location.t -> Parsetree.type_extension ->
+    Typedtree.type_extension * Env.t
+
+val transl_value_decl:
+    Env.t -> Location.t ->
+    Parsetree.value_description -> Typedtree.value_description * Env.t
+
+val transl_with_constraint:
+    Env.t -> Ident.t -> Path.t option -> Types.type_declaration ->
+    Parsetree.type_declaration -> Typedtree.type_declaration
+
+val abstract_type_decl: int -> type_declaration
+val approx_type_decl:
+    Parsetree.type_declaration list ->
+                                  (Ident.t * type_declaration) list
+val check_recmod_typedecl:
+    Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+    Env.t -> Location.t -> Ident.t -> type_declaration -> unit
+
+(* for fixed types *)
+val is_fixed_type : Parsetree.type_declaration -> bool
+
+(* for typeclass.ml *)
+val compute_variance_decls:
+    Env.t ->
+    (Ident.t * Types.type_declaration * Types.type_declaration *
+     Types.class_declaration * Types.class_type_declaration *
+     'a Typedtree.class_infos) list ->
+    (Types.type_declaration * Types.type_declaration *
+     Types.class_declaration * Types.class_type_declaration) list
+
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+
+type native_repr_kind = Unboxed | Untagged
+
+type error =
+    Repeated_parameter
+  | Duplicate_constructor of string
+  | Too_many_constructors
+  | Duplicate_label of string
+  | Recursive_abbrev of string
+  | Cycle_in_def of string * type_expr
+  | Definition_mismatch of type_expr * Includecore.type_mismatch list
+  | Constraint_failed of type_expr * type_expr
+  | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
+  | Type_clash of Env.t * (type_expr * type_expr) list
+  | Parameters_differ of Path.t * type_expr * type_expr
+  | Null_arity_external
+  | Missing_native_external
+  | Unbound_type_var of type_expr * type_declaration
+  | Not_open_type of Path.t
+  | Not_extensible_type of Path.t
+  | Extension_mismatch of Path.t * Includecore.type_mismatch list
+  | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
+  | Rebind_mismatch of Longident.t * Path.t * Path.t
+  | Rebind_private of Longident.t
+  | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool)
+  | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
+  | Unbound_type_var_ext of type_expr * extension_constructor
+  | Varying_anonymous
+  | Val_in_structure
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
+  | Deep_unbox_or_untag_attribute of native_repr_kind
+  | Bad_immediate_attribute
+  | Bad_unboxed_attribute of string
+  | Wrong_unboxed_type_float
+  | Boxed_and_unboxed
+
+exception Error of Location.t * error
+
+val report_error: formatter -> error -> unit
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
new file mode 100644
index 00000000..db4440c1
--- /dev/null
+++ b/typing/typedtree.ml
@@ -0,0 +1,613 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract syntax tree after typing *)
+
+open Misc
+open Asttypes
+open Types
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+type pattern =
+  { pat_desc: pattern_desc;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attribute list) list;
+    pat_type: type_expr;
+    mutable pat_env: Env.t;
+    pat_attributes: attribute list;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+  | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+
+and pattern_desc =
+    Tpat_any
+  | Tpat_var of Ident.t * string loc
+  | Tpat_alias of pattern * Ident.t * string loc
+  | Tpat_constant of constant
+  | Tpat_tuple of pattern list
+  | Tpat_construct of
+      Longident.t loc * constructor_description * pattern list
+  | Tpat_variant of label * pattern option * row_desc ref
+  | Tpat_record of
+      (Longident.t loc * label_description * pattern) list *
+        closed_flag
+  | Tpat_array of pattern list
+  | Tpat_or of pattern * pattern * row_desc option
+  | Tpat_lazy of pattern
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attribute list) list;
+    exp_type: type_expr;
+    exp_env: Env.t;
+    exp_attributes: attribute list;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+  | Texp_coerce of core_type option * core_type
+  | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
+  | Texp_poly of core_type option
+  | Texp_newtype of string
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+  | Texp_constant of constant
+  | Texp_let of rec_flag * value_binding list * expression
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : case list; partial : partial; }
+  | Texp_apply of expression * (arg_label * expression option) list
+  | Texp_match of expression * case list * case list * partial
+  | Texp_try of expression * case list
+  | Texp_tuple of expression list
+  | Texp_construct of
+      Longident.t loc * constructor_description * expression list
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+  | Texp_field of expression * Longident.t loc * label_description
+  | Texp_setfield of
+      expression * Longident.t loc * label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of Ident.t * string loc * module_expr * expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and case =
+    {
+     c_lhs: pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attribute list;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * string loc * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * string loc * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Concr.t
+    (* Visible instance variables, methods and concretes methods *)
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attribute list;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attribute list;
+   }
+
+and module_type_constraint =
+  Tmodtype_implicit
+| Tmodtype_explicit of module_type
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of Ident.t * string loc * module_type option * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of extension_constructor
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_description
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t;
+     mb_name: string loc;
+     mb_expr: module_expr;
+     mb_attributes: attribute list;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attribute list;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of Ident.t * string loc * module_type option * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+(* Keep primitive type information for type-based lambda-code specialization *)
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of extension_constructor
+  | Tsig_module of module_declaration
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t;
+     md_name: string loc;
+     md_type: module_type;
+     md_attributes: attribute list;
+     md_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attribute list;
+     mtd_loc: Location.t;
+    }
+
+and open_description =
+    {
+     open_path: Path.t;
+     open_txt: Longident.t loc;
+     open_override: override_flag;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+
+and core_type =
+(* mutable because of [Typeclass.declare_method] *)
+  { mutable ctyp_desc : core_type_desc;
+    mutable ctyp_type : type_expr;
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attribute list;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of (string * attributes * core_type) list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field =
+    Ttag of label * attributes * bool * core_type list
+  | Tinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attribute list;
+    }
+
+and type_declaration =
+  { typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * variance) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attribute list;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attribute list;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attribute list;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * variance) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_attributes: attribute list;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type: Types.extension_constructor;
+    ext_kind: extension_constructor_kind;
+    ext_loc: Location.t;
+    ext_attributes: attribute list;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+
+and class_signature = {
+    csig_self: core_type;
+    csig_fields: class_type_field list;
+    csig_type: Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attribute list;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * variance) list;
+    ci_id_name: string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type: Ident.t;
+    ci_id_object: Ident.t;
+    ci_id_typehash: Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl: Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attribute list;
+   }
+
+(* Auxiliary functions over the a.s.t. *)
+
+let iter_pattern_desc f = function
+  | Tpat_alias(p, _, _) -> f p
+  | Tpat_tuple patl -> List.iter f patl
+  | Tpat_construct(_, _, patl) -> List.iter f patl
+  | Tpat_variant(_, pat, _) -> may f pat
+  | Tpat_record (lbl_pat_list, _) ->
+      List.iter (fun (_, _, pat) -> f pat) lbl_pat_list
+  | Tpat_array patl -> List.iter f patl
+  | Tpat_or(p1, p2, _) -> f p1; f p2
+  | Tpat_lazy p -> f p
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+
+let map_pattern_desc f d =
+  match d with
+  | Tpat_alias (p1, id, s) ->
+      Tpat_alias (f p1, id, s)
+  | Tpat_tuple pats ->
+      Tpat_tuple (List.map f pats)
+  | Tpat_record (lpats, closed) ->
+      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
+  | Tpat_construct (lid, c,pats) ->
+      Tpat_construct (lid, c, List.map f pats)
+  | Tpat_array pats ->
+      Tpat_array (List.map f pats)
+  | Tpat_lazy p1 -> Tpat_lazy (f p1)
+  | Tpat_variant (x1, Some p1, x2) ->
+      Tpat_variant (x1, Some (f p1), x2)
+  | Tpat_or (p1,p2,path) ->
+      Tpat_or (f p1, f p2, path)
+  | Tpat_var _
+  | Tpat_constant _
+  | Tpat_any
+  | Tpat_variant (_,None,_) -> d
+
+(* List the identifiers bound by a pattern or a let *)
+
+let idents = ref([]: (Ident.t * string loc) list)
+
+let rec bound_idents pat =
+  match pat.pat_desc with
+  | Tpat_var (id,s) -> idents := (id,s) :: !idents
+  | Tpat_alias(p, id, s ) ->
+      bound_idents p; idents := (id,s) :: !idents
+  | Tpat_or(p1, _, _) ->
+      (* Invariant : both arguments binds the same variables *)
+      bound_idents p1
+  | d -> iter_pattern_desc bound_idents d
+
+let pat_bound_idents pat =
+  idents := [];
+  bound_idents pat;
+  let res = !idents in
+  idents := [];
+  List.map fst res
+
+let rev_let_bound_idents_with_loc bindings =
+  idents := [];
+  List.iter (fun vb -> bound_idents vb.vb_pat) bindings;
+  let res = !idents in idents := []; res
+
+let let_bound_idents_with_loc pat_expr_list =
+  List.rev(rev_let_bound_idents_with_loc pat_expr_list)
+
+let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat)
+let let_bound_idents pat = List.map  fst (let_bound_idents_with_loc pat)
+
+let alpha_var env id = List.assoc id env
+
+let rec alpha_pat env p = match p.pat_desc with
+| Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+    {p with pat_desc =
+     try Tpat_var (alpha_var env id, s) with
+     | Not_found -> Tpat_any}
+| Tpat_alias (p1, id, s) ->
+    let new_p =  alpha_pat env p1 in
+    begin try
+      {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+    with
+    | Not_found -> new_p
+    end
+| d ->
+    {p with pat_desc = map_pattern_desc (alpha_pat env) d}
+
+let mkloc = Location.mkloc
+let mknoloc = Location.mknoloc
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
new file mode 100644
index 00000000..ee26bca3
--- /dev/null
+++ b/typing/typedtree.mli
@@ -0,0 +1,664 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Abstract syntax tree after typing *)
+
+
+(** By comparison with {!Parsetree}:
+    - Every {!Longindent.t} is accompanied by a resolved {!Path.t}.
+
+*)
+
+open Asttypes
+open Types
+
+(* Value expressions for the core language *)
+
+type partial = Partial | Total
+
+(** {2 Extension points} *)
+
+type attribute = Parsetree.attribute
+type attributes = attribute list
+
+(** {2 Core language} *)
+
+type pattern =
+  { pat_desc: pattern_desc;
+    pat_loc: Location.t;
+    pat_extra : (pat_extra * Location.t * attributes) list;
+    pat_type: type_expr;
+    mutable pat_env: Env.t;
+    pat_attributes: attributes;
+   }
+
+and pat_extra =
+  | Tpat_constraint of core_type
+        (** P : T          { pat_desc = P
+                           ; pat_extra = (Tpat_constraint T, _, _) :: ... }
+         *)
+  | Tpat_type of Path.t * Longident.t loc
+        (** #tconst        { pat_desc = disjunction
+                           ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...}
+
+                           where [disjunction] is a [Tpat_or _] representing the
+                           branches of [tconst].
+         *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
+  | Tpat_unpack
+        (** (module P)     { pat_desc  = Tpat_var "P"
+                           ; pat_extra = (Tpat_unpack, _, _) :: ... }
+         *)
+
+and pattern_desc =
+    Tpat_any
+        (** _ *)
+  | Tpat_var of Ident.t * string loc
+        (** x *)
+  | Tpat_alias of pattern * Ident.t * string loc
+        (** P as a *)
+  | Tpat_constant of constant
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Tpat_tuple of pattern list
+        (** (P1, ..., Pn)
+
+            Invariant: n >= 2
+         *)
+  | Tpat_construct of
+      Longident.t loc * constructor_description * pattern list
+        (** C                []
+            C P              [P]
+            C (P1, ..., Pn)  [P1; ...; Pn]
+          *)
+  | Tpat_variant of label * pattern option * row_desc ref
+        (** `A             (None)
+            `A P           (Some P)
+
+            See {!Types.row_desc} for an explanation of the last parameter.
+         *)
+  | Tpat_record of
+      (Longident.t loc * label_description * pattern) list *
+        closed_flag
+        (** { l1=P1; ...; ln=Pn }     (flag = Closed)
+            { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+            Invariant: n > 0
+         *)
+  | Tpat_array of pattern list
+        (** [| P1; ...; Pn |] *)
+  | Tpat_or of pattern * pattern * row_desc option
+        (** P1 | P2
+
+            [row_desc] = [Some _] when translating [Ppat_type _],
+                         [None] otherwise.
+         *)
+  | Tpat_lazy of pattern
+        (** lazy P *)
+
+and expression =
+  { exp_desc: expression_desc;
+    exp_loc: Location.t;
+    exp_extra: (exp_extra * Location.t * attributes) list;
+    exp_type: type_expr;
+    exp_env: Env.t;
+    exp_attributes: attributes;
+   }
+
+and exp_extra =
+  | Texp_constraint of core_type
+        (** E : T *)
+  | Texp_coerce of core_type option * core_type
+        (** E :> T           [Texp_coerce (None, T)]
+            E : T0 :> T      [Texp_coerce (Some T0, T)]
+         *)
+  | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
+        (** let open[!] M in    [Texp_open (!, P, M, env)]
+                                where [env] is the environment after opening [P]
+         *)
+  | Texp_poly of core_type option
+        (** Used for method bodies. *)
+  | Texp_newtype of string
+        (** fun (type t) ->  *)
+
+and expression_desc =
+    Texp_ident of Path.t * Longident.t loc * Types.value_description
+        (** x
+            M.x
+         *)
+  | Texp_constant of constant
+        (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+  | Texp_let of rec_flag * value_binding list * expression
+        (** let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
+            let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
+         *)
+  | Texp_function of { arg_label : arg_label; param : Ident.t;
+      cases : case list; partial : partial; }
+        (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
+            See {!Parsetree} for more details.
+
+            [param] is the identifier that is to be used to name the
+            parameter of the function.
+
+            partial =
+              [Partial] if the pattern match is partial
+              [Total] otherwise.
+         *)
+  | Texp_apply of expression * (arg_label * expression option) list
+        (** E0 ~l1:E1 ... ~ln:En
+
+            The expression can be None if the expression is abstracted over
+            this argument. It currently appears when a label is applied.
+
+            For example:
+            let f x ~y = x + y in
+            f ~y:3
+
+            The resulting typedtree for the application is:
+            Texp_apply (Texp_ident "f/1037",
+                        [(Nolabel, None);
+                         (Labelled "y", Some (Texp_constant Const_int 3))
+                        ])
+         *)
+  | Texp_match of expression * case list * case list * partial
+        (** match E0 with
+            | P1 -> E1
+            | P2 -> E2
+            | exception P3 -> E3
+
+            [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)]
+         *)
+  | Texp_try of expression * case list
+        (** try E with P1 -> E1 | ... | PN -> EN *)
+  | Texp_tuple of expression list
+        (** (E1, ..., EN) *)
+  | Texp_construct of
+      Longident.t loc * constructor_description * expression list
+        (** C                []
+            C E              [E]
+            C (E1, ..., En)  [E1;...;En]
+         *)
+  | Texp_variant of label * expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
+  | Texp_field of expression * Longident.t loc * label_description
+  | Texp_setfield of
+      expression * Longident.t loc * label_description * expression
+  | Texp_array of expression list
+  | Texp_ifthenelse of expression * expression * expression option
+  | Texp_sequence of expression * expression
+  | Texp_while of expression * expression
+  | Texp_for of
+      Ident.t * Parsetree.pattern * expression * expression * direction_flag *
+        expression
+  | Texp_send of expression * meth * expression option
+  | Texp_new of Path.t * Longident.t loc * Types.class_declaration
+  | Texp_instvar of Path.t * Path.t * string loc
+  | Texp_setinstvar of Path.t * Path.t * string loc * expression
+  | Texp_override of Path.t * (Path.t * string loc * expression) list
+  | Texp_letmodule of Ident.t * string loc * module_expr * expression
+  | Texp_letexception of extension_constructor * expression
+  | Texp_assert of expression
+  | Texp_lazy of expression
+  | Texp_object of class_structure * string list
+  | Texp_pack of module_expr
+  | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
+
+and meth =
+    Tmeth_name of string
+  | Tmeth_val of Ident.t
+
+and case =
+    {
+     c_lhs: pattern;
+     c_guard: expression option;
+     c_rhs: expression;
+    }
+
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
+(* Value expressions for the class language *)
+
+and class_expr =
+    {
+     cl_desc: class_expr_desc;
+     cl_loc: Location.t;
+     cl_type: Types.class_type;
+     cl_env: Env.t;
+     cl_attributes: attributes;
+    }
+
+and class_expr_desc =
+    Tcl_ident of Path.t * Longident.t loc * core_type list
+  | Tcl_structure of class_structure
+  | Tcl_fun of
+      arg_label * pattern * (Ident.t * string loc * expression) list
+      * class_expr * partial
+  | Tcl_apply of class_expr * (arg_label * expression option) list
+  | Tcl_let of rec_flag * value_binding list *
+                  (Ident.t * string loc * expression) list * class_expr
+  | Tcl_constraint of
+      class_expr * class_type option * string list * string list * Concr.t
+    (* Visible instance variables, methods and concretes methods *)
+
+and class_structure =
+  {
+   cstr_self: pattern;
+   cstr_fields: class_field list;
+   cstr_type: Types.class_signature;
+   cstr_meths: Ident.t Meths.t;
+  }
+
+and class_field =
+   {
+    cf_desc: class_field_desc;
+    cf_loc: Location.t;
+    cf_attributes: attributes;
+  }
+
+and class_field_kind =
+  | Tcfk_virtual of core_type
+  | Tcfk_concrete of override_flag * expression
+
+and class_field_desc =
+    Tcf_inherit of
+      override_flag * class_expr * string option * (string * Ident.t) list *
+        (string * Ident.t) list
+    (* Inherited instance variables and concrete methods *)
+  | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+  | Tcf_method of string loc * private_flag * class_field_kind
+  | Tcf_constraint of core_type * core_type
+  | Tcf_initializer of expression
+  | Tcf_attribute of attribute
+
+(* Value expressions for the module language *)
+
+and module_expr =
+  { mod_desc: module_expr_desc;
+    mod_loc: Location.t;
+    mod_type: Types.module_type;
+    mod_env: Env.t;
+    mod_attributes: attributes;
+   }
+
+(** Annotations for [Tmod_constraint]. *)
+and module_type_constraint =
+  | Tmodtype_implicit
+  (** The module type constraint has been synthesized during typecheking. *)
+  | Tmodtype_explicit of module_type
+  (** The module type was in the source file. *)
+
+and module_expr_desc =
+    Tmod_ident of Path.t * Longident.t loc
+  | Tmod_structure of structure
+  | Tmod_functor of Ident.t * string loc * module_type option * module_expr
+  | Tmod_apply of module_expr * module_expr * module_coercion
+  | Tmod_constraint of
+      module_expr * Types.module_type * module_type_constraint * module_coercion
+    (** ME          (constraint = Tmodtype_implicit)
+        (ME : MT)   (constraint = Tmodtype_explicit MT)
+     *)
+  | Tmod_unpack of expression * Types.module_type
+
+and structure = {
+  str_items : structure_item list;
+  str_type : Types.signature;
+  str_final_env : Env.t;
+}
+
+and structure_item =
+  { str_desc : structure_item_desc;
+    str_loc : Location.t;
+    str_env : Env.t
+  }
+
+and structure_item_desc =
+    Tstr_eval of expression * attributes
+  | Tstr_value of rec_flag * value_binding list
+  | Tstr_primitive of value_description
+  | Tstr_type of rec_flag * type_declaration list
+  | Tstr_typext of type_extension
+  | Tstr_exception of extension_constructor
+  | Tstr_module of module_binding
+  | Tstr_recmodule of module_binding list
+  | Tstr_modtype of module_type_declaration
+  | Tstr_open of open_description
+  | Tstr_class of (class_declaration * string list) list
+  | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
+  | Tstr_include of include_declaration
+  | Tstr_attribute of attribute
+
+and module_binding =
+    {
+     mb_id: Ident.t;
+     mb_name: string loc;
+     mb_expr: module_expr;
+     mb_attributes: attributes;
+     mb_loc: Location.t;
+    }
+
+and value_binding =
+  {
+    vb_pat: pattern;
+    vb_expr: expression;
+    vb_attributes: attributes;
+    vb_loc: Location.t;
+  }
+
+and module_coercion =
+    Tcoerce_none
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
+  | Tcoerce_functor of module_coercion * module_coercion
+  | Tcoerce_primitive of primitive_coercion
+  | Tcoerce_alias of Path.t * module_coercion
+
+and module_type =
+  { mty_desc: module_type_desc;
+    mty_type : Types.module_type;
+    mty_env : Env.t;
+    mty_loc: Location.t;
+    mty_attributes: attributes;
+   }
+
+and module_type_desc =
+    Tmty_ident of Path.t * Longident.t loc
+  | Tmty_signature of signature
+  | Tmty_functor of Ident.t * string loc * module_type option * module_type
+  | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
+  | Tmty_typeof of module_expr
+  | Tmty_alias of Path.t * Longident.t loc
+
+and primitive_coercion =
+  {
+    pc_desc: Primitive.description;
+    pc_type: type_expr;
+    pc_env: Env.t;
+    pc_loc : Location.t;
+  }
+
+and signature = {
+  sig_items : signature_item list;
+  sig_type : Types.signature;
+  sig_final_env : Env.t;
+}
+
+and signature_item =
+  { sig_desc: signature_item_desc;
+    sig_env : Env.t; (* BINANNOT ADDED *)
+    sig_loc: Location.t }
+
+and signature_item_desc =
+    Tsig_value of value_description
+  | Tsig_type of rec_flag * type_declaration list
+  | Tsig_typext of type_extension
+  | Tsig_exception of extension_constructor
+  | Tsig_module of module_declaration
+  | Tsig_recmodule of module_declaration list
+  | Tsig_modtype of module_type_declaration
+  | Tsig_open of open_description
+  | Tsig_include of include_description
+  | Tsig_class of class_description list
+  | Tsig_class_type of class_type_declaration list
+  | Tsig_attribute of attribute
+
+and module_declaration =
+    {
+     md_id: Ident.t;
+     md_name: string loc;
+     md_type: module_type;
+     md_attributes: attributes;
+     md_loc: Location.t;
+    }
+
+and module_type_declaration =
+    {
+     mtd_id: Ident.t;
+     mtd_name: string loc;
+     mtd_type: module_type option;
+     mtd_attributes: attributes;
+     mtd_loc: Location.t;
+    }
+
+and open_description =
+    {
+     open_path: Path.t;
+     open_txt: Longident.t loc;
+     open_override: override_flag;
+     open_loc: Location.t;
+     open_attributes: attribute list;
+    }
+
+and 'a include_infos =
+    {
+     incl_mod: 'a;
+     incl_type: Types.signature;
+     incl_loc: Location.t;
+     incl_attributes: attribute list;
+    }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
+and with_constraint =
+    Twith_type of type_declaration
+  | Twith_module of Path.t * Longident.t loc
+  | Twith_typesubst of type_declaration
+  | Twith_modsubst of Path.t * Longident.t loc
+
+and core_type =
+  { mutable ctyp_desc : core_type_desc;
+      (** mutable because of [Typeclass.declare_method] *)
+    mutable ctyp_type : type_expr;
+      (** mutable because of [Typeclass.declare_method] *)
+    ctyp_env : Env.t; (* BINANNOT ADDED *)
+    ctyp_loc : Location.t;
+    ctyp_attributes: attributes;
+   }
+
+and core_type_desc =
+    Ttyp_any
+  | Ttyp_var of string
+  | Ttyp_arrow of arg_label * core_type * core_type
+  | Ttyp_tuple of core_type list
+  | Ttyp_constr of Path.t * Longident.t loc * core_type list
+  | Ttyp_object of (string * attributes * core_type) list * closed_flag
+  | Ttyp_class of Path.t * Longident.t loc * core_type list
+  | Ttyp_alias of core_type * string
+  | Ttyp_variant of row_field list * closed_flag * label list option
+  | Ttyp_poly of string list * core_type
+  | Ttyp_package of package_type
+
+and package_type = {
+  pack_path : Path.t;
+  pack_fields : (Longident.t loc * core_type) list;
+  pack_type : Types.module_type;
+  pack_txt : Longident.t loc;
+}
+
+and row_field =
+    Ttag of label * attributes * bool * core_type list
+  | Tinherit of core_type
+
+and value_description =
+  { val_id: Ident.t;
+    val_name: string loc;
+    val_desc: core_type;
+    val_val: Types.value_description;
+    val_prim: string list;
+    val_loc: Location.t;
+    val_attributes: attributes;
+    }
+
+and type_declaration =
+  {
+    typ_id: Ident.t;
+    typ_name: string loc;
+    typ_params: (core_type * variance) list;
+    typ_type: Types.type_declaration;
+    typ_cstrs: (core_type * core_type * Location.t) list;
+    typ_kind: type_kind;
+    typ_private: private_flag;
+    typ_manifest: core_type option;
+    typ_loc: Location.t;
+    typ_attributes: attributes;
+   }
+
+and type_kind =
+    Ttype_abstract
+  | Ttype_variant of constructor_declaration list
+  | Ttype_record of label_declaration list
+  | Ttype_open
+
+and label_declaration =
+    {
+     ld_id: Ident.t;
+     ld_name: string loc;
+     ld_mutable: mutable_flag;
+     ld_type: core_type;
+     ld_loc: Location.t;
+     ld_attributes: attributes;
+    }
+
+and constructor_declaration =
+    {
+     cd_id: Ident.t;
+     cd_name: string loc;
+     cd_args: constructor_arguments;
+     cd_res: core_type option;
+     cd_loc: Location.t;
+     cd_attributes: attributes;
+    }
+
+and constructor_arguments =
+  | Cstr_tuple of core_type list
+  | Cstr_record of label_declaration list
+
+and type_extension =
+  {
+    tyext_path: Path.t;
+    tyext_txt: Longident.t loc;
+    tyext_params: (core_type * variance) list;
+    tyext_constructors: extension_constructor list;
+    tyext_private: private_flag;
+    tyext_attributes: attributes;
+  }
+
+and extension_constructor =
+  {
+    ext_id: Ident.t;
+    ext_name: string loc;
+    ext_type : Types.extension_constructor;
+    ext_kind : extension_constructor_kind;
+    ext_loc : Location.t;
+    ext_attributes: attributes;
+  }
+
+and extension_constructor_kind =
+    Text_decl of constructor_arguments * core_type option
+  | Text_rebind of Path.t * Longident.t loc
+
+and class_type =
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attributes;
+    }
+
+and class_type_desc =
+    Tcty_constr of Path.t * Longident.t loc * core_type list
+  | Tcty_signature of class_signature
+  | Tcty_arrow of arg_label * core_type * class_type
+
+and class_signature = {
+    csig_self : core_type;
+    csig_fields : class_type_field list;
+    csig_type : Types.class_signature;
+  }
+
+and class_type_field = {
+    ctf_desc: class_type_field_desc;
+    ctf_loc: Location.t;
+    ctf_attributes: attributes;
+  }
+
+and class_type_field_desc =
+  | Tctf_inherit of class_type
+  | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
+  | Tctf_method of (string * private_flag * virtual_flag * core_type)
+  | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
+
+and class_declaration =
+  class_expr class_infos
+
+and class_description =
+  class_type class_infos
+
+and class_type_declaration =
+  class_type class_infos
+
+and 'a class_infos =
+  { ci_virt: virtual_flag;
+    ci_params: (core_type * variance) list;
+    ci_id_name : string loc;
+    ci_id_class: Ident.t;
+    ci_id_class_type : Ident.t;
+    ci_id_object : Ident.t;
+    ci_id_typehash : Ident.t;
+    ci_expr: 'a;
+    ci_decl: Types.class_declaration;
+    ci_type_decl : Types.class_type_declaration;
+    ci_loc: Location.t;
+    ci_attributes: attributes;
+   }
+
+(* Auxiliary functions over the a.s.t. *)
+
+val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit
+val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc
+
+val let_bound_idents: value_binding list -> Ident.t list
+val rev_let_bound_idents: value_binding list -> Ident.t list
+
+val let_bound_idents_with_loc:
+    value_binding list -> (Ident.t * string loc) list
+
+(** Alpha conversion of patterns *)
+val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern
+
+val mknoloc: 'a -> 'a Asttypes.loc
+val mkloc: 'a -> Location.t -> 'a Asttypes.loc
+
+val pat_bound_idents: pattern -> Ident.t list
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
new file mode 100644
index 00000000..fd04e552
--- /dev/null
+++ b/typing/typedtreeIter.ml
@@ -0,0 +1,679 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*
+TODO:
+ - 2012/05/10: Follow camlp4 way of building map and iter using classes
+     and inheritance ?
+*)
+
+open Asttypes
+open Typedtree
+
+module type IteratorArgument = sig
+
+    val enter_structure : structure -> unit
+    val enter_value_description : value_description -> unit
+    val enter_type_extension : type_extension -> unit
+    val enter_extension_constructor : extension_constructor -> unit
+    val enter_pattern : pattern -> unit
+    val enter_expression : expression -> unit
+    val enter_package_type : package_type -> unit
+    val enter_signature : signature -> unit
+    val enter_signature_item : signature_item -> unit
+    val enter_module_type_declaration : module_type_declaration -> unit
+    val enter_module_type : module_type -> unit
+    val enter_module_expr : module_expr -> unit
+    val enter_with_constraint : with_constraint -> unit
+    val enter_class_expr : class_expr -> unit
+    val enter_class_signature : class_signature -> unit
+    val enter_class_declaration : class_declaration -> unit
+    val enter_class_description : class_description -> unit
+    val enter_class_type_declaration : class_type_declaration -> unit
+    val enter_class_type : class_type -> unit
+    val enter_class_type_field : class_type_field -> unit
+    val enter_core_type : core_type -> unit
+    val enter_class_structure : class_structure -> unit
+    val enter_class_field : class_field -> unit
+    val enter_structure_item : structure_item -> unit
+
+
+    val leave_structure : structure -> unit
+    val leave_value_description : value_description -> unit
+    val leave_type_extension : type_extension -> unit
+    val leave_extension_constructor : extension_constructor -> unit
+    val leave_pattern : pattern -> unit
+    val leave_expression : expression -> unit
+    val leave_package_type : package_type -> unit
+    val leave_signature : signature -> unit
+    val leave_signature_item : signature_item -> unit
+    val leave_module_type_declaration : module_type_declaration -> unit
+    val leave_module_type : module_type -> unit
+    val leave_module_expr : module_expr -> unit
+    val leave_with_constraint : with_constraint -> unit
+    val leave_class_expr : class_expr -> unit
+    val leave_class_signature : class_signature -> unit
+    val leave_class_declaration : class_declaration -> unit
+    val leave_class_description : class_description -> unit
+    val leave_class_type_declaration : class_type_declaration -> unit
+    val leave_class_type : class_type -> unit
+    val leave_class_type_field : class_type_field -> unit
+    val leave_core_type : core_type -> unit
+    val leave_class_structure : class_structure -> unit
+    val leave_class_field : class_field -> unit
+    val leave_structure_item : structure_item -> unit
+
+    val enter_bindings : rec_flag -> unit
+    val enter_binding : value_binding -> unit
+    val leave_binding : value_binding -> unit
+    val leave_bindings : rec_flag -> unit
+
+    val enter_type_declarations : rec_flag -> unit
+    val enter_type_declaration : type_declaration -> unit
+    val leave_type_declaration : type_declaration -> unit
+    val leave_type_declarations : rec_flag -> unit
+
+      end
+
+module MakeIterator(Iter : IteratorArgument) : sig
+
+    val iter_structure : structure -> unit
+    val iter_signature : signature -> unit
+    val iter_structure_item : structure_item -> unit
+    val iter_signature_item : signature_item -> unit
+    val iter_expression : expression -> unit
+    val iter_module_type : module_type -> unit
+    val iter_pattern : pattern -> unit
+    val iter_class_expr : class_expr -> unit
+
+  end = struct
+
+    let may_iter f v =
+      match v with
+        None -> ()
+      | Some x -> f x
+
+
+    let rec iter_structure str =
+      Iter.enter_structure str;
+      List.iter iter_structure_item str.str_items;
+      Iter.leave_structure str
+
+
+    and iter_binding vb =
+      Iter.enter_binding vb;
+      iter_pattern vb.vb_pat;
+      iter_expression vb.vb_expr;
+      Iter.leave_binding vb
+
+    and iter_bindings rec_flag list =
+      Iter.enter_bindings rec_flag;
+      List.iter iter_binding list;
+      Iter.leave_bindings rec_flag
+
+    and iter_case {c_lhs; c_guard; c_rhs} =
+      iter_pattern c_lhs;
+      may_iter iter_expression c_guard;
+      iter_expression c_rhs
+
+    and iter_cases cases =
+      List.iter iter_case cases
+
+    and iter_structure_item item =
+      Iter.enter_structure_item item;
+      begin
+        match item.str_desc with
+          Tstr_eval (exp, _attrs) -> iter_expression exp
+        | Tstr_value (rec_flag, list) ->
+            iter_bindings rec_flag list
+        | Tstr_primitive vd -> iter_value_description vd
+        | Tstr_type (rf, list) -> iter_type_declarations rf list
+        | Tstr_typext tyext -> iter_type_extension tyext
+        | Tstr_exception ext -> iter_extension_constructor ext
+        | Tstr_module x -> iter_module_binding x
+        | Tstr_recmodule list -> List.iter iter_module_binding list
+        | Tstr_modtype mtd -> iter_module_type_declaration mtd
+        | Tstr_open _ -> ()
+        | Tstr_class list ->
+            List.iter (fun (ci, _) -> iter_class_declaration ci) list
+        | Tstr_class_type list ->
+            List.iter
+              (fun (_, _, ct) -> iter_class_type_declaration ct)
+              list
+        | Tstr_include incl -> iter_module_expr incl.incl_mod
+        | Tstr_attribute _ ->
+            ()
+      end;
+      Iter.leave_structure_item item
+
+    and iter_module_binding x =
+      iter_module_expr x.mb_expr
+
+    and iter_value_description v =
+      Iter.enter_value_description v;
+      iter_core_type v.val_desc;
+      Iter.leave_value_description v
+
+    and iter_constructor_arguments = function
+      | Cstr_tuple l -> List.iter iter_core_type l
+      | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l
+
+    and iter_constructor_declaration cd =
+      iter_constructor_arguments cd.cd_args;
+      option iter_core_type cd.cd_res;
+
+    and iter_type_parameter (ct, _v) =
+      iter_core_type ct
+
+    and iter_type_declaration decl =
+      Iter.enter_type_declaration decl;
+      List.iter iter_type_parameter decl.typ_params;
+      List.iter (fun (ct1, ct2, _loc) ->
+          iter_core_type ct1;
+          iter_core_type ct2
+      ) decl.typ_cstrs;
+      begin match decl.typ_kind with
+          Ttype_abstract -> ()
+        | Ttype_variant list ->
+            List.iter iter_constructor_declaration list
+        | Ttype_record list ->
+            List.iter
+              (fun ld ->
+                iter_core_type ld.ld_type
+            ) list
+        | Ttype_open -> ()
+      end;
+      option iter_core_type decl.typ_manifest;
+      Iter.leave_type_declaration decl
+
+    and iter_type_declarations rec_flag decls =
+      Iter.enter_type_declarations rec_flag;
+      List.iter iter_type_declaration decls;
+      Iter.leave_type_declarations rec_flag
+
+    and iter_extension_constructor ext =
+      Iter.enter_extension_constructor ext;
+      begin match ext.ext_kind with
+          Text_decl(args, ret) ->
+          iter_constructor_arguments args;
+            option iter_core_type ret
+        | Text_rebind _ -> ()
+      end;
+      Iter.leave_extension_constructor ext;
+
+    and iter_type_extension tyext =
+      Iter.enter_type_extension tyext;
+      List.iter iter_type_parameter tyext.tyext_params;
+      List.iter iter_extension_constructor tyext.tyext_constructors;
+      Iter.leave_type_extension tyext
+
+    and iter_pattern pat =
+      Iter.enter_pattern pat;
+      List.iter (fun (cstr, _, _attrs) -> match cstr with
+              | Tpat_type _ -> ()
+              | Tpat_unpack -> ()
+              | Tpat_open _ -> ()
+              | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
+      begin
+        match pat.pat_desc with
+          Tpat_any -> ()
+        | Tpat_var _ -> ()
+        | Tpat_alias (pat1, _, _) -> iter_pattern pat1
+        | Tpat_constant _ -> ()
+        | Tpat_tuple list ->
+            List.iter iter_pattern list
+        | Tpat_construct (_, _, args) ->
+            List.iter iter_pattern args
+        | Tpat_variant (_, pato, _) ->
+            begin match pato with
+                None -> ()
+              | Some pat -> iter_pattern pat
+            end
+        | Tpat_record (list, _closed) ->
+            List.iter (fun (_, _, pat) -> iter_pattern pat) list
+        | Tpat_array list -> List.iter iter_pattern list
+        | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
+        | Tpat_lazy p -> iter_pattern p
+      end;
+      Iter.leave_pattern pat
+
+    and option f x = match x with None -> () | Some e -> f e
+
+    and iter_expression exp =
+      Iter.enter_expression exp;
+      List.iter (function (cstr, _, _attrs) ->
+        match cstr with
+          Texp_constraint ct ->
+            iter_core_type ct
+        | Texp_coerce (cty1, cty2) ->
+            option iter_core_type cty1; iter_core_type cty2
+        | Texp_open _ -> ()
+        | Texp_poly cto -> option iter_core_type cto
+        | Texp_newtype _ -> ())
+        exp.exp_extra;
+      begin
+        match exp.exp_desc with
+          Texp_ident _ -> ()
+        | Texp_constant _ -> ()
+        | Texp_let (rec_flag, list, exp) ->
+            iter_bindings rec_flag list;
+            iter_expression exp
+        | Texp_function { cases; _ } ->
+            iter_cases cases
+        | Texp_apply (exp, list) ->
+            iter_expression exp;
+            List.iter (fun (_label, expo) ->
+                match expo with
+                  None -> ()
+                | Some exp -> iter_expression exp
+            ) list
+        | Texp_match (exp, list1, list2, _) ->
+            iter_expression exp;
+            iter_cases list1;
+            iter_cases list2;
+        | Texp_try (exp, list) ->
+            iter_expression exp;
+            iter_cases list
+        | Texp_tuple list ->
+            List.iter iter_expression list
+        | Texp_construct (_, _, args) ->
+            List.iter iter_expression args
+        | Texp_variant (_label, expo) ->
+            begin match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+            end
+        | Texp_record { fields; extended_expression; _ } ->
+            Array.iter (function
+                | _, Kept _ -> ()
+                | _, Overridden (_, exp) -> iter_expression exp)
+              fields;
+            begin match extended_expression with
+                None -> ()
+              | Some exp -> iter_expression exp
+            end
+        | Texp_field (exp, _, _label) ->
+            iter_expression exp
+        | Texp_setfield (exp1, _, _label, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_array list ->
+            List.iter iter_expression list
+        | Texp_ifthenelse (exp1, exp2, expo) ->
+            iter_expression exp1;
+            iter_expression exp2;
+            begin match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+            end
+        | Texp_sequence (exp1, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_while (exp1, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_for (_id, _, exp1, exp2, _dir, exp3) ->
+            iter_expression exp1;
+            iter_expression exp2;
+            iter_expression exp3
+        | Texp_send (exp, _meth, expo) ->
+            iter_expression exp;
+          begin
+            match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+          end
+        | Texp_new _ -> ()
+        | Texp_instvar _ -> ()
+        | Texp_setinstvar (_, _, _, exp) ->
+            iter_expression exp
+        | Texp_override (_, list) ->
+            List.iter (fun (_path, _, exp) ->
+                iter_expression exp
+            ) list
+        | Texp_letmodule (_id, _, mexpr, exp) ->
+            iter_module_expr mexpr;
+            iter_expression exp
+        | Texp_letexception (cd, exp) ->
+            iter_extension_constructor cd;
+            iter_expression exp
+        | Texp_assert exp -> iter_expression exp
+        | Texp_lazy exp -> iter_expression exp
+        | Texp_object (cl, _) ->
+            iter_class_structure cl
+        | Texp_pack (mexpr) ->
+            iter_module_expr mexpr
+        | Texp_unreachable ->
+            ()
+        | Texp_extension_constructor _ ->
+            ()
+      end;
+      Iter.leave_expression exp;
+
+    and iter_package_type pack =
+      Iter.enter_package_type pack;
+      List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields;
+      Iter.leave_package_type pack;
+
+    and iter_signature sg =
+      Iter.enter_signature sg;
+      List.iter iter_signature_item sg.sig_items;
+      Iter.leave_signature sg;
+
+    and iter_signature_item item =
+      Iter.enter_signature_item item;
+      begin
+        match item.sig_desc with
+          Tsig_value vd ->
+            iter_value_description vd
+        | Tsig_type (rf, list) ->
+            iter_type_declarations rf list
+        | Tsig_exception ext ->
+            iter_extension_constructor ext
+        | Tsig_typext tyext ->
+            iter_type_extension tyext
+        | Tsig_module md ->
+            iter_module_type md.md_type
+        | Tsig_recmodule list ->
+            List.iter (fun md -> iter_module_type md.md_type) list
+        | Tsig_modtype mtd ->
+            iter_module_type_declaration mtd
+        | Tsig_open _ -> ()
+        | Tsig_include incl -> iter_module_type incl.incl_mod
+        | Tsig_class list ->
+            List.iter iter_class_description list
+        | Tsig_class_type list ->
+            List.iter iter_class_type_declaration list
+        | Tsig_attribute _ -> ()
+      end;
+      Iter.leave_signature_item item;
+
+    and iter_module_type_declaration mtd =
+      Iter.enter_module_type_declaration mtd;
+      begin
+        match mtd.mtd_type with
+        | None -> ()
+        | Some mtype -> iter_module_type mtype
+      end;
+      Iter.leave_module_type_declaration mtd
+
+    and iter_class_declaration cd =
+      Iter.enter_class_declaration cd;
+      List.iter iter_type_parameter cd.ci_params;
+      iter_class_expr cd.ci_expr;
+      Iter.leave_class_declaration cd;
+
+    and iter_class_description cd =
+      Iter.enter_class_description cd;
+      List.iter iter_type_parameter cd.ci_params;
+      iter_class_type cd.ci_expr;
+      Iter.leave_class_description cd;
+
+    and iter_class_type_declaration cd =
+      Iter.enter_class_type_declaration cd;
+      List.iter iter_type_parameter cd.ci_params;
+      iter_class_type cd.ci_expr;
+      Iter.leave_class_type_declaration cd;
+
+    and iter_module_type mty =
+      Iter.enter_module_type mty;
+      begin
+        match mty.mty_desc with
+          Tmty_ident _ -> ()
+        | Tmty_alias _ -> ()
+        | Tmty_signature sg -> iter_signature sg
+        | Tmty_functor (_, _, mtype1, mtype2) ->
+            Misc.may iter_module_type mtype1; iter_module_type mtype2
+        | Tmty_with (mtype, list) ->
+            iter_module_type mtype;
+            List.iter (fun (_path, _, withc) ->
+                iter_with_constraint withc
+            ) list
+        | Tmty_typeof mexpr ->
+            iter_module_expr mexpr
+      end;
+      Iter.leave_module_type mty;
+
+    and iter_with_constraint cstr =
+      Iter.enter_with_constraint cstr;
+      begin
+        match cstr with
+          Twith_type decl -> iter_type_declaration decl
+        | Twith_module _ -> ()
+        | Twith_typesubst decl -> iter_type_declaration decl
+        | Twith_modsubst _ -> ()
+      end;
+      Iter.leave_with_constraint cstr;
+
+    and iter_module_expr mexpr =
+      Iter.enter_module_expr mexpr;
+      begin
+        match mexpr.mod_desc with
+          Tmod_ident _ -> ()
+        | Tmod_structure st -> iter_structure st
+        | Tmod_functor (_, _, mtype, mexpr) ->
+            Misc.may iter_module_type mtype;
+            iter_module_expr mexpr
+        | Tmod_apply (mexp1, mexp2, _) ->
+            iter_module_expr mexp1;
+            iter_module_expr mexp2
+        | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
+            iter_module_expr mexpr
+        | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+            iter_module_expr mexpr;
+            iter_module_type mtype
+        | Tmod_unpack (exp, _mty) ->
+            iter_expression exp
+(*          iter_module_type mty *)
+      end;
+      Iter.leave_module_expr mexpr;
+
+    and iter_class_expr cexpr =
+      Iter.enter_class_expr cexpr;
+      begin
+        match cexpr.cl_desc with
+        | Tcl_constraint (cl, None, _, _, _ ) ->
+            iter_class_expr cl;
+        | Tcl_structure clstr -> iter_class_structure clstr
+        | Tcl_fun (_label, pat, priv, cl, _partial) ->
+          iter_pattern pat;
+          List.iter (fun (_id, _, exp) -> iter_expression exp) priv;
+          iter_class_expr cl
+
+        | Tcl_apply (cl, args) ->
+            iter_class_expr cl;
+            List.iter (fun (_label, expo) ->
+                match expo with
+                  None -> ()
+                | Some exp -> iter_expression exp
+            ) args
+
+        | Tcl_let (rec_flat, bindings, ivars, cl) ->
+          iter_bindings rec_flat bindings;
+          List.iter (fun (_id, _, exp) -> iter_expression exp) ivars;
+            iter_class_expr cl
+
+        | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+            iter_class_expr cl;
+            iter_class_type clty
+
+        | Tcl_ident (_, _, tyl) ->
+            List.iter iter_core_type tyl
+      end;
+      Iter.leave_class_expr cexpr;
+
+    and iter_class_type ct =
+      Iter.enter_class_type ct;
+      begin
+        match ct.cltyp_desc with
+          Tcty_signature csg -> iter_class_signature csg
+        | Tcty_constr (_path, _, list) ->
+            List.iter iter_core_type list
+        | Tcty_arrow (_label, ct, cl) ->
+            iter_core_type ct;
+            iter_class_type cl
+      end;
+      Iter.leave_class_type ct;
+
+    and iter_class_signature cs =
+      Iter.enter_class_signature cs;
+      iter_core_type cs.csig_self;
+      List.iter iter_class_type_field cs.csig_fields;
+      Iter.leave_class_signature cs
+
+
+    and iter_class_type_field ctf =
+      Iter.enter_class_type_field ctf;
+      begin
+        match ctf.ctf_desc with
+          Tctf_inherit ct -> iter_class_type ct
+        | Tctf_val (_s, _mut, _virt, ct) ->
+            iter_core_type ct
+        | Tctf_method (_s, _priv, _virt, ct) ->
+            iter_core_type ct
+        | Tctf_constraint  (ct1, ct2) ->
+            iter_core_type ct1;
+            iter_core_type ct2
+        | Tctf_attribute _ -> ()
+      end;
+      Iter.leave_class_type_field ctf
+
+    and iter_core_type ct =
+      Iter.enter_core_type ct;
+      begin
+        match ct.ctyp_desc with
+          Ttyp_any -> ()
+        | Ttyp_var _ -> ()
+        | Ttyp_arrow (_label, ct1, ct2) ->
+            iter_core_type ct1;
+            iter_core_type ct2
+        | Ttyp_tuple list -> List.iter iter_core_type list
+        | Ttyp_constr (_path, _, list) ->
+            List.iter iter_core_type list
+        | Ttyp_object (list, _o) ->
+            List.iter (fun (_, _, t) -> iter_core_type t) list
+        | Ttyp_class (_path, _, list) ->
+            List.iter iter_core_type list
+        | Ttyp_alias (ct, _s) ->
+            iter_core_type ct
+        | Ttyp_variant (list, _bool, _labels) ->
+            List.iter iter_row_field list
+        | Ttyp_poly (_list, ct) -> iter_core_type ct
+        | Ttyp_package pack -> iter_package_type pack
+      end;
+      Iter.leave_core_type ct
+
+    and iter_class_structure cs =
+      Iter.enter_class_structure cs;
+      iter_pattern cs.cstr_self;
+      List.iter iter_class_field cs.cstr_fields;
+      Iter.leave_class_structure cs;
+
+
+    and iter_row_field rf =
+      match rf with
+        Ttag (_label, _attrs, _bool, list) ->
+          List.iter iter_core_type list
+      | Tinherit ct -> iter_core_type ct
+
+    and iter_class_field cf =
+      Iter.enter_class_field cf;
+      begin
+        match cf.cf_desc with
+          Tcf_inherit (_ovf, cl, _super, _vals, _meths) ->
+          iter_class_expr cl
+      | Tcf_constraint (cty, cty') ->
+          iter_core_type cty;
+          iter_core_type cty'
+      | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) ->
+          iter_core_type cty
+      | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) ->
+          iter_expression exp
+      | Tcf_method (_lab, _, Tcfk_virtual cty) ->
+          iter_core_type cty
+      | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) ->
+          iter_expression exp
+      | Tcf_initializer exp ->
+          iter_expression exp
+      | Tcf_attribute _ -> ()
+      end;
+      Iter.leave_class_field cf;
+  end
+
+module DefaultIteratorArgument = struct
+
+      let enter_structure _ = ()
+      let enter_value_description _ = ()
+      let enter_type_extension _ = ()
+      let enter_extension_constructor _ = ()
+      let enter_pattern _ = ()
+      let enter_expression _ = ()
+      let enter_package_type _ = ()
+      let enter_signature _ = ()
+      let enter_signature_item _ = ()
+      let enter_module_type_declaration _ = ()
+      let enter_module_type _ = ()
+      let enter_module_expr _ = ()
+      let enter_with_constraint _ = ()
+      let enter_class_expr _ = ()
+      let enter_class_signature _ = ()
+      let enter_class_declaration _ = ()
+      let enter_class_description _ = ()
+      let enter_class_type_declaration _ = ()
+      let enter_class_type _ = ()
+      let enter_class_type_field _ = ()
+      let enter_core_type _ = ()
+      let enter_class_structure _ = ()
+    let enter_class_field _ = ()
+    let enter_structure_item _ = ()
+
+
+      let leave_structure _ = ()
+      let leave_value_description _ = ()
+      let leave_type_extension _ = ()
+      let leave_extension_constructor _ = ()
+      let leave_pattern _ = ()
+      let leave_expression _ = ()
+      let leave_package_type _ = ()
+      let leave_signature _ = ()
+      let leave_signature_item _ = ()
+      let leave_module_type_declaration _ = ()
+      let leave_module_type _ = ()
+      let leave_module_expr _ = ()
+      let leave_with_constraint _ = ()
+      let leave_class_expr _ = ()
+      let leave_class_signature _ = ()
+      let leave_class_declaration _ = ()
+      let leave_class_description _ = ()
+      let leave_class_type_declaration _ = ()
+      let leave_class_type _ = ()
+      let leave_class_type_field _ = ()
+      let leave_core_type _ = ()
+      let leave_class_structure _ = ()
+    let leave_class_field _ = ()
+    let leave_structure_item _ = ()
+
+    let enter_binding _ = ()
+    let leave_binding _ = ()
+
+    let enter_bindings _ = ()
+    let leave_bindings _ = ()
+
+    let enter_type_declaration _ = ()
+    let leave_type_declaration _ = ()
+
+    let enter_type_declarations _ = ()
+    let leave_type_declarations _ = ()
+end
diff --git a/typing/typedtreeIter.mli b/typing/typedtreeIter.mli
new file mode 100644
index 00000000..53aa54c1
--- /dev/null
+++ b/typing/typedtreeIter.mli
@@ -0,0 +1,97 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+
+module type IteratorArgument = sig
+    val enter_structure : structure -> unit
+    val enter_value_description : value_description -> unit
+    val enter_type_extension : type_extension -> unit
+    val enter_extension_constructor : extension_constructor -> unit
+    val enter_pattern : pattern -> unit
+    val enter_expression : expression -> unit
+    val enter_package_type : package_type -> unit
+    val enter_signature : signature -> unit
+    val enter_signature_item : signature_item -> unit
+    val enter_module_type_declaration : module_type_declaration -> unit
+    val enter_module_type : module_type -> unit
+    val enter_module_expr : module_expr -> unit
+    val enter_with_constraint : with_constraint -> unit
+    val enter_class_expr : class_expr -> unit
+    val enter_class_signature : class_signature -> unit
+    val enter_class_declaration : class_declaration -> unit
+    val enter_class_description : class_description -> unit
+    val enter_class_type_declaration : class_type_declaration -> unit
+    val enter_class_type : class_type -> unit
+    val enter_class_type_field : class_type_field -> unit
+    val enter_core_type : core_type -> unit
+    val enter_class_structure : class_structure -> unit
+    val enter_class_field : class_field -> unit
+    val enter_structure_item : structure_item -> unit
+
+
+    val leave_structure : structure -> unit
+    val leave_value_description : value_description -> unit
+    val leave_type_extension : type_extension -> unit
+    val leave_extension_constructor : extension_constructor -> unit
+    val leave_pattern : pattern -> unit
+    val leave_expression : expression -> unit
+    val leave_package_type : package_type -> unit
+    val leave_signature : signature -> unit
+    val leave_signature_item : signature_item -> unit
+    val leave_module_type_declaration : module_type_declaration -> unit
+    val leave_module_type : module_type -> unit
+    val leave_module_expr : module_expr -> unit
+    val leave_with_constraint : with_constraint -> unit
+    val leave_class_expr : class_expr -> unit
+    val leave_class_signature : class_signature -> unit
+    val leave_class_declaration : class_declaration -> unit
+    val leave_class_description : class_description -> unit
+    val leave_class_type_declaration : class_type_declaration -> unit
+    val leave_class_type : class_type -> unit
+    val leave_class_type_field : class_type_field -> unit
+    val leave_core_type : core_type -> unit
+    val leave_class_structure : class_structure -> unit
+    val leave_class_field : class_field -> unit
+    val leave_structure_item : structure_item -> unit
+
+    val enter_bindings : rec_flag -> unit
+    val enter_binding : value_binding -> unit
+    val leave_binding : value_binding -> unit
+    val leave_bindings : rec_flag -> unit
+
+    val enter_type_declarations : rec_flag -> unit
+    val enter_type_declaration : type_declaration -> unit
+    val leave_type_declaration : type_declaration -> unit
+    val leave_type_declarations : rec_flag -> unit
+
+end
+
+module MakeIterator :
+  functor (Iter : IteratorArgument) ->
+    sig
+      val iter_structure : structure -> unit
+      val iter_signature : signature -> unit
+      val iter_structure_item : structure_item -> unit
+      val iter_signature_item : signature_item -> unit
+      val iter_expression : expression -> unit
+      val iter_module_type : module_type -> unit
+      val iter_pattern : pattern -> unit
+      val iter_class_expr : class_expr -> unit
+    end
+
+module DefaultIteratorArgument : IteratorArgument
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
new file mode 100644
index 00000000..58249be2
--- /dev/null
+++ b/typing/typedtreeMap.ml
@@ -0,0 +1,722 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree
+
+module type MapArgument = sig
+  val enter_structure : structure -> structure
+  val enter_value_description : value_description -> value_description
+  val enter_type_declaration : type_declaration -> type_declaration
+  val enter_type_extension : type_extension -> type_extension
+  val enter_extension_constructor :
+    extension_constructor -> extension_constructor
+  val enter_pattern : pattern -> pattern
+  val enter_expression : expression -> expression
+  val enter_package_type : package_type -> package_type
+  val enter_signature : signature -> signature
+  val enter_signature_item : signature_item -> signature_item
+  val enter_module_type_declaration :
+      module_type_declaration -> module_type_declaration
+  val enter_module_type : module_type -> module_type
+  val enter_module_expr : module_expr -> module_expr
+  val enter_with_constraint : with_constraint -> with_constraint
+  val enter_class_expr : class_expr -> class_expr
+  val enter_class_signature : class_signature -> class_signature
+  val enter_class_declaration : class_declaration -> class_declaration
+  val enter_class_description : class_description -> class_description
+  val enter_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val enter_class_type : class_type -> class_type
+  val enter_class_type_field : class_type_field -> class_type_field
+  val enter_core_type : core_type -> core_type
+  val enter_class_structure : class_structure -> class_structure
+  val enter_class_field : class_field -> class_field
+  val enter_structure_item : structure_item -> structure_item
+
+  val leave_structure : structure -> structure
+  val leave_value_description : value_description -> value_description
+  val leave_type_declaration : type_declaration -> type_declaration
+  val leave_type_extension : type_extension -> type_extension
+  val leave_extension_constructor :
+    extension_constructor -> extension_constructor
+  val leave_pattern : pattern -> pattern
+  val leave_expression : expression -> expression
+  val leave_package_type : package_type -> package_type
+  val leave_signature : signature -> signature
+  val leave_signature_item : signature_item -> signature_item
+  val leave_module_type_declaration :
+      module_type_declaration -> module_type_declaration
+  val leave_module_type : module_type -> module_type
+  val leave_module_expr : module_expr -> module_expr
+  val leave_with_constraint : with_constraint -> with_constraint
+  val leave_class_expr : class_expr -> class_expr
+  val leave_class_signature : class_signature -> class_signature
+  val leave_class_declaration : class_declaration -> class_declaration
+  val leave_class_description : class_description -> class_description
+  val leave_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val leave_class_type : class_type -> class_type
+  val leave_class_type_field : class_type_field -> class_type_field
+  val leave_core_type : core_type -> core_type
+  val leave_class_structure : class_structure -> class_structure
+  val leave_class_field : class_field -> class_field
+  val leave_structure_item : structure_item -> structure_item
+
+end
+
+
+module MakeMap(Map : MapArgument) = struct
+
+  open Misc
+
+  let rec map_structure str =
+    let str = Map.enter_structure str in
+    let str_items = List.map map_structure_item str.str_items in
+    Map.leave_structure { str with str_items = str_items }
+
+  and map_binding vb =
+    {
+      vb_pat = map_pattern vb.vb_pat;
+      vb_expr = map_expression vb.vb_expr;
+      vb_attributes = vb.vb_attributes;
+      vb_loc = vb.vb_loc;
+    }
+
+  and map_bindings list =
+    List.map map_binding list
+
+  and map_case {c_lhs; c_guard; c_rhs} =
+    {
+     c_lhs = map_pattern c_lhs;
+     c_guard = may_map map_expression c_guard;
+     c_rhs = map_expression c_rhs;
+    }
+
+  and map_cases list =
+    List.map map_case list
+
+  and map_structure_item item =
+    let item = Map.enter_structure_item item in
+    let str_desc =
+      match item.str_desc with
+          Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs)
+        | Tstr_value (rec_flag, list) ->
+          Tstr_value (rec_flag, map_bindings list)
+        | Tstr_primitive vd ->
+          Tstr_primitive (map_value_description vd)
+        | Tstr_type (rf, list) ->
+          Tstr_type (rf, List.map map_type_declaration list)
+        | Tstr_typext tyext ->
+          Tstr_typext (map_type_extension tyext)
+        | Tstr_exception ext ->
+          Tstr_exception (map_extension_constructor ext)
+        | Tstr_module x ->
+          Tstr_module (map_module_binding x)
+        | Tstr_recmodule list ->
+          let list = List.map map_module_binding list in
+          Tstr_recmodule list
+        | Tstr_modtype mtd ->
+          Tstr_modtype (map_module_type_declaration mtd)
+        | Tstr_open od -> Tstr_open od
+        | Tstr_class list ->
+          let list =
+            List.map
+              (fun (ci, string_list) ->
+                 map_class_declaration ci, string_list)
+              list
+          in
+            Tstr_class list
+        | Tstr_class_type list ->
+          let list =
+            List.map
+              (fun (id, name, ct) ->
+               id, name, map_class_type_declaration ct)
+              list
+          in
+            Tstr_class_type list
+        | Tstr_include incl ->
+          Tstr_include {incl with incl_mod = map_module_expr incl.incl_mod}
+        | Tstr_attribute x -> Tstr_attribute x
+    in
+    Map.leave_structure_item { item with str_desc = str_desc}
+
+  and map_module_binding x =
+    {x with mb_expr = map_module_expr x.mb_expr}
+
+  and map_value_description v =
+    let v = Map.enter_value_description v in
+    let val_desc = map_core_type v.val_desc in
+    Map.leave_value_description { v with val_desc = val_desc }
+
+  and map_type_declaration decl =
+    let decl = Map.enter_type_declaration decl in
+    let typ_params = List.map map_type_parameter decl.typ_params in
+    let typ_cstrs = List.map (fun (ct1, ct2, loc) ->
+      (map_core_type ct1,
+       map_core_type ct2,
+       loc)
+    ) decl.typ_cstrs in
+    let typ_kind = match decl.typ_kind with
+        Ttype_abstract -> Ttype_abstract
+      | Ttype_variant list ->
+          let list = List.map map_constructor_declaration list in
+          Ttype_variant list
+      | Ttype_record list ->
+        let list =
+          List.map
+            (fun ld ->
+              {ld with ld_type = map_core_type ld.ld_type}
+            ) list
+        in
+        Ttype_record list
+      | Ttype_open -> Ttype_open
+    in
+    let typ_manifest = may_map map_core_type decl.typ_manifest in
+    Map.leave_type_declaration { decl with typ_params = typ_params;
+      typ_cstrs = typ_cstrs; typ_kind = typ_kind; typ_manifest = typ_manifest }
+
+  and map_type_parameter (ct, v) = (map_core_type ct, v)
+
+  and map_constructor_arguments = function
+    | Cstr_tuple l ->
+        Cstr_tuple (List.map map_core_type l)
+    | Cstr_record l ->
+        Cstr_record
+          (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type})
+             l)
+
+  and map_constructor_declaration cd =
+    let cd_args = map_constructor_arguments cd.cd_args in
+    {cd with cd_args;
+     cd_res = may_map map_core_type cd.cd_res
+    }
+
+  and map_type_extension tyext =
+    let tyext = Map.enter_type_extension tyext in
+    let tyext_params = List.map map_type_parameter tyext.tyext_params in
+    let tyext_constructors  =
+      List.map map_extension_constructor tyext.tyext_constructors
+    in
+    Map.leave_type_extension { tyext with tyext_params = tyext_params;
+      tyext_constructors = tyext_constructors }
+
+  and map_extension_constructor ext =
+    let ext = Map.enter_extension_constructor ext in
+    let ext_kind = match ext.ext_kind with
+        Text_decl(args, ret) ->
+          let args = map_constructor_arguments args in
+          let ret = may_map map_core_type ret in
+            Text_decl(args, ret)
+      | Text_rebind(p, lid) -> Text_rebind(p, lid)
+    in
+    Map.leave_extension_constructor {ext with ext_kind = ext_kind}
+
+  and map_pattern pat =
+    let pat = Map.enter_pattern pat in
+    let pat_desc =
+      match pat.pat_desc with
+        | Tpat_alias (pat1, p, text) ->
+          let pat1 = map_pattern pat1 in
+          Tpat_alias (pat1, p, text)
+        | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
+        | Tpat_construct (lid, cstr_decl, args) ->
+          Tpat_construct (lid, cstr_decl,
+                          List.map map_pattern args)
+        | Tpat_variant (label, pato, rowo) ->
+          let pato = match pato with
+              None -> pato
+            | Some pat -> Some (map_pattern pat)
+          in
+          Tpat_variant (label, pato, rowo)
+        | Tpat_record (list, closed) ->
+          Tpat_record (List.map (fun (lid, lab_desc, pat) ->
+            (lid, lab_desc, map_pattern pat) ) list, closed)
+        | Tpat_array list -> Tpat_array (List.map map_pattern list)
+        | Tpat_or (p1, p2, rowo) ->
+          Tpat_or (map_pattern p1, map_pattern p2, rowo)
+        | Tpat_lazy p -> Tpat_lazy (map_pattern p)
+        | Tpat_constant _
+        | Tpat_any
+        | Tpat_var _ -> pat.pat_desc
+
+    in
+    let pat_extra = List.map map_pat_extra pat.pat_extra in
+    Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra }
+
+  and map_pat_extra pat_extra =
+    match pat_extra with
+      | Tpat_constraint ct, loc, attrs ->
+          (Tpat_constraint (map_core_type  ct), loc, attrs)
+      | (Tpat_type _ | Tpat_unpack | Tpat_open _ ), _, _ -> pat_extra
+
+  and map_expression exp =
+    let exp = Map.enter_expression exp in
+    let exp_desc =
+      match exp.exp_desc with
+          Texp_ident (_, _, _)
+        | Texp_constant _ -> exp.exp_desc
+        | Texp_let (rec_flag, list, exp) ->
+          Texp_let (rec_flag,
+                    map_bindings list,
+                    map_expression exp)
+        | Texp_function { arg_label; param; cases; partial; } ->
+          Texp_function { arg_label; param; cases = map_cases cases; partial; }
+        | Texp_apply (exp, list) ->
+          Texp_apply (map_expression exp,
+                      List.map (fun (label, expo) ->
+                        let expo =
+                          match expo with
+                              None -> expo
+                            | Some exp -> Some (map_expression exp)
+                        in
+                        (label, expo)
+                      ) list )
+        | Texp_match (exp, list1, list2, partial) ->
+          Texp_match (
+            map_expression exp,
+            map_cases list1,
+            map_cases list2,
+            partial
+          )
+        | Texp_try (exp, list) ->
+          Texp_try (
+            map_expression exp,
+            map_cases list
+          )
+        | Texp_tuple list ->
+          Texp_tuple (List.map map_expression list)
+        | Texp_construct (lid, cstr_desc, args) ->
+          Texp_construct (lid, cstr_desc,
+                          List.map map_expression args )
+        | Texp_variant (label, expo) ->
+          let expo =match expo with
+              None -> expo
+            | Some exp -> Some (map_expression exp)
+          in
+          Texp_variant (label, expo)
+        | Texp_record { fields; representation; extended_expression } ->
+          let fields =
+            Array.map (function
+                | label, Kept t -> label, Kept t
+                | label, Overridden (lid, exp) ->
+                    label, Overridden (lid, map_expression exp))
+              fields
+          in
+          let extended_expression = match extended_expression with
+              None -> extended_expression
+            | Some exp -> Some (map_expression exp)
+          in
+          Texp_record { fields; representation; extended_expression }
+        | Texp_field (exp, lid, label) ->
+          Texp_field (map_expression exp, lid, label)
+        | Texp_setfield (exp1, lid, label, exp2) ->
+          Texp_setfield (
+            map_expression exp1,
+            lid,
+            label,
+            map_expression exp2)
+        | Texp_array list ->
+          Texp_array (List.map map_expression list)
+        | Texp_ifthenelse (exp1, exp2, expo) ->
+          Texp_ifthenelse (
+            map_expression exp1,
+            map_expression exp2,
+            match expo with
+                None -> expo
+              | Some exp -> Some (map_expression exp)
+          )
+        | Texp_sequence (exp1, exp2) ->
+          Texp_sequence (
+            map_expression exp1,
+            map_expression exp2
+          )
+        | Texp_while (exp1, exp2) ->
+          Texp_while (
+            map_expression exp1,
+            map_expression exp2
+          )
+        | Texp_for (id, name, exp1, exp2, dir, exp3) ->
+          Texp_for (
+            id, name,
+            map_expression exp1,
+            map_expression exp2,
+            dir,
+            map_expression exp3
+          )
+        | Texp_send (exp, meth, expo) ->
+          Texp_send (map_expression exp, meth, may_map map_expression expo)
+        | Texp_new _ -> exp.exp_desc
+        | Texp_instvar _ -> exp.exp_desc
+        | Texp_setinstvar (path, lid, path2, exp) ->
+          Texp_setinstvar (path, lid, path2, map_expression exp)
+        | Texp_override (path, list) ->
+          Texp_override (
+            path,
+            List.map (fun (path, lid, exp) ->
+              (path, lid, map_expression exp)
+            ) list
+          )
+        | Texp_letmodule (id, name, mexpr, exp) ->
+          Texp_letmodule (
+            id, name,
+            map_module_expr mexpr,
+            map_expression exp
+          )
+        | Texp_letexception (cd, exp) ->
+          Texp_letexception (
+            map_extension_constructor cd,
+            map_expression exp
+          )
+        | Texp_assert exp -> Texp_assert (map_expression exp)
+        | Texp_lazy exp -> Texp_lazy (map_expression exp)
+        | Texp_object (cl, string_list) ->
+          Texp_object (map_class_structure cl, string_list)
+        | Texp_pack (mexpr) ->
+          Texp_pack (map_module_expr mexpr)
+        | Texp_unreachable ->
+          Texp_unreachable
+        | Texp_extension_constructor _ as e ->
+          e
+    in
+    let exp_extra = List.map map_exp_extra exp.exp_extra in
+    Map.leave_expression {
+      exp with
+        exp_desc = exp_desc;
+        exp_extra = exp_extra; }
+
+  and map_exp_extra ((desc, loc, attrs) as exp_extra) =
+    match desc with
+      | Texp_constraint ct ->
+        Texp_constraint (map_core_type ct), loc, attrs
+      | Texp_coerce (None, ct) ->
+        Texp_coerce (None, map_core_type ct), loc, attrs
+      | Texp_coerce (Some ct1, ct2) ->
+        Texp_coerce (Some (map_core_type ct1),
+                         map_core_type ct2), loc, attrs
+      | Texp_poly (Some ct) ->
+        Texp_poly (Some ( map_core_type ct )), loc, attrs
+      | Texp_newtype _
+      | Texp_open _
+      | Texp_poly None -> exp_extra
+
+
+  and map_package_type pack =
+    let pack = Map.enter_package_type pack in
+    let pack_fields = List.map (
+      fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in
+    Map.leave_package_type { pack with pack_fields = pack_fields }
+
+  and map_signature sg =
+    let sg = Map.enter_signature sg in
+    let sig_items = List.map map_signature_item sg.sig_items in
+    Map.leave_signature { sg with sig_items = sig_items }
+
+  and map_signature_item item =
+    let item = Map.enter_signature_item item in
+    let sig_desc =
+      match item.sig_desc with
+          Tsig_value vd ->
+            Tsig_value (map_value_description vd)
+        | Tsig_type (rf, list) ->
+            Tsig_type (rf, List.map map_type_declaration list)
+        | Tsig_typext tyext ->
+            Tsig_typext (map_type_extension tyext)
+        | Tsig_exception ext ->
+            Tsig_exception (map_extension_constructor ext)
+        | Tsig_module md ->
+            Tsig_module {md with md_type = map_module_type md.md_type}
+        | Tsig_recmodule list ->
+            Tsig_recmodule
+                (List.map
+                   (fun md -> {md with md_type = map_module_type md.md_type})
+                   list
+                )
+        | Tsig_modtype mtd ->
+            Tsig_modtype (map_module_type_declaration mtd)
+        | Tsig_open _ -> item.sig_desc
+        | Tsig_include incl ->
+            Tsig_include {incl with incl_mod = map_module_type incl.incl_mod}
+        | Tsig_class list -> Tsig_class (List.map map_class_description list)
+        | Tsig_class_type list ->
+            Tsig_class_type (List.map map_class_type_declaration list)
+        | Tsig_attribute _ as x -> x
+    in
+    Map.leave_signature_item { item with sig_desc = sig_desc }
+
+  and map_module_type_declaration mtd =
+    let mtd = Map.enter_module_type_declaration mtd in
+    let mtd = {mtd with mtd_type = may_map map_module_type mtd.mtd_type} in
+    Map.leave_module_type_declaration mtd
+
+  and map_class_declaration cd =
+    let cd = Map.enter_class_declaration cd in
+    let ci_params = List.map map_type_parameter cd.ci_params in
+    let ci_expr = map_class_expr cd.ci_expr in
+    Map.leave_class_declaration
+      { cd with ci_params = ci_params; ci_expr = ci_expr }
+
+  and map_class_description cd =
+    let cd = Map.enter_class_description cd in
+    let ci_params = List.map map_type_parameter cd.ci_params in
+    let ci_expr = map_class_type cd.ci_expr in
+    Map.leave_class_description
+      { cd with ci_params = ci_params; ci_expr = ci_expr}
+
+  and map_class_type_declaration cd =
+    let cd = Map.enter_class_type_declaration cd in
+    let ci_params = List.map map_type_parameter cd.ci_params in
+    let ci_expr = map_class_type cd.ci_expr in
+    Map.leave_class_type_declaration
+      { cd with ci_params = ci_params; ci_expr = ci_expr }
+
+  and map_module_type mty =
+    let mty = Map.enter_module_type mty in
+    let mty_desc =
+      match mty.mty_desc with
+          Tmty_ident _ -> mty.mty_desc
+        | Tmty_alias _ -> mty.mty_desc
+        | Tmty_signature sg -> Tmty_signature (map_signature sg)
+        | Tmty_functor (id, name, mtype1, mtype2) ->
+          Tmty_functor (id, name, Misc.may_map map_module_type mtype1,
+                        map_module_type mtype2)
+        | Tmty_with (mtype, list) ->
+          Tmty_with (map_module_type mtype,
+                     List.map (fun (path, lid, withc) ->
+                       (path, lid, map_with_constraint withc)
+                     ) list)
+        | Tmty_typeof mexpr ->
+          Tmty_typeof (map_module_expr mexpr)
+    in
+    Map.leave_module_type { mty with mty_desc = mty_desc}
+
+  and map_with_constraint cstr =
+    let cstr = Map.enter_with_constraint cstr in
+    let cstr =
+      match cstr with
+          Twith_type decl -> Twith_type (map_type_declaration decl)
+        | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
+        | Twith_module _ -> cstr
+        | Twith_modsubst _ -> cstr
+    in
+    Map.leave_with_constraint cstr
+
+  and map_module_expr mexpr =
+    let mexpr = Map.enter_module_expr mexpr in
+    let mod_desc =
+      match mexpr.mod_desc with
+          Tmod_ident _ -> mexpr.mod_desc
+        | Tmod_structure st -> Tmod_structure (map_structure st)
+        | Tmod_functor (id, name, mtype, mexpr) ->
+          Tmod_functor (id, name, Misc.may_map map_module_type mtype,
+                        map_module_expr mexpr)
+        | Tmod_apply (mexp1, mexp2, coercion) ->
+          Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)
+        | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) ->
+          Tmod_constraint (map_module_expr mexpr, mod_type,
+                           Tmodtype_implicit, coercion)
+        | Tmod_constraint (mexpr, mod_type,
+                           Tmodtype_explicit mtype, coercion) ->
+          Tmod_constraint (map_module_expr mexpr, mod_type,
+                           Tmodtype_explicit (map_module_type mtype),
+                           coercion)
+        | Tmod_unpack (exp, mod_type) ->
+          Tmod_unpack (map_expression exp, mod_type)
+    in
+    Map.leave_module_expr { mexpr with mod_desc = mod_desc }
+
+  and map_class_expr cexpr =
+    let cexpr = Map.enter_class_expr cexpr in
+    let cl_desc =
+      match cexpr.cl_desc with
+        | Tcl_constraint (cl, None, string_list1, string_list2, concr ) ->
+          Tcl_constraint (map_class_expr cl, None, string_list1,
+                          string_list2, concr)
+        | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr)
+        | Tcl_fun (label, pat, priv, cl, partial) ->
+          Tcl_fun (label, map_pattern pat,
+                   List.map (fun (id, name, exp) ->
+                     (id, name, map_expression exp)) priv,
+                   map_class_expr cl, partial)
+
+        | Tcl_apply (cl, args) ->
+          Tcl_apply (map_class_expr cl,
+                     List.map (fun (label, expo) ->
+                       (label, may_map map_expression expo)
+                     ) args)
+        | Tcl_let (rec_flag, bindings, ivars, cl) ->
+          Tcl_let (rec_flag, map_bindings bindings,
+                   List.map (fun (id, name, exp) ->
+                     (id, name, map_expression exp)) ivars,
+                   map_class_expr cl)
+
+        | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+          Tcl_constraint ( map_class_expr cl,
+                           Some (map_class_type clty), vals, meths, concrs)
+
+        | Tcl_ident (id, name, tyl) ->
+          Tcl_ident (id, name, List.map map_core_type tyl)
+    in
+    Map.leave_class_expr { cexpr with cl_desc = cl_desc }
+
+  and map_class_type ct =
+    let ct = Map.enter_class_type ct in
+    let cltyp_desc =
+      match ct.cltyp_desc with
+          Tcty_signature csg -> Tcty_signature (map_class_signature csg)
+        | Tcty_constr (path, lid, list) ->
+          Tcty_constr (path, lid, List.map map_core_type list)
+        | Tcty_arrow (label, ct, cl) ->
+          Tcty_arrow (label, map_core_type ct, map_class_type cl)
+    in
+    Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
+
+  and map_class_signature cs =
+    let cs = Map.enter_class_signature cs in
+    let csig_self = map_core_type cs.csig_self in
+    let csig_fields = List.map map_class_type_field cs.csig_fields in
+    Map.leave_class_signature { cs with
+      csig_self = csig_self; csig_fields = csig_fields }
+
+
+  and map_class_type_field ctf =
+    let ctf = Map.enter_class_type_field ctf in
+    let ctf_desc =
+      match ctf.ctf_desc with
+          Tctf_inherit ct -> Tctf_inherit (map_class_type ct)
+        | Tctf_val (s, mut, virt, ct) ->
+          Tctf_val (s, mut, virt, map_core_type ct)
+        | Tctf_method (s, priv, virt, ct) ->
+          Tctf_method (s, priv, virt, map_core_type ct)
+        | Tctf_constraint (ct1, ct2) ->
+          Tctf_constraint (map_core_type ct1, map_core_type ct2)
+        | Tctf_attribute _ as x -> x
+    in
+    Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
+
+  and map_core_type ct =
+    let ct = Map.enter_core_type ct in
+    let ctyp_desc =
+      match ct.ctyp_desc with
+          Ttyp_any
+        | Ttyp_var _ -> ct.ctyp_desc
+        | Ttyp_arrow (label, ct1, ct2) ->
+          Ttyp_arrow (label, map_core_type ct1, map_core_type ct2)
+        | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list)
+        | Ttyp_constr (path, lid, list) ->
+          Ttyp_constr (path, lid, List.map map_core_type list)
+        | Ttyp_object (list, o) ->
+          Ttyp_object
+            (List.map (fun (s, a, t) -> (s, a, map_core_type t)) list, o)
+        | Ttyp_class (path, lid, list) ->
+          Ttyp_class (path, lid, List.map map_core_type list)
+        | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
+        | Ttyp_variant (list, bool, labels) ->
+          Ttyp_variant (List.map map_row_field list, bool, labels)
+        | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct)
+        | Ttyp_package pack -> Ttyp_package (map_package_type pack)
+    in
+    Map.leave_core_type { ct with ctyp_desc = ctyp_desc }
+
+  and map_class_structure cs =
+    let cs = Map.enter_class_structure cs in
+    let cstr_self = map_pattern cs.cstr_self in
+    let cstr_fields = List.map map_class_field cs.cstr_fields in
+    Map.leave_class_structure { cs with cstr_self; cstr_fields }
+
+  and map_row_field rf =
+    match rf with
+        Ttag (label, attrs, bool, list) ->
+          Ttag (label, attrs, bool, List.map map_core_type list)
+      | Tinherit ct -> Tinherit (map_core_type ct)
+
+  and map_class_field cf =
+    let cf = Map.enter_class_field cf in
+    let cf_desc =
+      match cf.cf_desc with
+          Tcf_inherit (ovf, cl, super, vals, meths) ->
+            Tcf_inherit (ovf, map_class_expr cl, super, vals, meths)
+        | Tcf_constraint (cty, cty') ->
+          Tcf_constraint (map_core_type cty, map_core_type cty')
+        | Tcf_val (lab, mut, ident, Tcfk_virtual cty, b) ->
+          Tcf_val (lab, mut, ident, Tcfk_virtual (map_core_type cty), b)
+        | Tcf_val (lab, mut, ident, Tcfk_concrete (o, exp), b) ->
+          Tcf_val (lab, mut, ident, Tcfk_concrete (o, map_expression exp), b)
+        | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+          Tcf_method (lab, priv, Tcfk_virtual (map_core_type cty))
+        | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+          Tcf_method (lab, priv, Tcfk_concrete (o, map_expression exp))
+        | Tcf_initializer exp -> Tcf_initializer (map_expression exp)
+        | Tcf_attribute _ as x -> x
+    in
+    Map.leave_class_field { cf with cf_desc = cf_desc }
+end
+
+
+module DefaultMapArgument = struct
+
+  let enter_structure t = t
+  let enter_value_description t = t
+  let enter_type_declaration t = t
+  let enter_type_extension t = t
+  let enter_extension_constructor t = t
+  let enter_pattern t = t
+  let enter_expression t = t
+  let enter_package_type t = t
+  let enter_signature t = t
+  let enter_signature_item t = t
+  let enter_module_type_declaration t = t
+  let enter_module_type t = t
+  let enter_module_expr t = t
+  let enter_with_constraint t = t
+  let enter_class_expr t = t
+  let enter_class_signature t = t
+  let enter_class_declaration t = t
+  let enter_class_description t = t
+  let enter_class_type_declaration t = t
+  let enter_class_type t = t
+  let enter_class_type_field t = t
+  let enter_core_type t = t
+  let enter_class_structure t = t
+  let enter_class_field t = t
+  let enter_structure_item t = t
+
+
+  let leave_structure t = t
+  let leave_value_description t = t
+  let leave_type_declaration t = t
+  let leave_type_extension t = t
+  let leave_extension_constructor t = t
+  let leave_pattern t = t
+  let leave_expression t = t
+  let leave_package_type t = t
+  let leave_signature t = t
+  let leave_signature_item t = t
+  let leave_module_type_declaration t = t
+  let leave_module_type t = t
+  let leave_module_expr t = t
+  let leave_with_constraint t = t
+  let leave_class_expr t = t
+  let leave_class_signature t = t
+  let leave_class_declaration t = t
+  let leave_class_description t = t
+  let leave_class_type_declaration t = t
+  let leave_class_type t = t
+  let leave_class_type_field t = t
+  let leave_core_type t = t
+  let leave_class_structure t = t
+  let leave_class_field t = t
+  let leave_structure_item t = t
+
+end
diff --git a/typing/typedtreeMap.mli b/typing/typedtreeMap.mli
new file mode 100644
index 00000000..7a826ae8
--- /dev/null
+++ b/typing/typedtreeMap.mli
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Fabrice Le Fessant, INRIA Saclay                     *)
+(*                                                                        *)
+(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Typedtree
+
+module type MapArgument = sig
+  val enter_structure : structure -> structure
+  val enter_value_description : value_description -> value_description
+  val enter_type_declaration : type_declaration -> type_declaration
+  val enter_type_extension : type_extension -> type_extension
+  val enter_extension_constructor :
+    extension_constructor -> extension_constructor
+  val enter_pattern : pattern -> pattern
+  val enter_expression : expression -> expression
+  val enter_package_type : package_type -> package_type
+  val enter_signature : signature -> signature
+  val enter_signature_item : signature_item -> signature_item
+  val enter_module_type_declaration :
+      module_type_declaration -> module_type_declaration
+  val enter_module_type : module_type -> module_type
+  val enter_module_expr : module_expr -> module_expr
+  val enter_with_constraint : with_constraint -> with_constraint
+  val enter_class_expr : class_expr -> class_expr
+  val enter_class_signature : class_signature -> class_signature
+  val enter_class_declaration : class_declaration -> class_declaration
+  val enter_class_description : class_description -> class_description
+  val enter_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val enter_class_type : class_type -> class_type
+  val enter_class_type_field : class_type_field -> class_type_field
+  val enter_core_type : core_type -> core_type
+  val enter_class_structure : class_structure -> class_structure
+  val enter_class_field : class_field -> class_field
+  val enter_structure_item : structure_item -> structure_item
+
+  val leave_structure : structure -> structure
+  val leave_value_description : value_description -> value_description
+  val leave_type_declaration : type_declaration -> type_declaration
+  val leave_type_extension : type_extension -> type_extension
+  val leave_extension_constructor :
+    extension_constructor -> extension_constructor
+  val leave_pattern : pattern -> pattern
+  val leave_expression : expression -> expression
+  val leave_package_type : package_type -> package_type
+  val leave_signature : signature -> signature
+  val leave_signature_item : signature_item -> signature_item
+  val leave_module_type_declaration :
+      module_type_declaration -> module_type_declaration
+  val leave_module_type : module_type -> module_type
+  val leave_module_expr : module_expr -> module_expr
+  val leave_with_constraint : with_constraint -> with_constraint
+  val leave_class_expr : class_expr -> class_expr
+  val leave_class_signature : class_signature -> class_signature
+  val leave_class_declaration : class_declaration -> class_declaration
+  val leave_class_description : class_description -> class_description
+  val leave_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val leave_class_type : class_type -> class_type
+  val leave_class_type_field : class_type_field -> class_type_field
+  val leave_core_type : core_type -> core_type
+  val leave_class_structure : class_structure -> class_structure
+  val leave_class_field : class_field -> class_field
+  val leave_structure_item : structure_item -> structure_item
+
+end
+
+module MakeMap :
+  functor
+    (Iter : MapArgument) ->
+sig
+  val map_structure : structure -> structure
+  val map_pattern : pattern -> pattern
+  val map_structure_item : structure_item -> structure_item
+  val map_expression : expression -> expression
+  val map_class_expr : class_expr -> class_expr
+
+  val map_signature : signature -> signature
+  val map_signature_item : signature_item -> signature_item
+  val map_module_type : module_type -> module_type
+end
+
+module DefaultMapArgument : MapArgument
diff --git a/typing/typemod.ml b/typing/typemod.ml
new file mode 100644
index 00000000..cdff23ee
--- /dev/null
+++ b/typing/typemod.ml
@@ -0,0 +1,1837 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Longident
+open Path
+open Asttypes
+open Parsetree
+open Types
+open Format
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.error list
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.error list
+  | Repeated_name of string * string
+  | 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
+  | Not_allowed_in_functor_body
+  | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+module ImplementationHooks = Misc.MakeHooks(struct
+    type t = Typedtree.structure * Typedtree.module_coercion
+  end)
+module InterfaceHooks = Misc.MakeHooks(struct
+    type t = Typedtree.signature
+  end)
+
+open Typedtree
+
+let fst3 (x,_,_) = x
+
+let rec path_concat head p =
+  match p with
+    Pident tail -> Pdot (Pident head, Ident.name tail, 0)
+  | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos)
+  | Papply _ -> assert false
+
+(* Extract a signature from a module type *)
+
+let extract_sig env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias(_, path) ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | _ -> raise(Error(loc, env, Signature_expected))
+
+let extract_sig_open env loc mty =
+  match Env.scrape_alias env mty with
+    Mty_signature sg -> sg
+  | Mty_alias(_, path) ->
+      raise(Error(loc, env, Cannot_scrape_alias path))
+  | mty -> raise(Error(loc, env, Structure_expected mty))
+
+(* Compute the environment after opening a module *)
+
+let type_open_ ?toplevel ovf env loc lid =
+  let path, md = Typetexp.find_module env lid.loc lid.txt in
+  let sg = extract_sig_open env lid.loc md.md_type in
+  path, Env.open_signature ~loc ?toplevel ovf path sg env
+
+let type_open ?toplevel env sod =
+  let (path, newenv) =
+    type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid
+  in
+  let od =
+    {
+      open_override = sod.popen_override;
+      open_path = path;
+      open_txt = sod.popen_lid;
+      open_attributes = sod.popen_attributes;
+      open_loc = sod.popen_loc;
+    }
+  in
+  (path, newenv, od)
+
+(* Record a module type *)
+let rm node =
+  Stypes.record (Stypes.Ti_mod node);
+  node
+
+(* Forward declaration, to be filled in by type_module_type_of *)
+let type_module_type_of_fwd :
+    (Env.t -> Parsetree.module_expr ->
+      Typedtree.module_expr * Types.module_type) ref
+  = ref (fun _env _m -> assert false)
+
+(* Merge one "with" constraint in a signature *)
+
+let rec add_rec_types env = function
+    Sig_type(id, decl, Trec_next) :: rem ->
+      add_rec_types (Env.add_type ~check:true id decl env) rem
+  | _ -> env
+
+let check_type_decl env loc id row_id newdecl decl rs rem =
+  let env = Env.add_type ~check:true id newdecl env in
+  let env =
+    match row_id with
+    | None -> env
+    | Some id -> Env.add_type ~check:false id newdecl env
+  in
+  let env = if rs = Trec_not then env else add_rec_types env rem in
+  Includemod.type_declarations env id newdecl decl;
+  Typedecl.check_coherence env loc id newdecl
+
+let update_rec_next rs rem =
+  match rs with
+    Trec_next -> rem
+  | Trec_first | Trec_not ->
+      match rem with
+        Sig_type (id, decl, Trec_next) :: rem ->
+          Sig_type (id, decl, rs) :: rem
+      | Sig_module (id, mty, Trec_next) :: rem ->
+          Sig_module (id, mty, rs) :: rem
+      | _ -> rem
+
+let make p n i =
+  let open Variance in
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
+
+let merge_constraint initial_env loc sg constr =
+  let lid =
+    match constr with
+    | Pwith_type (lid, _) | Pwith_module (lid, _) -> lid
+    | Pwith_typesubst {ptype_name=s} | Pwith_modsubst (s, _) ->
+        {loc = s.loc; txt=Lident s.txt}
+  in
+  let real_id = ref None in
+  let rec merge env sg namelist row_id =
+    match (sg, namelist, constr) with
+      ([], _, _) ->
+        raise(Error(loc, env, With_no_component lid.txt))
+    | (Sig_type(id, decl, rs) :: rem, [s],
+       Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)))
+      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
+        let decl_row =
+          { type_params =
+              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+            type_arity = List.length sdecl.ptype_params;
+            type_kind = Type_abstract;
+            type_private = Private;
+            type_manifest = None;
+            type_variance =
+              List.map
+                (fun (_, v) ->
+                   let (c, n) =
+                     match v with
+                     | Covariant -> true, false
+                     | Contravariant -> false, true
+                     | Invariant -> false, false
+                   in
+                   make (not n) (not c) false
+                )
+                sdecl.ptype_params;
+            type_loc = sdecl.ptype_loc;
+            type_newtype_level = None;
+            type_attributes = [];
+            type_immediate = false;
+            type_unboxed = unboxed_false_default_false;
+          }
+        and id_row = Ident.create (s^"#row") in
+        let initial_env =
+          Env.add_type ~check:false id_row decl_row initial_env
+        in
+        let tdecl = Typedecl.transl_with_constraint
+                        initial_env id (Some(Pident id_row)) decl sdecl in
+        let newdecl = tdecl.typ_type in
+        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
+        let decl_row = {decl_row with type_params = newdecl.type_params} in
+        let rs' = if rs = Trec_first then Trec_not else rs in
+        (Pident id, lid, Twith_type tdecl),
+        Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem
+    | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type (_, sdecl))
+      when Ident.name id = s ->
+        let tdecl =
+          Typedecl.transl_with_constraint initial_env id None decl sdecl in
+        let newdecl = tdecl.typ_type in
+        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
+        (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem
+    | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
+      when Ident.name id = s ^ "#row" ->
+        merge env rem namelist (Some id)
+    | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl)
+      when Ident.name id = s ->
+        (* Check as for a normal with constraint, but discard definition *)
+        let tdecl =
+          Typedecl.transl_with_constraint initial_env id None decl sdecl in
+        let newdecl = tdecl.typ_type in
+        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
+        real_id := Some id;
+        (Pident id, lid, Twith_typesubst tdecl),
+        update_rec_next rs rem
+    | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid'))
+      when Ident.name id = s ->
+        let path, md' = Typetexp.find_module initial_env loc lid'.txt in
+        let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
+        let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
+        ignore(Includemod.modtypes env newmd.md_type md.md_type);
+        (Pident id, lid, Twith_module (path, lid')),
+        Sig_module(id, newmd, rs) :: rem
+    | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
+      when Ident.name id = s ->
+        let path, md' = Typetexp.find_module initial_env loc lid'.txt in
+        let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
+        ignore(Includemod.modtypes env newmd.md_type md.md_type);
+        real_id := Some id;
+        (Pident id, lid, Twith_modsubst (path, lid')),
+        update_rec_next rs rem
+    | (Sig_module(id, md, rs) :: rem, s :: namelist, _)
+      when Ident.name id = s ->
+        let ((path, _path_loc, tcstr), newsg) =
+          merge env (extract_sig env loc md.md_type) namelist None in
+        (path_concat id path, lid, tcstr),
+        Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem
+    | (item :: rem, _, _) ->
+        let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
+        in
+        cstr, item :: items
+  in
+  try
+    let names = Longident.flatten lid.txt in
+    let (tcstr, sg) = merge initial_env sg names None in
+    let sg =
+    match names, constr with
+      [_], Pwith_typesubst sdecl ->
+        let id =
+          match !real_id with None -> assert false | Some id -> id in
+        let lid =
+          try match sdecl.ptype_manifest with
+          | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+            when List.length stl = List.length sdecl.ptype_params ->
+              List.iter2 (fun x (y, _) ->
+                match x, y with
+                  {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
+                    when sx = sy -> ()
+                | _, _ -> raise Exit)
+                stl sdecl.ptype_params;
+              lid
+          | _ -> raise Exit
+          with Exit ->
+            raise(Error(sdecl.ptype_loc, initial_env, With_need_typeconstr))
+        in
+        let path =
+          try Env.lookup_type lid.txt initial_env with Not_found -> assert false
+        in
+        let sub = Subst.add_type id path Subst.identity in
+        Subst.signature sub sg
+    | [_], Pwith_modsubst (_, lid) ->
+        let id =
+          match !real_id with None -> assert false | Some id -> id in
+        let path = Typetexp.lookup_module initial_env loc lid.txt in
+        let sub = Subst.add_module id path Subst.identity in
+        Subst.signature sub sg
+    | _ ->
+          sg
+    in
+    (tcstr, sg)
+  with Includemod.Error explanation ->
+    raise(Error(loc, initial_env, With_mismatch(lid.txt, 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
+
+let map_rec_type ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      let first =
+        match rec_flag with
+        | Recursive -> Trec_first
+        | Nonrecursive -> Trec_not
+      in
+      fn first d1 :: map_end (fn Trec_next) dl rem
+
+let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl ->
+      if Btype.is_row_name (Ident.name d1.typ_id) then
+        fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem
+      else
+        map_rec_type ~rec_flag fn decls rem
+
+(* Add type extension flags to extension contructors *)
+let map_ext fn exts rem =
+  match exts with
+  | [] -> rem
+  | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_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
+   components of signatures.  For types, retain only their arity,
+   making them abstract otherwise. *)
+
+let rec approx_modtype env smty =
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in
+      Mty_ident path
+  | Pmty_alias lid ->
+      let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in
+      Mty_alias(Mta_absent, path)
+  | Pmty_signature ssg ->
+      Mty_signature(approx_sig env ssg)
+  | Pmty_functor(param, sarg, sres) ->
+      let arg = may_map (approx_modtype env) sarg in
+      let (id, newenv) =
+        Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in
+      let res = approx_modtype newenv sres in
+      Mty_functor(id, arg, res)
+  | Pmty_with(sbody, _constraints) ->
+      approx_modtype env sbody
+  | Pmty_typeof smod ->
+      let (_, mty) = !type_module_type_of_fwd env smod in
+      mty
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and approx_module_declaration env pmd =
+  {
+    Types.md_type = approx_modtype env pmd.pmd_type;
+    md_attributes = pmd.pmd_attributes;
+    md_loc = pmd.pmd_loc;
+  }
+
+and approx_sig env ssg =
+  match ssg with
+    [] -> []
+  | item :: srem ->
+      match item.psig_desc with
+      | Psig_type (rec_flag, sdecls) ->
+          let decls = Typedecl.approx_type_decl sdecls in
+          let rem = approx_sig env srem in
+          map_rec_type ~rec_flag
+            (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
+      | Psig_module pmd ->
+          let id = Ident.create pmd.pmd_name.txt in
+          let md = approx_module_declaration env pmd in
+          let newenv = Env.enter_module_declaration id md env in
+          Sig_module(id, md, Trec_not) :: approx_sig newenv srem
+      | Psig_recmodule sdecls ->
+          let decls =
+            List.map
+              (fun pmd ->
+                 (Ident.create pmd.pmd_name.txt,
+                  approx_module_declaration env pmd)
+              )
+              sdecls
+          in
+          let newenv =
+            List.fold_left
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id md env)
+              env decls in
+          map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls
+                  (approx_sig newenv srem)
+      | Psig_modtype d ->
+          let info = approx_modtype_info env d in
+          let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
+          Sig_modtype(id, info) :: approx_sig newenv srem
+      | Psig_open sod ->
+          let (_path, mty, _od) = type_open env sod in
+          approx_sig mty srem
+      | Psig_include sincl ->
+          let smty = sincl.pincl_mod in
+          let mty = approx_modtype env smty in
+          let sg = Subst.signature Subst.identity
+                     (extract_sig env smty.pmty_loc mty) in
+          let newenv = Env.add_signature sg env in
+          sg @ approx_sig newenv srem
+      | Psig_class sdecls | Psig_class_type sdecls ->
+          let decls = Typeclass.approx_class_declarations env sdecls in
+          let rem = approx_sig env srem in
+          List.flatten
+            (map_rec
+               (fun rs decl ->
+                  let open Typeclass in
+                  [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                   Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                   Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
+              decls [rem])
+      | _ ->
+          approx_sig env srem
+
+and approx_modtype_info env sinfo =
+  {
+   mtd_type = may_map (approx_modtype env) sinfo.pmtd_type;
+   mtd_attributes = sinfo.pmtd_attributes;
+   mtd_loc = sinfo.pmtd_loc;
+  }
+
+(* Additional validity checks on type definitions arising from
+   recursive modules *)
+
+let check_recmod_typedecls env sdecls decls =
+  let recmod_ids = List.map fst3 decls in
+  List.iter2
+    (fun pmd (id, _, mty) ->
+       let mty = mty.mty_type in
+      List.iter
+        (fun path ->
+          Typedecl.check_recmod_typedecl env pmd.pmd_type.pmty_loc recmod_ids
+                                         path (Env.find_type path env))
+        (Mtype.type_paths env (Pident id) mty))
+    sdecls decls
+
+(* Auxiliaries for checking uniqueness of names in signatures and structures *)
+
+module StringSet =
+  Set.Make(struct type t = string let compare (x:t) y = String.compare x y end)
+
+let check cl loc set_ref name =
+  if StringSet.mem name !set_ref
+  then raise(Error(loc, Env.empty, Repeated_name(cl, name)))
+  else set_ref := StringSet.add name !set_ref
+
+type names =
+  {
+    types: StringSet.t ref;
+    modules: StringSet.t ref;
+    modtypes: StringSet.t ref;
+    typexts: StringSet.t ref;
+  }
+
+let new_names () =
+  {
+    types = ref StringSet.empty;
+    modules = ref StringSet.empty;
+    modtypes = ref StringSet.empty;
+    typexts = ref StringSet.empty;
+  }
+
+
+let check_name check names name = check names name.loc name.txt
+let check_type names loc s = check "type" loc names.types s
+let check_module names loc s = check "module" loc names.modules s
+let check_modtype names loc s = check "module type" loc names.modtypes s
+let check_typext names loc s = check "extension constructor" loc names.typexts s
+
+
+let check_sig_item names loc = function
+  | Sig_type(id, _, _) -> check_type names loc (Ident.name id)
+  | Sig_module(id, _, _) -> check_module names loc (Ident.name id)
+  | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id)
+  | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id)
+  | _ -> ()
+
+(* Simplify multiple specifications of a value or an extension in a signature.
+   (Other signature components, e.g. types, modules, etc, are checked for
+   name uniqueness.)  If multiple specifications with the same name,
+   keep only the last (rightmost) one. *)
+
+let simplify_signature sg =
+  let rec aux = function
+    | [] -> [], StringSet.empty
+    | (Sig_value(id, _descr) as component) :: sg ->
+        let (sg, val_names) as k = aux sg in
+        let name = Ident.name id in
+        if StringSet.mem name val_names then k
+        else (component :: sg, StringSet.add name val_names)
+    | component :: sg ->
+        let (sg, val_names) = aux sg in
+        (component :: sg, val_names)
+  in
+  let (sg, _) = aux sg in
+  sg
+
+(* Check and translate a module type expression *)
+
+let transl_modtype_longident loc env lid =
+  let (path, _info) = Typetexp.find_modtype env loc lid in
+  path
+
+let transl_module_alias loc env lid =
+  Typetexp.lookup_module env loc lid
+
+let mkmty desc typ env loc attrs =
+  let mty = {
+    mty_desc = desc;
+    mty_type = typ;
+    mty_loc = loc;
+    mty_env = env;
+    mty_attributes = attrs;
+    } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
+  mty
+
+let mksig desc env loc =
+  let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in
+  Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg);
+  sg
+
+(* let signature sg = List.map (fun item -> item.sig_type) sg *)
+
+let rec transl_modtype env smty =
+  let loc = smty.pmty_loc in
+  match smty.pmty_desc with
+    Pmty_ident lid ->
+      let path = transl_modtype_longident loc env lid.txt in
+      mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
+        smty.pmty_attributes
+  | Pmty_alias lid ->
+      let path = transl_module_alias loc env lid.txt in
+      mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc
+        smty.pmty_attributes
+  | Pmty_signature ssg ->
+      let sg = transl_signature env ssg in
+      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
+        smty.pmty_attributes
+  | Pmty_functor(param, sarg, sres) ->
+      let arg = Misc.may_map (transl_modtype env) sarg in
+      let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
+      let (id, newenv) =
+        Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in
+      Ctype.init_def(Ident.current_time()); (* PR#6513 *)
+      let res = transl_modtype newenv sres in
+      mkmty (Tmty_functor (id, param, arg, res))
+      (Mty_functor(id, ty_arg, res.mty_type)) env loc
+        smty.pmty_attributes
+  | Pmty_with(sbody, constraints) ->
+      let body = transl_modtype env sbody in
+      let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+      let (rev_tcstrs, final_sg) =
+        List.fold_left
+          (fun (rev_tcstrs,sg) sdecl ->
+            let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl
+            in
+            (tcstr :: rev_tcstrs, sg)
+        )
+        ([],init_sg) constraints in
+      mkmty (Tmty_with ( body, List.rev rev_tcstrs))
+        (Mtype.freshen (Mty_signature final_sg)) env loc
+        smty.pmty_attributes
+  | Pmty_typeof smod ->
+      let env = Env.in_signature false env in
+      let tmty, mty = !type_module_type_of_fwd env smod in
+      mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
+  | Pmty_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_signature env sg =
+  let names = new_names () in
+  let rec transl_sig env sg =
+    Ctype.init_def(Ident.current_time());
+    match sg with
+      [] -> [], [], env
+    | item :: srem ->
+        let loc = item.psig_loc in
+        match item.psig_desc with
+        | Psig_value sdesc ->
+            let (tdesc, newenv) =
+              Builtin_attributes.with_warning_attribute sdesc.pval_attributes
+                (fun () -> Typedecl.transl_value_decl env item.psig_loc sdesc)
+            in
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_value tdesc) env loc :: trem,
+            Sig_value(tdesc.val_id, tdesc.val_val) :: rem,
+              final_env
+        | Psig_type (rec_flag, sdecls) ->
+            List.iter
+              (fun decl -> check_name check_type names decl.ptype_name)
+              sdecls;
+            let (decls, newenv) =
+              Typedecl.transl_type_decl env rec_flag sdecls
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_type (rec_flag, decls)) env loc :: trem,
+            map_rec_type_with_row_types ~rec_flag
+              (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem,
+            final_env
+        | Psig_typext styext ->
+            List.iter
+              (fun pext -> check_name check_typext names pext.pext_name)
+              styext.ptyext_constructors;
+            let (tyext, newenv) =
+              Typedecl.transl_type_extension false env item.psig_loc styext
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            let constructors = tyext.tyext_constructors in
+              mksig (Tsig_typext tyext) env loc :: trem,
+              map_ext (fun es ext ->
+                Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem,
+              final_env
+        | Psig_exception sext ->
+            check_name check_typext names sext.pext_name;
+            let (ext, newenv) = Typedecl.transl_exception env sext in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_exception ext) env loc :: trem,
+            Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem,
+            final_env
+        | Psig_module pmd ->
+            check_name check_module names pmd.pmd_name;
+            let id = Ident.create pmd.pmd_name.txt in
+            let tmty =
+              Builtin_attributes.with_warning_attribute pmd.pmd_attributes
+                (fun () -> transl_modtype env pmd.pmd_type)
+            in
+            let md = {
+              md_type=tmty.mty_type;
+              md_attributes=pmd.pmd_attributes;
+              md_loc=pmd.pmd_loc;
+            }
+            in
+            let newenv = Env.enter_module_declaration id md env in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty;
+                                md_loc=pmd.pmd_loc;
+                                md_attributes=pmd.pmd_attributes})
+              env loc :: trem,
+            Sig_module(id, md, Trec_not) :: rem,
+            final_env
+        | Psig_recmodule sdecls ->
+            List.iter
+              (fun pmd -> check_name check_module names pmd.pmd_name)
+              sdecls;
+            let (decls, newenv) =
+              transl_recmodule_modtypes env sdecls in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_recmodule decls) env loc :: trem,
+            map_rec (fun rs md ->
+                let d = {Types.md_type = md.md_type.mty_type;
+                         md_attributes = md.md_attributes;
+                         md_loc = md.md_loc;
+                        } in
+                Sig_module(md.md_id, d, rs))
+              decls rem,
+            final_env
+        | Psig_modtype pmtd ->
+            let newenv, mtd, sg =
+              Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
+                (fun () -> transl_modtype_decl names env pmtd)
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtype mtd) env loc :: trem,
+            sg :: rem,
+            final_env
+        | Psig_open sod ->
+            let (_path, newenv, od) = type_open env sod in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_open od) env loc :: trem,
+            rem, final_env
+        | Psig_include sincl ->
+            let smty = sincl.pincl_mod in
+            let tmty =
+              Builtin_attributes.with_warning_attribute sincl.pincl_attributes
+                (fun () -> transl_modtype env smty)
+            in
+            let mty = tmty.mty_type in
+            let sg = Subst.signature Subst.identity
+                       (extract_sig env smty.pmty_loc mty) in
+            List.iter (check_sig_item names item.psig_loc) sg;
+            let newenv = Env.add_signature sg env in
+            let incl =
+              { incl_mod = tmty;
+                incl_type = sg;
+                incl_attributes = sincl.pincl_attributes;
+                incl_loc = sincl.pincl_loc;
+              }
+            in
+            let (trem, rem, final_env) = transl_sig newenv srem  in
+            mksig (Tsig_include incl) env loc :: trem,
+            sg @ rem,
+            final_env
+        | Psig_class cl ->
+            List.iter
+              (fun {pci_name} -> check_name check_type names pci_name)
+              cl;
+            let (classes, newenv) = Typeclass.class_descriptions env cl in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_class
+                     (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
+            :: trem,
+            List.flatten
+              (map_rec
+                 (fun rs cls ->
+                    let open Typeclass in
+                    [Sig_class(cls.cls_id, cls.cls_decl, rs);
+                     Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
+                     Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
+                     Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
+                 classes [rem]),
+            final_env
+        | Psig_class_type cl ->
+            List.iter
+              (fun {pci_name} -> check_name check_type names pci_name)
+              cl;
+            let (classes, newenv) = Typeclass.class_type_declarations env cl in
+            let (trem,rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_class_type
+                     (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+              env loc :: trem,
+            List.flatten
+              (map_rec
+                 (fun rs decl ->
+                    let open Typeclass in
+                    [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                     Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                     Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
+                 classes [rem]),
+            final_env
+        | Psig_attribute x ->
+            Builtin_attributes.warning_attribute [x];
+            let (trem,rem, final_env) = transl_sig env srem in
+            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+        | Psig_extension (ext, _attrs) ->
+            raise (Error_forward (Builtin_attributes.error_of_extension ext))
+  in
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  Builtin_attributes.warning_enter_scope ();
+  let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
+  let rem = simplify_signature rem in
+  let sg = { sig_items = trem; sig_type =  rem; sig_final_env = final_env } in
+  Builtin_attributes.warning_leave_scope ();
+  Cmt_format.set_saved_types
+    ((Cmt_format.Partial_signature sg) :: previous_saved_types);
+  sg
+
+and transl_modtype_decl names env
+    {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
+  check_name check_modtype names pmtd_name;
+  let tmty = Misc.may_map (transl_modtype env) pmtd_type in
+  let decl =
+    {
+     Types.mtd_type=may_map (fun t -> t.mty_type) tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+    }
+  in
+  let (id, newenv) = Env.enter_modtype pmtd_name.txt decl env in
+  let mtd =
+    {
+     mtd_id=id;
+     mtd_name=pmtd_name;
+     mtd_type=tmty;
+     mtd_attributes=pmtd_attributes;
+     mtd_loc=pmtd_loc;
+    }
+  in
+  newenv, mtd, Sig_modtype(id, decl)
+
+and transl_recmodule_modtypes env sdecls =
+  let make_env curr =
+    List.fold_left
+      (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env)
+      env curr in
+  let make_env2 curr =
+    List.fold_left
+      (fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env)
+      env curr in
+  let transition env_c curr =
+    List.map2
+      (fun pmd (id, id_loc, _mty) ->
+        let tmty =
+          Builtin_attributes.with_warning_attribute pmd.pmd_attributes
+            (fun () -> transl_modtype env_c pmd.pmd_type)
+        in
+        (id, id_loc, tmty))
+      sdecls curr in
+  let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in
+  let approx_env =
+    (*
+       cf #5965
+       We use a dummy module type in order to detect a reference to one
+       of the module being defined during the call to approx_modtype.
+       It will be detected in Env.lookup_module.
+    *)
+    List.fold_left
+      (fun env id ->
+         let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in
+         Env.add_module ~arg:true id dummy env
+      )
+      env ids
+  in
+  Ctype.init_def(Ident.current_time()); (* PR#7082 *)
+  let init =
+    List.map2
+      (fun id pmd ->
+        (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type))
+      ids sdecls
+  in
+  let env0 = make_env init in
+  let dcl1 = transition env0 init in
+  let env1 = make_env2 dcl1 in
+  check_recmod_typedecls env1 sdecls dcl1;
+  let dcl2 = transition env1 dcl1 in
+(*
+  List.iter
+    (fun (id, mty) ->
+      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
+    dcl2;
+*)
+  let env2 = make_env2 dcl2 in
+  check_recmod_typedecls env2 sdecls dcl2;
+  let dcl2 =
+    List.map2
+      (fun pmd (id, id_loc, mty) ->
+        {md_id=id; md_name=id_loc; md_type=mty;
+         md_loc=pmd.pmd_loc;
+         md_attributes=pmd.pmd_attributes})
+      sdecls dcl2
+  in
+  (dcl2, env2)
+
+(* Try to convert a module expression to a module path. *)
+
+exception Not_a_path
+
+let rec path_of_module mexp =
+  match mexp.mod_desc with
+    Tmod_ident (p,_) -> p
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
+      Papply(path_of_module funct, path_of_module arg)
+  | Tmod_constraint (mexp, _, _, _) ->
+      path_of_module mexp
+  | _ -> raise Not_a_path
+
+let path_of_module mexp =
+ try Some (path_of_module mexp) with Not_a_path -> None
+
+(* Check that all core type schemes in a structure are closed *)
+
+let rec closed_modtype env = function
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
+  | Mty_signature sg ->
+      let env = Env.add_signature sg env in
+      List.for_all (closed_signature_item env) sg
+  | Mty_functor(id, param, body) ->
+      let env = Env.add_module ~arg:true id (Btype.default_mty param) env in
+      closed_modtype env body
+
+and closed_signature_item env = function
+    Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, md, _) -> closed_modtype env md.md_type
+  | _ -> true
+
+let check_nongen_scheme env sig_item =
+  match sig_item with
+    Sig_value(_id, vd) ->
+      if not (Ctype.closed_schema env vd.val_type) then
+        raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
+  | Sig_module (_id, md, _) ->
+      if not (closed_modtype env md.md_type) then
+        raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
+  | _ -> ()
+
+let check_nongen_schemes env sg =
+  List.iter (check_nongen_scheme env) sg
+
+(* Helpers for typing recursive modules *)
+
+let anchor_submodule name anchor =
+  match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos))
+let anchor_recmodule id =
+  Some (Pident id)
+
+let enrich_type_decls anchor decls oldenv newenv =
+  match anchor with
+    None -> newenv
+  | Some p ->
+      List.fold_left
+        (fun e info ->
+          let id = info.typ_id in
+          let info' =
+            Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos))
+              info.typ_type
+          in
+            Env.add_type ~check:true id info' e)
+        oldenv decls
+
+let enrich_module_type anchor name mty env =
+  match anchor with
+    None -> mty
+  | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty
+
+let check_recmodule_inclusion env bindings =
+  (* PR#4450, PR#4470: consider
+        module rec X : DECL = MOD  where MOD has inferred type ACTUAL
+     The "natural" typing condition
+        E, X: ACTUAL |- ACTUAL <: DECL
+     leads to circularities through manifest types.
+     Instead, we "unroll away" the potential circularities a finite number
+     of times.  The (weaker) condition we implement is:
+        E, X: DECL,
+           X1: ACTUAL,
+           X2: ACTUAL{X <- X1}/X1
+           ...
+           Xn: ACTUAL{X <- X(n-1)}/X(n-1)
+        |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
+     so that manifest types rooted at X(n+1) are expanded in terms of X(n),
+     avoiding circularities.  The strengthenings ensure that
+     Xn.t = X(n-1).t = ... = X2.t = X1.t.
+     N can be chosen arbitrarily; larger values of N result in more
+     recursive definitions being accepted.  A good choice appears to be
+     the number of mutually recursive declarations. *)
+
+  let subst_and_strengthen env s id mty =
+    Mtype.strengthen ~aliasable:false env (Subst.modtype s mty)
+      (Subst.module_path s (Pident id)) in
+
+  let rec check_incl first_time n env s =
+    if n > 0 then begin
+      (* Generate fresh names Y_i for the rec. bound module idents X_i *)
+      let bindings1 =
+        List.map
+          (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
+             (id, Ident.rename id, mty_actual))
+          bindings in
+      (* Enter the Y_i in the environment with their actual types substituted
+         by the input substitution s *)
+      let env' =
+        List.fold_left
+          (fun env (id, id', mty_actual) ->
+             let mty_actual' =
+               if first_time
+               then mty_actual
+               else subst_and_strengthen env s id mty_actual in
+             Env.add_module ~arg:false id' mty_actual' env)
+          env bindings1 in
+      (* Build the output substitution Y_i <- X_i *)
+      let s' =
+        List.fold_left
+          (fun s (id, id', _mty_actual) ->
+             Subst.add_module id (Pident id') s)
+          Subst.identity bindings1 in
+      (* Recurse with env' and s' *)
+      check_incl false (n-1) env' s'
+    end else begin
+      (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
+         and insert coercion if needed *)
+      let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) =
+        let mty_decl' = Subst.modtype s mty_decl.mty_type
+        and mty_actual' = subst_and_strengthen env s id mty_actual in
+        let coercion =
+          try
+            Includemod.modtypes env mty_actual' mty_decl'
+          with Includemod.Error msg ->
+            raise(Error(modl.mod_loc, env, Not_included msg)) in
+        let modl' =
+            { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
+                Tmodtype_explicit mty_decl, coercion);
+              mod_type = mty_decl.mty_type;
+              mod_env = env;
+              mod_loc = modl.mod_loc;
+              mod_attributes = [];
+             } in
+        {
+         mb_id = id;
+         mb_name = id_loc;
+         mb_expr = modl';
+         mb_attributes = attrs;
+         mb_loc = loc;
+        }
+      in
+      List.map check_inclusion bindings
+    end
+  in check_incl true (List.length bindings) env Subst.identity
+
+(* Helper for unpack *)
+
+let rec package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else let sg = extract_sig env loc mty in
+  let sg' =
+    List.map
+      (function
+        | Sig_type (id, ({type_params=[]} as td), rs)
+          when List.mem_assoc [Ident.name id] constrs ->
+            let ty = List.assoc [Ident.name id] constrs in
+            Sig_type (id, {td with type_manifest = Some ty}, rs)
+        | Sig_module (id, md, rs) ->
+            let rec aux = function
+              | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id ->
+                  (l, t) :: aux rest
+              | _ :: rest -> aux rest
+              | [] -> []
+            in
+            let md =
+              {md with
+               md_type = package_constraints env loc md.md_type (aux constrs)
+              }
+            in
+            Sig_module (id, md, rs)
+        | item -> item
+      )
+      sg
+  in
+  Mty_signature sg'
+
+let modtype_of_package env loc p nl tl =
+  try match (Env.find_modtype p env).mtd_type with
+  | Some mty when nl <> [] ->
+      package_constraints env loc mty
+        (List.combine (List.map Longident.flatten nl) tl)
+  | _ ->
+      if nl = [] then Mty_ident p
+      else raise(Error(loc, env, Signature_expected))
+  with Not_found ->
+    let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in
+    raise(Typetexp.Error(loc, env, error))
+
+let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
+  let mkmty p nl tl =
+    let ntl =
+      List.filter (fun (_n,t) -> Ctype.free_variables t = [])
+        (List.combine nl tl) in
+    let (nl, tl) = List.split ntl in
+    modtype_of_package env Location.none p nl tl
+  in
+  let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in
+  try Includemod.modtypes env mty1 mty2 = Tcoerce_none
+  with Includemod.Error _msg -> false
+    (* raise(Error(Location.none, env, Not_included msg)) *)
+
+let () = Ctype.package_subtype := package_subtype
+
+let wrap_constraint env arg mty explicit =
+  let coercion =
+    try
+      Includemod.modtypes env arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, env, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_attributes = [];
+    mod_loc = arg.mod_loc }
+
+(* Type a module value expression *)
+
+let rec type_module ?(alias=false) sttn funct_body anchor env smod =
+  match smod.pmod_desc with
+    Pmod_ident lid ->
+      let path =
+        Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in
+      let md = { mod_desc = Tmod_ident (path, lid);
+                 mod_type = Mty_alias(Mta_absent, path);
+                 mod_env = env;
+                 mod_attributes = smod.pmod_attributes;
+                 mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
+      let md =
+        if alias && aliasable then
+          (Env.add_required_global (Path.head path); md)
+        else match (Env.find_module path env).md_type with
+          Mty_alias(_, p1) when not alias ->
+            let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
+            let mty = Includemod.expand_module_alias env [] p1 in
+            { md with
+              mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,
+                                          Tcoerce_alias (p1, Tcoerce_none));
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
+        | mty ->
+            let mty =
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
+            { md with mod_type = mty }
+      in rm md
+  | Pmod_structure sstr ->
+      let (str, sg, _finalenv) =
+        type_structure funct_body anchor env sstr smod.pmod_loc in
+      let md =
+        rm { mod_desc = Tmod_structure str;
+             mod_type = Mty_signature sg;
+             mod_env = env;
+             mod_attributes = smod.pmod_attributes;
+             mod_loc = smod.pmod_loc }
+      in
+      let sg' = simplify_signature sg in
+      if List.length sg' = List.length sg then md else
+      wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg')
+        Tmodtype_implicit
+  | Pmod_functor(name, smty, sbody) ->
+      let mty = may_map (transl_modtype env) smty in
+      let ty_arg = may_map (fun m -> m.mty_type) mty in
+      let (id, newenv), funct_body =
+        match ty_arg with None -> (Ident.create "*", env), false
+        | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in
+      Ctype.init_def(Ident.current_time()); (* PR#6981 *)
+      let body = type_module sttn funct_body None newenv sbody in
+      rm { mod_desc = Tmod_functor(id, name, mty, body);
+           mod_type = Mty_functor(id, ty_arg, body.mod_type);
+           mod_env = env;
+           mod_attributes = smod.pmod_attributes;
+           mod_loc = smod.pmod_loc }
+  | Pmod_apply(sfunct, sarg) ->
+      let arg = type_module true funct_body None env sarg in
+      let path = path_of_module arg in
+      let funct =
+        type_module (sttn && path <> None) funct_body None env sfunct in
+      begin match Env.scrape_alias env funct.mod_type with
+        Mty_functor(param, mty_param, mty_res) as mty_functor ->
+          let generative, mty_param =
+            (mty_param = None, Btype.default_mty mty_param) in
+          if generative then begin
+            if sarg.pmod_desc <> Pmod_structure [] then
+              raise (Error (sfunct.pmod_loc, env, Apply_generative));
+            if funct_body && Mtype.contains_type env funct.mod_type then
+              raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+          end;
+          let coercion =
+            try
+              Includemod.modtypes env arg.mod_type mty_param
+            with Includemod.Error msg ->
+              raise(Error(sarg.pmod_loc, env, Not_included msg)) in
+          let mty_appl =
+            match path with
+              Some path ->
+                Subst.modtype (Subst.add_module param path Subst.identity)
+                              mty_res
+            | None ->
+                if generative then mty_res else
+                try
+                  Mtype.nondep_supertype
+                    (Env.add_module ~arg:true param arg.mod_type env)
+                    param mty_res
+                with Not_found ->
+                  raise(Error(smod.pmod_loc, env,
+                              Cannot_eliminate_dependency mty_functor))
+          in
+          rm { mod_desc = Tmod_apply(funct, arg, coercion);
+               mod_type = mty_appl;
+               mod_env = env;
+               mod_attributes = smod.pmod_attributes;
+               mod_loc = smod.pmod_loc }
+      | Mty_alias(_, path) ->
+          raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
+      | _ ->
+          raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
+      end
+  | Pmod_constraint(sarg, smty) ->
+      let arg = type_module ~alias true funct_body anchor env sarg in
+      let mty = transl_modtype env smty in
+      rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with
+          mod_loc = smod.pmod_loc;
+          mod_attributes = smod.pmod_attributes;
+         }
+
+  | Pmod_unpack sexp ->
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, nl, tl)} ->
+            if List.exists (fun t -> Ctype.free_variables t <> []) tl then
+              raise (Error (smod.pmod_loc, env,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p nl tl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
+      in
+      if funct_body && Mtype.contains_type env mty then
+        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+      rm { mod_desc = Tmod_unpack(exp, mty);
+           mod_type = mty;
+           mod_env = env;
+           mod_attributes = smod.pmod_attributes;
+           mod_loc = smod.pmod_loc }
+  | Pmod_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
+  let names = new_names () in
+
+  let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} =
+    match desc with
+    | Pstr_eval (sexpr, attrs) ->
+        let expr =
+          Builtin_attributes.with_warning_attribute attrs
+            (fun () -> Typecore.type_expression env sexpr)
+        in
+        Tstr_eval (expr, attrs), [], env
+    | Pstr_value(rec_flag, sdefs) ->
+        let scope =
+          match rec_flag with
+          | Recursive ->
+              Some (Annot.Idef {scope with
+                                Location.loc_start = loc.Location.loc_start})
+          | Nonrecursive ->
+              let start =
+                match srem with
+                | [] -> loc.Location.loc_end
+                | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
+              in
+              Some (Annot.Idef {scope with Location.loc_start = start})
+        in
+        let (defs, newenv) =
+          Typecore.type_binding env rec_flag sdefs scope in
+        (* Note: Env.find_value does not trigger the value_used event. Values
+           will be marked as being used during the signature inclusion test. *)
+        Tstr_value(rec_flag, defs),
+        List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv))
+          (let_bound_idents defs),
+        newenv
+    | Pstr_primitive sdesc ->
+        let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
+        Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv
+    | Pstr_type (rec_flag, sdecls) ->
+        List.iter
+          (fun decl -> check_name check_type names decl.ptype_name)
+          sdecls;
+        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        Tstr_type (rec_flag, decls),
+        map_rec_type_with_row_types ~rec_flag
+          (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs))
+          decls [],
+        enrich_type_decls anchor decls env newenv
+    | Pstr_typext styext ->
+        List.iter
+          (fun pext -> check_name check_typext names pext.pext_name)
+          styext.ptyext_constructors;
+        let (tyext, newenv) =
+          Typedecl.transl_type_extension true env loc styext
+        in
+        (Tstr_typext tyext,
+         map_ext
+           (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es))
+           tyext.tyext_constructors [],
+         newenv)
+    | Pstr_exception sext ->
+        check_name check_typext names sext.pext_name;
+        let (ext, newenv) = Typedecl.transl_exception env sext in
+        Tstr_exception ext,
+        [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)],
+        newenv
+    | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
+                   pmb_loc;
+                  } ->
+        check_name check_module names name;
+        let id = Ident.create name.txt in (* create early for PR#6752 *)
+        let modl =
+          Builtin_attributes.with_warning_attribute attrs
+            (fun () ->
+               type_module ~alias:true true funct_body
+                 (anchor_submodule name.txt anchor) env smodl
+            )
+        in
+        let md =
+          { md_type = enrich_module_type anchor name.txt modl.mod_type env;
+            md_attributes = attrs;
+            md_loc = pmb_loc;
+          }
+        in
+        (*prerr_endline (Ident.unique_toplevel_name id);*)
+        Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type;
+        let newenv = Env.enter_module_declaration id md env in
+        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
+                     mb_attributes=attrs;  mb_loc=pmb_loc;
+                    },
+        [Sig_module(id,
+                    {md_type = modl.mod_type;
+                     md_attributes = attrs;
+                     md_loc = pmb_loc;
+                    }, Trec_not)],
+        newenv
+    | Pstr_recmodule sbind ->
+        let sbind =
+          List.map
+            (function
+              | {pmb_name = name;
+                 pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)};
+                 pmb_attributes = attrs;
+                 pmb_loc = loc;
+                } ->
+                  name, typ, expr, attrs, loc
+              | mb ->
+                  raise (Error (mb.pmb_expr.pmod_loc, env,
+                                Recursive_module_require_explicit_type))
+            )
+            sbind
+        in
+        List.iter
+          (fun (name, _, _, _, _) -> check_name check_module names name)
+          sbind;
+        let (decls, newenv) =
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
+                 {pmd_name=name; pmd_type=smty;
+                  pmd_attributes=attrs; pmd_loc=loc}) sbind
+            ) in
+        let bindings1 =
+          List.map2
+            (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) ->
+               let modl =
+                 Builtin_attributes.with_warning_attribute attrs
+                   (fun () ->
+                      type_module true funct_body (anchor_recmodule id)
+                        newenv smodl
+                   )
+               in
+               let mty' =
+                 enrich_module_type anchor (Ident.name id) modl.mod_type newenv
+               in
+               (id, name, mty, modl, mty', attrs, loc))
+            decls sbind in
+        let newenv = (* allow aliasing recursive modules from outside *)
+          List.fold_left
+            (fun env md ->
+               let mdecl =
+                 {
+                   md_type = md.md_type.mty_type;
+                   md_attributes = md.md_attributes;
+                   md_loc = md.md_loc;
+                 }
+               in
+               Env.add_module_declaration ~check:true md.md_id mdecl env
+            )
+            env decls
+        in
+        let bindings2 =
+          check_recmodule_inclusion newenv bindings1 in
+        Tstr_recmodule bindings2,
+        map_rec (fun rs mb ->
+            Sig_module(mb.mb_id, {
+                md_type=mb.mb_expr.mod_type;
+                md_attributes=mb.mb_attributes;
+                md_loc=mb.mb_loc;
+              }, rs))
+           bindings2 [],
+        newenv
+    | Pstr_modtype pmtd ->
+        (* check that it is non-abstract *)
+        let newenv, mtd, sg =
+          Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
+            (fun () -> transl_modtype_decl names env pmtd)
+        in
+        Tstr_modtype mtd, [sg], newenv
+    | Pstr_open sod ->
+        let (_path, newenv, od) = type_open ~toplevel env sod in
+        Tstr_open od, [], newenv
+    | Pstr_class cl ->
+        List.iter
+          (fun {pci_name} -> check_name check_type names pci_name)
+          cl;
+        let (classes, new_env) = Typeclass.class_declarations env cl in
+        Tstr_class
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
+(* TODO: check with Jacques why this is here
+      Tstr_class_type
+          (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
+      Tstr_type
+          (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) ::
+      Tstr_type
+          (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
+*)
+        List.flatten
+          (map_rec
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
+             classes []),
+        new_env
+    | Pstr_class_type cl ->
+        List.iter
+          (fun {pci_name} -> check_name check_type names pci_name)
+          cl;
+        let (classes, new_env) = Typeclass.class_type_declarations env cl in
+        Tstr_class_type
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
+(*  TODO: check with Jacques why this is here
+           Tstr_type
+             (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
+           Tstr_type
+             (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
+        List.flatten
+          (map_rec
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
+             classes []),
+        new_env
+    | Pstr_include sincl ->
+        let smodl = sincl.pincl_mod in
+        let modl =
+          Builtin_attributes.with_warning_attribute sincl.pincl_attributes
+            (fun () -> type_module true funct_body None env smodl)
+        in
+        (* Rename all identifiers bound by this signature to avoid clashes *)
+        let sg = Subst.signature Subst.identity
+            (extract_sig_open env smodl.pmod_loc modl.mod_type) in
+        List.iter (check_sig_item names loc) sg;
+        let new_env = Env.add_signature sg env in
+        let incl =
+          { incl_mod = modl;
+            incl_type = sg;
+            incl_attributes = sincl.pincl_attributes;
+            incl_loc = sincl.pincl_loc;
+          }
+        in
+        Tstr_include incl, sg, new_env
+    | Pstr_extension (ext, _attrs) ->
+        raise (Error_forward (Builtin_attributes.error_of_extension ext))
+    | Pstr_attribute x ->
+        Builtin_attributes.warning_attribute [x];
+        Tstr_attribute x, [], env
+  in
+  let rec type_struct env sstr =
+    Ctype.init_def(Ident.current_time());
+    match sstr with
+    | [] -> ([], [], env)
+    | pstr :: srem ->
+        let previous_saved_types = Cmt_format.get_saved_types () in
+        let desc, sg, new_env = type_str_item env srem pstr in
+        let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in
+        Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+                                    :: previous_saved_types);
+        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+        (str :: str_rem, sg @ sig_rem, final_env)
+  in
+  if !Clflags.annotations then
+    (* moved to genannot *)
+    List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  if not toplevel then Builtin_attributes.warning_enter_scope ();
+  let (items, sg, final_env) = type_struct env sstr in
+  let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+  if not toplevel then Builtin_attributes.warning_leave_scope ();
+  Cmt_format.set_saved_types
+    (Cmt_format.Partial_structure str :: previous_saved_types);
+  str, sg, final_env
+
+let type_toplevel_phrase env s =
+  Env.reset_required_globals ();
+  begin
+    let iter = Builtin_attributes.emit_external_warnings in
+    iter.Ast_iterator.structure iter s
+  end;
+  let (str, sg, env) =
+    type_structure ~toplevel:true false None env s Location.none in
+  let (str, _coerce) = ImplementationHooks.apply_hooks
+      { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none)
+  in
+  (str, sg, env)
+
+let type_module_alias = type_module ~alias:true true false None
+let type_module = type_module true false None
+let type_structure = type_structure false None
+
+(* Normalize types in a signature *)
+
+let rec normalize_modtype env = function
+    Mty_ident _
+  | Mty_alias _ -> ()
+  | Mty_signature sg -> normalize_signature env sg
+  | Mty_functor(_id, _param, body) -> normalize_modtype env body
+
+and normalize_signature env = List.iter (normalize_signature_item env)
+
+and normalize_signature_item env = function
+    Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type
+  | Sig_module(_id, md, _) -> normalize_modtype env md.md_type
+  | _ -> ()
+
+(* Extract the module type of a module expression *)
+
+let type_module_type_of env smod =
+  let tmty =
+    match smod.pmod_desc with
+    | Pmod_ident lid -> (* turn off strengthening in this case *)
+        let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in
+        rm { mod_desc = Tmod_ident (path, lid);
+             mod_type = md.md_type;
+             mod_env = env;
+             mod_attributes = smod.pmod_attributes;
+             mod_loc = smod.pmod_loc }
+    | _ -> type_module env smod in
+  let mty = tmty.mod_type in
+  (* PR#6307: expand aliases at root and submodules *)
+  let mty = Mtype.remove_aliases env mty in
+  (* PR#5036: must not contain non-generalized type variables *)
+  if not (closed_modtype env mty) then
+    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
+  tmty, mty
+
+(* For Typecore *)
+
+let type_package env m p nl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  let lv = Ctype.get_current_level () in
+  Ctype.begin_def ();
+  Ident.set_current_time lv;
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  Ctype.init_def(Ident.current_time());
+  Typetexp.widen context;
+  let (mp, env) =
+    match modl.mod_desc with
+      Tmod_ident (mp,_) -> (mp, env)
+    | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
+        -> (mp, env)  (* PR#6982 *)
+    | _ ->
+      let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in
+      (Pident id, new_env)
+  in
+  let rec mkpath mp = function
+    | Lident name -> Pdot(mp, name, nopos)
+    | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos)
+    | _ -> assert false
+  in
+  let tl' =
+    List.map
+      (fun name -> Btype.newgenty (Tconstr (mkpath mp name,[],ref Mnil)))
+      nl in
+  (* go back to original level *)
+  Ctype.end_def ();
+  if nl = [] then
+    (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, [])
+  else let mty = modtype_of_package env modl.mod_loc p nl tl' in
+  List.iter2
+    (fun n ty ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ ->
+        raise (Error(m.pmod_loc, env, Scoping_pack (n,ty))))
+    nl tl';
+  (wrap_constraint env modl mty Tmodtype_implicit, tl')
+
+(* Fill in the forward declarations *)
+let () =
+  Typecore.type_module := type_module_alias;
+  Typetexp.transl_modtype_longident := transl_modtype_longident;
+  Typetexp.transl_modtype := transl_modtype;
+  Typecore.type_open := type_open_ ?toplevel:None;
+  Typecore.type_package := type_package;
+  type_module_type_of_fwd := type_module_type_of
+
+
+(* Typecheck an implementation file *)
+
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  Cmt_format.clear ();
+  try
+  Typecore.reset_delayed_checks ();
+  Env.reset_required_globals ();
+  begin
+    let iter = Builtin_attributes.emit_external_warnings in
+    iter.Ast_iterator.structure iter ast
+  end;
+
+  let (str, sg, finalenv) =
+    type_structure initial_env ast (Location.in_file sourcefile) in
+  let simple_sg = simplify_signature sg in
+  if !Clflags.print_types then begin
+    Printtyp.wrap_printing_env initial_env
+      (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
+    (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
+  end else begin
+    let sourceintf =
+      Filename.remove_extension sourcefile ^ !Config.interface_suffix in
+    if Sys.file_exists sourceintf then begin
+      let intf_file =
+        try
+          find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
+        with Not_found ->
+          raise(Error(Location.in_file sourcefile, Env.empty,
+                      Interface_not_compiled sourceintf)) in
+      let dclsig = Env.read_signature modulename intf_file in
+      let coercion =
+        Includemod.compunit initial_env sourcefile sg intf_file dclsig in
+      Typecore.force_delayed_checks ();
+      (* It is important to run these checks after the inclusion test above,
+         so that value declarations which are not used internally but exported
+         are not reported as being unused. *)
+      Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
+        (Cmt_format.Implementation str) (Some sourcefile) initial_env None;
+      (str, coercion)
+    end else begin
+      check_nongen_schemes finalenv sg;
+      normalize_signature finalenv simple_sg;
+      let coercion =
+        Includemod.compunit initial_env sourcefile sg
+                            "(inferred signature)" simple_sg in
+      Typecore.force_delayed_checks ();
+      (* See comment above. Here the target signature contains all
+         the value being exported. We can still capture unused
+         declarations like "let x = true;; let x = 1;;", because in this
+         case, the inferred signature contains only the last declaration. *)
+      if not !Clflags.dont_write_files then begin
+        let deprecated = Builtin_attributes.deprecated_of_str ast in
+        let cmi =
+          Env.save_signature ~deprecated
+            simple_sg modulename (outputprefix ^ ".cmi")
+        in
+        Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+          (Cmt_format.Implementation str)
+          (Some sourcefile) initial_env (Some cmi);
+      end;
+      (str, coercion)
+    end
+    end
+  with e ->
+    Cmt_format.save_cmt  (outputprefix ^ ".cmt") modulename
+      (Cmt_format.Partial_implementation
+         (Array.of_list (Cmt_format.get_saved_types ())))
+      (Some sourcefile) initial_env None;
+    raise e
+
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  ImplementationHooks.apply_hooks { Misc.sourcefile }
+    (type_implementation sourcefile outputprefix modulename initial_env ast)
+
+let save_signature modname tsg outputprefix source_file initial_env cmi =
+  Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
+    (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
+
+let type_interface sourcefile env ast =
+  begin
+    let iter = Builtin_attributes.emit_external_warnings in
+    iter.Ast_iterator.signature iter ast
+  end;
+  InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast)
+
+(* "Packaging" of several compilation units into one unit
+   having them as sub-modules.  *)
+
+let rec package_signatures subst = function
+    [] -> []
+  | (name, sg) :: rem ->
+      let sg' = Subst.signature subst sg in
+      let oldid = Ident.create_persistent name
+      and newid = Ident.create name in
+      Sig_module(newid, {md_type=Mty_signature sg';
+                         md_attributes=[];
+                         md_loc=Location.none;
+                        },
+                 Trec_not) ::
+      package_signatures (Subst.add_module oldid (Pident newid) subst) rem
+
+let package_units initial_env objfiles cmifile modulename =
+  (* Read the signatures of the units *)
+  let units =
+    List.map
+      (fun f ->
+         let pref = chop_extensions f in
+         let modname = String.capitalize_ascii(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_safe_string sg)
+         then raise(Error(Location.none, Env.empty,
+                          Implementation_is_required f));
+         (modname, Env.read_signature modname (pref ^ ".cmi")))
+      objfiles in
+  (* Compute signature of packaged unit *)
+  Ident.reinit();
+  let sg = package_signatures Subst.identity units in
+  (* See if explicit interface is provided *)
+  let prefix = Filename.remove_extension cmifile in
+  let mlifile = prefix ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    if not (Sys.file_exists cmifile) then begin
+      raise(Error(Location.in_file mlifile, Env.empty,
+                  Interface_not_compiled mlifile))
+    end;
+    let dclsig = Env.read_signature modulename cmifile in
+    Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
+      (Cmt_format.Packed (sg, objfiles)) None initial_env  None ;
+    Includemod.compunit initial_env "(obtained by packing)" sg mlifile dclsig
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, _crc) -> not (List.mem name unit_names))
+        (Env.imports()) in
+    (* Write packaged signature *)
+    if not !Clflags.dont_write_files then begin
+      let cmi =
+        Env.save_signature_with_imports ~deprecated:None
+          sg modulename
+          (prefix ^ ".cmi") imports
+      in
+      Cmt_format.save_cmt (prefix ^ ".cmt")  modulename
+        (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env (Some cmi)
+    end;
+    Tcoerce_none
+  end
+
+(* Error report *)
+
+open Printtyp
+
+let report_error ppf = function
+    Cannot_apply mty ->
+      fprintf ppf
+        "@[This module is not a functor; it has type@ %a@]" modtype mty
+  | Not_included errs ->
+      fprintf ppf
+        "@[Signature mismatch:@ %a@]" Includemod.report_error errs
+  | Cannot_eliminate_dependency mty ->
+      fprintf ppf
+        "@[This functor has type@ %a@ \
+           The parameter cannot be eliminated in the result type.@  \
+           Please bind the argument to a module identifier.@]" modtype mty
+  | Signature_expected -> fprintf ppf "This module type is not a signature"
+  | Structure_expected mty ->
+      fprintf ppf
+        "@[This module is not a structure; it has type@ %a" modtype mty
+  | With_no_component lid ->
+      fprintf ppf
+        "@[The signature constrained by `with' has no component named %a@]"
+        longident lid
+  | With_mismatch(lid, explanation) ->
+      fprintf ppf
+        "@[\
+           @[In this `with' constraint, the new definition of %a@ \
+             does not match its original definition@ \
+             in the constrained signature:@]@ \
+           %a@]"
+        longident lid Includemod.report_error explanation
+  | Repeated_name(kind, name) ->
+      fprintf ppf
+        "@[Multiple definition of the %s name %s.@ \
+           Names must be unique in a given structure or signature.@]" kind name
+  | Non_generalizable typ ->
+      fprintf ppf
+        "@[The type of this expression,@ %a,@ \
+           contains type variables that cannot be generalized@]" type_scheme typ
+  | Non_generalizable_class (id, desc) ->
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (class_declaration id) desc
+  | Non_generalizable_module mty ->
+      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 %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
+  | Interface_not_compiled intf_name ->
+      fprintf ppf
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
+  | Not_allowed_in_functor_body ->
+      fprintf ppf
+        "@[This expression creates fresh types.@ %s@]"
+        "It is not allowed inside applicative functors."
+  | With_need_typeconstr ->
+      fprintf ppf
+        "Only type constructors with identical parameters can be substituted."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      fprintf ppf
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      fprintf ppf
+        "The type %a in this module cannot be exported.@ " longident lid;
+      fprintf ppf
+        "Its type contains local dependencies:@ %a" type_expr ty
+  | Recursive_module_require_explicit_type ->
+      fprintf ppf "Recursive modules require an explicit module type."
+  | Apply_generative ->
+      fprintf ppf "This is a generative functor. It can only be applied to ()"
+  | Cannot_scrape_alias p ->
+      fprintf ppf
+        "This is an alias for module %a, which is missing"
+        path p
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/typing/typemod.mli b/typing/typemod.mli
new file mode 100644
index 00000000..fab7cdae
--- /dev/null
+++ b/typing/typemod.mli
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Type-checking of the module language *)
+
+open Types
+open Format
+
+val type_module:
+        Env.t -> Parsetree.module_expr -> Typedtree.module_expr
+val type_structure:
+        Env.t -> Parsetree.structure -> Location.t ->
+         Typedtree.structure * Types.signature * Env.t
+val type_toplevel_phrase:
+        Env.t -> Parsetree.structure ->
+         Typedtree.structure * Types.signature * Env.t
+val type_implementation:
+  string -> string -> string -> Env.t -> Parsetree.structure ->
+  Typedtree.structure * Typedtree.module_coercion
+val type_interface:
+        string -> Env.t -> Parsetree.signature -> Typedtree.signature
+val transl_signature:
+        Env.t -> Parsetree.signature -> Typedtree.signature
+val check_nongen_schemes:
+        Env.t -> Types.signature -> unit
+val type_open_:
+        ?toplevel:bool -> Asttypes.override_flag ->
+        Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
+val modtype_of_package:
+        Env.t -> Location.t ->
+        Path.t -> Longident.t list -> type_expr list -> module_type
+val simplify_signature: signature -> signature
+
+val path_of_module : Typedtree.module_expr -> Path.t option
+
+val save_signature:
+  string -> Typedtree.signature -> string -> string ->
+  Env.t -> Cmi_format.cmi_infos -> unit
+
+val package_units:
+  Env.t -> string list -> string -> string -> Typedtree.module_coercion
+
+type error =
+    Cannot_apply of module_type
+  | Not_included of Includemod.error list
+  | Cannot_eliminate_dependency of module_type
+  | Signature_expected
+  | Structure_expected of module_type
+  | With_no_component of Longident.t
+  | With_mismatch of Longident.t * Includemod.error list
+  | Repeated_name of string * string
+  | 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
+  | Not_allowed_in_functor_body
+  | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
+  | Recursive_module_require_explicit_type
+  | Apply_generative
+  | Cannot_scrape_alias of Path.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+val report_error: Env.t -> formatter -> error -> unit
+
+
+module ImplementationHooks : Misc.HookSig
+  with type t = Typedtree.structure * Typedtree.module_coercion
+module InterfaceHooks : Misc.HookSig
+  with type t = Typedtree.signature
diff --git a/typing/types.ml b/typing/types.ml
new file mode 100644
index 00000000..0e85644f
--- /dev/null
+++ b/typing/types.ml
@@ -0,0 +1,336 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Representation of types and declarations *)
+
+open Asttypes
+
+(* Type expressions for the core language *)
+
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    id: int }
+
+and type_desc =
+    Tvar of string option
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  | Ttuple of type_expr list
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  | Tfield of string * field_kind * type_expr * type_expr
+  | Tnil
+  | Tlink of type_expr
+  | Tsubst of type_expr         (* for copying *)
+  | Tvariant of row_desc
+  | Tunivar of string option
+  | Tpoly of type_expr * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
+
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit;
+      row_closed: bool;
+      row_fixed: bool;
+      row_name: (Path.t * type_expr list) option }
+
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+and abbrev_memo =
+    Mnil
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  | Mlink of abbrev_memo ref
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps = struct
+  type t = type_expr
+  let compare t1 t2 = t1.id - t2.id
+  let hash t = t.id
+  let equal t1 t2 = t1 == t2
+end
+
+(* Maps of methods and instance variables *)
+
+module OrderedString =
+  struct type t = string let compare (x:t) y = compare x y end
+module Meths = Map.Make(OrderedString)
+module Vars = Meths
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+ }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * Asttypes.mutable_flag *
+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+  | Val_unbound                         (* Unbound variable *)
+
+(* Variance *)
+
+module Variance = struct
+  type t = int
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
+  let subset v1 v2 = (v1 land v2 = v1)
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
+  let null = 0
+  let may_inv = 7
+  let full = 127
+  let covariant = single May_pos lor single Pos lor single Inj
+  let swap f1 f2 v =
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    type_newtype_level: (int * int) option;
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: bool;
+    type_unboxed: unboxed_status;
+ }
+
+and type_kind =
+    Type_abstract
+  | Type_record of label_declaration list  * record_representation
+  | Type_variant of constructor_declaration list
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension                    (* Inlined record under extension *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+and unboxed_status =
+  {
+    unboxed: bool;
+    default: bool; (* False if the unboxed field was set from an attribute. *)
+  }
+
+let unboxed_false_default_false = {unboxed = false; default = false}
+let unboxed_false_default_true = {unboxed = false; default = true}
+let unboxed_true_default_false = {unboxed = true; default = false}
+let unboxed_true_default_true = {unboxed = true; default = true}
+
+type extension_constructor =
+    { ext_type_path: Path.t;
+      ext_type_params: type_expr list;
+      ext_args: constructor_arguments;
+      ext_ret_type: type_expr option;
+      ext_private: private_flag;
+      ext_loc: Location.t;
+      ext_attributes: Parsetree.attributes; }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr = Set.Make(OrderedString)
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+ }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+  }
+
+(* Type expressions for the module language *)
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of Ident.t * module_type option * module_type
+  | Mty_alias of alias_presence * Path.t
+
+and alias_presence =
+  | Mta_present
+  | Mta_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description
+  | Sig_type of Ident.t * type_declaration * rec_status
+  | Sig_typext of Ident.t * extension_constructor * ext_status
+  | Sig_module of Ident.t * module_declaration * rec_status
+  | Sig_modtype of Ident.t * modtype_declaration
+  | Sig_class of Ident.t * class_declaration * rec_status
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* Nonte: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor of an extension *)
+  | Text_next                      (* not first constructor of an extension *)
+  | Text_exception                 (* an exception *)
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+   }
diff --git a/typing/types.mli b/typing/types.mli
new file mode 100644
index 00000000..2dc1481e
--- /dev/null
+++ b/typing/types.mli
@@ -0,0 +1,487 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {0 Representation of types and declarations} *)
+
+(** [Types] defines the representation of types and declarations (that is, the
+    content of module signatures).
+
+    CMI files are made of marshalled types.
+*)
+
+(** Asttypes exposes basic definitions shared both by Parsetree and Types. *)
+open Asttypes
+
+(** Type expressions for the core language.
+
+    The [type_desc] variant defines all the possible type expressions one can
+    find in OCaml. [type_expr] wraps this with some annotations.
+
+    The [level] field tracks the level of polymorphism associated to a type,
+    guiding the generalization algorithm.
+    Put shortly, when referring to a type in a given environment, both the type
+    and the environment have a level. If the type has an higher level, then it
+    can be considered fully polymorphic (type variables will be printed as
+    ['a]), otherwise it'll be weakly polymorphic, or non generalized (type
+    variables printed as ['_a]).
+    See [http://okmij.org/ftp/ML/generalization.html] for more information.
+
+    Note about [type_declaration]: one should not make the confusion between
+    [type_expr] and [type_declaration].
+
+    [type_declaration] refers specifically to the [type] construct in OCaml
+    language, where you create and name a new type or type alias.
+
+    [type_expr] is used when you refer to existing types, e.g. when annotating
+    the expected type of a value.
+
+    Also, as the type system of OCaml is generative, a [type_declaration] can
+    have the side-effect of introducing a new type constructor, different from
+    all other known types.
+    Whereas [type_expr] is a pure construct which allows referring to existing
+    types.
+
+    Note on mutability: TBD.
+ *)
+type type_expr =
+  { mutable desc: type_desc;
+    mutable level: int;
+    id: int }
+
+and type_desc =
+  | Tvar of string option
+  (** [Tvar (Some "a")] ==> ['a] or ['_a]
+      [Tvar None]       ==> [_] *)
+
+  | Tarrow of arg_label * type_expr * type_expr * commutable
+  (** [Tarrow (Nolabel,      e1, e2, c)] ==> [e1    -> e2]
+      [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1  -> e2]
+      [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2]
+
+      See [commutable] for the last argument. *)
+
+  | Ttuple of type_expr list
+  (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *)
+
+  | Tconstr of Path.t * type_expr list * abbrev_memo ref
+  (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t]
+      The last parameter keep tracks of known expansions, see [abbrev_memo]. *)
+
+  | Tobject of type_expr * (Path.t * type_expr list) option ref
+  (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >]
+      f1, fn are represented as a linked list of types using Tfield and Tnil
+      constructors.
+
+      [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct].
+      where A.ct is the type of some class.
+
+      There are also special cases for so-called "class-types", cf. [Typeclass]
+      and [Ctype.set_object_name]:
+
+        [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...),
+                         Some(`A.#ct`, [rv;t1;...;tn])]
+             ==> [(t1, ..., tn) #A.ct]
+        [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct]
+
+      where [rv] is the hidden row variable.
+  *)
+
+  | Tfield of string * field_kind * type_expr * type_expr
+  (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *)
+
+  | Tnil
+  (** [Tnil] ==> [<...; >] *)
+
+  | Tlink of type_expr
+  (** Indirection used by unification engine. *)
+
+  | Tsubst of type_expr         (* for copying *)
+  (** [Tsubst] is used temporarily to store information in low-level
+      functions manipulating representation of types, such as
+      instantiation or copy.
+      This constructor should not appear outside of these cases. *)
+
+  | Tvariant of row_desc
+  (** Representation of polymorphic variants, see [row_desc]. *)
+
+  | Tunivar of string option
+  (** Occurrence of a type variable introduced by a
+      forall quantifier / [Tpoly]. *)
+
+  | Tpoly of type_expr * type_expr list
+  (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
+      where 'a1 ... 'an are names given to types in tyl
+      and occurences of those types in ty. *)
+
+  | Tpackage of Path.t * Longident.t list * type_expr list
+  (** Type of a first-class module (a.k.a package). *)
+
+(** [  `X | `Y ]       (row_closed = true)
+    [< `X | `Y ]       (row_closed = true)
+    [> `X | `Y ]       (row_closed = false)
+    [< `X | `Y > `X ]  (row_closed = true)
+
+    type t = [> `X ] as 'a      (row_more = Tvar a)
+    type t = private [> `X ]    (row_more = Tconstr (t#row, [], ref Mnil)
+
+    And for:
+
+        let f = function `X -> `X -> | `Y -> `X
+
+    the type of "f" will be a [Tarrow] whose lhs will (basically) be:
+
+        Tvariant { row_fields = [("X", _)];
+                   row_more   =
+                     Tvariant { row_fields = [("Y", _)];
+                                row_more   =
+                                  Tvariant { row_fields = [];
+                                             row_more   = _;
+                                             _ };
+                                _ };
+                   _
+                 }
+
+*)
+and row_desc =
+    { row_fields: (label * row_field) list;
+      row_more: type_expr;
+      row_bound: unit; (* kept for compatibility *)
+      row_closed: bool;
+      row_fixed: bool;
+      row_name: (Path.t * type_expr list) option }
+
+and row_field =
+    Rpresent of type_expr option
+  | Reither of bool * type_expr list * bool * row_field option ref
+        (* 1st true denotes a constant constructor *)
+        (* 2nd true denotes a tag in a pattern matching, and
+           is erased later *)
+  | Rabsent
+
+(** [abbrev_memo] allows one to keep track of different expansions of a type
+    alias. This is done for performance purposes.
+
+    For instance, when defining [type 'a pair = 'a * 'a], when one refers to an
+    ['a pair], it is just a shortcut for the ['a * 'a] type.
+    This expansion will be stored in the [abbrev_memo] of the corresponding
+    [Tconstr] node.
+
+    In practice, [abbrev_memo] behaves like list of expansions with a mutable
+    tail.
+
+    Note on marshalling: [abbrev_memo] must not appear in saved types.
+    [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and
+    removing abbreviations.
+*)
+and abbrev_memo =
+  | Mnil (** No known abbrevation *)
+
+  | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+  (** Found one abbreviation.
+      A valid abbreviation should be at least as visible and reachable by the
+      same path.
+      The first expression is the abbreviation and the second the expansion. *)
+
+  | Mlink of abbrev_memo ref
+  (** Abbreviations can be found after this indirection *)
+
+and field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+(** [commutable] is a flag appended to every arrow type.
+
+    When typing an application, if the type of the functional is
+    known, its type is instantiated with [Cok] arrows, otherwise as
+    [Clink (ref Cunknown)].
+
+    When the type is not known, the application will be used to infer
+    the actual type.  This is fragile in presence of labels where
+    there is no principal type.
+
+    Two incompatible applications relying on [Cunknown] arrows will
+    trigger an error.
+
+    let f g =
+      g ~a:() ~b:();
+      g ~b:() ~a:();
+
+    Error: This function is applied to arguments
+    in an order different from other calls.
+    This is only allowed when the real type is known.
+*)
+and commutable =
+    Cok
+  | Cunknown
+  | Clink of commutable ref
+
+module TypeOps : sig
+  type t = type_expr
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+(* Maps of methods and instance variables *)
+
+module Meths : Map.S with type key = string
+module Vars  : Map.S with type key = string
+
+(* Value descriptions *)
+
+type value_description =
+  { val_type: type_expr;                (* Type of the value *)
+    val_kind: value_kind;
+    val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
+   }
+
+and value_kind =
+    Val_reg                             (* Regular value *)
+  | Val_prim of Primitive.description   (* Primitive *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+  | Val_self of (Ident.t * type_expr) Meths.t ref *
+                (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
+                string * type_expr
+                                        (* Self *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
+  | Val_unbound                         (* Unbound variable *)
+
+(* Variance *)
+
+module Variance : sig
+  type t
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  val null : t                          (* no occurence *)
+  val full : t                          (* strictly invariant *)
+  val covariant : t                     (* strictly covariant *)
+  val may_inv : t                       (* maybe invariant *)
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
+  val subset : t -> t -> bool
+  val set : f -> bool -> t -> t
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
+  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
+end
+
+(* Type definitions *)
+
+type type_declaration =
+  { type_params: type_expr list;
+    type_arity: int;
+    type_kind: type_kind;
+    type_private: private_flag;
+    type_manifest: type_expr option;
+    type_variance: Variance.t list;
+    (* covariant, contravariant, weakly contravariant, injective *)
+    type_newtype_level: (int * int) option;
+    (* definition level * expansion level *)
+    type_loc: Location.t;
+    type_attributes: Parsetree.attributes;
+    type_immediate: bool; (* true iff type should not be a pointer *)
+    type_unboxed: unboxed_status;
+  }
+
+and type_kind =
+    Type_abstract
+  | Type_record of label_declaration list  * record_representation
+  | Type_variant of constructor_declaration list
+  | Type_open
+
+and record_representation =
+    Record_regular                      (* All fields are boxed / tagged *)
+  | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int               (* Inlined record *)
+  | Record_extension                    (* Inlined record under extension *)
+
+and label_declaration =
+  {
+    ld_id: Ident.t;
+    ld_mutable: mutable_flag;
+    ld_type: type_expr;
+    ld_loc: Location.t;
+    ld_attributes: Parsetree.attributes;
+  }
+
+and constructor_declaration =
+  {
+    cd_id: Ident.t;
+    cd_args: constructor_arguments;
+    cd_res: type_expr option;
+    cd_loc: Location.t;
+    cd_attributes: Parsetree.attributes;
+  }
+
+and constructor_arguments =
+  | Cstr_tuple of type_expr list
+  | Cstr_record of label_declaration list
+
+and unboxed_status = private
+  (* This type must be private in order to ensure perfect sharing of the
+     four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce
+     different executables. *)
+  {
+    unboxed: bool;
+    default: bool; (* True for unannotated unboxable types. *)
+  }
+
+val unboxed_false_default_false : unboxed_status
+val unboxed_false_default_true : unboxed_status
+val unboxed_true_default_false : unboxed_status
+val unboxed_true_default_true : unboxed_status
+
+type extension_constructor =
+    {
+      ext_type_path: Path.t;
+      ext_type_params: type_expr list;
+      ext_args: constructor_arguments;
+      ext_ret_type: type_expr option;
+      ext_private: private_flag;
+      ext_loc: Location.t;
+      ext_attributes: Parsetree.attributes;
+    }
+
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
+(* Type expressions for the class language *)
+
+module Concr : Set.S with type elt = string
+
+type class_type =
+    Cty_constr of Path.t * type_expr list * class_type
+  | Cty_signature of class_signature
+  | Cty_arrow of arg_label * type_expr * class_type
+
+and class_signature =
+  { csig_self: type_expr;
+    csig_vars:
+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+    csig_concr: Concr.t;
+    csig_inher: (Path.t * type_expr list) list }
+
+type class_declaration =
+  { cty_params: type_expr list;
+    mutable cty_type: class_type;
+    cty_path: Path.t;
+    cty_new: type_expr option;
+    cty_variance: Variance.t list;
+    cty_loc: Location.t;
+    cty_attributes: Parsetree.attributes;
+  }
+
+type class_type_declaration =
+  { clty_params: type_expr list;
+    clty_type: class_type;
+    clty_path: Path.t;
+    clty_variance: Variance.t list;
+    clty_loc: Location.t;
+    clty_attributes: Parsetree.attributes;
+  }
+
+(* Type expressions for the module language *)
+
+type module_type =
+    Mty_ident of Path.t
+  | Mty_signature of signature
+  | Mty_functor of Ident.t * module_type option * module_type
+  | Mty_alias of alias_presence * Path.t
+
+and alias_presence =
+  | Mta_present
+  | Mta_absent
+
+and signature = signature_item list
+
+and signature_item =
+    Sig_value of Ident.t * value_description
+  | Sig_type of Ident.t * type_declaration * rec_status
+  | Sig_typext of Ident.t * extension_constructor * ext_status
+  | Sig_module of Ident.t * module_declaration * rec_status
+  | Sig_modtype of Ident.t * modtype_declaration
+  | Sig_class of Ident.t * class_declaration * rec_status
+  | Sig_class_type of Ident.t * class_type_declaration * rec_status
+
+and module_declaration =
+  {
+    md_type: module_type;
+    md_attributes: Parsetree.attributes;
+    md_loc: Location.t;
+  }
+
+and modtype_declaration =
+  {
+    mtd_type: module_type option;  (* None: abstract *)
+    mtd_attributes: Parsetree.attributes;
+    mtd_loc: Location.t;
+  }
+
+and rec_status =
+    Trec_not                   (* first in a nonrecursive group *)
+  | Trec_first                 (* first in a recursive group *)
+  | Trec_next                  (* not first in a recursive/nonrecursive group *)
+
+and ext_status =
+    Text_first                     (* first constructor in an extension *)
+  | Text_next                      (* not first constructor in an extension *)
+  | Text_exception
+
+
+(* Constructor and record label descriptions inserted held in typing
+   environments *)
+
+type constructor_description =
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
+    cstr_args: type_expr list;          (* Type of the arguments *)
+    cstr_arity: int;                    (* Number of arguments *)
+    cstr_tag: constructor_tag;          (* Tag for heap blocks *)
+    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
+    cstr_private: private_flag;         (* Read-only constructor? *)
+    cstr_loc: Location.t;
+    cstr_attributes: Parsetree.attributes;
+    cstr_inlined: type_declaration option;
+   }
+
+and constructor_tag =
+    Cstr_constant of int                (* Constant constructor (an int) *)
+  | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor
+                                           true if a constant false if a block*)
+
+type label_description =
+  { lbl_name: string;                   (* Short name *)
+    lbl_res: type_expr;                 (* Type of the result *)
+    lbl_arg: type_expr;                 (* Type of the argument *)
+    lbl_mut: mutable_flag;              (* Is this a mutable field? *)
+    lbl_pos: int;                       (* Position in block *)
+    lbl_all: label_description array;   (* All the labels in this type *)
+    lbl_repres: record_representation;  (* Representation for this record *)
+    lbl_private: private_flag;          (* Read-only field? *)
+    lbl_loc: Location.t;
+    lbl_attributes: Parsetree.attributes;
+  }
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
new file mode 100644
index 00000000..f37a5c13
--- /dev/null
+++ b/typing/typetexp.ml
@@ -0,0 +1,917 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
+
+(* Typechecking of type expressions for the core language *)
+
+open Asttypes
+open Misc
+open Parsetree
+open Typedtree
+open Types
+open Ctype
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Unbound_type_constructor of Longident.t
+  | Unbound_type_constructor_2 of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of (type_expr * type_expr) list
+  | Alias_type_mismatch of (type_expr * type_expr) list
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Repeated_method_label of string
+  | Unbound_value of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Ill_typed_functor_application of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Access_functor_as_structure of Longident.t
+  | Apply_structure_as_functor of Longident.t
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+exception Error of Location.t * Env.t * error
+exception Error_forward of Location.error
+
+
+type variable_context = int * (string, type_expr) Tbl.t
+
+(* Local definitions *)
+
+let instance_list = Ctype.instance_list Env.empty
+
+(* Narrowing unbound identifier errors. *)
+
+let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
+  fun env loc lid make_error ->
+  let check_module mlid =
+    try ignore (Env.lookup_module ~load:true mlid env) with
+    | Not_found ->
+        narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid)
+    | Env.Recmodule ->
+        raise (Error (loc, env, Illegal_reference_to_recursive_module))
+  in
+  begin match lid with
+  | Longident.Lident _ -> ()
+  | Longident.Ldot (mlid, _) ->
+      check_module mlid;
+      let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in
+      begin match Env.scrape_alias env md.md_type with
+      | Mty_functor _ ->
+          raise (Error (loc, env, Access_functor_as_structure mlid))
+      | Mty_alias(_, p) ->
+          raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
+      | _ -> ()
+      end
+  | Longident.Lapply (flid, mlid) ->
+      check_module flid;
+      let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in
+      begin match Env.scrape_alias env fmd.md_type with
+      | Mty_signature _ ->
+          raise (Error (loc, env, Apply_structure_as_functor flid))
+      | Mty_alias(_, p) ->
+          raise (Error (loc, env, Cannot_scrape_alias(flid, p)))
+      | _ -> ()
+      end;
+      check_module mlid;
+      let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
+      begin match Env.scrape_alias env mmd.md_type with
+      | Mty_alias(_, p) ->
+          raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
+      | _ ->
+          raise (Error (loc, env, Ill_typed_functor_application lid))
+      end
+  end;
+  raise (Error (loc, env, make_error lid))
+
+let find_component (lookup : ?loc:_ -> _) make_error env loc lid =
+  try
+    match lid with
+    | Longident.Ldot (Longident.Lident "*predef*", s) ->
+        lookup ~loc (Longident.Lident s) Env.initial_safe_string
+    | _ ->
+        lookup ~loc lid env
+  with Not_found ->
+    narrow_unbound_lid_error env loc lid make_error
+  | Env.Recmodule ->
+    raise (Error (loc, env, Illegal_reference_to_recursive_module))
+
+let find_type env loc lid =
+  let path =
+    find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
+      env loc lid
+  in
+  let decl = Env.find_type path env in
+  Builtin_attributes.check_deprecated loc decl.type_attributes (Path.name path);
+  (path, decl)
+
+let find_constructor =
+  find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
+let find_all_constructors =
+  find_component Env.lookup_all_constructors
+    (fun lid -> Unbound_constructor lid)
+let find_label =
+  find_component Env.lookup_label (fun lid -> Unbound_label lid)
+let find_all_labels =
+  find_component Env.lookup_all_labels (fun lid -> Unbound_label lid)
+
+let find_class env loc lid =
+  let (path, decl) as r =
+    find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid
+  in
+  Builtin_attributes.check_deprecated loc decl.cty_attributes (Path.name path);
+  r
+
+let find_value env loc lid =
+  Env.check_value_name (Longident.last lid) loc;
+  let (path, decl) as r =
+    find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid
+  in
+  Builtin_attributes.check_deprecated loc decl.val_attributes (Path.name path);
+  r
+
+let lookup_module ?(load=false) env loc lid =
+  find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env))
+    (fun lid -> Unbound_module lid) env loc lid
+
+let find_module env loc lid =
+  let path = lookup_module ~load:true env loc lid in
+  let decl = Env.find_module path env in
+  (* No need to check for deprecated here, this is done in Env. *)
+  (path, decl)
+
+let find_modtype env loc lid =
+  let (path, decl) as r =
+    find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
+      env loc lid
+  in
+  Builtin_attributes.check_deprecated loc decl.mtd_attributes (Path.name path);
+  r
+
+let find_class_type env loc lid =
+  let (path, decl) as r =
+    find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
+      env loc lid
+  in
+  Builtin_attributes.check_deprecated loc decl.clty_attributes (Path.name path);
+  r
+
+let unbound_constructor_error env lid =
+  narrow_unbound_lid_error env lid.loc lid.txt
+    (fun lid -> Unbound_constructor lid)
+
+let unbound_label_error env lid =
+  narrow_unbound_lid_error env lid.loc lid.txt
+    (fun lid -> Unbound_label lid)
+
+(* Support for first-class modules. *)
+
+let transl_modtype_longident = ref (fun _ -> assert false)
+let transl_modtype = ref (fun _ -> assert false)
+
+let create_package_mty fake loc env (p, l) =
+  let l =
+    List.sort
+      (fun (s1, _t1) (s2, _t2) ->
+         if s1.txt = s2.txt then
+           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
+         compare s1.txt s2.txt)
+      l
+  in
+  l,
+  List.fold_left
+    (fun mty (s, t) ->
+      let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
+               ptype_params = [];
+               ptype_cstrs = [];
+               ptype_kind = Ptype_abstract;
+               ptype_private = Asttypes.Public;
+               ptype_manifest = if fake then None else Some t;
+               ptype_attributes = [];
+               ptype_loc = loc} in
+      Ast_helper.Mty.mk ~loc
+        (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
+    )
+    (Ast_helper.Mty.mk ~loc (Pmty_ident p))
+    l
+
+(* Translation of type expressions *)
+
+let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
+let univars        = ref ([] : (string * type_expr) list)
+let pre_univars    = ref ([] : type_expr list)
+let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t)
+
+let reset_type_variables () =
+  reset_global_level ();
+  Ctype.reset_reified_var_counter ();
+  type_variables := Tbl.empty
+
+let narrow () =
+  (increase_global_level (), !type_variables)
+
+let widen (gl, tv) =
+  restore_global_level gl;
+  type_variables := tv
+
+let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_ident name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
+let type_variable loc name =
+  try
+    Tbl.find name !type_variables
+  with Not_found ->
+    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
+
+let transl_type_param env styp =
+  let loc = styp.ptyp_loc in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty = new_global_var ~name:"_" () in
+        { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | Ptyp_var name ->
+      let ty =
+        try
+          if name <> "" && name.[0] = '_' then
+            raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
+          ignore (Tbl.find name !type_variables);
+          raise Already_bound
+        with Not_found ->
+          let v = new_global_var ~name () in
+            type_variables := Tbl.add name v !type_variables;
+            v
+      in
+        { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
+          ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
+  | _ -> assert false
+
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
+
+let rec swap_list = function
+    x :: y :: l -> y :: x :: swap_list l
+  | l -> l
+
+type policy = Fixed | Extensible | Univars
+
+let rec transl_type env policy styp =
+  let loc = styp.ptyp_loc in
+  let ctyp ctyp_desc ctyp_type =
+    { ctyp_desc; ctyp_type; ctyp_env = env;
+      ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
+  in
+  match styp.ptyp_desc with
+    Ptyp_any ->
+      let ty =
+        if policy = Univars then new_pre_univar () else
+          if policy = Fixed then
+            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
+          else newvar ()
+      in
+      ctyp Ttyp_any ty
+  | Ptyp_var name ->
+    let ty =
+      if name <> "" && name.[0] = '_' then
+        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
+      begin try
+        instance env (List.assoc name !univars)
+      with Not_found -> try
+        instance env (fst(Tbl.find name !used_variables))
+      with Not_found ->
+        let v =
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
+        used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
+        v
+      end
+    in
+    ctyp (Ttyp_var name) ty
+  | Ptyp_arrow(l, st1, st2) ->
+    let cty1 = transl_type env policy st1 in
+    let cty2 = transl_type env policy st2 in
+    let ty1 = cty1.ctyp_type in
+    let ty1 =
+      if Btype.is_optional l
+      then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
+      else ty1 in
+    let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
+    ctyp (Ttyp_arrow (l, cty1, cty2)) ty
+  | Ptyp_tuple stl ->
+    assert (List.length stl >= 2);
+    let ctys = List.map (transl_type env policy) stl in
+    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
+    ctyp (Ttyp_tuple ctys) ty
+  | Ptyp_constr(lid, stl) ->
+      let (path, decl) = find_type env lid.loc lid.txt in
+      let stl =
+        match stl with
+        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
+            List.map (fun _ -> t) decl.type_params
+        | _ -> stl
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      let unify_param =
+        match decl.type_manifest with
+          None -> unify_var
+        | Some ty ->
+            if (repr ty).level = Btype.generic_level then unify_var else unify
+      in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_param env ty' cty.ctyp_type with Unify trace ->
+             raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
+        (List.combine stl args) params;
+      let constr =
+        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
+      begin try
+        Ctype.enforce_constraints env constr
+      with Unify trace ->
+        raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      end;
+      ctyp (Ttyp_constr (path, lid, args)) constr
+  | Ptyp_object (fields, o) ->
+      let fields =
+        List.map (fun (s, a, t) -> (s.txt, a, transl_poly_type env policy t))
+          fields
+      in
+      let ty = newobj (transl_fields loc env policy [] o fields) in
+      ctyp (Ttyp_object (fields, o)) ty
+  | Ptyp_class(lid, stl) ->
+      let (path, decl, _is_variant) =
+        try
+          let path = Env.lookup_type lid.txt env in
+          let decl = Env.find_type path env in
+          let rec check decl =
+            match decl.type_manifest with
+              None -> raise Not_found
+            | Some ty ->
+                match (repr ty).desc with
+                  Tvariant row when Btype.static_row row -> ()
+                | Tconstr (path, _, _) ->
+                    check (Env.find_type path env)
+                | _ -> raise Not_found
+          in check decl;
+          Location.prerr_warning styp.ptyp_loc
+            (Warnings.Deprecated "old syntax for polymorphic variant type");
+          (path, decl,true)
+        with Not_found -> try
+          let lid2 =
+            match lid.txt with
+              Longident.Lident s     -> Longident.Lident ("#" ^ s)
+            | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
+            | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
+          in
+          let path = Env.lookup_type lid2 env in
+          let decl = Env.find_type path env in
+          (path, decl, false)
+        with Not_found ->
+          ignore (find_class env lid.loc lid.txt); assert false
+      in
+      if List.length stl <> decl.type_arity then
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
+      let args = List.map (transl_type env policy) stl in
+      let params = instance_list decl.type_params in
+      List.iter2
+        (fun (sty, cty) ty' ->
+           try unify_var env ty' cty.ctyp_type with Unify trace ->
+             raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
+        (List.combine stl args) params;
+        let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
+      let ty =
+        try Ctype.expand_head env (newconstr path ty_args)
+        with Unify trace ->
+          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
+      in
+      let ty = match ty.desc with
+        Tvariant row ->
+          let row = Btype.row_repr row in
+          let fields =
+            List.map
+              (fun (l,f) -> l,
+                match Btype.row_field_repr f with
+                | Rpresent (Some ty) ->
+                    Reither(false, [ty], false, ref None)
+                | Rpresent None ->
+                    Reither (true, [], false, ref None)
+                | _ -> f)
+              row.row_fields
+          in
+          let row = { row_closed = true; row_fields = fields;
+                      row_bound = (); row_name = Some (path, ty_args);
+                      row_fixed = false; row_more = newvar () } in
+          let static = Btype.static_row row in
+          let row =
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
+            else { row with row_more = new_pre_univar () }
+          in
+          newty (Tvariant row)
+      | Tobject (fi, _) ->
+          let _, tv = flatten_fields fi in
+          if policy = Univars then pre_univars := tv :: !pre_univars;
+          ty
+      | _ ->
+          assert false
+      in
+      ctyp (Ttyp_class (path, lid, args)) ty
+  | Ptyp_alias(st, alias) ->
+      let cty =
+        try
+          let t =
+            try List.assoc alias !univars
+            with Not_found ->
+              instance env (fst(Tbl.find alias !used_variables))
+          in
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = swap_list trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          ty
+        with Not_found ->
+          if !Clflags.principal then begin_def ();
+          let t = newvar () in
+          used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables;
+          let ty = transl_type env policy st in
+          begin try unify_var env t ty.ctyp_type with Unify trace ->
+            let trace = swap_list trace in
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
+          end;
+          if !Clflags.principal then begin
+            end_def ();
+            generalize_structure t;
+          end;
+          let t = instance env t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
+          | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
+          | _ -> ()
+          end;
+          { ty with ctyp_type = t }
+      in
+      ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
+  | Ptyp_variant(fields, closed, present) ->
+      let name = ref None in
+      let mkfield l f =
+        newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+                         row_bound=(); row_closed=true;
+                         row_fixed=false; row_name=None}) in
+      let hfields = Hashtbl.create 17 in
+      let add_typed_field loc l f =
+        let h = Btype.hash_variant l in
+        try
+          let (l',f') = Hashtbl.find hfields h in
+          (* Check for tag conflicts *)
+          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
+          let ty = mkfield l f and ty' = mkfield l f' in
+          if equal env false [ty] [ty'] then () else
+          try unify env ty ty'
+          with Unify _trace ->
+            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
+        with Not_found ->
+          Hashtbl.add hfields h (l,f)
+      in
+      let add_field = function
+          Rtag (l, attrs, c, stl) ->
+            name := None;
+            let tl = List.map (transl_type env policy) stl in
+            let f = match present with
+              Some present when not (List.mem l present) ->
+                let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
+                Reither(c, ty_tl, false, ref None)
+            | _ ->
+                if List.length stl > 1 || c && stl <> [] then
+                  raise(Error(styp.ptyp_loc, env, Present_has_conjunction l));
+                match tl with [] -> Rpresent None
+                | st :: _ ->
+                      Rpresent (Some st.ctyp_type)
+            in
+            add_typed_field styp.ptyp_loc l f;
+              Ttag (l,attrs,c,tl)
+        | Rinherit sty ->
+            let cty = transl_type env policy sty in
+            let ty = cty.ctyp_type in
+            let nm =
+              match repr cty.ctyp_type with
+                {desc=Tconstr(p, tl, _)} -> Some(p, tl)
+              | _                        -> None
+            in
+            begin try
+              (* Set name if there are no fields yet *)
+              Hashtbl.iter (fun _ _ -> raise Exit) hfields;
+              name := nm
+            with Exit ->
+              (* Unset it otherwise *)
+              name := None
+            end;
+            let fl = match expand_head env cty.ctyp_type, nm with
+              {desc=Tvariant row}, _ when Btype.static_row row ->
+                let row = Btype.row_repr row in
+                row.row_fields
+            | {desc=Tvar _}, Some(p, _) ->
+                raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p))
+            | _ ->
+                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
+            in
+            List.iter
+              (fun (l, f) ->
+                let f = match present with
+                  Some present when not (List.mem l present) ->
+                    begin match f with
+                      Rpresent(Some ty) ->
+                        Reither(false, [ty], false, ref None)
+                    | Rpresent None ->
+                        Reither(true, [], false, ref None)
+                    | _ ->
+                        assert false
+                    end
+                | _ -> f
+                in
+                add_typed_field sty.ptyp_loc l f)
+              fl;
+              Tinherit cty
+      in
+      let tfields = List.map add_field fields in
+      let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
+      begin match present with None -> ()
+      | Some present ->
+          List.iter
+            (fun l -> if not (List.mem_assoc l fields) then
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
+            present
+      end;
+      let row =
+        { row_fields = List.rev fields; row_more = newvar ();
+          row_bound = (); row_closed = (closed = Closed);
+          row_fixed = false; row_name = !name } in
+      let static = Btype.static_row row in
+      let row =
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
+        else { row with row_more = new_pre_univar () }
+      in
+      let ty = newty (Tvariant row) in
+      ctyp (Ttyp_variant (tfields, closed, present)) ty
+  | Ptyp_poly(vars, st) ->
+      let vars = List.map (fun v -> v.txt) vars in
+      begin_def();
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
+      let old_univars = !univars in
+      univars := new_univars @ !univars;
+      let cty = transl_type env policy st in
+      let ty = cty.ctyp_type in
+      univars := old_univars;
+      end_def();
+      generalize ty;
+      let ty_list =
+        List.fold_left
+          (fun tyl (name, ty1) ->
+            let v = Btype.proxy ty1 in
+            if deep_occur v ty then begin
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  v.desc <- Tunivar name;
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
+            end else tyl)
+          [] new_univars
+      in
+      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
+      unify_var env (newvar()) ty';
+      ctyp (Ttyp_poly (vars, cty)) ty'
+  | Ptyp_package (p, l) ->
+      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
+      let z = narrow () in
+      let mty = !transl_modtype env mty in
+      widen z;
+      let ptys = List.map (fun (s, pty) ->
+                             s, transl_type env policy pty
+                          ) l in
+      let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
+      let ty = newty (Tpackage (path,
+                       List.map (fun (s, _pty) -> s.txt) l,
+                       List.map (fun (_,cty) -> cty.ctyp_type) ptys))
+      in
+      ctyp (Ttyp_package {
+            pack_path = path;
+            pack_type = mty.mty_type;
+            pack_fields = ptys;
+            pack_txt = p;
+           }) ty
+  | Ptyp_extension ext ->
+      raise (Error_forward (Builtin_attributes.error_of_extension ext))
+
+and transl_poly_type env policy t =
+  transl_type env policy (Ast_helper.Typ.force_poly t)
+
+and transl_fields loc env policy seen o =
+  function
+    [] ->
+      begin match o, policy with
+      | Closed, _ -> newty Tnil
+      | Open, Univars -> new_pre_univar ()
+      | Open, _ -> newvar ()
+      end
+  | (s, _attrs, ty1) :: l ->
+      if List.mem s seen then raise (Error (loc, env, Repeated_method_label s));
+      let ty2 = transl_fields loc env policy (s :: seen) o l in
+      newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2))
+
+(* Make the rows "fixed" in this type, to make universal check easier *)
+let rec make_fixed_univars ty =
+  let ty = repr ty in
+  if ty.level >= Btype.lowest_level then begin
+    Btype.mark_type_node ty;
+    match ty.desc with
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        if Btype.is_Tunivar (Btype.row_more row) then
+          ty.desc <- Tvariant
+              {row with row_fixed=true;
+               row_fields = List.map
+                 (fun (s,f as p) -> match Btype.row_field_repr f with
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
+                 | _ -> p)
+                 row.row_fields};
+        Btype.iter_row make_fixed_univars row
+    | _ ->
+        Btype.iter_type_expr make_fixed_univars ty
+  end
+
+let make_fixed_univars ty =
+  make_fixed_univars ty;
+  Btype.unmark_type ty
+
+let create_package_mty = create_package_mty false
+
+let globalize_used_variables env fixed =
+  let r = ref [] in
+  Tbl.iter
+    (fun name (ty, loc) ->
+      let v = new_global_var () in
+      let snap = Btype.snapshot () in
+      if try unify env v ty; true with _ -> Btype.backtrack snap; false
+      then try
+        r := (loc, v,  Tbl.find name !type_variables) :: !r
+      with Not_found ->
+        if fixed && Btype.is_Tvar (repr ty) then
+          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
+        let v2 = new_global_var () in
+        r := (loc, v, v2) :: !r;
+        type_variables := Tbl.add name v2 !type_variables)
+    !used_variables;
+  used_variables := Tbl.empty;
+  fun () ->
+    List.iter
+      (function (loc, t1, t2) ->
+        try unify env t1 t2 with Unify trace ->
+          raise (Error(loc, env, Type_mismatch trace)))
+      !r
+
+let transl_simple_type env fixed styp =
+  univars := []; used_variables := Tbl.empty;
+  let typ = transl_type env (if fixed then Fixed else Extensible) styp in
+  globalize_used_variables env fixed ();
+  make_fixed_univars typ.ctyp_type;
+  typ
+
+let transl_simple_type_univars env styp =
+  univars := []; used_variables := Tbl.empty; pre_univars := [];
+  begin_def ();
+  let typ = transl_type env Univars styp in
+  (* Only keep already global variables in used_variables *)
+  let new_variables = !used_variables in
+  used_variables := Tbl.empty;
+  Tbl.iter
+    (fun name p ->
+      if Tbl.mem name !type_variables then
+        used_variables := Tbl.add name p !used_variables)
+    new_variables;
+  globalize_used_variables env false ();
+  end_def ();
+  generalize typ.ctyp_type;
+  let univs =
+    List.fold_left
+      (fun acc v ->
+        let v = repr v in
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            v.desc <- Tunivar name; v :: acc
+        | _ -> acc)
+      [] !pre_univars
+  in
+  make_fixed_univars typ.ctyp_type;
+    { typ with ctyp_type =
+        instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
+
+let transl_simple_type_delayed env styp =
+  univars := []; used_variables := Tbl.empty;
+  let typ = transl_type env Extensible styp in
+  make_fixed_univars typ.ctyp_type;
+  (typ, globalize_used_variables env false)
+
+let transl_type_scheme env styp =
+  reset_type_variables();
+  begin_def();
+  let typ = transl_simple_type env false styp in
+  end_def();
+  generalize typ.ctyp_type;
+  typ
+
+
+(* Error report *)
+
+open Format
+open Printtyp
+
+let spellcheck ppf fold env lid =
+  let choices ~path name =
+    let env = fold (fun x xs -> x::xs) path env [] in
+    Misc.spellcheck env name in
+  match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:None s)
+    | Longident.Ldot (r, s) ->
+       Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
+
+let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc)
+let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc)
+
+let fold_values = fold_simple Env.fold_values
+let fold_types = fold_simple Env.fold_types
+let fold_modules = fold_simple Env.fold_modules
+let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name)
+let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name)
+let fold_classs = fold_simple Env.fold_classs
+let fold_modtypes = fold_simple Env.fold_modtypes
+let fold_cltypes = fold_simple Env.fold_cltypes
+
+let report_error env ppf = function
+  | Unbound_type_variable name ->
+     (* we don't use "spellcheck" here: the function that raises this
+        error seems not to be called anywhere, so it's unclear how it
+        should be handled *)
+    fprintf ppf "Unbound type parameter %s@." name
+  | Unbound_type_constructor lid ->
+    fprintf ppf "Unbound type constructor %a" longident lid;
+    spellcheck ppf fold_types env lid;
+  | Unbound_type_constructor_2 p ->
+    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+      path p
+  | Type_arity_mismatch(lid, expected, provided) ->
+    fprintf ppf
+      "@[The type constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+      longident lid expected provided
+  | Bound_type_variable name ->
+    fprintf ppf "Already bound type parameter '%s" name
+  | Recursive_type ->
+    fprintf ppf "This type is recursive"
+  | Unbound_row_variable lid ->
+      (* we don't use "spellcheck" here: this error is not raised
+         anywhere so it's unclear how it should be handled *)
+      fprintf ppf "Unbound row variable in #%a" longident lid
+  | Type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This type")
+        (function ppf ->
+           fprintf ppf "should be an instance of type")
+  | Alias_type_mismatch trace ->
+      Printtyp.report_unification_error ppf Env.empty trace
+        (function ppf ->
+           fprintf ppf "This alias is bound to type")
+        (function ppf ->
+           fprintf ppf "but is used as an instance of type")
+  | Present_has_conjunction l ->
+      fprintf ppf "The present constructor %s has a conjunctive type" l
+  | Present_has_no_type l ->
+      fprintf ppf "The present constructor %s has no type" l
+  | Constructor_mismatch (ty, ty') ->
+      wrap_printing_env env (fun ()  ->
+        Printtyp.reset_and_mark_loops_list [ty; ty'];
+        fprintf ppf "@[%s %a@ %s@ %a@]"
+          "This variant type contains a constructor"
+          Printtyp.type_expr ty
+          "which should be"
+          Printtyp.type_expr ty')
+  | Not_a_variant ty ->
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf "@[The type %a@ is not a polymorphic variant type@]"
+        Printtyp.type_expr ty;
+      begin match ty.desc with
+        | Tvar (Some s) ->
+           (* PR#7012: help the user that wrote 'Foo instead of `Foo *)
+           Misc.did_you_mean ppf (fun () -> ["`" ^ s])
+        | _ -> ()
+      end
+  | Variant_tags (lab1, lab2) ->
+      fprintf ppf
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
+  | Invalid_variable_name name ->
+      fprintf ppf "The type variable name %s is not allowed in programs" name
+  | Cannot_quantify (name, v) ->
+      fprintf ppf
+        "@[The universal type variable '%s cannot be generalized:@ %s.@]"
+        name
+        (if Btype.is_Tvar v then "it escapes its scope" else
+         if Btype.is_Tunivar v then "it is already bound to another variable"
+         else "it is not a variable")
+  | Multiple_constraints_on_type s ->
+      fprintf ppf "Multiple constraints for type %a" longident s
+  | Repeated_method_label s ->
+      fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
+        s "Multiple occurrences are not allowed."
+  | Unbound_value lid ->
+      fprintf ppf "Unbound value %a" longident lid;
+      spellcheck ppf fold_values env lid;
+  | Unbound_module lid ->
+      fprintf ppf "Unbound module %a" longident lid;
+      spellcheck ppf fold_modules env lid;
+  | Unbound_constructor lid ->
+      fprintf ppf "Unbound constructor %a" longident lid;
+      spellcheck ppf fold_constructors env lid;
+  | Unbound_label lid ->
+      fprintf ppf "Unbound record field %a" longident lid;
+      spellcheck ppf fold_labels env lid;
+  | Unbound_class lid ->
+      fprintf ppf "Unbound class %a" longident lid;
+      spellcheck ppf fold_classs env lid;
+  | Unbound_modtype lid ->
+      fprintf ppf "Unbound module type %a" longident lid;
+      spellcheck ppf fold_modtypes env lid;
+  | Unbound_cltype lid ->
+      fprintf ppf "Unbound class type %a" longident lid;
+      spellcheck ppf fold_cltypes env lid;
+  | Ill_typed_functor_application lid ->
+      fprintf ppf "Ill-typed functor application %a" longident lid
+  | Illegal_reference_to_recursive_module ->
+      fprintf ppf "Illegal recursive module reference"
+  | Access_functor_as_structure lid ->
+      fprintf ppf "The module %a is a functor, not a structure" longident lid
+  | Apply_structure_as_functor lid ->
+      fprintf ppf "The module %a is a structure, not a functor" longident lid
+  | Cannot_scrape_alias(lid, p) ->
+      fprintf ppf
+        "The module %a is an alias for module %a, which is missing"
+        longident lid path p
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, env, err) ->
+        Some (Location.error_of_printer loc (report_error env) err)
+      | Error_forward err ->
+        Some err
+      | _ ->
+        None
+    )
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
new file mode 100644
index 00000000..20ca9cb4
--- /dev/null
+++ b/typing/typetexp.mli
@@ -0,0 +1,113 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Typechecking of type expressions for the core language *)
+
+open Types
+
+val transl_simple_type:
+        Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_univars:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val transl_simple_type_delayed:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit)
+        (* Translate a type, but leave type variables unbound. Returns
+           the type and a function that binds the type variable. *)
+val transl_type_scheme:
+        Env.t -> Parsetree.core_type -> Typedtree.core_type
+val reset_type_variables: unit -> unit
+val type_variable: Location.t -> string -> type_expr
+val transl_type_param:
+  Env.t -> Parsetree.core_type -> Typedtree.core_type
+
+type variable_context
+val narrow: unit -> variable_context
+val widen: variable_context -> unit
+
+exception Already_bound
+
+type error =
+    Unbound_type_variable of string
+  | Unbound_type_constructor of Longident.t
+  | Unbound_type_constructor_2 of Path.t
+  | Type_arity_mismatch of Longident.t * int * int
+  | Bound_type_variable of string
+  | Recursive_type
+  | Unbound_row_variable of Longident.t
+  | Type_mismatch of (type_expr * type_expr) list
+  | Alias_type_mismatch of (type_expr * type_expr) list
+  | Present_has_conjunction of string
+  | Present_has_no_type of string
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
+  | Variant_tags of string * string
+  | Invalid_variable_name of string
+  | Cannot_quantify of string * type_expr
+  | Multiple_constraints_on_type of Longident.t
+  | Repeated_method_label of string
+  | Unbound_value of Longident.t
+  | Unbound_constructor of Longident.t
+  | Unbound_label of Longident.t
+  | Unbound_module of Longident.t
+  | Unbound_class of Longident.t
+  | Unbound_modtype of Longident.t
+  | Unbound_cltype of Longident.t
+  | Ill_typed_functor_application of Longident.t
+  | Illegal_reference_to_recursive_module
+  | Access_functor_as_structure of Longident.t
+  | Apply_structure_as_functor of Longident.t
+  | Cannot_scrape_alias of Longident.t * Path.t
+
+exception Error of Location.t * Env.t * error
+
+val report_error: Env.t -> Format.formatter -> error -> unit
+
+(* Support for first-class modules. *)
+val transl_modtype_longident:  (* from Typemod *)
+    (Location.t -> Env.t -> Longident.t -> Path.t) ref
+val transl_modtype: (* from Typemod *)
+    (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref
+val create_package_mty:
+    Location.t -> Env.t -> Parsetree.package_type ->
+    (Longident.t Asttypes.loc * Parsetree.core_type) list *
+      Parsetree.module_type
+
+val find_type:
+    Env.t -> Location.t -> Longident.t -> Path.t * type_declaration
+val find_constructor:
+    Env.t -> Location.t -> Longident.t -> constructor_description
+val find_all_constructors:
+    Env.t -> Location.t -> Longident.t ->
+    (constructor_description * (unit -> unit)) list
+val find_label:
+    Env.t -> Location.t -> Longident.t -> label_description
+val find_all_labels:
+    Env.t -> Location.t -> Longident.t ->
+    (label_description * (unit -> unit)) list
+val find_value:
+    Env.t -> Location.t -> Longident.t -> Path.t * value_description
+val find_class:
+    Env.t -> Location.t -> Longident.t -> Path.t * class_declaration
+val find_module:
+    Env.t -> Location.t -> Longident.t -> Path.t * module_declaration
+val lookup_module:
+    ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t
+val find_modtype:
+    Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
+val find_class_type:
+    Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration
+
+val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
+val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
new file mode 100644
index 00000000..0cb58f48
--- /dev/null
+++ b/typing/untypeast.ml
@@ -0,0 +1,813 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Longident
+open Asttypes
+open Parsetree
+open Ast_helper
+
+module T = Typedtree
+
+type mapper = {
+  attribute: mapper -> T.attribute -> attribute;
+  attributes: mapper -> T.attribute list -> attribute list;
+  case: mapper -> T.case -> case;
+  cases: mapper -> T.case list -> case list;
+  class_declaration: mapper -> T.class_declaration -> class_declaration;
+  class_description: mapper -> T.class_description -> class_description;
+  class_expr: mapper -> T.class_expr -> class_expr;
+  class_field: mapper -> T.class_field -> class_field;
+  class_signature: mapper -> T.class_signature -> class_signature;
+  class_structure: mapper -> T.class_structure -> class_structure;
+  class_type: mapper -> T.class_type -> class_type;
+  class_type_declaration: mapper -> T.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> T.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> T.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> T.expression -> expression;
+  extension_constructor: mapper -> T.extension_constructor
+                         -> extension_constructor;
+  include_declaration: mapper -> T.include_declaration -> include_declaration;
+  include_description: mapper -> T.include_description -> include_description;
+  label_declaration: mapper -> T.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> T.module_binding -> module_binding;
+  module_declaration: mapper -> T.module_declaration -> module_declaration;
+  module_expr: mapper -> T.module_expr -> module_expr;
+  module_type: mapper -> T.module_type -> module_type;
+  module_type_declaration:
+    mapper -> T.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> T.package_type -> package_type;
+  open_description: mapper -> T.open_description -> open_description;
+  pat: mapper -> T.pattern -> pattern;
+  row_field: mapper -> T.row_field -> row_field;
+  signature: mapper -> T.signature -> signature;
+  signature_item: mapper -> T.signature_item -> signature_item;
+  structure: mapper -> T.structure -> structure;
+  structure_item: mapper -> T.structure_item -> structure_item;
+  typ: mapper -> T.core_type -> core_type;
+  type_declaration: mapper -> T.type_declaration -> type_declaration;
+  type_extension: mapper -> T.type_extension -> type_extension;
+  type_kind: mapper -> T.type_kind -> type_kind;
+  value_binding: mapper -> T.value_binding -> value_binding;
+  value_description: mapper -> T.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
+    -> with_constraint;
+}
+
+open T
+
+(*
+Some notes:
+
+   * For Pexp_function, we cannot go back to the exact original version
+   when there is a default argument, because the default argument is
+   translated in the typer. The code, if printed, will not be parsable because
+   new generated identifiers are not correct.
+
+   * For Pexp_apply, it is unclear whether arguments are reordered, especially
+    when there are optional arguments.
+
+*)
+
+
+(** Utility functions. *)
+
+let string_is_prefix sub str =
+  let sublen = String.length sub in
+  String.length str >= sublen && String.sub str 0 sublen = sub
+
+let map_opt f = function None -> None | Some e -> Some (f e)
+
+let rec lident_of_path = function
+  | Path.Pident id -> Longident.Lident (Ident.name id)
+  | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lident_of_path p1, lident_of_path p2)
+
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+
+(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
+let fresh_name s env =
+  let rec aux i =
+    let name = s ^ string_of_int i in
+    try
+      let _ = Env.lookup_value (Lident name) env in
+      name
+    with
+      | Not_found -> aux (i+1)
+  in
+  aux 0
+
+(** Mapping functions. *)
+
+let constant = function
+  | Const_char c -> Pconst_char c
+  | Const_string (s,d) -> Pconst_string (s,d)
+  | Const_int i -> Pconst_integer (string_of_int i, None)
+  | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
+  | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
+  | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
+  | Const_float f -> Pconst_float (f,None)
+
+let attribute sub (s, p) = (map_loc sub s, p)
+let attributes sub l = List.map (sub.attribute sub) l
+
+let structure sub str =
+  List.map (sub.structure_item sub) str.str_items
+
+let open_description sub od =
+  let loc = sub.location sub od.open_loc in
+  let attrs = sub.attributes sub od.open_attributes in
+  Opn.mk ~loc ~attrs
+    ~override:od.open_override
+    (map_loc sub od.open_txt)
+
+let structure_item sub item =
+  let loc = sub.location sub item.str_loc in
+  let desc =
+    match item.str_desc with
+      Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
+    | Tstr_value (rec_flag, list) ->
+        Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
+    | Tstr_primitive vd ->
+        Pstr_primitive (sub.value_description sub vd)
+    | Tstr_type (rec_flag, list) ->
+        Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tstr_typext tyext ->
+        Pstr_typext (sub.type_extension sub tyext)
+    | Tstr_exception ext ->
+        Pstr_exception (sub.extension_constructor sub ext)
+    | Tstr_module mb ->
+        Pstr_module (sub.module_binding sub mb)
+    | Tstr_recmodule list ->
+        Pstr_recmodule (List.map (sub.module_binding sub) list)
+    | Tstr_modtype mtd ->
+        Pstr_modtype (sub.module_type_declaration sub mtd)
+    | Tstr_open od ->
+        Pstr_open (sub.open_description sub od)
+    | Tstr_class list ->
+        Pstr_class
+          (List.map
+             (fun (ci, _) -> sub.class_declaration sub ci)
+             list)
+    | Tstr_class_type list ->
+        Pstr_class_type
+          (List.map
+             (fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
+             list)
+    | Tstr_include incl ->
+        Pstr_include (sub.include_declaration sub incl)
+    | Tstr_attribute x ->
+        Pstr_attribute x
+  in
+  Str.mk ~loc desc
+
+let value_description sub v =
+  let loc = sub.location sub v.val_loc in
+  let attrs = sub.attributes sub v.val_attributes in
+  Val.mk ~loc ~attrs
+    ~prim:v.val_prim
+    (map_loc sub v.val_name)
+    (sub.typ sub v.val_desc)
+
+let module_binding sub mb =
+  let loc = sub.location sub mb.mb_loc; in
+  let attrs = sub.attributes sub mb.mb_attributes in
+  Mb.mk ~loc ~attrs
+    (map_loc sub mb.mb_name)
+    (sub.module_expr sub mb.mb_expr)
+
+let type_parameter sub (ct, v) = (sub.typ sub ct, v)
+
+let type_declaration sub decl =
+  let loc = sub.location sub decl.typ_loc; in
+  let attrs = sub.attributes sub decl.typ_attributes in
+  Type.mk ~loc ~attrs
+    ~params:(List.map (type_parameter sub) decl.typ_params)
+    ~cstrs:(
+      List.map
+        (fun (ct1, ct2, loc) ->
+           (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
+        decl.typ_cstrs)
+    ~kind:(sub.type_kind sub decl.typ_kind)
+    ~priv:decl.typ_private
+    ?manifest:(map_opt (sub.typ sub) decl.typ_manifest)
+    (map_loc sub decl.typ_name)
+
+let type_kind sub tk = match tk with
+  | Ttype_abstract -> Ptype_abstract
+  | Ttype_variant list ->
+      Ptype_variant (List.map (sub.constructor_declaration sub) list)
+  | Ttype_record list ->
+      Ptype_record (List.map (sub.label_declaration sub) list)
+  | Ttype_open -> Ptype_open
+
+let constructor_arguments sub = function
+   | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
+   | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
+
+let constructor_declaration sub cd =
+  let loc = sub.location sub cd.cd_loc; in
+  let attrs = sub.attributes sub cd.cd_attributes in
+  Type.constructor ~loc ~attrs
+    ~args:(constructor_arguments sub cd.cd_args)
+    ?res:(map_opt (sub.typ sub) cd.cd_res)
+    (map_loc sub cd.cd_name)
+
+let label_declaration sub ld =
+  let loc = sub.location sub ld.ld_loc; in
+  let attrs = sub.attributes sub ld.ld_attributes in
+  Type.field ~loc ~attrs
+    ~mut:ld.ld_mutable
+    (map_loc sub ld.ld_name)
+    (sub.typ sub ld.ld_type)
+
+let type_extension sub tyext =
+  let attrs = sub.attributes sub tyext.tyext_attributes in
+  Te.mk ~attrs
+    ~params:(List.map (type_parameter sub) tyext.tyext_params)
+    ~priv:tyext.tyext_private
+    (map_loc sub tyext.tyext_txt)
+    (List.map (sub.extension_constructor sub) tyext.tyext_constructors)
+
+let extension_constructor sub ext =
+  let loc = sub.location sub ext.ext_loc; in
+  let attrs = sub.attributes sub ext.ext_attributes in
+  Te.constructor ~loc ~attrs
+    (map_loc sub ext.ext_name)
+    (match ext.ext_kind with
+      | Text_decl (args, ret) ->
+          Pext_decl (constructor_arguments sub args,
+                     map_opt (sub.typ sub) ret)
+      | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
+    )
+
+let pattern sub pat =
+  let loc = sub.location sub pat.pat_loc; in
+  (* todo: fix attributes on extras *)
+  let attrs = sub.attributes sub pat.pat_attributes in
+  let desc =
+  match pat with
+      { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+        Ppat_unpack name
+    | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
+        Ppat_type (map_loc sub lid)
+    | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
+        Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
+                         sub.typ sub ct)
+    | _ ->
+    match pat.pat_desc with
+      Tpat_any -> Ppat_any
+    | Tpat_var (id, name) ->
+        begin
+          match (Ident.name id).[0] with
+            'A'..'Z' ->
+              Ppat_unpack name
+          | _ ->
+              Ppat_var name
+        end
+
+    (* We transform (_ as x) in x if _ and x have the same location.
+       The compiler transforms (x:t) into (_ as x : t).
+       This avoids transforming a warning 27 into a 26.
+     *)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+         when pat_loc = pat.pat_loc ->
+       Ppat_var name
+
+    | Tpat_alias (pat, _id, name) ->
+        Ppat_alias (sub.pat sub pat, name)
+    | Tpat_constant cst -> Ppat_constant (constant cst)
+    | Tpat_tuple list ->
+        Ppat_tuple (List.map (sub.pat sub) list)
+    | Tpat_construct (lid, _, args) ->
+        Ppat_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+            | [arg] -> Some (sub.pat sub arg)
+            | args ->
+                Some
+                  (Pat.tuple ~loc
+                     (List.map (sub.pat sub) args)
+                  )
+          ))
+    | Tpat_variant (label, pato, _) ->
+        Ppat_variant (label, map_opt (sub.pat sub) pato)
+    | Tpat_record (list, closed) ->
+        Ppat_record (List.map (fun (lid, _, pat) ->
+            map_loc sub lid, sub.pat sub pat) list, closed)
+    | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
+    | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
+    | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
+  in
+  Pat.mk ~loc ~attrs desc
+
+let exp_extra sub (extra, loc, attrs) sexp =
+  let loc = sub.location sub loc; in
+  let attrs = sub.attributes sub attrs in
+  let desc =
+    match extra with
+      Texp_coerce (cty1, cty2) ->
+        Pexp_coerce (sexp,
+                     map_opt (sub.typ sub) cty1,
+                     sub.typ sub cty2)
+    | Texp_constraint cty ->
+        Pexp_constraint (sexp, sub.typ sub cty)
+    | Texp_open (ovf, _path, lid, _) ->
+        Pexp_open (ovf, map_loc sub lid, sexp)
+    | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto)
+    | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
+  in
+  Exp.mk ~loc ~attrs desc
+
+let cases sub l = List.map (sub.case sub) l
+
+let case sub {c_lhs; c_guard; c_rhs} =
+  {
+   pc_lhs = sub.pat sub c_lhs;
+   pc_guard = map_opt (sub.expr sub) c_guard;
+   pc_rhs = sub.expr sub c_rhs;
+  }
+
+let value_binding sub vb =
+  let loc = sub.location sub vb.vb_loc; in
+  let attrs = sub.attributes sub vb.vb_attributes in
+  Vb.mk ~loc ~attrs
+    (sub.pat sub vb.vb_pat)
+    (sub.expr sub vb.vb_expr)
+
+let expression sub exp =
+  let loc = sub.location sub exp.exp_loc; in
+  let attrs = sub.attributes sub exp.exp_attributes in
+  let desc =
+    match exp.exp_desc with
+      Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
+    | Texp_constant cst -> Pexp_constant (constant cst)
+    | Texp_let (rec_flag, list, exp) ->
+        Pexp_let (rec_flag,
+          List.map (sub.value_binding sub) list,
+          sub.expr sub exp)
+
+    (* Pexp_function can't have a label, so we split in 3 cases. *)
+    (* One case, no guard: It's a fun. *)
+    | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
+          _ } ->
+        Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
+    (* No label: it's a function. *)
+    | Texp_function { arg_label = Nolabel; cases; _; } ->
+        Pexp_function (sub.cases sub cases)
+    (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
+    | Texp_function { arg_label = Labelled s | Optional s as label; cases;
+          _ } ->
+        let name = fresh_name s exp.exp_env in
+        Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
+          Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
+                          (sub.cases sub cases))
+    | Texp_apply (exp, list) ->
+        Pexp_apply (sub.expr sub exp,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) list [])
+    | Texp_match (exp, cases, exn_cases, _) ->
+      let merged_cases = sub.cases sub cases
+        @ List.map
+          (fun c ->
+            let uc = sub.case sub c in
+            let pat = { uc.pc_lhs
+                        with ppat_desc = Ppat_exception uc.pc_lhs }
+            in
+            { uc with pc_lhs = pat })
+          exn_cases
+      in
+      Pexp_match (sub.expr sub exp, merged_cases)
+    | Texp_try (exp, cases) ->
+        Pexp_try (sub.expr sub exp, sub.cases sub cases)
+    | Texp_tuple list ->
+        Pexp_tuple (List.map (sub.expr sub) list)
+    | Texp_construct (lid, _, args) ->
+        Pexp_construct (map_loc sub lid,
+          (match args with
+              [] -> None
+          | [ arg ] -> Some (sub.expr sub arg)
+          | args ->
+              Some
+                (Exp.tuple ~loc (List.map (sub.expr sub) args))
+          ))
+    | Texp_variant (label, expo) ->
+        Pexp_variant (label, map_opt (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, map_opt (sub.expr sub) extended_expression)
+    | Texp_field (exp, lid, _label) ->
+        Pexp_field (sub.expr sub exp, map_loc sub lid)
+    | Texp_setfield (exp1, lid, _label, exp2) ->
+        Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
+          sub.expr sub exp2)
+    | Texp_array list ->
+        Pexp_array (List.map (sub.expr sub) list)
+    | Texp_ifthenelse (exp1, exp2, expo) ->
+        Pexp_ifthenelse (sub.expr sub exp1,
+          sub.expr sub exp2,
+          map_opt (sub.expr sub) expo)
+    | Texp_sequence (exp1, exp2) ->
+        Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_while (exp1, exp2) ->
+        Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
+    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
+        Pexp_for (name,
+          sub.expr sub exp1, sub.expr sub exp2,
+          dir, sub.expr sub exp3)
+    | Texp_send (exp, meth, _) ->
+        Pexp_send (sub.expr sub exp, match meth with
+            Tmeth_name name -> mkloc name loc
+          | Tmeth_val id -> mkloc (Ident.name id) loc)
+    | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
+    | Texp_instvar (_, path, name) ->
+      Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+    | Texp_setinstvar (_, _path, lid, exp) ->
+        Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
+    | Texp_override (_, list) ->
+        Pexp_override (List.map (fun (_path, lid, exp) ->
+              (map_loc sub lid, sub.expr sub exp)
+          ) list)
+    | Texp_letmodule (_id, name, mexpr, exp) ->
+        Pexp_letmodule (name, sub.module_expr sub mexpr,
+          sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
+    | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
+    | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
+    | Texp_object (cl, _) ->
+        Pexp_object (sub.class_structure sub cl)
+    | Texp_pack (mexpr) ->
+        Pexp_pack (sub.module_expr sub mexpr)
+    | Texp_unreachable ->
+        Pexp_unreachable
+    | Texp_extension_constructor (lid, _) ->
+        Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
+                        PStr [ Str.eval ~loc
+                                 (Exp.construct ~loc (map_loc sub lid) None)
+                             ])
+  in
+  List.fold_right (exp_extra sub) exp.exp_extra
+    (Exp.mk ~loc ~attrs desc)
+
+let package_type sub pack =
+  (map_loc sub pack.pack_txt,
+    List.map (fun (s, ct) ->
+        (s, sub.typ sub ct)) pack.pack_fields)
+
+let module_type_declaration sub mtd =
+  let loc = sub.location sub mtd.mtd_loc; in
+  let attrs = sub.attributes sub mtd.mtd_attributes in
+  Mtd.mk ~loc ~attrs
+    ?typ:(map_opt (sub.module_type sub) mtd.mtd_type)
+    (map_loc sub mtd.mtd_name)
+
+let signature sub sg =
+  List.map (sub.signature_item sub) sg.sig_items
+
+let signature_item sub item =
+  let loc = sub.location sub item.sig_loc; in
+  let desc =
+    match item.sig_desc with
+      Tsig_value v ->
+        Psig_value (sub.value_description sub v)
+    | Tsig_type (rec_flag, list) ->
+        Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
+    | Tsig_typext tyext ->
+        Psig_typext (sub.type_extension sub tyext)
+    | Tsig_exception ext ->
+        Psig_exception (sub.extension_constructor sub ext)
+    | Tsig_module md ->
+        Psig_module (sub.module_declaration sub md)
+    | Tsig_recmodule list ->
+        Psig_recmodule (List.map (sub.module_declaration sub) list)
+    | Tsig_modtype mtd ->
+        Psig_modtype (sub.module_type_declaration sub mtd)
+    | Tsig_open od ->
+        Psig_open (sub.open_description sub od)
+    | Tsig_include incl ->
+        Psig_include (sub.include_description sub incl)
+    | Tsig_class list ->
+        Psig_class (List.map (sub.class_description sub) list)
+    | Tsig_class_type list ->
+        Psig_class_type (List.map (sub.class_type_declaration sub) list)
+    | Tsig_attribute x ->
+        Psig_attribute x
+  in
+  Sig.mk ~loc desc
+
+let module_declaration sub md =
+  let loc = sub.location sub md.md_loc; in
+  let attrs = sub.attributes sub md.md_attributes in
+  Md.mk ~loc ~attrs
+    (map_loc sub md.md_name)
+    (sub.module_type sub md.md_type)
+
+let include_infos f sub incl =
+  let loc = sub.location sub incl.incl_loc; in
+  let attrs = sub.attributes sub incl.incl_attributes in
+  Incl.mk ~loc ~attrs
+    (f sub incl.incl_mod)
+
+let include_declaration sub = include_infos sub.module_expr sub
+let include_description sub = include_infos sub.module_type sub
+
+let class_infos f sub ci =
+  let loc = sub.location sub ci.ci_loc; in
+  let attrs = sub.attributes sub ci.ci_attributes in
+  Ci.mk ~loc ~attrs
+    ~virt:ci.ci_virt
+    ~params:(List.map (type_parameter sub) ci.ci_params)
+    (map_loc sub ci.ci_id_name)
+    (f sub ci.ci_expr)
+
+let class_declaration sub = class_infos sub.class_expr sub
+let class_description sub = class_infos sub.class_type sub
+let class_type_declaration sub = class_infos sub.class_type sub
+
+let module_type sub mty =
+  let loc = sub.location sub mty.mty_loc; in
+  let attrs = sub.attributes sub mty.mty_attributes in
+  let desc = match mty.mty_desc with
+      Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
+    | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
+    | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
+    | Tmty_functor (_id, name, mtype1, mtype2) ->
+        Pmty_functor (name, map_opt (sub.module_type sub) mtype1,
+          sub.module_type sub mtype2)
+    | Tmty_with (mtype, list) ->
+        Pmty_with (sub.module_type sub mtype,
+          List.map (sub.with_constraint sub) list)
+    | Tmty_typeof mexpr ->
+        Pmty_typeof (sub.module_expr sub mexpr)
+  in
+  Mty.mk ~loc ~attrs desc
+
+let with_constraint sub (_path, lid, cstr) =
+  match cstr with
+  | Twith_type decl ->
+      Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
+  | Twith_module (_path, lid2) ->
+      Pwith_module (map_loc sub lid, map_loc sub lid2)
+  | Twith_typesubst decl -> Pwith_typesubst (sub.type_declaration sub decl)
+  | Twith_modsubst (_path, lid2) ->
+      Pwith_modsubst
+        ({loc = sub.location sub lid.loc; txt=Longident.last lid.txt},
+         map_loc sub lid2)
+
+let module_expr sub mexpr =
+  let loc = sub.location sub mexpr.mod_loc; in
+  let attrs = sub.attributes sub mexpr.mod_attributes in
+  match mexpr.mod_desc with
+      Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
+        sub.module_expr sub m
+    | _ ->
+        let desc = match mexpr.mod_desc with
+            Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
+          | Tmod_structure st -> Pmod_structure (sub.structure sub st)
+          | Tmod_functor (_id, name, mtype, mexpr) ->
+              Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype,
+                sub.module_expr sub mexpr)
+          | Tmod_apply (mexp1, mexp2, _) ->
+              Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
+          | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+              Pmod_constraint (sub.module_expr sub mexpr,
+                sub.module_type sub mtype)
+          | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
+              assert false
+          | Tmod_unpack (exp, _pack) ->
+              Pmod_unpack (sub.expr sub exp)
+              (* TODO , sub.package_type sub pack) *)
+        in
+        Mod.mk ~loc ~attrs desc
+
+let class_expr sub cexpr =
+  let loc = sub.location sub cexpr.cl_loc; in
+  let attrs = sub.attributes sub cexpr.cl_attributes in
+  let desc = match cexpr.cl_desc with
+    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+                       None, _, _, _ ) ->
+        Pcl_constr (map_loc sub lid,
+          List.map (sub.typ sub) tyl)
+    | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)
+
+    | Tcl_fun (label, pat, _pv, cl, _partial) ->
+        Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)
+
+    | Tcl_apply (cl, args) ->
+        Pcl_apply (sub.class_expr sub cl,
+          List.fold_right (fun (label, expo) list ->
+              match expo with
+                None -> list
+              | Some exp -> (label, sub.expr sub exp) :: list
+          ) args [])
+
+    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
+        Pcl_let (rec_flat,
+          List.map (sub.value_binding sub) bindings,
+          sub.class_expr sub cl)
+
+    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+        Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
+
+    | Tcl_ident _ -> assert false
+    | Tcl_constraint (_, None, _, _, _) -> assert false
+  in
+  Cl.mk ~loc ~attrs desc
+
+let class_type sub ct =
+  let loc = sub.location sub ct.cltyp_loc; in
+  let attrs = sub.attributes sub ct.cltyp_attributes in
+  let desc = match ct.cltyp_desc with
+      Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
+    | Tcty_constr (_path, lid, list) ->
+        Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
+    | Tcty_arrow (label, ct, cl) ->
+        Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
+  in
+  Cty.mk ~loc ~attrs desc
+
+let class_signature sub cs =
+  {
+    pcsig_self = sub.typ sub cs.csig_self;
+    pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
+  }
+
+let class_type_field sub ctf =
+  let loc = sub.location sub ctf.ctf_loc; in
+  let attrs = sub.attributes sub ctf.ctf_attributes in
+  let desc = match ctf.ctf_desc with
+      Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
+    | Tctf_val (s, mut, virt, ct) ->
+        Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
+    | Tctf_method  (s, priv, virt, ct) ->
+        Pctf_method  (mkloc s loc, priv, virt, sub.typ sub ct)
+    | Tctf_constraint  (ct1, ct2) ->
+        Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
+    | Tctf_attribute x -> Pctf_attribute x
+  in
+  Ctf.mk ~loc ~attrs desc
+
+let core_type sub ct =
+  let loc = sub.location sub ct.ctyp_loc; in
+  let attrs = sub.attributes sub ct.ctyp_attributes in
+  let desc = match ct.ctyp_desc with
+      Ttyp_any -> Ptyp_any
+    | Ttyp_var s -> Ptyp_var s
+    | Ttyp_arrow (label, ct1, ct2) ->
+        Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
+    | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_constr (_path, lid, list) ->
+        Ptyp_constr (map_loc sub lid,
+          List.map (sub.typ sub) list)
+    | Ttyp_object (list, o) ->
+        Ptyp_object
+          (List.map (fun (s, a, t) ->
+               (mkloc s loc, a, sub.typ sub t)) list, o)
+    | Ttyp_class (_path, lid, list) ->
+        Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
+    | Ttyp_alias (ct, s) ->
+        Ptyp_alias (sub.typ sub ct, s)
+    | Ttyp_variant (list, bool, labels) ->
+        Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
+    | Ttyp_poly (list, ct) ->
+        let list = List.map (fun v -> mkloc v loc) list in
+        Ptyp_poly (list, sub.typ sub ct)
+    | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
+  in
+  Typ.mk ~loc ~attrs desc
+
+let class_structure sub cs =
+  let rec remove_self = function
+    | { pat_desc = Tpat_alias (p, id, _s) }
+      when string_is_prefix "selfpat-" id.Ident.name ->
+        remove_self p
+    | p -> p
+  in
+  { pcstr_self = sub.pat sub (remove_self cs.cstr_self);
+    pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
+  }
+
+let row_field sub rf =
+  match rf with
+    Ttag (label, attrs, bool, list) ->
+      Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list)
+  | Tinherit ct -> Rinherit (sub.typ sub ct)
+
+and is_self_pat = function
+  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+      string_is_prefix "self-" (Ident.name id)
+  | _ -> false
+
+let class_field sub cf =
+  let loc = sub.location sub cf.cf_loc; in
+  let attrs = sub.attributes sub cf.cf_attributes in
+  let desc = match cf.cf_desc with
+      Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+        Pcf_inherit (ovf, sub.class_expr sub cl,
+                     map_opt (fun v -> mkloc v loc) super)
+    | Tcf_constraint (cty, cty') ->
+        Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
+    | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
+        Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
+    | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
+        Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+        Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
+    | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
+    | Tcf_initializer exp ->
+        let remove_fun_self = function
+          | { exp_desc =
+              Texp_function { arg_label = Nolabel; cases = [case]; _ } }
+            when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
+          | e -> e
+        in
+        let exp = remove_fun_self exp in
+        Pcf_initializer (sub.expr sub exp)
+    | Tcf_attribute x -> Pcf_attribute x
+  in
+  Cf.mk ~loc ~attrs desc
+
+let location _sub l = l
+
+let default_mapper =
+  {
+    attribute = attribute ;
+    attributes = attributes ;
+    structure = structure;
+    structure_item = structure_item;
+    module_expr = module_expr;
+    signature = signature;
+    signature_item = signature_item;
+    module_type = module_type;
+    with_constraint = with_constraint;
+    class_declaration = class_declaration;
+    class_expr = class_expr;
+    class_field = class_field;
+    class_structure = class_structure;
+    class_type = class_type;
+    class_type_field = class_type_field;
+    class_signature = class_signature;
+    class_type_declaration = class_type_declaration;
+    class_description = class_description;
+    type_declaration = type_declaration;
+    type_kind = type_kind;
+    typ = core_type;
+    type_extension = type_extension;
+    extension_constructor = extension_constructor;
+    value_description = value_description;
+    pat = pattern;
+    expr = expression;
+    module_declaration = module_declaration;
+    module_type_declaration = module_type_declaration;
+    module_binding = module_binding;
+    package_type = package_type ;
+    open_description = open_description;
+    include_description = include_description;
+    include_declaration = include_declaration;
+    value_binding = value_binding;
+    constructor_declaration = constructor_declaration;
+    label_declaration = label_declaration;
+    cases = cases;
+    case = case;
+    location = location;
+    row_field = row_field ;
+  }
+
+let untype_structure ?(mapper=default_mapper) structure =
+  mapper.structure mapper structure
+
+let untype_signature ?(mapper=default_mapper) signature =
+  mapper.signature mapper signature
diff --git a/typing/untypeast.mli b/typing/untypeast.mli
new file mode 100644
index 00000000..1b5e84a2
--- /dev/null
+++ b/typing/untypeast.mli
@@ -0,0 +1,78 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)   *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Parsetree
+
+val lident_of_path : Path.t -> Longident.t
+
+type mapper = {
+  attribute: mapper -> Typedtree.attribute -> attribute;
+  attributes: mapper -> Typedtree.attribute list -> attribute list;
+  case: mapper -> Typedtree.case -> case;
+  cases: mapper -> Typedtree.case list -> case list;
+  class_declaration: mapper -> Typedtree.class_declaration -> class_declaration;
+  class_description: mapper -> Typedtree.class_description -> class_description;
+  class_expr: mapper -> Typedtree.class_expr -> class_expr;
+  class_field: mapper -> Typedtree.class_field -> class_field;
+  class_signature: mapper -> Typedtree.class_signature -> class_signature;
+  class_structure: mapper -> Typedtree.class_structure -> class_structure;
+  class_type: mapper -> Typedtree.class_type -> class_type;
+  class_type_declaration: mapper -> Typedtree.class_type_declaration
+                          -> class_type_declaration;
+  class_type_field: mapper -> Typedtree.class_type_field -> class_type_field;
+  constructor_declaration: mapper -> Typedtree.constructor_declaration
+                           -> constructor_declaration;
+  expr: mapper -> Typedtree.expression -> expression;
+  extension_constructor: mapper -> Typedtree.extension_constructor
+                         -> extension_constructor;
+  include_declaration:
+    mapper -> Typedtree.include_declaration -> include_declaration;
+  include_description:
+    mapper -> Typedtree.include_description -> include_description;
+  label_declaration:
+    mapper -> Typedtree.label_declaration -> label_declaration;
+  location: mapper -> Location.t -> Location.t;
+  module_binding: mapper -> Typedtree.module_binding -> module_binding;
+  module_declaration:
+    mapper -> Typedtree.module_declaration -> module_declaration;
+  module_expr: mapper -> Typedtree.module_expr -> module_expr;
+  module_type: mapper -> Typedtree.module_type -> module_type;
+  module_type_declaration:
+    mapper -> Typedtree.module_type_declaration -> module_type_declaration;
+  package_type: mapper -> Typedtree.package_type -> package_type;
+  open_description: mapper -> Typedtree.open_description -> open_description;
+  pat: mapper -> Typedtree.pattern -> pattern;
+  row_field: mapper -> Typedtree.row_field -> row_field;
+  signature: mapper -> Typedtree.signature -> signature;
+  signature_item: mapper -> Typedtree.signature_item -> signature_item;
+  structure: mapper -> Typedtree.structure -> structure;
+  structure_item: mapper -> Typedtree.structure_item -> structure_item;
+  typ: mapper -> Typedtree.core_type -> core_type;
+  type_declaration: mapper -> Typedtree.type_declaration -> type_declaration;
+  type_extension: mapper -> Typedtree.type_extension -> type_extension;
+  type_kind: mapper -> Typedtree.type_kind -> type_kind;
+  value_binding: mapper -> Typedtree.value_binding -> value_binding;
+  value_description: mapper -> Typedtree.value_description -> value_description;
+  with_constraint:
+    mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint)
+    -> with_constraint;
+}
+
+val default_mapper : mapper
+
+val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
+val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature
+
+val constant : Asttypes.constant -> Parsetree.constant
diff --git a/utils/arg_helper.ml b/utils/arg_helper.ml
new file mode 100644
index 00000000..fa80007a
--- /dev/null
+++ b/utils/arg_helper.ml
@@ -0,0 +1,127 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let fatal err =
+  prerr_endline err;
+  exit 2
+
+module Make (S : sig
+  module Key : sig
+    type t
+    val of_string : string -> t
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+    val of_string : string -> t
+  end
+end) = struct
+  type parsed = {
+    base_default : S.Value.t;
+    base_override : S.Value.t S.Key.Map.t;
+    user_default : S.Value.t option;
+    user_override : S.Value.t S.Key.Map.t;
+  }
+
+  let default v =
+    { base_default = v;
+      base_override = S.Key.Map.empty;
+      user_default = None;
+      user_override = S.Key.Map.empty; }
+
+  let set_base_default value t =
+    { t with base_default = value }
+
+  let add_base_override key value t =
+    { t with base_override = S.Key.Map.add key value t.base_override }
+
+  let reset_base_overrides t =
+    { t with base_override = S.Key.Map.empty }
+
+  let set_user_default value t =
+    { t with user_default = Some value }
+
+  let add_user_override key value t =
+    { t with user_override = S.Key.Map.add key value t.user_override }
+
+  exception Parse_failure of exn
+
+  let parse_exn str ~update =
+    (* Is the removal of empty chunks really relevant here? *)
+    (* (It has been added to mimic the old Misc.String.split.) *)
+    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
+    let parsed =
+      List.fold_left (fun acc value ->
+          match String.index value '=' with
+          | exception Not_found ->
+            begin match S.Value.of_string value with
+            | value -> set_user_default value acc
+            | exception exn -> raise (Parse_failure exn)
+            end
+          | equals ->
+            let key_value_pair = value in
+            let length = String.length key_value_pair in
+            assert (equals >= 0 && equals < length);
+            if equals = 0 then begin
+              raise (Parse_failure (
+                Failure "Missing key in argument specification"))
+            end;
+            let key =
+              let key = String.sub key_value_pair 0 equals in
+              try S.Key.of_string key
+              with exn -> raise (Parse_failure exn)
+            in
+            let value =
+              let value =
+                String.sub key_value_pair (equals + 1) (length - equals - 1)
+              in
+              try S.Value.of_string value
+              with exn -> raise (Parse_failure exn)
+            in
+            add_user_override key value acc)
+        !update
+        values
+    in
+    update := parsed
+
+  let parse str help_text update =
+    match parse_exn str ~update with
+    | () -> ()
+    | exception (Parse_failure exn) ->
+      fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  let parse_no_error str update =
+    match parse_exn str ~update with
+    | () -> Ok
+    | exception (Parse_failure exn) -> Parse_failed exn
+
+  let get ~key parsed =
+    match S.Key.Map.find key parsed.user_override with
+    | value -> value
+    | exception Not_found ->
+      match parsed.user_default with
+      | Some value -> value
+      | None ->
+        match S.Key.Map.find key parsed.base_override with
+        | value -> value
+        | exception Not_found -> parsed.base_default
+
+end
diff --git a/utils/arg_helper.mli b/utils/arg_helper.mli
new file mode 100644
index 00000000..fba7aa21
--- /dev/null
+++ b/utils/arg_helper.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 OCamlPro SAS                                    *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Decipher command line arguments of the form
+         | =[,...]
+    (as used for example for the specification of inlining parameters
+    varying by simplification round).
+*)
+
+module Make (S : sig
+  module Key : sig
+    type t
+
+    (** The textual representation of a key must not contain '=' or ','. *)
+    val of_string : string -> t
+
+    module Map : Map.S with type key = t
+  end
+
+  module Value : sig
+    type t
+
+    (** The textual representation of a value must not contain ','. *)
+    val of_string : string -> t
+  end
+end) : sig
+  type parsed
+
+  val default : S.Value.t -> parsed
+
+  val set_base_default : S.Value.t -> parsed -> parsed
+
+  val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val reset_base_overrides : parsed -> parsed
+
+  val set_user_default : S.Value.t -> parsed -> parsed
+
+  val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:S.Key.t -> parsed -> S.Value.t
+end
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
new file mode 100644
index 00000000..30115b0b
--- /dev/null
+++ b/utils/ccomp.ml
@@ -0,0 +1,198 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compiling C files and building C libraries *)
+
+let command cmdline =
+  if !Clflags.verbose then begin
+    prerr_string "+ ";
+    prerr_string cmdline;
+    prerr_newline()
+  end;
+  Sys.command cmdline
+
+let run_command cmdline = ignore(command cmdline)
+
+(* Build @responsefile to work around Windows limitations on
+   command-line length *)
+let build_diversion lst =
+  let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
+  List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst;
+  close_out oc;
+  at_exit (fun () -> Misc.remove_file responsefile);
+  "@" ^ responsefile
+
+let quote_files lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let quoted = List.map Filename.quote lst in
+  let s = String.concat " " quoted in
+  if String.length s >= 4096 && Sys.os_type = "Win32"
+  then build_diversion quoted
+  else s
+
+let quote_prefixed pr lst =
+  let lst = List.filter (fun f -> f <> "") lst in
+  let lst = List.map (fun f -> pr ^ f) lst in
+  quote_files lst
+
+let quote_optfile = function
+  | None -> ""
+  | Some f -> Filename.quote f
+
+let display_msvc_output file name =
+  let c = open_in file in
+  try
+    let first = input_line c in
+    if first <> Filename.basename name then
+      print_string first;
+    while true do
+      print_string (input_line c)
+    done
+  with _ ->
+    close_in c;
+    Sys.remove file
+
+let compile_file name =
+  let (pipe, file) =
+    if Config.ccomp_type = "msvc" && not !Clflags.verbose then
+      try
+        let (t, c) = Filename.open_temp_file "msvc" "stdout" in
+        close_out c;
+        (Printf.sprintf " > %s" (Filename.quote t), t)
+      with _ ->
+        ("", "")
+    else
+      ("", "") in
+  let exit =
+    command
+      (Printf.sprintf
+         "%s -c %s %s %s %s %s%s"
+         (match !Clflags.c_compiler with
+          | Some cc -> cc
+          | None ->
+              if !Clflags.native_code
+              then Config.native_c_compiler
+              else Config.bytecomp_c_compiler)
+         (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "")
+         (String.concat " " (List.rev !Clflags.all_ccopts))
+         (quote_prefixed "-I" (List.rev !Clflags.include_dirs))
+         (Clflags.std_include_flag "-I")
+         (Filename.quote name)
+         (* cl tediously includes the name of the C file as the first thing it
+            outputs (in fairness, the tedious thing is that there's no switch to
+            disable this behaviour). In the absence of the Unix module, use
+            a temporary file to filter the output (cannot pipe the output to a
+            filter because this removes the exit status of cl, which is wanted.
+          *)
+         pipe) in
+  if pipe <> ""
+  then display_msvc_output file name;
+  exit
+
+let macos_create_empty_archive ~quoted_archive =
+  let result =
+    command (Printf.sprintf "%s rc %s /dev/null" Config.ar quoted_archive)
+  in
+  if result <> 0 then result
+  else
+    let result =
+      command (Printf.sprintf "%s %s 2> /dev/null" Config.ranlib quoted_archive)
+    in
+    if result <> 0 then result
+    else
+      command (Printf.sprintf "%s d %s /dev/null" Config.ar quoted_archive)
+
+let create_archive archive file_list =
+  Misc.remove_file archive;
+  let quoted_archive = Filename.quote archive in
+  match Config.ccomp_type with
+    "msvc" ->
+      command(Printf.sprintf "link /lib /nologo /out:%s %s"
+                             quoted_archive (quote_files file_list))
+  | _ ->
+      assert(String.length Config.ar > 0);
+      let is_macosx =
+        match Config.system with
+        | "macosx" -> true
+        | _ -> false
+      in
+      if is_macosx && file_list = [] then  (* PR#6550 *)
+        macos_create_empty_archive ~quoted_archive
+      else
+        let r1 =
+          command(Printf.sprintf "%s rc %s %s"
+                  Config.ar quoted_archive (quote_files file_list)) in
+        if r1 <> 0 || String.length Config.ranlib = 0
+        then r1
+        else command(Config.ranlib ^ " " ^ quoted_archive)
+
+let expand_libname name =
+  if String.length name < 2 || String.sub name 0 2 <> "-l"
+  then name
+  else begin
+    let libname =
+      "lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in
+    try
+      Misc.find_in_path !Config.load_path libname
+    with Not_found ->
+      libname
+  end
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+let remove_Wl cclibs =
+  cclibs |> List.map (fun cclib ->
+    (* -Wl,-foo,bar -> -foo bar *)
+    if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then
+      String.map (function ',' -> ' ' | c -> c)
+                 (String.sub cclib 4 (String.length cclib - 4))
+    else cclib)
+
+let call_linker mode output_name files extra =
+  let cmd =
+    if mode = Partial then
+      let l_prefix =
+        match Config.ccomp_type with
+        | "msvc" -> "/libpath:"
+        | _ -> "-L"
+      in
+      Printf.sprintf "%s%s %s %s %s"
+        Config.native_pack_linker
+        (Filename.quote output_name)
+        (quote_prefixed l_prefix !Config.load_path)
+        (quote_files (remove_Wl files))
+        extra
+    else
+      Printf.sprintf "%s -o %s %s %s %s %s %s %s"
+        (match !Clflags.c_compiler, mode with
+        | Some cc, _ -> cc
+        | None, Exe -> Config.mkexe
+        | None, Dll -> Config.mkdll
+        | None, MainDll -> Config.mkmaindll
+        | None, Partial -> assert false
+        )
+        (Filename.quote output_name)
+        (if !Clflags.gprofile then Config.cc_profile else "")
+        ""  (*(Clflags.std_include_flag "-I")*)
+        (quote_prefixed "-L" !Config.load_path)
+        (String.concat " " (List.rev !Clflags.all_ccopts))
+        (quote_files files)
+        extra
+  in
+  command cmd = 0
diff --git a/utils/ccomp.mli b/utils/ccomp.mli
new file mode 100644
index 00000000..b57df6e0
--- /dev/null
+++ b/utils/ccomp.mli
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compiling C files and building C libraries *)
+
+val command: string -> int
+val run_command: string -> unit
+val compile_file: string -> int
+val create_archive: string -> string list -> int
+val expand_libname: string -> string
+val quote_files: string list -> string
+val quote_optfile: string option -> string
+(*val make_link_options: string list -> string*)
+
+type link_mode =
+  | Exe
+  | Dll
+  | MainDll
+  | Partial
+
+val call_linker: link_mode -> string -> string list -> string -> bool
diff --git a/utils/clflags.ml b/utils/clflags.ml
new file mode 100644
index 00000000..04c95847
--- /dev/null
+++ b/utils/clflags.ml
@@ -0,0 +1,393 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Command-line parameters *)
+
+module Int_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+end)
+module Float_arg_helper = Arg_helper.Make (struct
+  module Key = struct
+    include Numbers.Int
+    let of_string = int_of_string
+  end
+
+  module Value = struct
+    include Numbers.Float
+    let of_string = float_of_string
+  end
+end)
+
+let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
+and ccobjs = ref ([] : string list)     (* .o, .a, .so and -cclib -lxxx *)
+and dllibs = ref ([] : string list)     (* .so and -dllib -lxxx *)
+
+let compile_only = ref false            (* -c *)
+and output_name = ref (None : string option) (* -o *)
+and include_dirs = ref ([] : string list)(* -I *)
+and no_std_include = ref false          (* -nostdlib *)
+and print_types = ref false             (* -i *)
+and make_archive = ref false            (* -a *)
+and debug = ref false                   (* -g *)
+and fast = ref false                    (* -unsafe *)
+and link_everything = ref false         (* -linkall *)
+and custom_runtime = ref false          (* -custom *)
+and no_check_prims = ref false          (* -no-check-prims *)
+and bytecode_compatible_32 = ref false  (* -compat-32 *)
+and output_c_object = ref false         (* -output-obj *)
+and output_complete_object = ref false  (* -output-complete-obj *)
+and all_ccopts = ref ([] : string list)     (* -ccopt *)
+and classic = ref false                 (* -nolabels *)
+and nopervasives = ref false            (* -nopervasives *)
+and preprocessor = ref(None : string option) (* -pp *)
+and all_ppx = ref ([] : string list)        (* -ppx *)
+let annotations = ref false             (* -annot *)
+let binary_annotations = ref false      (* -annot *)
+and use_threads = ref false             (* -thread *)
+and use_vmthreads = ref false           (* -vmthread *)
+and noassert = ref false                (* -noassert *)
+and verbose = ref false                 (* -verbose *)
+and noversion = ref false               (* -no-version *)
+and noprompt = ref false                (* -noprompt *)
+and nopromptcont = ref false            (* -nopromptcont *)
+and init_file = ref (None : string option)   (* -init *)
+and noinit = ref false                  (* -noinit *)
+and open_modules = ref []               (* -open *)
+and use_prims = ref ""                  (* -use-prims ... *)
+and use_runtime = ref ""                (* -use-runtime ... *)
+and principal = ref false               (* -principal *)
+and real_paths = ref true               (* -short-paths *)
+and recursive_types = ref false         (* -rectypes *)
+and strict_sequence = ref false         (* -strict-sequence *)
+and strict_formats = ref false          (* -strict-formats *)
+and applicative_functors = ref true     (* -no-app-funct *)
+and make_runtime = ref false            (* -make-runtime *)
+and gprofile = ref false                (* -p *)
+and c_compiler = ref (None: string option) (* -cc *)
+and no_auto_link = ref false            (* -noautolink *)
+and dllpaths = ref ([] : string list)   (* -dllpath *)
+and make_package = ref false            (* -pack *)
+and for_package = ref (None: string option) (* -for-pack *)
+and error_size = ref 500                (* -error-size *)
+and float_const_prop = ref true         (* -no-float-const-prop *)
+and transparent_modules = ref false     (* -trans-mod *)
+let dump_source = ref false             (* -dsource *)
+let dump_parsetree = ref false          (* -dparsetree *)
+and dump_typedtree = ref false          (* -dtypedtree *)
+and dump_rawlambda = ref false          (* -drawlambda *)
+and dump_lambda = ref false             (* -dlambda *)
+and dump_rawclambda = ref false         (* -drawclambda *)
+and dump_clambda = ref false            (* -dclambda *)
+and dump_rawflambda = ref false            (* -drawflambda *)
+and dump_flambda = ref false            (* -dflambda *)
+and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *)
+and dump_flambda_verbose = ref false    (* -dflambda-verbose *)
+and dump_instr = ref false              (* -dinstr *)
+
+let keep_asm_file = ref false           (* -S *)
+let optimize_for_speed = ref true       (* -compact *)
+and opaque = ref false                  (* -opaque *)
+
+and dump_cmm = ref false                (* -dcmm *)
+let dump_selection = ref false          (* -dsel *)
+let dump_cse = ref false                (* -dcse *)
+let dump_live = ref false               (* -dlive *)
+let dump_spill = ref false              (* -dspill *)
+let dump_split = ref false              (* -dsplit *)
+let dump_interf = ref false             (* -dinterf *)
+let dump_prefer = ref false             (* -dprefer *)
+let dump_regalloc = ref false           (* -dalloc *)
+let dump_reload = ref false             (* -dreload *)
+let dump_scheduling = ref false         (* -dscheduling *)
+let dump_linear = ref false             (* -dlinear *)
+let keep_startup_file = ref false       (* -dstartup *)
+let dump_combine = ref false            (* -dcombine *)
+let print_timings = ref false           (* -dtimings *)
+
+let native_code = ref false             (* set to true under ocamlopt *)
+
+let force_slash = ref false             (* for ocamldep *)
+let clambda_checks = ref false          (* -clambda-checks *)
+
+let flambda_invariant_checks = ref true (* -flambda-invariants *)
+
+let dont_write_files = ref false        (* set to true under ocamldoc *)
+
+let std_include_flag prefix =
+  if !no_std_include then ""
+  else (prefix ^ (Filename.quote Config.standard_library))
+;;
+
+let std_include_dir () =
+  if !no_std_include then [] else [Config.standard_library]
+;;
+
+let shared = ref false (* -shared *)
+let dlcode = ref true (* not -nodynlink *)
+
+let pic_code = ref (match Config.architecture with (* -fPIC *)
+                     | "amd64" -> true
+                     | _       -> false)
+
+let runtime_variant = ref "";;      (* -runtime-variant *)
+
+let keep_docs = ref false              (* -keep-docs *)
+let keep_locs = ref false              (* -keep-locs *)
+let unsafe_string = ref (not Config.safe_string)
+                                   (* -safe-string / -unsafe-string *)
+
+let classic_inlining = ref false       (* -Oclassic *)
+let inlining_report = ref false    (* -inlining-report *)
+
+let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
+let afl_inst_ratio = ref 100           (* -afl-inst-ratio *)
+
+let simplify_rounds = ref None        (* -rounds *)
+let default_simplify_rounds = ref 1        (* -rounds *)
+let rounds () =
+  match !simplify_rounds with
+  | None -> !default_simplify_rounds
+  | Some r -> r
+
+let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
+let inline_toplevel_multiplier = 16
+let default_inline_toplevel_threshold =
+  int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold)
+let default_inline_call_cost = 5
+let default_inline_alloc_cost = 7
+let default_inline_prim_cost = 3
+let default_inline_branch_cost = 5
+let default_inline_indirect_cost = 4
+let default_inline_branch_factor = 0.1
+let default_inline_lifting_benefit = 1300
+let default_inline_max_unroll = 0
+let default_inline_max_depth = 1
+
+let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
+let inline_toplevel_threshold =
+  ref (Int_arg_helper.default default_inline_toplevel_threshold)
+let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost)
+let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost)
+let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost)
+let inline_branch_cost =
+  ref (Int_arg_helper.default default_inline_branch_cost)
+let inline_indirect_cost =
+  ref (Int_arg_helper.default default_inline_indirect_cost)
+let inline_branch_factor =
+  ref (Float_arg_helper.default default_inline_branch_factor)
+let inline_lifting_benefit =
+  ref (Int_arg_helper.default default_inline_lifting_benefit)
+let inline_max_unroll =
+  ref (Int_arg_helper.default default_inline_max_unroll)
+let inline_max_depth =
+  ref (Int_arg_helper.default default_inline_max_depth)
+
+
+let unbox_specialised_args = ref true   (* -no-unbox-specialised-args *)
+let unbox_free_vars_of_closures = ref true
+let unbox_closures = ref false          (* -unbox-closures *)
+let default_unbox_closures_factor = 10
+let unbox_closures_factor =
+  ref default_unbox_closures_factor      (* -unbox-closures-factor *)
+let remove_unused_arguments = ref false (* -remove-unused-arguments *)
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+let set_int_arg round (arg:Int_arg_helper.parsed ref) default value =
+  let value : int =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Int_arg_helper.set_base_default value
+             (Int_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Int_arg_helper.add_base_override round value !arg
+
+let set_float_arg round (arg:Float_arg_helper.parsed ref) default value =
+  let value =
+    match value with
+    | None -> default
+    | Some value -> value
+  in
+  match round with
+  | None ->
+    arg := Float_arg_helper.set_base_default value
+             (Float_arg_helper.reset_base_overrides !arg)
+  | Some round ->
+    arg := Float_arg_helper.add_base_override round value !arg
+
+let use_inlining_arguments_set ?round (arg:inlining_arguments) =
+  let set_int = set_int_arg round in
+  let set_float = set_float_arg round in
+  set_int inline_call_cost default_inline_call_cost arg.inline_call_cost;
+  set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost;
+  set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost;
+  set_int inline_branch_cost
+    default_inline_branch_cost arg.inline_branch_cost;
+  set_int inline_indirect_cost
+    default_inline_indirect_cost arg.inline_indirect_cost;
+  set_int inline_lifting_benefit
+    default_inline_lifting_benefit arg.inline_lifting_benefit;
+  set_float inline_branch_factor
+    default_inline_branch_factor arg.inline_branch_factor;
+  set_int inline_max_depth
+    default_inline_max_depth arg.inline_max_depth;
+  set_int inline_max_unroll
+    default_inline_max_unroll arg.inline_max_unroll;
+  set_float inline_threshold
+    default_inline_threshold arg.inline_threshold;
+  set_int inline_toplevel_threshold
+    default_inline_toplevel_threshold arg.inline_toplevel_threshold
+
+(* o1 is the default *)
+let o1_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  inline_threshold = None;
+  inline_toplevel_threshold = None;
+}
+
+let classic_arguments = {
+  inline_call_cost = None;
+  inline_alloc_cost = None;
+  inline_prim_cost = None;
+  inline_branch_cost = None;
+  inline_indirect_cost = None;
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = None;
+  inline_max_unroll = None;
+  (* [inline_threshold] matches the current compiler's default.
+     Note that this particular fraction can be expressed exactly in
+     floating point. *)
+  inline_threshold = Some (10. /. 8.);
+  (* [inline_toplevel_threshold] is not used in classic mode. *)
+  inline_toplevel_threshold = Some 1;
+}
+
+let o2_arguments = {
+  inline_call_cost = Some (2 * default_inline_call_cost);
+  inline_alloc_cost = Some (2 * default_inline_alloc_cost);
+  inline_prim_cost = Some (2 * default_inline_prim_cost);
+  inline_branch_cost = Some (2 * default_inline_branch_cost);
+  inline_indirect_cost = Some (2 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = None;
+  inline_max_depth = Some 2;
+  inline_max_unroll = None;
+  inline_threshold = Some 25.;
+  inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier);
+}
+
+let o3_arguments = {
+  inline_call_cost = Some (3 * default_inline_call_cost);
+  inline_alloc_cost = Some (3 * default_inline_alloc_cost);
+  inline_prim_cost = Some (3 * default_inline_prim_cost);
+  inline_branch_cost = Some (3 * default_inline_branch_cost);
+  inline_indirect_cost = Some (3 * default_inline_indirect_cost);
+  inline_lifting_benefit = None;
+  inline_branch_factor = Some 0.;
+  inline_max_depth = Some 3;
+  inline_max_unroll = Some 1;
+  inline_threshold = Some 50.;
+  inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier);
+}
+
+let all_passes = ref []
+let dumped_passes_list = ref []
+let dumped_pass s =
+  assert(List.mem s !all_passes);
+  List.mem s !dumped_passes_list
+
+let set_dumped_pass s enabled =
+  if (List.mem s !all_passes) then begin
+    let passes_without_s = List.filter ((<>) s) !dumped_passes_list in
+    let dumped_passes =
+      if enabled then
+        s :: passes_without_s
+      else
+        passes_without_s
+    in
+    dumped_passes_list := dumped_passes
+  end
+
+let parse_color_setting = function
+  | "auto" -> Some Misc.Color.Auto
+  | "always" -> Some Misc.Color.Always
+  | "never" -> Some Misc.Color.Never
+  | _ -> None
+let color = ref None ;; (* -color *)
+
+let unboxed_types = ref false
+
+let arg_spec = ref []
+let arg_names = ref Misc.StringMap.empty
+let add_arguments loc args =
+  List.iter (function (arg_name, _, _) as arg ->
+    try
+      let loc2 = Misc.StringMap.find arg_name !arg_names in
+      Printf.eprintf
+        "Warning: plugin argument %s is already defined:\n" arg_name;
+      Printf.eprintf "   First definition: %s\n" loc2;
+      Printf.eprintf "   New definition: %s\n" loc;
+    with Not_found ->
+      arg_spec := !arg_spec @ [ arg ];
+      arg_names := Misc.StringMap.add arg_name loc !arg_names
+  ) args
+
+let print_arguments usage =
+  Arg.usage !arg_spec usage
+
+(* This function is almost the same as [Arg.parse_expand], except
+   that [Arg.parse_expand] could not be used because it does not take a
+   reference for [arg_spec].*)
+let parse_arguments f msg =
+  try
+    let argv = ref Sys.argv in
+    let current = ref (!Arg.current) in
+    Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg
+  with
+  | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
+  | Arg.Help msg -> Printf.printf "%s" msg; exit 0
diff --git a/utils/clflags.mli b/utils/clflags.mli
new file mode 100644
index 00000000..79e79aad
--- /dev/null
+++ b/utils/clflags.mli
@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Optimization parameters represented as ints indexed by round number. *)
+module Int_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> int
+end
+
+(** Optimization parameters represented as floats indexed by round number. *)
+module Float_arg_helper : sig
+  type parsed
+
+  val parse : string -> string -> parsed ref -> unit
+
+  type parse_result =
+    | Ok
+    | Parse_failed of exn
+  val parse_no_error : string -> parsed ref -> parse_result
+
+  val get : key:int -> parsed -> float
+end
+
+type inlining_arguments = {
+  inline_call_cost : int option;
+  inline_alloc_cost : int option;
+  inline_prim_cost : int option;
+  inline_branch_cost : int option;
+  inline_indirect_cost : int option;
+  inline_lifting_benefit : int option;
+  inline_branch_factor : float option;
+  inline_max_depth : int option;
+  inline_max_unroll : int option;
+  inline_threshold : float option;
+  inline_toplevel_threshold : int option;
+}
+
+val classic_arguments : inlining_arguments
+val o1_arguments : inlining_arguments
+val o2_arguments : inlining_arguments
+val o3_arguments : inlining_arguments
+
+(** Set all the inlining arguments for a round.
+    The default is set if no round is provided. *)
+val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit
+
+val objfiles : string list ref
+val ccobjs : string list ref
+val dllibs : string list ref
+val compile_only : bool ref
+val output_name : string option ref
+val include_dirs : string list ref
+val no_std_include : bool ref
+val print_types : bool ref
+val make_archive : bool ref
+val debug : bool ref
+val fast : bool ref
+val link_everything : bool ref
+val custom_runtime : bool ref
+val no_check_prims : bool ref
+val bytecode_compatible_32 : bool ref
+val output_c_object : bool ref
+val output_complete_object : bool ref
+val all_ccopts : string list ref
+val classic : bool ref
+val nopervasives : bool ref
+val open_modules : string list ref
+val preprocessor : string option ref
+val all_ppx : string list ref
+val annotations : bool ref
+val binary_annotations : bool ref
+val use_threads : bool ref
+val use_vmthreads : bool ref
+val noassert : bool ref
+val verbose : bool ref
+val noprompt : bool ref
+val nopromptcont : bool ref
+val init_file : string option ref
+val noinit : bool ref
+val noversion : bool ref
+val use_prims : string ref
+val use_runtime : string ref
+val principal : bool ref
+val real_paths : bool ref
+val recursive_types : bool ref
+val strict_sequence : bool ref
+val strict_formats : bool ref
+val applicative_functors : bool ref
+val make_runtime : bool ref
+val gprofile : bool ref
+val c_compiler : string option ref
+val no_auto_link : bool ref
+val dllpaths : string list ref
+val make_package : bool ref
+val for_package : string option ref
+val error_size : int ref
+val float_const_prop : bool ref
+val transparent_modules : bool ref
+val dump_source : bool ref
+val dump_parsetree : bool ref
+val dump_typedtree : bool ref
+val dump_rawlambda : bool ref
+val dump_lambda : bool ref
+val dump_rawclambda : bool ref
+val dump_clambda : bool ref
+val dump_rawflambda : bool ref
+val dump_flambda : bool ref
+val dump_flambda_let : int option ref
+val dump_instr : bool ref
+val keep_asm_file : bool ref
+val optimize_for_speed : bool ref
+val dump_cmm : bool ref
+val dump_selection : bool ref
+val dump_cse : bool ref
+val dump_live : bool ref
+val dump_spill : bool ref
+val dump_split : bool ref
+val dump_interf : bool ref
+val dump_prefer : bool ref
+val dump_regalloc : bool ref
+val dump_reload : bool ref
+val dump_scheduling : bool ref
+val dump_linear : bool ref
+val keep_startup_file : bool ref
+val dump_combine : bool ref
+val native_code : bool ref
+val default_inline_threshold : float
+val inline_threshold : Float_arg_helper.parsed ref
+val inlining_report : bool ref
+val simplify_rounds : int option ref
+val default_simplify_rounds : int ref
+val rounds : unit -> int
+val default_inline_max_unroll : int
+val inline_max_unroll : Int_arg_helper.parsed ref
+val default_inline_toplevel_threshold : int
+val inline_toplevel_threshold : Int_arg_helper.parsed ref
+val default_inline_call_cost : int
+val default_inline_alloc_cost : int
+val default_inline_prim_cost : int
+val default_inline_branch_cost : int
+val default_inline_indirect_cost : int
+val default_inline_lifting_benefit : int
+val inline_call_cost : Int_arg_helper.parsed ref
+val inline_alloc_cost : Int_arg_helper.parsed ref
+val inline_prim_cost : Int_arg_helper.parsed ref
+val inline_branch_cost : Int_arg_helper.parsed ref
+val inline_indirect_cost : Int_arg_helper.parsed ref
+val inline_lifting_benefit : Int_arg_helper.parsed ref
+val default_inline_branch_factor : float
+val inline_branch_factor : Float_arg_helper.parsed ref
+val dont_write_files : bool ref
+val std_include_flag : string -> string
+val std_include_dir : unit -> string list
+val shared : bool ref
+val dlcode : bool ref
+val pic_code : bool ref
+val runtime_variant : string ref
+val force_slash : bool ref
+val keep_docs : bool ref
+val keep_locs : bool ref
+val unsafe_string : bool ref
+val opaque : bool ref
+val print_timings : bool ref
+val flambda_invariant_checks : bool ref
+val unbox_closures : bool ref
+val unbox_closures_factor : int ref
+val default_unbox_closures_factor : int
+val unbox_free_vars_of_closures : bool ref
+val unbox_specialised_args : bool ref
+val clambda_checks : bool ref
+val default_inline_max_depth : int
+val inline_max_depth : Int_arg_helper.parsed ref
+val remove_unused_arguments : bool ref
+val dump_flambda_verbose : bool ref
+val classic_inlining : bool ref
+val afl_instrument : bool ref
+val afl_inst_ratio : int ref
+
+val all_passes : string list ref
+val dumped_pass : string -> bool
+val set_dumped_pass : string -> bool -> unit
+
+val parse_color_setting : string -> Misc.Color.setting option
+val color : Misc.Color.setting option ref
+
+val unboxed_types : bool ref
+
+val arg_spec : (string * Arg.spec * string) list ref
+
+(* [add_arguments __LOC__ args] will add the arguments from [args] at
+   the end of [arg_spec], checking that they have not already been
+   added by [add_arguments] before. A warning is printed showing the
+   locations of the function from which the argument was previously
+   added. *)
+val add_arguments : string -> (string * Arg.spec * string) list -> unit
+
+(* [parse_arguments anon_arg usage] will parse the arguments, using
+  the arguments provided in [Clflags.arg_spec]. It allows plugins to
+  provide their own arguments.
+*)
+val parse_arguments : Arg.anon_fun -> string -> unit
+
+val print_arguments : string -> unit
diff --git a/utils/config.mli b/utils/config.mli
new file mode 100644
index 00000000..07be0f12
--- /dev/null
+++ b/utils/config.mli
@@ -0,0 +1,163 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* System configuration *)
+
+val version: string
+        (* The current version number of the system *)
+
+val standard_library: string
+        (* The directory containing the standard libraries *)
+val standard_runtime: string
+        (* The full path to the standard bytecode interpreter ocamlrun *)
+val ccomp_type: string
+        (* The "kind" of the C compiler, assembler and linker used: one of
+               "cc" (for Unix-style C compilers)
+               "msvc" (for Microsoft Visual C++ and MASM) *)
+val bytecomp_c_compiler: string
+        (* The C compiler to use for compiling C files
+           with the bytecode compiler *)
+val bytecomp_c_libraries: string
+        (* The C libraries to link with custom runtimes *)
+val native_c_compiler: string
+        (* The C compiler to use for compiling C files
+           with the native-code compiler *)
+val native_c_libraries: string
+        (* The C libraries to link with native-code programs *)
+val native_pack_linker: string
+        (* The linker to use for packaging (ocamlopt -pack) and for partial
+           links (ocamlopt -output-obj). *)
+val mkdll: string
+        (* The linker command line to build dynamic libraries. *)
+val mkexe: string
+        (* The linker command line to build executables. *)
+val mkmaindll: string
+        (* The linker command line to build main programs as dlls. *)
+val ranlib: string
+        (* Command to randomize a library, or "" if not needed *)
+val ar: string
+        (* Name of the ar command, or "" if not needed  (MSVC) *)
+val cc_profile : string
+        (* The command line option to the C compiler to enable profiling. *)
+
+val load_path: string list ref
+        (* Directories in the search path for .cmi and .cmo files *)
+
+val interface_suffix: string ref
+        (* Suffix for interface file names *)
+
+val exec_magic_number: string
+        (* Magic number for bytecode executable files *)
+val cmi_magic_number: string
+        (* Magic number for compiled interface files *)
+val cmo_magic_number: string
+        (* Magic number for object bytecode files *)
+val cma_magic_number: string
+        (* Magic number for archive files *)
+val cmx_magic_number: string
+        (* Magic number for compilation unit descriptions *)
+val cmxa_magic_number: string
+        (* Magic number for libraries of compilation unit descriptions *)
+val ast_intf_magic_number: string
+        (* Magic number for file holding an interface syntax tree *)
+val ast_impl_magic_number: string
+        (* Magic number for file holding an implementation syntax tree *)
+val cmxs_magic_number: string
+        (* Magic number for dynamically-loadable plugins *)
+val cmt_magic_number: string
+        (* Magic number for compiled interface files *)
+
+val max_tag: int
+        (* Biggest tag that can be stored in the header of a regular block. *)
+val lazy_tag : int
+        (* Normally the same as Obj.lazy_tag.  Separate definition because
+           of technical reasons for bootstrapping. *)
+val max_young_wosize: int
+        (* Maximal size of arrays that are directly allocated in the
+           minor heap *)
+val stack_threshold: int
+        (* Size in words of safe area at bottom of VM stack,
+           see byterun/config.h *)
+val stack_safety_margin: int
+        (* Size in words of the safety margin between the bottom of
+           the stack and the stack pointer. This margin can be used by
+           intermediate computations of some instructions, or the event
+           handler. *)
+
+val architecture: string
+        (* Name of processor type for the native-code compiler *)
+val model: string
+        (* Name of processor submodel for the native-code compiler *)
+val system: string
+        (* Name of operating system for the native-code compiler *)
+
+val asm: string
+        (* The assembler (and flags) to use for assembling
+           ocamlopt-generated code. *)
+
+val asm_cfi_supported: bool
+        (* Whether assembler understands CFI directives *)
+val with_frame_pointers : bool
+        (* Whether assembler should maintain frame pointers *)
+
+val ext_obj: string
+        (* Extension for object files, e.g. [.o] under Unix. *)
+val ext_asm: string
+        (* Extension for assembler files, e.g. [.s] under Unix. *)
+val ext_lib: string
+        (* Extension for library files, e.g. [.a] under Unix. *)
+val ext_dll: string
+        (* Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*)
+
+val default_executable_name: string
+        (* Name of executable produced by linking if none is given with -o,
+           e.g. [a.out] under Unix. *)
+
+val systhread_supported : bool
+        (* Whether the system thread library is implemented *)
+
+val flexdll_dirs : string list
+        (* Directories needed for the FlexDLL objects *)
+
+val host : string
+        (* Whether the compiler is a cross-compiler *)
+
+val target : string
+        (* Whether the compiler is a cross-compiler *)
+
+val print_config : out_channel -> unit;;
+
+val profiling : bool
+        (* Whether profiling with gprof is supported on this platform *)
+
+val flambda : bool
+        (* Whether the compiler was configured for flambda *)
+
+val spacetime : bool
+        (* Whether the compiler was configured for Spacetime profiling *)
+val profinfo : bool
+        (* Whether the compiler was configured for profiling *)
+val profinfo_width : int
+        (* How many bits are to be used in values' headers for profiling
+           information *)
+val libunwind_available : bool
+        (* Whether the libunwind library is available on the target *)
+val libunwind_link_flags : string
+        (* Linker flags to use libunwind *)
+
+val safe_string: bool
+        (* Whether the compiler was configured with -safe-string *)
+val afl_instrument : bool
+        (* Whether afl-fuzz instrumentation is generated by default *)
diff --git a/utils/config.mlp b/utils/config.mlp
new file mode 100644
index 00000000..28bff73a
--- /dev/null
+++ b/utils/config.mlp
@@ -0,0 +1,183 @@
+#2 "utils/config.mlp"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The main OCaml version string has moved to ../VERSION *)
+let version = Sys.ocaml_version
+
+let standard_library_default = "%%LIBDIR%%"
+
+let standard_library =
+  try
+    Sys.getenv "OCAMLLIB"
+  with Not_found ->
+  try
+    Sys.getenv "CAMLLIB"
+  with Not_found ->
+    standard_library_default
+
+let standard_runtime = "%%BYTERUN%%"
+let ccomp_type = "%%CCOMPTYPE%%"
+let bytecomp_c_compiler = "%%BYTECODE_C_COMPILER%%"
+let bytecomp_c_libraries = "%%BYTECCLIBS%%"
+let native_c_compiler = "%%NATIVE_C_COMPILER%%"
+let native_c_libraries = "%%NATIVECCLIBS%%"
+let native_pack_linker = "%%PACKLD%%"
+let ranlib = "%%RANLIBCMD%%"
+let ar = "%%ARCMD%%"
+let cc_profile = "%%CC_PROFILE%%"
+let mkdll, mkexe, mkmaindll =
+  (* @@DRA Cygwin - but only if shared libraries are enabled, which we
+     should be able to detect? *)
+  if Sys.os_type = "Win32" then
+    try
+      let flexlink =
+        let flexlink = Sys.getenv "OCAML_FLEXLINK" in
+        let f i =
+          let c = flexlink.[i] in
+          if c = '/' then '\\' else c in
+        (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in
+      flexlink,
+      flexlink ^ " -exe",
+      flexlink ^ " -maindll"
+    with Not_found ->
+      "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+  else
+    "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+
+let profiling = %%PROFILING%%
+let flambda = %%FLAMBDA%%
+let safe_string = %%SAFE_STRING%%
+
+let afl_instrument = %%AFL_INSTRUMENT%%
+
+let exec_magic_number = "Caml1999X011"
+and cmi_magic_number = "Caml1999I021"
+and cmo_magic_number = "Caml1999O011"
+and cma_magic_number = "Caml1999A012"
+and cmx_magic_number =
+  if flambda then
+    "Caml1999Y016"
+  else
+    "Caml1999Y015"
+and cmxa_magic_number =
+  if flambda then
+    "Caml1999Z015"
+  else
+    "Caml1999Z014"
+and ast_impl_magic_number = "Caml1999M020"
+and ast_intf_magic_number = "Caml1999N018"
+and cmxs_magic_number = "Caml2007D002"
+and cmt_magic_number = "Caml2012T009"
+
+let load_path = ref ([] : string list)
+
+let interface_suffix = ref ".mli"
+
+let max_tag = 245
+(* This is normally the same as in obj.ml, but we have to define it
+   separately because it can differ when we're in the middle of a
+   bootstrapping phase. *)
+let lazy_tag = 246
+
+let max_young_wosize = 256
+let stack_threshold = 256 (* see byterun/config.h *)
+let stack_safety_margin = 60
+
+let architecture = "%%ARCH%%"
+let model = "%%MODEL%%"
+let system = "%%SYSTEM%%"
+
+let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
+let spacetime = %%WITH_SPACETIME%%
+let libunwind_available = %%LIBUNWIND_AVAILABLE%%
+let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%"
+let profinfo = %%WITH_PROFINFO%%
+let profinfo_width = %%PROFINFO_WIDTH%%
+
+let ext_exe = "%%EXT_EXE%%"
+let ext_obj = "%%EXT_OBJ%%"
+let ext_asm = "%%EXT_ASM%%"
+let ext_lib = "%%EXT_LIB%%"
+let ext_dll = "%%EXT_DLL%%"
+
+let host = "%%HOST%%"
+let target = "%%TARGET%%"
+
+let default_executable_name =
+  match Sys.os_type with
+    "Unix" -> "a.out"
+  | "Win32" | "Cygwin" -> "camlprog.exe"
+  | _ -> "camlprog"
+
+let systhread_supported = %%SYSTHREAD_SUPPORT%%;;
+
+let flexdll_dirs = [%%FLEXDLL_DIR%%];;
+
+let print_config oc =
+  let p name valu = Printf.fprintf oc "%s: %s\n" name valu in
+  let p_int name valu = Printf.fprintf oc "%s: %d\n" name valu in
+  let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in
+  p "version" version;
+  p "standard_library_default" standard_library_default;
+  p "standard_library" standard_library;
+  p "standard_runtime" standard_runtime;
+  p "ccomp_type" ccomp_type;
+  p "bytecomp_c_compiler" bytecomp_c_compiler;
+  p "bytecomp_c_libraries" bytecomp_c_libraries;
+  p "native_c_compiler" native_c_compiler;
+  p "native_c_libraries" native_c_libraries;
+  p "native_pack_linker" native_pack_linker;
+  p "ranlib" ranlib;
+  p "cc_profile" cc_profile;
+  p "architecture" architecture;
+  p "model" model;
+  p_int "int_size" Sys.int_size;
+  p_int "word_size" Sys.word_size;
+  p "system" system;
+  p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
+  p_bool "with_frame_pointers" with_frame_pointers;
+  p "ext_exe" ext_exe;
+  p "ext_obj" ext_obj;
+  p "ext_asm" ext_asm;
+  p "ext_lib" ext_lib;
+  p "ext_dll" ext_dll;
+  p "os_type" Sys.os_type;
+  p "default_executable_name" default_executable_name;
+  p_bool "systhread_supported" systhread_supported;
+  p "host" host;
+  p "target" target;
+  p_bool "profiling" profiling;
+  p_bool "flambda" flambda;
+  p_bool "spacetime" spacetime;
+  p_bool "safe_string" safe_string;
+
+  (* print the magic number *)
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
+
+  flush oc;
+;;
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
new file mode 100644
index 00000000..dbba5d1f
--- /dev/null
+++ b/utils/consistbl.ml
@@ -0,0 +1,66 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Consistency tables: for checking consistency of module CRCs *)
+
+type t = (string, Digest.t * string) Hashtbl.t
+
+let create () = Hashtbl.create 13
+
+let clear = Hashtbl.clear
+
+exception Inconsistency of string * string * string
+
+exception Not_available of string
+
+let check tbl name crc source =
+  try
+    let (old_crc, old_source) = Hashtbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency(name, source, old_source))
+  with Not_found ->
+    Hashtbl.add tbl name (crc, source)
+
+let check_noadd tbl name crc source =
+  try
+    let (old_crc, old_source) = Hashtbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency(name, source, old_source))
+  with Not_found ->
+    raise (Not_available name)
+
+let set tbl name crc source = Hashtbl.add tbl name (crc, source)
+
+let source tbl name = snd (Hashtbl.find tbl name)
+
+let extract l tbl =
+  let l = List.sort_uniq String.compare l in
+  List.fold_left
+    (fun assc name ->
+       try
+         let (crc, _) = Hashtbl.find tbl name in
+           (name, Some crc) :: assc
+       with Not_found ->
+         (name, None) :: assc)
+    [] l
+
+let filter p tbl =
+  let to_remove = ref [] in
+  Hashtbl.iter
+    (fun name _ ->
+      if not (p name) then to_remove := name :: !to_remove)
+    tbl;
+  List.iter
+    (fun name ->
+       while Hashtbl.mem tbl name do Hashtbl.remove tbl name done)
+    !to_remove
diff --git a/utils/consistbl.mli b/utils/consistbl.mli
new file mode 100644
index 00000000..c532bddf
--- /dev/null
+++ b/utils/consistbl.mli
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Consistency tables: for checking consistency of module CRCs *)
+
+type t
+
+val create: unit -> t
+
+val clear: t -> unit
+
+val check: t -> string -> Digest.t -> string -> unit
+      (* [check tbl name crc source]
+           checks consistency of ([name], [crc]) with infos previously
+           stored in [tbl].  If no CRC was previously associated with
+           [name], record ([name], [crc]) in [tbl].
+           [source] is the name of the file from which the information
+           comes from.  This is used for error reporting. *)
+
+val check_noadd: t -> string -> Digest.t -> string -> unit
+      (* Same as [check], but raise [Not_available] if no CRC was previously
+           associated with [name]. *)
+
+val set: t -> string -> Digest.t -> string -> unit
+      (* [set tbl name crc source] forcefully associates [name] with
+         [crc] in [tbl], even if [name] already had a different CRC
+         associated with [name] in [tbl]. *)
+
+val source: t -> string -> string
+      (* [source tbl name] returns the file name associated with [name]
+         if the latter has an associated CRC in [tbl].
+         Raise [Not_found] otherwise. *)
+
+val extract: string list -> t -> (string * Digest.t option) list
+      (* [extract tbl names] returns an associative list mapping each string
+         in [names] to the CRC associated with it in [tbl]. If no CRC is
+         associated with a name then it is mapped to [None]. *)
+
+val filter: (string -> bool) -> t -> unit
+      (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
+         such that [pred name] is [false]. *)
+
+exception Inconsistency of string * string * string
+      (* Raised by [check] when a CRC mismatch is detected.
+         First string is the name of the compilation unit.
+         Second string is the source that caused the inconsistency.
+         Third string is the source that set the CRC. *)
+
+exception Not_available of string
+      (* Raised by [check_noadd] when a name doesn't have an associated CRC. *)
diff --git a/utils/identifiable.ml b/utils/identifiable.ml
new file mode 100644
index 00000000..8bbafcd3
--- /dev/null
+++ b/utils/identifiable.ml
@@ -0,0 +1,242 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Stdlib_map = Map
+module Stdlib_set = Set
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
+  type t = A.t * B.t
+
+  let compare (a1, b1) (a2, b2) =
+    let c = A.compare a1 a2 in
+    if c <> 0 then c
+    else B.compare b1 b2
+
+  let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b
+  let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b)
+  let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2
+  let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b
+end
+
+module Make_map (T : Thing) = struct
+  include Map.Make (T)
+
+  let filter_map t ~f =
+    fold (fun id v map ->
+        match f id v with
+        | None -> map
+        | Some r -> add id r map) t empty
+
+  let of_list l =
+    List.fold_left (fun map (id, v) -> add id v map) empty l
+
+  let disjoint_union ?eq ?print m1 m2 =
+    union (fun id v1 v2 ->
+        let ok = match eq with
+          | None -> false
+          | Some eq -> eq v1 v2
+        in
+        if not ok then
+          let err =
+            match print with
+            | None ->
+              Format.asprintf "Map.disjoint_union %a" T.print id
+            | Some print ->
+              Format.asprintf "Map.disjoint_union %a => %a <> %a"
+                T.print id print v1 print v2
+          in
+          Misc.fatal_error err
+        else Some v1)
+      m1 m2
+
+  let union_right m1 m2 =
+    merge (fun _id x y -> match x, y with
+        | None, None -> None
+        | None, Some v
+        | Some v, None
+        | Some _, Some v -> Some v)
+      m1 m2
+
+  let union_left m1 m2 = union_right m2 m1
+
+  let union_merge f m1 m2 =
+    let aux _ m1 m2 =
+      match m1, m2 with
+      | None, m | m, None -> m
+      | Some m1, Some m2 -> Some (f m1 m2)
+    in
+    merge aux m1 m2
+
+  let rename m v =
+    try find v m
+    with Not_found -> v
+
+  let map_keys f m =
+    of_list (List.map (fun (k, v) -> f k, v) (bindings m))
+
+  let print f ppf s =
+    let elts ppf s = iter (fun id v ->
+        Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  module T_set = Set.Make (T)
+
+  let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty
+
+  let data t = List.map snd (bindings t)
+
+  let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
+
+  let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+  let transpose_keys_and_data_set map =
+    fold (fun k v m ->
+        let set =
+          match find v m with
+          | exception Not_found ->
+            T_set.singleton k
+          | set ->
+            T_set.add k set
+        in
+        add v set m)
+      map empty
+end
+
+module Make_set (T : Thing) = struct
+  include Set.Make (T)
+
+  let output oc s =
+    Printf.fprintf oc " ( ";
+    iter (fun v -> Printf.fprintf oc "%a " T.output v) s;
+    Printf.fprintf oc ")"
+
+  let print ppf s =
+    let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in
+    Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s
+
+  let to_string s = Format.asprintf "%a" print s
+
+  let of_list l = match l with
+    | [] -> empty
+    | [t] -> singleton t
+    | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q
+
+  let map f s = of_list (List.map f (elements s))
+end
+
+module Make_tbl (T : Thing) = struct
+  include Hashtbl.Make (T)
+
+  module T_map = Make_map (T)
+
+  let to_list t =
+    fold (fun key datum elts -> (key, datum)::elts) t []
+
+  let of_list elts =
+    let t = create 42 in
+    List.iter (fun (key, datum) -> add t key datum) elts;
+    t
+
+  let to_map v = fold T_map.add v T_map.empty
+
+  let of_map m =
+    let t = create (T_map.cardinal m) in
+    T_map.iter (fun k v -> add t k v) m;
+    t
+
+  let memoize t f = fun key ->
+    try find t key with
+    | Not_found ->
+      let r = f key in
+      add t key r;
+      r
+
+  let map t f =
+    of_map (T_map.map f (to_map t))
+end
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : sig
+    include Stdlib_set.S
+      with type elt = T.t
+      and type t = Make_set (T).t
+
+    val output : out_channel -> t -> unit
+    val print : Format.formatter -> t -> unit
+    val to_string : t -> string
+    val of_list : elt list -> t
+    val map : (elt -> elt) -> t -> t
+  end
+
+  module Map : sig
+    include Stdlib_map.S
+      with type key = T.t
+      and type 'a t = 'a Make_map (T).t
+
+    val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
+    val of_list : (key * 'a) list -> 'a t
+    val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
+    val union_right : 'a t -> 'a t -> 'a t
+    val union_left : 'a t -> 'a t -> 'a t
+    val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+    val rename : key t -> key -> key
+    val map_keys : (key -> key) -> 'a t -> 'a t
+    val keys : 'a t -> Make_set (T).t
+    val data : 'a t -> 'a list
+    val of_set : (key -> 'a) -> Make_set (T).t -> 'a t
+    val transpose_keys_and_data : key t -> key t
+    val transpose_keys_and_data_set : key t -> Set.t t
+    val print :
+      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+  end
+
+  module Tbl : sig
+    include Hashtbl.S
+      with type key = T.t
+      and type 'a t = 'a Hashtbl.Make (T).t
+
+    val to_list : 'a t -> (T.t * 'a) list
+    val of_list : (T.t * 'a) list -> 'a t
+
+    val to_map : 'a t -> 'a Make_map (T).t
+    val of_map : 'a Make_map (T).t -> 'a t
+    val memoize : 'a t -> (key -> 'a) -> key -> 'a
+    val map : 'a t -> ('a -> 'b) -> 'b t
+  end
+end
+
+module Make (T : Thing) = struct
+  module T = T
+  include T
+
+  module Set = Make_set (T)
+  module Map = Make_map (T)
+  module Tbl = Make_tbl (T)
+end
diff --git a/utils/identifiable.mli b/utils/identifiable.mli
new file mode 100644
index 00000000..55ed4446
--- /dev/null
+++ b/utils/identifiable.mli
@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Uniform interface for common data structures over various things. *)
+
+module type Thing = sig
+  type t
+
+  include Hashtbl.HashedType with type t := t
+  include Map.OrderedType with type t := t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t
+
+module type S = sig
+  type t
+
+  module T : Thing with type t = t
+  include Thing with type t := T.t
+
+  module Set : sig
+    include Set.S
+      with type elt = T.t
+      and type t = Set.Make (T).t
+
+    val output : out_channel -> t -> unit
+    val print : Format.formatter -> t -> unit
+    val to_string : t -> string
+    val of_list : elt list -> t
+    val map : (elt -> elt) -> t -> t
+  end
+
+  module Map : sig
+    include Map.S
+      with type key = T.t
+      and type 'a t = 'a Map.Make (T).t
+
+    val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
+    val of_list : (key * 'a) list -> 'a t
+
+    (** [disjoint_union m1 m2] contains all bindings from [m1] and
+        [m2]. If some binding is present in both and the associated
+        value is not equal, a Fatal_error is raised *)
+    val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
+
+    (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
+        some binding is present in both, the one from [m2] is taken *)
+    val union_right : 'a t -> 'a t -> 'a t
+
+    (** [union_left m1 m2 = union_right m2 m1] *)
+    val union_left : 'a t -> 'a t -> 'a t
+
+    val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+    val rename : key t -> key -> key
+    val map_keys : (key -> key) -> 'a t -> 'a t
+    val keys : 'a t -> Set.t
+    val data : 'a t -> 'a list
+    val of_set : (key -> 'a) -> Set.t -> 'a t
+    val transpose_keys_and_data : key t -> key t
+    val transpose_keys_and_data_set : key t -> Set.t t
+    val print :
+      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+  end
+
+  module Tbl : sig
+    include Hashtbl.S
+      with type key = T.t
+      and type 'a t = 'a Hashtbl.Make (T).t
+
+    val to_list : 'a t -> (T.t * 'a) list
+    val of_list : (T.t * 'a) list -> 'a t
+
+    val to_map : 'a t -> 'a Map.t
+    val of_map : 'a Map.t -> 'a t
+    val memoize : 'a t -> (key -> 'a) -> key -> 'a
+    val map : 'a t -> ('a -> 'b) -> 'b t
+  end
+end
+
+module Make (T : Thing) : S with type t := T.t
diff --git a/utils/misc.ml b/utils/misc.ml
new file mode 100644
index 00000000..fa084bf1
--- /dev/null
+++ b/utils/misc.ml
@@ -0,0 +1,696 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Errors *)
+
+exception Fatal_error
+
+let fatal_error msg =
+  prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error
+
+let fatal_errorf fmt = Format.kasprintf fatal_error fmt
+
+(* Exceptions *)
+
+let try_finally work cleanup =
+  let result = (try work () with e -> cleanup (); raise e) in
+  cleanup ();
+  result
+;;
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    match f () with
+    | x           -> set_refs backup; x
+    | exception e -> set_refs backup; raise e
+
+(* List functions *)
+
+let rec map_end f l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd::tl -> f hd :: map_end f tl l2
+
+let rec map_left_right f = function
+    [] -> []
+  | hd::tl -> let res = f hd in res :: map_left_right f tl
+
+let rec for_all2 pred l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
+  | (_, _) -> false
+
+let rec replicate_list elem n =
+  if n <= 0 then [] else elem :: replicate_list elem (n-1)
+
+let rec list_remove x = function
+    [] -> []
+  | hd :: tl ->
+      if hd = x then tl else hd :: list_remove x tl
+
+let rec split_last = function
+    [] -> assert false
+  | [x] -> ([], x)
+  | hd :: tl ->
+      let (lst, last) = split_last tl in
+      (hd :: lst, last)
+
+module Stdlib = struct
+  module List = struct
+    type 'a t = 'a list
+
+    let rec compare cmp l1 l2 =
+      match l1, l2 with
+      | [], [] -> 0
+      | [], _::_ -> -1
+      | _::_, [] -> 1
+      | h1::t1, h2::t2 ->
+        let c = cmp h1 h2 in
+        if c <> 0 then c
+        else compare cmp t1 t2
+
+    let rec equal eq l1 l2 =
+      match l1, l2 with
+      | ([], []) -> true
+      | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2
+      | (_, _) -> false
+
+    let filter_map f l =
+      let rec aux acc l =
+        match l with
+        | [] -> List.rev acc
+        | h :: t ->
+          match f h with
+          | None -> aux acc t
+          | Some v -> aux (v :: acc) t
+      in
+      aux [] l
+
+    let map2_prefix f l1 l2 =
+      let rec aux acc l1 l2 =
+        match l1, l2 with
+        | [], _ -> (List.rev acc, l2)
+        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
+        | h1::t1, h2::t2 ->
+          let h = f h1 h2 in
+          aux (h :: acc) t1 t2
+      in
+      aux [] l1 l2
+
+    let some_if_all_elements_are_some l =
+      let rec aux acc l =
+        match l with
+        | [] -> Some (List.rev acc)
+        | None :: _ -> None
+        | Some h :: t -> aux (h :: acc) t
+      in
+      aux [] l
+
+    let split_at n l =
+      let rec aux n acc l =
+        if n = 0
+        then List.rev acc, l
+        else
+          match l with
+          | [] -> raise (Invalid_argument "split_at")
+          | t::q -> aux (n-1) (t::acc) q
+      in
+      aux n [] l
+  end
+
+  module Option = struct
+    type 'a t = 'a option
+
+    let equal eq o1 o2 =
+      match o1, o2 with
+      | None, None -> true
+      | Some e1, Some e2 -> eq e1 e2
+      | _, _ -> false
+
+    let iter f = function
+      | Some x -> f x
+      | None -> ()
+
+    let map f = function
+      | Some x -> Some (f x)
+      | None -> None
+
+    let fold f a b =
+      match a with
+      | None -> b
+      | Some a -> f a b
+
+    let value_default f ~default a =
+      match a with
+      | None -> default
+      | Some a -> f a
+  end
+end
+
+let may = Stdlib.Option.iter
+let may_map = Stdlib.Option.map
+
+(* File functions *)
+
+let find_in_path path name =
+  if not (Filename.is_implicit name) then
+    if Sys.file_exists name then name else raise Not_found
+  else begin
+    let rec try_dir = function
+      [] -> raise Not_found
+    | dir::rem ->
+        let fullname = Filename.concat dir name in
+        if Sys.file_exists fullname then fullname else try_dir rem
+    in try_dir path
+  end
+
+let find_in_path_rel path name =
+  let rec simplify s =
+    let open Filename in
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then simplify dir
+    else concat (simplify dir) base
+  in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = simplify (Filename.concat dir name) in
+      if Sys.file_exists fullname then fullname else try_dir rem
+  in try_dir path
+
+let find_in_path_uncap path name =
+  let uname = String.uncapitalize_ascii name in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = Filename.concat dir name
+      and ufullname = Filename.concat dir uname in
+      if Sys.file_exists ufullname then ufullname
+      else if Sys.file_exists fullname then fullname
+      else try_dir rem
+  in try_dir path
+
+let remove_file filename =
+  try
+    if Sys.file_exists filename
+    then Sys.remove filename
+  with Sys_error _msg ->
+    ()
+
+(* Expand a -I option: if it starts with +, make it relative to the standard
+   library directory *)
+
+let expand_directory alt s =
+  if String.length s > 0 && s.[0] = '+'
+  then Filename.concat alt
+                       (String.sub s 1 (String.length s - 1))
+  else s
+
+(* Hashtable functions *)
+
+let create_hashtable size init =
+  let tbl = Hashtbl.create size in
+  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
+  tbl
+
+(* File copy *)
+
+let copy_file ic oc =
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then () else (output oc buff 0 n; copy())
+  in copy()
+
+let copy_file_chunk ic oc len =
+  let buff = Bytes.create 0x1000 in
+  let rec copy n =
+    if n <= 0 then () else begin
+      let r = input ic buff 0 (min n 0x1000) in
+      if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
+    end
+  in copy len
+
+let string_of_file ic =
+  let b = Buffer.create 0x10000 in
+  let buff = Bytes.create 0x1000 in
+  let rec copy () =
+    let n = input ic buff 0 0x1000 in
+    if n = 0 then Buffer.contents b else
+      (Buffer.add_subbytes b buff 0 n; copy())
+  in copy()
+
+(* Integer operations *)
+
+let rec log2 n =
+  if n <= 1 then 0 else 1 + log2(n asr 1)
+
+let align n a =
+  if n >= 0 then (n + a - 1) land (-a) else n land (-a)
+
+let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
+
+let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
+
+let no_overflow_mul a b = b <> 0 && (a * b) / b = a
+
+let no_overflow_lsl a k =
+  0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k
+
+module Int_literal_converter = struct
+  (* To convert integer literals, allowing max_int + 1 (PR#4210) *)
+  let cvt_int_aux str neg of_string =
+    if String.length str = 0 || str.[0]= '-'
+    then of_string str
+    else neg (of_string ("-" ^ str))
+  let int s = cvt_int_aux s (~-) int_of_string
+  let int32 s = cvt_int_aux s Int32.neg Int32.of_string
+  let int64 s = cvt_int_aux s Int64.neg Int64.of_string
+  let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
+end
+
+(* String operations *)
+
+let chop_extensions file =
+  let dirname = Filename.dirname file and basename = Filename.basename file in
+  try
+    let pos = String.index basename '.' in
+    let basename = String.sub basename 0 pos in
+    if Filename.is_implicit file && dirname = Filename.current_dir_name then
+      basename
+    else
+      Filename.concat dirname basename
+  with Not_found -> file
+
+let search_substring pat str start =
+  let rec search i j =
+    if j >= String.length pat then i
+    else if i + j >= String.length str then raise Not_found
+    else if str.[i + j] = pat.[j] then search i (j+1)
+    else search (i+1) 0
+  in search start 0
+
+let replace_substring ~before ~after str =
+  let rec search acc curr =
+    match search_substring before str curr with
+      | next ->
+         let prefix = String.sub str curr (next - curr) in
+         search (prefix :: acc) (next + String.length before)
+      | exception Not_found ->
+        let suffix = String.sub str curr (String.length str - curr) in
+        List.rev (suffix :: acc)
+  in String.concat after (search [] 0)
+
+let rev_split_words s =
+  let rec split1 res i =
+    if i >= String.length s then res else begin
+      match s.[i] with
+        ' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
+      | _ -> split2 res i (i+1)
+    end
+  and split2 res i j =
+    if j >= String.length s then String.sub s i (j-i) :: res else begin
+      match s.[j] with
+        ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
+      | _ -> split2 res i (j+1)
+    end
+  in split1 [] 0
+
+let get_ref r =
+  let v = !r in
+  r := []; v
+
+let fst3 (x, _, _) = x
+let snd3 (_,x,_) = x
+let thd3 (_,_,x) = x
+
+let fst4 (x, _, _, _) = x
+let snd4 (_,x,_, _) = x
+let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = bytes array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size Bytes.empty in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- Bytes.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+
+  let set tbl ind c =
+    Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length)
+              c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let unsafe_blit_to_bytes src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let input_bytes ic len =
+    let tbl = create len in
+    Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl;
+    tbl
+end
+
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    min (max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
+let spellcheck env name =
+  let cutoff =
+    match String.length name with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target acc head =
+    match edit_distance target head cutoff with
+      | None -> acc
+      | Some dist ->
+         let (best_choice, best_dist) = acc in
+         if dist < best_dist then ([head], dist)
+         else if dist = best_dist then (head :: best_choice, dist)
+         else acc
+  in
+  fst (List.fold_left (compare name) ([], max_int) env)
+
+let did_you_mean ppf get_choices =
+  (* flush now to get the error report early, in the (unheard of) case
+     where the search in the get_choices function would take a bit of
+     time; in the worst case, the user has seen the error, she can
+     interrupt the process before the spell-checking terminates. *)
+  Format.fprintf ppf "@?";
+  match get_choices () with
+  | [] -> ()
+  | choices ->
+     let rest, last = split_last choices in
+     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
+       (String.concat ", " rest)
+       (if rest = [] then "" else " or ")
+       last
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
+
+
+module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringMap = Map.Make(struct type t = string let compare = compare end)
+
+(* Color handling *)
+module Color = struct
+  (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *)
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  let ansi_of_color = function
+    | Black -> "0"
+    | Red -> "1"
+    | Green -> "2"
+    | Yellow -> "3"
+    | Blue -> "4"
+    | Magenta -> "5"
+    | Cyan -> "6"
+    | White -> "7"
+
+  let code_of_style = function
+    | FG c -> "3" ^ ansi_of_color c
+    | BG c -> "4" ^ ansi_of_color c
+    | Bold -> "1"
+    | Reset -> "0"
+
+  let ansi_of_style_l l =
+    let s = match l with
+      | [] -> code_of_style Reset
+      | [s] -> code_of_style s
+      | _ -> String.concat ";" (List.map code_of_style l)
+    in
+    "\x1b[" ^ s ^ "m"
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  let default_styles = {
+    warning = [Bold; FG Magenta];
+    error = [Bold; FG Red];
+    loc = [Bold];
+  }
+
+  let cur_styles = ref default_styles
+  let get_styles () = !cur_styles
+  let set_styles s = cur_styles := s
+
+  (* map a tag to a style, if the tag is known.
+     @raise Not_found otherwise *)
+  let style_of_tag s = match s with
+    | "error" -> (!cur_styles).error
+    | "warning" -> (!cur_styles).warning
+    | "loc" -> (!cur_styles).loc
+    | _ -> raise Not_found
+
+  let color_enabled = ref true
+
+  (* either prints the tag of [s] or delegate to [or_else] *)
+  let mark_open_tag ~or_else s =
+    try
+      let style = style_of_tag s in
+      if !color_enabled then ansi_of_style_l style else ""
+    with Not_found -> or_else s
+
+  let mark_close_tag ~or_else s =
+    try
+      let _ = style_of_tag s in
+      if !color_enabled then ansi_of_style_l [Reset] else ""
+    with Not_found -> or_else s
+
+  (* add color handling to formatter [ppf] *)
+  let set_color_tag_handling ppf =
+    let open Format in
+    let functions = pp_get_formatter_tag_functions ppf () in
+    let functions' = {functions with
+      mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag);
+      mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag);
+    } in
+    pp_set_mark_tags ppf true; (* enable tags *)
+    pp_set_formatter_tag_functions ppf functions';
+    (* also setup margins *)
+    pp_set_margin ppf (pp_get_margin std_formatter());
+    ()
+
+  external isatty : out_channel -> bool = "caml_sys_isatty"
+
+  (* reasonable heuristic on whether colors should be enabled *)
+  let should_enable_color () =
+    let term = try Sys.getenv "TERM" with Not_found -> "" in
+    term <> "dumb"
+    && term <> ""
+    && isatty stderr
+
+  type setting = Auto | Always | Never
+
+  let setup =
+    let first = ref true in (* initialize only once *)
+    let formatter_l =
+      [Format.std_formatter; Format.err_formatter; Format.str_formatter]
+    in
+    fun o ->
+      if !first then (
+        first := false;
+        Format.set_mark_tags true;
+        List.iter set_color_tag_handling formatter_l;
+        color_enabled := (match o with
+            | Some Always -> true
+            | Some Auto -> should_enable_color ()
+            | Some Never -> false
+            | None -> should_enable_color ())
+      );
+      ()
+end
+
+let normalise_eol s =
+  let b = Buffer.create 80 in
+    for i = 0 to String.length s - 1 do
+      if s.[i] <> '\r' then Buffer.add_char b s.[i]
+    done;
+    Buffer.contents b
+
+let delete_eol_spaces src =
+  let len_src = String.length src in
+  let dst = Bytes.create len_src in
+  let rec loop i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces 1 (i_src + 1) i_dst
+      | c ->
+        Bytes.set dst i_dst c;
+        loop (i_src + 1) (i_dst + 1)
+  and loop_spaces spaces i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces (spaces + 1) (i_src + 1) i_dst
+      | '\n' ->
+        Bytes.set dst i_dst '\n';
+        loop (i_src + 1) (i_dst + 1)
+      | _ ->
+        for n = 0 to spaces do
+          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
+        done;
+        loop (i_src + 1) (i_dst + spaces + 1)
+  in
+  let stop = loop 0 0 in
+  Bytes.sub_string dst 0 stop
+
+type hook_info = {
+  sourcefile : string;
+}
+
+exception HookExnWrapper of
+    {
+      error: exn;
+      hook_name: string;
+      hook_info: hook_info;
+    }
+
+exception HookExn of exn
+
+let raise_direct_hook_exn e = raise (HookExn e)
+
+let fold_hooks list hook_info ast =
+  List.fold_left (fun ast (hook_name,f) ->
+    try
+      f hook_info ast
+    with
+    | HookExn e -> raise e
+    | error -> raise (HookExnWrapper {error; hook_name; hook_info})
+       (* when explicit reraise with backtrace will be available,
+          it should be used here *)
+
+  ) ast (List.sort compare list)
+
+module type HookSig = sig
+  type t
+
+  val add_hook : string -> (hook_info -> t -> t) -> unit
+  val apply_hooks : hook_info -> t -> t
+end
+
+module MakeHooks(M: sig
+    type t
+  end) : HookSig with type t = M.t
+= struct
+
+  type t = M.t
+
+  let hooks = ref []
+  let add_hook name f = hooks := (name, f) :: !hooks
+  let apply_hooks sourcefile intf =
+    fold_hooks !hooks sourcefile intf
+end
diff --git a/utils/misc.mli b/utils/misc.mli
new file mode 100644
index 00000000..0cd23baa
--- /dev/null
+++ b/utils/misc.mli
@@ -0,0 +1,333 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Miscellaneous useful types and functions *)
+
+val fatal_error: string -> 'a
+val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
+exception Fatal_error
+
+val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;;
+
+val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
+        (* [map_end f l t] is [map f l @ t], just more efficient. *)
+val map_left_right: ('a -> 'b) -> 'a list -> 'b list
+        (* Like [List.map], with guaranteed left-to-right evaluation order *)
+val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+        (* Same as [List.for_all] but for a binary predicate.
+           In addition, this [for_all2] never fails: given two lists
+           with different lengths, it returns false. *)
+val replicate_list: 'a -> int -> 'a list
+        (* [replicate_list elem n] is the list with [n] elements
+           all identical to [elem]. *)
+val list_remove: 'a -> 'a list -> 'a list
+        (* [list_remove x l] returns a copy of [l] with the first
+           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 may: ('a -> unit) -> 'a option -> unit
+val may_map: ('a -> 'b) -> 'a option -> 'b option
+
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception. *)
+
+module Stdlib : sig
+  module List : sig
+    type 'a t = 'a list
+
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    (** The lexicographic order supported by the provided order.
+        There is no constraint on the relative lengths of the lists. *)
+
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    (** Returns [true] iff the given lists have the same length and content
+        with respect to the given equality function. *)
+
+    val filter_map : ('a -> 'b option) -> 'a t -> 'b t
+    (** [filter_map f l] applies [f] to every element of [l], filters
+        out the [None] elements and returns the list of the arguments of
+        the [Some] elements. *)
+
+    val some_if_all_elements_are_some : 'a option t -> 'a t option
+    (** If all elements of the given list are [Some _] then [Some xs]
+        is returned with the [xs] being the contents of those [Some]s, with
+        order preserved.  Otherwise return [None]. *)
+
+    val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
+    (** [let r1, r2 = map2_prefix f l1 l2]
+        If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
+        r1 is [List.map2 f l1 h1] and r2 is t2. *)
+
+    val split_at : int -> 'a t -> 'a t * 'a t
+    (** [split_at n l] returns the pair [before, after] where [before] is
+        the [n] first elements of [l] and [after] the remaining ones.
+        If [l] has less than [n] elements, raises Invalid_argument. *)
+  end
+
+  module Option : sig
+    type 'a t = 'a option
+
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+    val iter : ('a -> unit) -> 'a t -> unit
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b
+  end
+end
+
+val find_in_path: string list -> string -> string
+        (* Search a file in a list of directories. *)
+val find_in_path_rel: string list -> string -> string
+        (* Search a relative file in a list of directories. *)
+val find_in_path_uncap: string list -> string -> string
+        (* Same, but search also for uncapitalized name, i.e.
+           if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
+           to match. *)
+val remove_file: string -> unit
+        (* Delete the given file if it exists. Never raise an error. *)
+val expand_directory: string -> string -> string
+        (* [expand_directory alt file] eventually expands a [+] at the
+           beginning of file into [alt] (an alternate root directory) *)
+
+val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+        (* Create a hashtable of the given size and fills it with the
+           given bindings. *)
+
+val copy_file: in_channel -> out_channel -> unit
+        (* [copy_file ic oc] reads the contents of file [ic] and copies
+           them to [oc]. It stops when encountering EOF on [ic]. *)
+val copy_file_chunk: in_channel -> out_channel -> int -> unit
+        (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
+           them to [oc]. It raises [End_of_file] when encountering
+           EOF on [ic]. *)
+val string_of_file: in_channel -> string
+        (* [string_of_file ic] reads the contents of file [ic] and copies
+           them to a string. It stops when encountering EOF on [ic]. *)
+val log2: int -> int
+        (* [log2 n] returns [s] such that [n = 1 lsl s]
+           if [n] is a power of 2*)
+val align: int -> int -> int
+        (* [align n a] rounds [n] upwards to a multiple of [a]
+           (a power of 2). *)
+val no_overflow_add: int -> int -> bool
+        (* [no_overflow_add n1 n2] returns [true] if the computation of
+           [n1 + n2] does not overflow. *)
+val no_overflow_sub: int -> int -> bool
+        (* [no_overflow_sub n1 n2] returns [true] if the computation of
+           [n1 - n2] does not overflow. *)
+val no_overflow_mul: int -> int -> bool
+        (* [no_overflow_mul n1 n2] returns [true] if the computation of
+           [n1 * n2] does not overflow. *)
+val no_overflow_lsl: int -> int -> bool
+        (* [no_overflow_lsl n k] returns [true] if the computation of
+           [n lsl k] does not overflow. *)
+
+module Int_literal_converter : sig
+  val int : string -> int
+  val int32 : string -> int32
+  val int64 : string -> int64
+  val nativeint : string -> nativeint
+end
+
+val chop_extensions: string -> string
+        (* Return the given file name without its extensions. The extensions
+           is the longest suffix starting with a period and not including
+           a directory separator, [.xyz.uvw] for instance.
+
+           Return the given name if it does not contain an extension. *)
+
+val search_substring: string -> string -> int -> int
+        (* [search_substring pat str start] returns the position of the first
+           occurrence of string [pat] in string [str].  Search starts
+           at offset [start] in [str].  Raise [Not_found] if [pat]
+           does not occur. *)
+
+val replace_substring: before:string -> after:string -> string -> string
+        (* [replace_substring ~before ~after str] replaces all
+           occurrences of [before] with [after] in [str] and returns
+           the resulting string. *)
+
+val rev_split_words: string -> string list
+        (* [rev_split_words s] splits [s] in blank-separated words, and returns
+           the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)
+
+
+val fst3: 'a * 'b * 'c -> 'a
+val snd3: 'a * 'b * 'c -> 'b
+val thd3: 'a * 'b * 'c -> 'c
+
+val fst4: 'a * 'b * 'c * 'd -> 'a
+val snd4: 'a * 'b * 'c * 'd -> 'b
+val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+  sig
+    type t = bytes array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val spellcheck : string list -> string -> string list
+(** [spellcheck env name] takes a list of names [env] that exist in
+    the current environment and an erroneous [name], and returns a
+    list of suggestions taken from [env], that are close enough to
+    [name] that it may be a typo for one of them. *)
+
+val did_you_mean : Format.formatter -> (unit -> string list) -> unit
+(** [did_you_mean ppf get_choices] hints that the user may have meant
+    one of the option returned by calling [get_choices]. It does nothing
+    if the returned list is empty.
+
+    The [unit -> ...] thunking is meant to delay any potentially-slow
+    computation (typically computing edit-distance with many things
+    from the current environment) to when the hint message is to be
+    printed. You should print an understandable error message before
+    calling [did_you_mean], so that users get a clear notification of
+    the failure even if producing the hint is slow.
+*)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
+
+
+module StringSet: Set.S with type elt = string
+module StringMap: Map.S with type key = string
+(* TODO: replace all custom instantiations of StringSet/StringMap in various
+   compiler modules with this one. *)
+
+(* Color handling *)
+module Color : sig
+  type color =
+    | Black
+    | Red
+    | Green
+    | Yellow
+    | Blue
+    | Magenta
+    | Cyan
+    | White
+  ;;
+
+  type style =
+    | FG of color (* foreground *)
+    | BG of color (* background *)
+    | Bold
+    | Reset
+
+  val ansi_of_style_l : style list -> string
+  (* ANSI escape sequence for the given style *)
+
+  type styles = {
+    error: style list;
+    warning: style list;
+    loc: style list;
+  }
+
+  val default_styles: styles
+  val get_styles: unit -> styles
+  val set_styles: styles -> unit
+
+  type setting = Auto | Always | Never
+
+  val setup : setting option -> unit
+  (* [setup opt] will enable or disable color handling on standard formatters
+     according to the value of color setting [opt].
+     Only the first call to this function has an effect. *)
+
+  val set_color_tag_handling : Format.formatter -> unit
+  (* adds functions to support color tags to the given formatter. *)
+end
+
+val normalise_eol : string -> string
+(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
+   removed. Intended for pre-processing text which will subsequently be printed
+   on a channel which performs EOL transformations (i.e. Windows) *)
+
+val delete_eol_spaces : string -> string
+(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
+   line spaces removed. Intended to normalize the output of the
+   toplevel for tests. *)
+
+
+
+(** {2 Hook machinery} *)
+
+(* Hooks machinery:
+   [add_hook name f] will register a function that will be called on the
+    argument of a later call to [apply_hooks]. Hooks are applied in the
+    lexicographical order of their names.
+*)
+
+type hook_info = {
+  sourcefile : string;
+}
+
+exception HookExnWrapper of
+    {
+      error: exn;
+      hook_name: string;
+      hook_info: hook_info;
+    }
+    (** An exception raised by a hook will be wrapped into a
+        [HookExnWrapper] constructor by the hook machinery.  *)
+
+
+val raise_direct_hook_exn: exn -> 'a
+  (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will
+      not be wrapped into a {!HookExnWrapper}. *)
+
+module type HookSig = sig
+  type t
+  val add_hook : string -> (hook_info -> t -> t) -> unit
+  val apply_hooks : hook_info -> t -> t
+end
+
+module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t
diff --git a/utils/numbers.ml b/utils/numbers.ml
new file mode 100644
index 00000000..070f5838
--- /dev/null
+++ b/utils/numbers.ml
@@ -0,0 +1,48 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int_base = Identifiable.Make (struct
+  type t = int
+
+  let compare x y = x - y
+  let output oc x = Printf.fprintf oc "%i" x
+  let hash i = i
+  let equal (i : int) j = i = j
+  let print = Format.pp_print_int
+end)
+
+module Int = struct
+  type t = int
+
+  include Int_base
+
+  let rec zero_to_n n =
+    if n < 0 then Set.empty else Set.add n (zero_to_n (n-1))
+end
+
+module Float = struct
+  type t = float
+
+  include Identifiable.Make (struct
+    type t = float
+
+    let compare x y = Pervasives.compare x y
+    let output oc x = Printf.fprintf oc "%f" x
+    let hash f = Hashtbl.hash f
+    let equal (i : float) j = i = j
+    let print = Format.pp_print_float
+  end)
+end
diff --git a/utils/numbers.mli b/utils/numbers.mli
new file mode 100644
index 00000000..873f409f
--- /dev/null
+++ b/utils/numbers.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Modules about numbers that satisfy {!Identifiable.S}. *)
+
+module Int : sig
+  include Identifiable.S with type t = int
+
+  (** [zero_to_n n] is the set of numbers \{0, ..., n\} (inclusive). *)
+  val zero_to_n : int -> Set.t
+end
+
+module Float : Identifiable.S with type t = float
diff --git a/utils/strongly_connected_components.ml b/utils/strongly_connected_components.ml
new file mode 100644
index 00000000..a11f6987
--- /dev/null
+++ b/utils/strongly_connected_components.ml
@@ -0,0 +1,200 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Int = Numbers.Int
+
+module Kosaraju : sig
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  val component_graph : int list array -> component_graph
+end = struct
+  let transpose graph =
+    let size = Array.length graph in
+    let transposed = Array.make size [] in
+    let add src dst = transposed.(src) <- dst :: transposed.(src) in
+    Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts)
+      graph;
+    transposed
+
+  let depth_first_order (graph : int list array) : int array =
+    let size = Array.length graph in
+    let marked = Array.make size false in
+    let stack = Array.make size ~-1 in
+    let pos = ref 0 in
+    let push i =
+      stack.(!pos) <- i;
+      incr pos
+    in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        List.iter aux graph.(node);
+        push node
+      end
+    in
+    for i = 0 to size - 1 do
+      aux i
+    done;
+    stack
+
+  let mark order graph =
+    let size = Array.length graph in
+    let graph = transpose graph in
+    let marked = Array.make size false in
+    let id = Array.make size ~-1 in
+    let count = ref 0 in
+    let rec aux node =
+      if not marked.(node)
+      then begin
+        marked.(node) <- true;
+        id.(node) <- !count;
+        List.iter aux graph.(node)
+      end
+    in
+    for i = size - 1 downto 0 do
+      let node = order.(i) in
+      if not marked.(node)
+      then begin
+        aux order.(i);
+        incr count
+      end
+    done;
+    id, !count
+
+  let kosaraju graph =
+    let dfo = depth_first_order graph in
+    let components, ncomponents = mark dfo graph in
+    ncomponents, components
+
+  type component_graph =
+    { sorted_connected_components : int list array;
+      component_edges : int list array;
+    }
+
+  let component_graph graph =
+    let ncomponents, components = kosaraju graph in
+    let id_scc = Array.make ncomponents [] in
+    let component_graph = Array.make ncomponents Int.Set.empty in
+    let add_component_dep node set =
+      let node_deps = graph.(node) in
+      List.fold_left (fun set dep -> Int.Set.add components.(dep) set)
+        set node_deps
+    in
+    Array.iteri (fun node component ->
+        id_scc.(component) <- node :: id_scc.(component);
+        component_graph.(component) <-
+          add_component_dep node (component_graph.(component)))
+      components;
+    { sorted_connected_components = id_scc;
+      component_edges = Array.map Int.Set.elements component_graph;
+    }
+end
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) = struct
+  type directed_graph = Id.Set.t Id.Map.t
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  (* Ensure that the dependency graph does not have external dependencies. *)
+  (* Note: this function is currently not used. *)
+  let _check dependencies =
+    Id.Map.iter (fun id set ->
+        Id.Set.iter (fun v ->
+            if not (Id.Map.mem v dependencies)
+            then
+              Misc.fatal_errorf "Strongly_connected_components.check: the \
+                  graph has external dependencies (%a -> %a)"
+               Id.print id Id.print v)
+          set)
+      dependencies
+
+  type numbering = {
+    back : int Id.Map.t;
+    forth : Id.t array;
+  }
+
+  let number graph =
+    let size = Id.Map.cardinal graph in
+    let bindings = Id.Map.bindings graph in
+    let a = Array.of_list bindings in
+    let forth = Array.map fst a in
+    let back =
+      let back = ref Id.Map.empty in
+      for i = 0 to size - 1 do
+        back := Id.Map.add forth.(i) i !back;
+      done;
+      !back
+    in
+    let integer_graph =
+      Array.init size (fun i ->
+        let _, dests = a.(i) in
+        Id.Set.fold (fun dest acc ->
+            let v =
+              try Id.Map.find dest back
+              with Not_found ->
+                Misc.fatal_errorf
+                  "Strongly_connected_components: missing dependency %a"
+                  Id.print dest
+            in
+            v :: acc)
+          dests [])
+    in
+    { back; forth }, integer_graph
+
+  let component_graph graph =
+    let numbering, integer_graph = number graph in
+    let { Kosaraju. sorted_connected_components;
+          component_edges } =
+      Kosaraju.component_graph integer_graph
+    in
+    Array.mapi (fun component nodes ->
+        match nodes with
+        | [] -> assert false
+        | [node] ->
+          (if List.mem node integer_graph.(node)
+           then Has_loop [numbering.forth.(node)]
+           else No_loop numbering.forth.(node)),
+            component_edges.(component)
+        | _::_ ->
+          (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)),
+            component_edges.(component))
+      sorted_connected_components
+
+  let connected_components_sorted_from_roots_to_leaf graph =
+    Array.map fst (component_graph graph)
+end
diff --git a/utils/strongly_connected_components.mli b/utils/strongly_connected_components.mli
new file mode 100644
index 00000000..59af9eec
--- /dev/null
+++ b/utils/strongly_connected_components.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Kosaraju's algorithm for strongly connected components. *)
+
+module type S = sig
+  module Id : Identifiable.S
+
+  type directed_graph = Id.Set.t Id.Map.t
+  (** If (a -> set) belongs to the map, it means that there are edges
+      from [a] to every element of [set].  It is assumed that no edge
+      points to a vertex not represented in the map. *)
+
+  type component =
+    | Has_loop of Id.t list
+    | No_loop of Id.t
+
+  val connected_components_sorted_from_roots_to_leaf
+     : directed_graph
+    -> component array
+
+  val component_graph : directed_graph -> (component * int list) array
+end
+
+module Make (Id : Identifiable.S) : S with module Id := Id
diff --git a/utils/targetint.ml b/utils/targetint.ml
new file mode 100644
index 00000000..78405a36
--- /dev/null
+++ b/utils/targetint.ml
@@ -0,0 +1,98 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+module type S = sig
+  type t
+  val zero : t
+  val one : t
+  val minus_one : t
+  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 succ : t -> t
+  val pred : t -> t
+  val abs : t -> t
+  val max_int : t
+  val min_int : t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val logxor : t -> t -> t
+  val lognot : 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 of_int_exn : int -> t
+  val to_int : t -> int
+  val of_float : float -> t
+  val to_float : t -> float
+  val of_int32 : int32 -> t
+  val to_int32 : t -> int32
+  val of_int64 : int64 -> t
+  val to_int64 : t -> int64
+  val of_string : string -> t
+  val to_string : t -> string
+  val compare: t -> t -> int
+  val equal: t -> t -> bool
+  val repr: t -> repr
+end
+
+let size = Sys.word_size
+(* Later, this will be set by the configure script
+   in order to support cross-compilation. *)
+
+module Int32 = struct
+  include Int32
+  let of_int_exn =
+    match Sys.word_size with (* size of [int] *)
+    | 32 ->
+        Int32.of_int
+    | 64 ->
+        fun n ->
+          if n < Int32.(to_int min_int) || n > Int32.(to_int max_int) then
+            Misc.fatal_errorf "Targetint.of_int_exn: 0x%x out of range" n
+          else
+            Int32.of_int n
+    | _ ->
+        assert false
+  let of_int32 x = x
+  let to_int32 x = x
+  let of_int64 = Int64.to_int32
+  let to_int64 = Int64.of_int32
+  let repr x = Int32 x
+end
+
+module Int64 = struct
+  include Int64
+  let of_int_exn = Int64.of_int
+  let of_int64 x = x
+  let to_int64 x = x
+  let repr x = Int64 x
+end
+
+include (val
+          (match size with
+           | 32 -> (module Int32)
+           | 64 -> (module Int64)
+           | _ -> assert false
+          ) : S)
diff --git a/utils/targetint.mli b/utils/targetint.mli
new file mode 100644
index 00000000..005e2501
--- /dev/null
+++ b/utils/targetint.mli
@@ -0,0 +1,188 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Target processor-native integers.
+
+   This module provides operations on the type of
+   signed 32-bit integers (on 32-bit target platforms) or
+   signed 64-bit integers (on 64-bit target platforms).
+   This integer type has exactly the same width as that of a
+   pointer type in the C compiler.  All arithmetic operations over
+   are taken modulo 2{^32} or 2{^64} depending
+   on the word size of the target architecture.
+*)
+
+type t
+(** The type of target integers. *)
+
+val zero : t
+(** The target integer 0.*)
+
+val one : t
+(** The target integer 1.*)
+
+val minus_one : t
+(** The target integer -1.*)
+
+val neg : t -> t
+(** Unary negation. *)
+
+val add : t -> t -> t
+(** Addition. *)
+
+val sub : t -> t -> t
+(** Subtraction. *)
+
+val mul : t -> t -> t
+(** Multiplication. *)
+
+val div : t -> t -> t
+(** Integer division.  Raise [Division_by_zero] if the second
+   argument is zero.  This division rounds the real quotient of
+   its arguments towards zero, as specified for {!Pervasives.(/)}. *)
+
+val rem : t -> t -> t
+(** Integer remainder.  If [y] is not zero, the result
+   of [Targetint.rem x y] satisfies the following properties:
+   [Targetint.zero <= Nativeint.rem x y < Targetint.abs y] and
+   [x = Targetint.add (Targetint.mul (Targetint.div x y) y)
+                      (Targetint.rem x y)].
+   If [y = 0], [Targetint.rem x y] raises [Division_by_zero]. *)
+
+val succ : t -> t
+(** Successor.
+   [Targetint.succ x] is [Targetint.add x Targetint.one]. *)
+
+val pred : t -> t
+(** Predecessor.
+   [Targetint.pred x] is [Targetint.sub x Targetint.one]. *)
+
+val abs : t -> t
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a target native integer. *)
+
+val max_int : t
+(** The greatest representable target integer,
+    either 2{^31} - 1 on a 32-bit platform,
+    or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : t
+(** The smallest representable target integer,
+   either -2{^31} on a 32-bit platform,
+   or -2{^63} on a 64-bit platform. *)
+
+val logand : t -> t -> t
+(** Bitwise logical and. *)
+
+val logor : t -> t -> t
+(** Bitwise logical or. *)
+
+val logxor : t -> t -> t
+(** Bitwise logical exclusive or. *)
+
+val lognot : t -> t
+(** Bitwise logical negation *)
+
+val shift_left : t -> int -> t
+(** [Targetint.shift_left x y] shifts [x] to the left by [y] bits.
+    The result is unspecified if [y < 0] or [y >= bitsize],
+    where [bitsize] is [32] on a 32-bit platform and
+    [64] on a 64-bit platform. *)
+
+val shift_right : t -> int -> t
+(** [Targetint.shift_right x y] shifts [x] to the right by [y] bits.
+    This is an arithmetic shift: the sign bit of [x] is replicated
+    and inserted in the vacated bits.
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val shift_right_logical : t -> int -> t
+(** [Targetint.shift_right_logical x y] shifts [x] to the right
+    by [y] bits.
+    This is a logical shift: zeroes are inserted in the vacated bits
+    regardless of the sign of [x].
+    The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val of_int : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]), module the target word size. *)
+
+val of_int_exn : int -> t
+(** Convert the given integer (type [int]) to a target integer
+    (type [t]).  Raises a fatal error if the conversion is not exact. *)
+
+val to_int : t -> int
+(** Convert the given target integer (type [t]) to an
+    integer (type [int]).  The high-order bit is lost during
+    the conversion. *)
+
+val of_float : float -> t
+(** Convert the given floating-point number to a target integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range
+   \[{!Targetint.min_int}, {!Targetint.max_int}\]. *)
+
+val to_float : t -> float
+(** Convert the given target integer to a floating-point number. *)
+
+val of_int32 : int32 -> t
+(** Convert the given 32-bit integer (type [int32])
+    to a target integer. *)
+
+val to_int32 : t -> int32
+(** Convert the given target integer to a
+    32-bit integer (type [int32]).  On 64-bit platforms,
+    the 64-bit native integer is taken modulo 2{^32},
+    i.e. the top 32 bits are lost.  On 32-bit platforms,
+    the conversion is exact. *)
+
+val of_int64 : int64 -> t
+(** Convert the given 64-bit integer (type [int64])
+    to a target integer. *)
+
+val to_int64 : t -> int64
+(** Convert the given target integer to a
+    64-bit integer (type [int64]). *)
+
+val of_string : string -> t
+(** Convert the given string to a target 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, or if the integer represented
+    exceeds the range of integers representable in type [nativeint]. *)
+
+val to_string : t -> string
+(** Return the string representation of its argument, in decimal. *)
+
+val compare: t -> t -> int
+(** The comparison function for target integers, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [Targetint] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equal function for target ints. *)
+
+type repr =
+  | Int32 of int32
+  | Int64 of int64
+
+val repr : t -> repr
+(** The concrete representation of a native integer. *)
diff --git a/utils/tbl.ml b/utils/tbl.ml
new file mode 100644
index 00000000..abb7309b
--- /dev/null
+++ b/utils/tbl.ml
@@ -0,0 +1,115 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ('a, 'b) t =
+    Empty
+  | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int
+
+let empty = Empty
+
+let height = function
+    Empty -> 0
+  | Node(_,_,_,_,h) -> h
+
+let create l x d r =
+  let hl = height l and hr = height r in
+  Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let bal l x d r =
+  let hl = height l and hr = height r in
+  if hl > hr + 1 then
+    match l with
+    | Node (ll, lv, ld, lr, _) when height ll >= height lr ->
+        create ll lv ld (create lr x d r)
+    | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) ->
+        create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+    | _ -> assert false
+  else if hr > hl + 1 then
+    match r with
+    | Node (rl, rv, rd, rr, _) when height rr >= height rl ->
+        create (create l x d rl) rv rd rr
+    | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) ->
+        create (create l x d rll) rlv rld (create rlr rv rd rr)
+    | _ -> assert false
+  else
+    create l x d r
+
+let rec add x data = function
+    Empty ->
+      Node(Empty, x, data, Empty, 1)
+  | Node(l, v, d, r, h) ->
+      let c = compare x v in
+      if c = 0 then
+        Node(l, x, data, r, h)
+      else if c < 0 then
+        bal (add x data l) v d r
+      else
+        bal l v d (add x data r)
+
+let rec find x = function
+    Empty ->
+      raise Not_found
+  | Node(l, v, d, r, _) ->
+      let c = compare x v in
+      if c = 0 then d
+      else find x (if c < 0 then l else r)
+
+let rec mem x = function
+    Empty -> false
+  | Node(l, v, _d, r, _) ->
+      let c = compare x v in
+      c = 0 || mem x (if c < 0 then l else r)
+
+let rec merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) ->
+      bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
+
+let rec remove x = function
+    Empty ->
+      Empty
+  | Node(l, v, d, r, _h) ->
+      let c = compare x v in
+      if c = 0 then
+        merge l r
+      else if c < 0 then
+        bal (remove x l) v d r
+      else
+        bal l v d (remove x r)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, v, d, r, _) ->
+      iter f l; f v d; iter f r
+
+let rec map f = function
+    Empty -> Empty
+  | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h)
+
+let rec fold f m accu =
+  match m with
+  | Empty -> accu
+  | Node(l, v, d, r, _) ->
+      fold f r (f v d (fold f l accu))
+
+open Format
+
+let print print_key print_data ppf tbl =
+  let print_tbl ppf tbl =
+    iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d)
+      tbl in
+  fprintf ppf "@[[[%a]]@]" print_tbl tbl
diff --git a/utils/tbl.mli b/utils/tbl.mli
new file mode 100644
index 00000000..dd545b6d
--- /dev/null
+++ b/utils/tbl.mli
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Association tables from any ordered type to any type.
+   We use the generic ordering to compare keys. *)
+
+type ('a, 'b) t
+
+val empty: ('a, 'b) t
+val add: 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t
+val find: 'a -> ('a, 'b) t -> 'b
+val mem: 'a -> ('a, 'b) t -> bool
+val remove: 'a -> ('a,  'b) t -> ('a, 'b) t
+val iter: ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+val map: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
+val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+
+open Format
+
+val print: (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) ->
+           formatter -> ('a, 'b) t -> unit
diff --git a/utils/terminfo.ml b/utils/terminfo.ml
new file mode 100644
index 00000000..5ed4bb5b
--- /dev/null
+++ b/utils/terminfo.ml
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic interface to the terminfo database *)
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term of int
+;;
+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
new file mode 100644
index 00000000..92af80f9
--- /dev/null
+++ b/utils/terminfo.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Basic interface to the terminfo database *)
+
+type status =
+  | Uninitialised
+  | Bad_term
+  | Good_term of int  (* number of lines of the terminal *)
+;;
+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/timings.ml b/utils/timings.ml
new file mode 100644
index 00000000..4fe6ec3a
--- /dev/null
+++ b/utils/timings.ml
@@ -0,0 +1,158 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type file = string
+
+type source_provenance =
+  | File of file
+  | Pack of string
+  | Startup
+  | Toplevel
+
+type compiler_pass =
+  | All
+  | Parsing of file
+  | Parser of file
+  | Dash_pp of file
+  | Dash_ppx of file
+  | Typing of file
+  | Transl of file
+  | Generate of file
+  | Assemble of source_provenance
+  | Clambda of source_provenance
+  | Cmm of source_provenance
+  | Compile_phrases of source_provenance
+  | Selection of source_provenance
+  | Comballoc of source_provenance
+  | CSE of source_provenance
+  | Liveness of source_provenance
+  | Deadcode of source_provenance
+  | Spill of source_provenance
+  | Split of source_provenance
+  | Regalloc of source_provenance
+  | Linearize of source_provenance
+  | Scheduling of source_provenance
+  | Emit of source_provenance
+  | Flambda_pass of string * source_provenance
+
+let timings : (compiler_pass, float * float option) Hashtbl.t =
+  Hashtbl.create 20
+
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
+let reset () = Hashtbl.clear timings
+
+let start pass =
+  (* Cannot assert it is not here: a source file can be compiled
+     multiple times on the same command line *)
+  (* assert(not (Hashtbl.mem timings pass)); *)
+  let time = cpu_time () in
+  Hashtbl.add timings pass (time, None)
+
+let stop pass =
+  assert(Hashtbl.mem timings pass);
+  let time = cpu_time () in
+  let (start, stop) = Hashtbl.find timings pass in
+  assert(stop = None);
+  Hashtbl.replace timings pass (start, Some (time -. start))
+
+let time_call pass f =
+  start pass;
+  let r = f () in
+  stop pass;
+  r
+
+let time pass f x = time_call pass (fun () -> f x)
+
+let restart pass =
+  let previous_duration =
+    match Hashtbl.find timings pass with
+    | exception Not_found -> 0.
+    | (_, Some duration) -> duration
+    | _, None -> assert false
+  in
+  let time = cpu_time () in
+  Hashtbl.replace timings pass (time, Some previous_duration)
+
+let accumulate pass =
+  let time = cpu_time () in
+  match Hashtbl.find timings pass with
+  | exception Not_found -> assert false
+  | _, None -> assert false
+  | (start, Some duration) ->
+    let duration = duration +. (time -. start) in
+    Hashtbl.replace timings pass (start, Some duration)
+
+let accumulate_time pass f x =
+  restart pass;
+  let r = f x in
+  accumulate pass;
+  r
+
+let get pass =
+  match Hashtbl.find timings pass with
+  | _start, Some duration -> Some duration
+  | _, None -> None
+  | exception Not_found -> None
+
+let kind_name = function
+  | File f -> Printf.sprintf "sourcefile(%s)" f
+  | Pack p -> Printf.sprintf "pack(%s)" p
+  | Startup -> "startup"
+  | Toplevel  -> "toplevel"
+
+let pass_name = function
+  | All -> "all"
+  | Parsing file -> Printf.sprintf "parsing(%s)" file
+  | Parser file -> Printf.sprintf "parser(%s)" file
+  | Dash_pp file -> Printf.sprintf "-pp(%s)" file
+  | Dash_ppx file -> Printf.sprintf "-ppx(%s)" file
+  | Typing file -> Printf.sprintf "typing(%s)" file
+  | Transl file -> Printf.sprintf "transl(%s)" file
+  | Generate file -> Printf.sprintf "generate(%s)" file
+  | Assemble k -> Printf.sprintf "assemble(%s)" (kind_name k)
+  | Clambda k -> Printf.sprintf "clambda(%s)" (kind_name k)
+  | Cmm k -> Printf.sprintf "cmm(%s)" (kind_name k)
+  | Compile_phrases k -> Printf.sprintf "compile_phrases(%s)" (kind_name k)
+  | Selection k -> Printf.sprintf "selection(%s)" (kind_name k)
+  | Comballoc k -> Printf.sprintf "comballoc(%s)" (kind_name k)
+  | CSE k -> Printf.sprintf "cse(%s)" (kind_name k)
+  | Liveness k -> Printf.sprintf "liveness(%s)" (kind_name k)
+  | Deadcode k -> Printf.sprintf "deadcode(%s)" (kind_name k)
+  | Spill k -> Printf.sprintf "spill(%s)" (kind_name k)
+  | Split k -> Printf.sprintf "split(%s)" (kind_name k)
+  | Regalloc k -> Printf.sprintf "regalloc(%s)" (kind_name k)
+  | Linearize k -> Printf.sprintf "linearize(%s)" (kind_name k)
+  | Scheduling k -> Printf.sprintf "scheduling(%s)" (kind_name k)
+  | Emit k -> Printf.sprintf "emit(%s)" (kind_name k)
+  | Flambda_pass (pass, file) ->
+    Printf.sprintf "flambda(%s)(%s)" pass (kind_name file)
+
+let timings_list () =
+  let l = Hashtbl.fold (fun pass times l -> (pass, times) :: l) timings [] in
+  List.sort (fun (pass1, (start1, _)) (pass2, (start2, _)) ->
+    compare (start1, pass1) (start2, pass2)) l
+
+let print ppf =
+  let current_time = cpu_time () in
+  List.iter (fun (pass, (start, stop)) ->
+      match stop with
+      | Some duration ->
+        Format.fprintf ppf "%s: %.03fs@." (pass_name pass) duration
+      | None ->
+        Format.fprintf ppf "%s: running for %.03fs@." (pass_name pass)
+          (current_time -. start))
+    (timings_list ())
diff --git a/utils/timings.mli b/utils/timings.mli
new file mode 100644
index 00000000..1983a9ce
--- /dev/null
+++ b/utils/timings.mli
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiler performance recording *)
+
+type file = string
+
+type source_provenance =
+  | File of file
+  | Pack of string
+  | Startup
+  | Toplevel
+
+type compiler_pass =
+  | All
+  | Parsing of file
+  | Parser of file
+  | Dash_pp of file
+  | Dash_ppx of file
+  | Typing of file
+  | Transl of file
+  | Generate of file
+  | Assemble of source_provenance
+  | Clambda of source_provenance
+  | Cmm of source_provenance
+  | Compile_phrases of source_provenance
+  | Selection of source_provenance
+  | Comballoc of source_provenance
+  | CSE of source_provenance
+  | Liveness of source_provenance
+  | Deadcode of source_provenance
+  | Spill of source_provenance
+  | Split of source_provenance
+  | Regalloc of source_provenance
+  | Linearize of source_provenance
+  | Scheduling of source_provenance
+  | Emit of source_provenance
+  | Flambda_pass of string * source_provenance
+
+val reset : unit -> unit
+(** erase all recorded times *)
+
+val get : compiler_pass -> float option
+(** returns the runtime in seconds of a completed pass *)
+
+val time_call : compiler_pass -> (unit -> 'a) -> 'a
+(** [time_call pass f] calls [f] and records its runtime. *)
+
+val time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
+(** [time pass f arg] records the runtime of [f arg] *)
+
+val accumulate_time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
+(** Like time for passes that can run multiple times *)
+
+val print : Format.formatter -> unit
+(** Prints all recorded timings to the formatter. *)
diff --git a/utils/warnings.ml b/utils/warnings.ml
new file mode 100644
index 00000000..f2e08580
--- /dev/null
+++ b/utils/warnings.ml
@@ -0,0 +1,604 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* When you change this, you need to update the documentation:
+   - man/ocamlc.m
+   - man/ocamlopt.m
+   - manual/manual/cmds/comp.etex
+   - manual/manual/cmds/native.etex
+*)
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+  | Deprecated of string                    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Partial_application                     (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Non_closed_record_pattern of string     (*  9 *)
+  | Statement_type                          (* 10 *)
+  | Unused_match                            (* 11 *)
+  | Unused_pat                              (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Without_principality of string          (* 19 *)
+  | Unused_argument                         (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Multiple_definition of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool    (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Bad_docstring of bool                   (* 50 *)
+  | Expect_tailcall                         (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_pattern of string list        (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+;;
+
+(* If you remove a warning, leave a hole in the numbering.  NEVER change
+   the numbers of existing warnings.
+   If you add a new warning, add it at the end with a new number;
+   do NOT reuse one of the holes.
+*)
+
+let number = function
+  | Comment_start -> 1
+  | Comment_not_end -> 2
+  | Deprecated _ -> 3
+  | Fragile_match _ -> 4
+  | Partial_application -> 5
+  | Labels_omitted _ -> 6
+  | Method_override _ -> 7
+  | Partial_match _ -> 8
+  | Non_closed_record_pattern _ -> 9
+  | Statement_type -> 10
+  | Unused_match -> 11
+  | Unused_pat -> 12
+  | Instance_variable_override _ -> 13
+  | Illegal_backslash -> 14
+  | Implicit_public_methods _ -> 15
+  | Unerasable_optional_argument -> 16
+  | Undeclared_virtual_method _ -> 17
+  | Not_principal _ -> 18
+  | Without_principality _ -> 19
+  | Unused_argument -> 20
+  | Nonreturning_statement -> 21
+  | Preprocessor _ -> 22
+  | Useless_record_with -> 23
+  | Bad_module_name _ -> 24
+  | All_clauses_guarded -> 8 (* used to be 25 *)
+  | Unused_var _ -> 26
+  | Unused_var_strict _ -> 27
+  | Wildcard_arg_to_constant_constr -> 28
+  | Eol_in_string -> 29
+  | Duplicate_definitions _ -> 30
+  | Multiple_definition _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_extension _ -> 38
+  | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
+  | Open_shadow_label_constructor _ -> 45
+  | Bad_env_variable _ -> 46
+  | Attribute_payload _ -> 47
+  | Eliminated_optional_arguments _ -> 48
+  | No_cmi_file _ -> 49
+  | Bad_docstring _ -> 50
+  | Expect_tailcall -> 51
+  | Fragile_literal_pattern -> 52
+  | Misplaced_attribute _ -> 53
+  | Duplicated_attribute _ -> 54
+  | Inlining_impossible _ -> 55
+  | Unreachable_case -> 56
+  | Ambiguous_pattern _ -> 57
+  | No_cmx_file _ -> 58
+  | Assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
+;;
+
+let last_warning_number = 61
+;;
+
+(* Must be the max number returned by the [number] function. *)
+
+let letter = function
+  | 'a' ->
+     let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
+     loop last_warning_number
+  | 'b' -> []
+  | 'c' -> [1; 2]
+  | 'd' -> [3]
+  | 'e' -> [4]
+  | 'f' -> [5]
+  | 'g' -> []
+  | 'h' -> []
+  | 'i' -> []
+  | 'j' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
+  | 'l' -> [6]
+  | 'm' -> [7]
+  | 'n' -> []
+  | 'o' -> []
+  | 'p' -> [8]
+  | 'q' -> []
+  | 'r' -> [9]
+  | 's' -> [10]
+  | 't' -> []
+  | 'u' -> [11; 12]
+  | 'v' -> [13]
+  | 'w' -> []
+  | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
+  | 'y' -> [26]
+  | 'z' -> [27]
+  | _ -> assert false
+;;
+
+type state =
+  {
+    active: bool array;
+    error: bool array;
+  }
+
+let current =
+  ref
+    {
+      active = Array.make (last_warning_number + 1) true;
+      error = Array.make (last_warning_number + 1) false;
+    }
+
+let backup () = !current
+
+let restore x = current := x
+
+let is_active x = (!current).active.(number x);;
+let is_error x = (!current).error.(number x);;
+
+let parse_opt error active flags s =
+  let set i = flags.(i) <- true in
+  let clear i = flags.(i) <- false in
+  let set_all i = active.(i) <- true; error.(i) <- true in
+  let error () = raise (Arg.Bad "Ill-formed list of warnings") in
+  let rec get_num n i =
+    if i >= String.length s then i, n
+    else match s.[i] with
+    | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
+    | _ -> i, n
+  in
+  let get_range i =
+    let i, n1 = get_num 0 i in
+    if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then
+      let i, n2 = get_num 0 (i + 2) in
+      if n2 < n1 then error ();
+      i, n1, n2
+    else
+      i, n1, n1
+  in
+  let rec loop i =
+    if i >= String.length s then () else
+    match s.[i] with
+    | 'A' .. 'Z' ->
+       List.iter set (letter (Char.lowercase_ascii s.[i]));
+       loop (i+1)
+    | 'a' .. 'z' ->
+       List.iter clear (letter s.[i]);
+       loop (i+1)
+    | '+' -> loop_letter_num set (i+1)
+    | '-' -> loop_letter_num clear (i+1)
+    | '@' -> loop_letter_num set_all (i+1)
+    | _ -> error ()
+  and loop_letter_num myset i =
+    if i >= String.length s then error () else
+    match s.[i] with
+    | '0' .. '9' ->
+        let i, n1, n2 = get_range i in
+        for n = n1 to min n2 last_warning_number do myset n done;
+        loop i
+    | 'A' .. 'Z' ->
+       List.iter myset (letter (Char.lowercase_ascii s.[i]));
+       loop (i+1)
+    | 'a' .. 'z' ->
+       List.iter myset (letter s.[i]);
+       loop (i+1)
+    | _ -> error ()
+  in
+  loop 0
+;;
+
+let parse_options errflag s =
+  let error = Array.copy (!current).error in
+  let active = Array.copy (!current).active in
+  parse_opt error active (if errflag then error else active) s;
+  current := {error; active}
+
+(* If you change these, don't forget to change them in man/ocamlc.m *)
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50-60";;
+let defaults_warn_error = "-a+31";;
+
+let () = parse_options false defaults_w;;
+let () = parse_options true defaults_warn_error;;
+
+let message = function
+  | Comment_start -> "this is the start of a comment."
+  | Comment_not_end -> "this is not the end of a comment."
+  | Deprecated s ->
+      (* Reduce \r\n to \n:
+           - Prevents any \r characters being printed on Unix when processing
+             Windows sources
+           - Prevents \r\r\n being generated on Windows, which affects the
+             testsuite
+       *)
+       "deprecated: " ^ Misc.normalise_eol s
+  | Fragile_match "" ->
+      "this pattern-matching is fragile."
+  | Fragile_match s ->
+      "this pattern-matching is fragile.\n\
+       It will remain exhaustive when constructors are added to type " ^ s ^ "."
+  | Partial_application ->
+      "this function application is partial,\n\
+       maybe some arguments are missing."
+  | Labels_omitted [] -> assert false
+  | Labels_omitted [l] ->
+     "label " ^ l ^ " was omitted in the application of this function."
+  | Labels_omitted ls ->
+     "labels " ^ String.concat ", " ls ^
+       " were omitted in the application of this function."
+  | Method_override [lab] ->
+      "the method " ^ lab ^ " is overridden."
+  | Method_override (cname :: slist) ->
+      String.concat " "
+        ("the following methods are overridden by the class"
+         :: cname  :: ":\n " :: slist)
+  | Method_override [] -> assert false
+  | Partial_match "" -> "this pattern-matching is not exhaustive."
+  | Partial_match s ->
+      "this pattern-matching is not exhaustive.\n\
+       Here is an example of a case that is not matched:\n" ^ s
+  | Non_closed_record_pattern s ->
+      "the following labels are not bound in this record pattern:\n" ^ s ^
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
+  | Statement_type ->
+      "this expression should have type unit."
+  | Unused_match -> "this match case is unused."
+  | Unused_pat   -> "this sub-pattern is unused."
+  | Instance_variable_override [lab] ->
+      "the instance variable " ^ lab ^ " is overridden.\n" ^
+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override (cname :: slist) ->
+      String.concat " "
+        ("the following instance variables are overridden by the class"
+         :: cname  :: ":\n " :: slist) ^
+      "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+  | Instance_variable_override [] -> assert false
+  | Illegal_backslash -> "illegal backslash escape in string."
+  | Implicit_public_methods l ->
+      "the following private methods were made public implicitly:\n "
+      ^ String.concat " " l ^ "."
+  | Unerasable_optional_argument -> "this optional argument cannot be erased."
+  | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
+  | Not_principal s -> s^" is not principal."
+  | Without_principality s -> s^" without principality."
+  | Unused_argument -> "this argument will not be used by the function."
+  | Nonreturning_statement ->
+      "this statement never returns (or has an unsound type.)"
+  | Preprocessor s -> s
+  | Useless_record_with ->
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
+  | Bad_module_name (modname) ->
+      "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
+  | All_clauses_guarded ->
+      "this pattern-matching is not exhaustive.\n\
+       All clauses in this pattern-matching are guarded."
+  | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
+  | Wildcard_arg_to_constant_constr ->
+     "wildcard pattern given as argument to a constant constructor"
+  | Eol_in_string ->
+     "unescaped end-of-line in a string constant (non-portable code)"
+  | Duplicate_definitions (kind, cname, tc1, tc2) ->
+      Printf.sprintf "the %s %s is defined in both types %s and %s."
+        kind cname tc1 tc2
+  | Multiple_definition(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, true, _) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, false, true) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_extension (s, is_exception, cu_pattern, cu_privatize) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match cu_pattern, cu_privatize with
+       | false, false -> "unused " ^ name
+       | true, _ ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | false, true ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
+  | Unused_rec_flag ->
+      "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+  | Ambiguous_name (_, _, false) -> assert false
+  | Ambiguous_name (_slist, tl, true) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
+  | Open_shadow_label_constructor (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s %s (which is later used)"
+        kind s
+  | Bad_env_variable (var, s) ->
+      Printf.sprintf "illegal environment variable %s : %s" var s
+  | Attribute_payload (a, s) ->
+      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
+  | Eliminated_optional_arguments sl ->
+      Printf.sprintf "implicit elimination of optional argument%s %s"
+        (if List.length sl = 1 then "" else "s")
+        (String.concat ", " sl)
+  | No_cmi_file(name, None) ->
+      "no cmi file was found in path for module " ^ name
+  | No_cmi_file(name, Some msg) ->
+      Printf.sprintf
+        "no valid cmi file was found in path for module %s. %s"
+        name msg
+  | Bad_docstring unattached ->
+      if unattached then "unattached documentation comment (ignored)"
+      else "ambiguous documentation comment"
+  | Expect_tailcall ->
+      Printf.sprintf "expected tailcall"
+  | Fragile_literal_pattern ->
+      Printf.sprintf
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. (See manual section 8.5)"
+  | Unreachable_case ->
+      "this match case is unreachable.\n\
+       Consider replacing it with a refutation case ' -> .'"
+  | Misplaced_attribute attr_name ->
+      Printf.sprintf "the %S attribute cannot appear in this context" attr_name
+  | Duplicated_attribute attr_name ->
+      Printf.sprintf "the %S attribute is used more than once on this \
+          expression"
+        attr_name
+  | Inlining_impossible reason ->
+      Printf.sprintf "Cannot inline: %s" reason
+  | Ambiguous_pattern vars ->
+      let msg =
+        let vars = List.sort String.compare vars in
+        match vars with
+        | [] -> assert false
+        | [x] -> "variable " ^ x
+        | _::_ ->
+            "variables " ^ String.concat "," vars in
+      Printf.sprintf
+        "Ambiguous or-pattern variables under guard;\n\
+         %s may match different arguments. (See manual section 8.5)"
+        msg
+  | No_cmx_file name ->
+      Printf.sprintf
+        "no cmx file was found in path for module %s, \
+         and its interface was not compiled with -opaque" name
+  | Assignment_to_non_mutable_value ->
+      "A potential assignment to a non-mutable value was detected \n\
+        in this source file.  Such assignments may generate incorrect code \n\
+        when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, which is unannotated and\n\
+         unboxable. The representation of such types may change in future\n\
+         versions. You should annotate the declaration of %s with [@@boxed]\n\
+         or [@@unboxed]." t t
+;;
+
+let nerrors = ref 0;;
+
+let print ppf w =
+  let msg = message w in
+  let num = number w in
+  Format.fprintf ppf "%d: %s" num msg;
+  Format.pp_print_flush ppf ();
+  if (!current).error.(num) then incr nerrors
+;;
+
+exception Errors of int;;
+
+let reset_fatal () =
+  nerrors := 0
+
+let check_fatal () =
+  if !nerrors > 0 then begin
+    let e = Errors !nerrors in
+    nerrors := 0;
+    raise e;
+  end;
+;;
+
+let descriptions =
+  [
+    1, "Suspicious-looking start-of-comment mark.";
+    2, "Suspicious-looking end-of-comment mark.";
+    3, "Deprecated feature.";
+    4, "Fragile pattern matching: matching that will remain complete even\n\
+   \    if additional constructors are added to one of the variant types\n\
+   \    matched.";
+    5, "Partially applied function: expression whose result has function\n\
+   \    type and is ignored.";
+    6, "Label omitted in function application.";
+    7, "Method overridden.";
+    8, "Partial match: missing cases in pattern-matching.";
+    9, "Missing fields in a record pattern.";
+   10, "Expression on the left-hand side of a sequence that doesn't have \
+      type\n\
+   \    \"unit\" (and that is not a function, see warning number 5).";
+   11, "Redundant case in a pattern matching (unused match case).";
+   12, "Redundant sub-pattern in a pattern-matching.";
+   13, "Instance variable overridden.";
+   14, "Illegal backslash escape in a string constant.";
+   15, "Private method made public implicitly.";
+   16, "Unerasable optional argument.";
+   17, "Undeclared virtual method.";
+   18, "Non-principal type.";
+   19, "Type without principality.";
+   20, "Unused function argument.";
+   21, "Non-returning statement.";
+   22, "Preprocessor warning.";
+   23, "Useless record \"with\" clause.";
+   24, "Bad module name: the source file name is not a valid OCaml module \
+        name.";
+   (* 25, "Pattern-matching with all clauses guarded.  Exhaustiveness cannot \
+      be\n\
+   \    checked.";  (* Now part of warning 8 *) *)
+   26, "Suspicious unused variable: unused variable that is bound\n\
+   \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+   \    character.";
+   27, "Innocuous unused variable: unused variable that is not bound with\n\
+   \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
+   \    character.";
+   28, "Wildcard pattern given as argument to a constant constructor.";
+   29, "Unescaped end-of-line in a string constant (non-portable code).";
+   30, "Two labels or constructors of the same name are defined in two\n\
+   \    mutually recursive types.";
+   31, "A module is linked twice in the same executable.";
+   32, "Unused value declaration.";
+   33, "Unused open statement.";
+   34, "Unused type declaration.";
+   35, "Unused for-loop index.";
+   36, "Unused ancestor variable.";
+   37, "Unused constructor.";
+   38, "Unused extension constructor.";
+   39, "Unused rec flag.";
+   40, "Constructor or label name used out of scope.";
+   41, "Ambiguous constructor or label name.";
+   42, "Disambiguated constructor or label name (compatibility warning).";
+   43, "Nonoptional label applied as optional.";
+   44, "Open statement shadows an already defined identifier.";
+   45, "Open statement shadows an already defined label or constructor.";
+   46, "Error in environment variable.";
+   47, "Illegal attribute payload.";
+   48, "Implicit elimination of optional arguments.";
+   49, "Absent cmi file when looking up module alias.";
+   50, "Unexpected documentation comment.";
+   51, "Warning on non-tail calls if @tailcall present.";
+   52, "Fragile constant pattern.";
+   53, "Attribute cannot appear in this context";
+   54, "Attribute used more than once on an expression";
+   55, "Inlining impossible";
+   56, "Unreachable case in a pattern-matching (based on type information).";
+   57, "Ambiguous or-pattern variables under guard";
+   58, "Missing cmx file";
+   59, "Assignment to non-mutable value";
+   60, "Unused module declaration";
+  ]
+;;
+
+let help_warnings () =
+  List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions;
+  print_endline "  A all warnings";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
+    | l ->
+        Printf.printf "  %c warnings %s.\n"
+          (Char.uppercase_ascii c)
+          (String.concat ", " (List.map string_of_int l))
+  done;
+  exit 0
+;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
new file mode 100644
index 00000000..fb03935b
--- /dev/null
+++ b/utils/warnings.mli
@@ -0,0 +1,101 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Pierre Weis && Damien Doligez, 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+type t =
+  | Comment_start                           (*  1 *)
+  | Comment_not_end                         (*  2 *)
+  | Deprecated of string                    (*  3 *)
+  | Fragile_match of string                 (*  4 *)
+  | Partial_application                     (*  5 *)
+  | Labels_omitted of string list           (*  6 *)
+  | Method_override of string list          (*  7 *)
+  | Partial_match of string                 (*  8 *)
+  | Non_closed_record_pattern of string     (*  9 *)
+  | Statement_type                          (* 10 *)
+  | Unused_match                            (* 11 *)
+  | Unused_pat                              (* 12 *)
+  | Instance_variable_override of string list (* 13 *)
+  | Illegal_backslash                       (* 14 *)
+  | Implicit_public_methods of string list  (* 15 *)
+  | Unerasable_optional_argument            (* 16 *)
+  | Undeclared_virtual_method of string     (* 17 *)
+  | Not_principal of string                 (* 18 *)
+  | Without_principality of string          (* 19 *)
+  | Unused_argument                         (* 20 *)
+  | Nonreturning_statement                  (* 21 *)
+  | Preprocessor of string                  (* 22 *)
+  | Useless_record_with                     (* 23 *)
+  | Bad_module_name of string               (* 24 *)
+  | All_clauses_guarded                     (* 25 *)
+  | Unused_var of string                    (* 26 *)
+  | Unused_var_strict of string             (* 27 *)
+  | Wildcard_arg_to_constant_constr         (* 28 *)
+  | Eol_in_string                           (* 29 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
+  | Multiple_definition of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool (* 37 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
+  | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
+  | Eliminated_optional_arguments of string list (* 48 *)
+  | No_cmi_file of string * string option   (* 49 *)
+  | Bad_docstring of bool                   (* 50 *)
+  | Expect_tailcall                         (* 51 *)
+  | Fragile_literal_pattern                 (* 52 *)
+  | Misplaced_attribute of string           (* 53 *)
+  | Duplicated_attribute of string          (* 54 *)
+  | Inlining_impossible of string           (* 55 *)
+  | Unreachable_case                        (* 56 *)
+  | Ambiguous_pattern of string list        (* 57 *)
+  | No_cmx_file of string                   (* 58 *)
+  | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
+;;
+
+val parse_options : bool -> string -> unit;;
+
+val is_active : t -> bool;;
+val is_error : t -> bool;;
+
+val defaults_w : string;;
+val defaults_warn_error : string;;
+
+val print : formatter -> t -> unit;;
+
+exception Errors of int;;
+
+val check_fatal : unit -> unit;;
+val reset_fatal: unit -> unit
+
+val help_warnings: unit -> unit
+
+type state
+val backup: unit -> state
+val restore: state -> unit
diff --git a/yacc/Makefile b/yacc/Makefile
new file mode 100644
index 00000000..d5be9f96
--- /dev/null
+++ b/yacc/Makefile
@@ -0,0 +1,63 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the parser generator.
+
+include ../config/Makefile
+
+CC=$(BYTECC)
+CFLAGS=-DNDEBUG $(BYTECCCOMPOPTS)
+
+ifeq "$(TOOLCHAIN)" "mingw"
+  CFLAGS += -DNO_UNIX
+else ifeq "$(TOOLCHAIN)" "msvc"
+  CFLAGS += -DNO_UNIX
+endif
+
+OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \
+  mkpar.$(O) output.$(O) reader.$(O) \
+  skeleton.$(O) symtab.$(O) verbose.$(O) warshall.$(O)
+
+all: ocamlyacc$(EXE)
+
+ocamlyacc$(EXE): $(OBJS)
+	$(MKEXE) -o ocamlyacc$(EXE) $(OBJS) $(EXTRALIBS)
+
+version.h : ../VERSION
+	echo "#define OCAML_VERSION \"`sed -e 1q $^ | tr -d '\r'`\"" > $@
+
+clean:
+	rm -f *.$(O) ocamlyacc$(EXE) *~ version.h
+
+depend:
+
+closure.$(O): defs.h
+error.$(O): defs.h
+lalr.$(O): defs.h
+lr0.$(O): defs.h
+main.$(O): defs.h version.h
+mkpar.$(O): defs.h
+output.$(O): defs.h
+reader.$(O): defs.h
+skeleton.$(O): defs.h
+symtab.$(O): defs.h
+verbose.$(O): defs.h
+warshall.$(O): defs.h
+
+# The following rule is similar to make's default one, except that it
+# also works for .obj files.
+
+%.$(O): %.c
+	$(CC) $(CFLAGS) -c $<
diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
new file mode 100644
index 00000000..ed9900bb
--- /dev/null
+++ b/yacc/Makefile.nt
@@ -0,0 +1,16 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            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 Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+include Makefile
diff --git a/yacc/closure.c b/yacc/closure.c
new file mode 100644
index 00000000..3f07ecf1
--- /dev/null
+++ b/yacc/closure.c
@@ -0,0 +1,284 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+short *itemset;
+short *itemsetend;
+unsigned *ruleset;
+
+static unsigned *first_derives;
+static unsigned *EFF;
+
+
+
+void print_EFF (void);
+void print_first_derives (void);
+void print_closure (void);
+
+void set_EFF(void)
+{
+    register unsigned *row;
+    register int symbol;
+    register short *sp;
+    register int rowsize;
+    register int i;
+    register int rule;
+
+    rowsize = WORDSIZE(nvars);
+    EFF = NEW2(nvars * rowsize, unsigned);
+
+    row = EFF;
+    for (i = start_symbol; i < nsyms; i++)
+    {
+        sp = derives[i];
+        for (rule = *sp; rule > 0; rule = *++sp)
+        {
+            symbol = ritem[rrhs[rule]];
+            if (ISVAR(symbol))
+            {
+                symbol -= start_symbol;
+                SETBIT(row, symbol);
+            }
+        }
+        row += rowsize;
+    }
+
+    reflexive_transitive_closure(EFF, nvars);
+
+#ifdef        DEBUG
+    print_EFF();
+#endif
+}
+
+
+void set_first_derives(void)
+{
+  register unsigned *rrow;
+  register unsigned *vrow;
+  register int j;
+  register unsigned mask;
+  register unsigned cword;
+  register short *rp;
+
+  int rule;
+  int i;
+  int rulesetsize;
+  int varsetsize;
+
+  rulesetsize = WORDSIZE(nrules);
+  varsetsize = WORDSIZE(nvars);
+  first_derives = NEW2(nvars * rulesetsize, unsigned) - ntokens * rulesetsize;
+
+  set_EFF();
+
+  rrow = first_derives + ntokens * rulesetsize;
+  for (i = start_symbol; i < nsyms; i++)
+    {
+      vrow = EFF + ((i - ntokens) * varsetsize);
+      cword = *vrow++;
+      mask = 1;
+      for (j = start_symbol; j < nsyms; j++)
+        {
+          if (cword & mask)
+            {
+              rp = derives[j];
+              while ((rule = *rp++) >= 0)
+                {
+                  SETBIT(rrow, rule);
+                }
+            }
+
+          mask <<= 1;
+          if (mask == 0)
+            {
+              cword = *vrow++;
+              mask = 1;
+            }
+        }
+
+      vrow += varsetsize;
+      rrow += rulesetsize;
+    }
+
+#ifdef        DEBUG
+  print_first_derives();
+#endif
+
+  FREE(EFF);
+}
+
+
+void closure(short int *nucleus, int n)
+{
+    register int ruleno;
+    register unsigned word;
+    register unsigned mask;
+    register short *csp;
+    register unsigned *dsp;
+    register unsigned *rsp;
+    register int rulesetsize;
+
+    short *csend;
+    unsigned *rsend;
+    int symbol;
+    int itemno;
+
+    rulesetsize = WORDSIZE(nrules);
+    rsp = ruleset;
+    rsend = ruleset + rulesetsize;
+    for (rsp = ruleset; rsp < rsend; rsp++)
+        *rsp = 0;
+
+    csend = nucleus + n;
+    for (csp = nucleus; csp < csend; ++csp)
+    {
+        symbol = ritem[*csp];
+        if (ISVAR(symbol))
+        {
+            dsp = first_derives + symbol * rulesetsize;
+            rsp = ruleset;
+            while (rsp < rsend)
+                *rsp++ |= *dsp++;
+        }
+    }
+
+    ruleno = 0;
+    itemsetend = itemset;
+    csp = nucleus;
+    for (rsp = ruleset; rsp < rsend; ++rsp)
+    {
+        word = *rsp;
+        if (word == 0)
+            ruleno += BITS_PER_WORD;
+        else
+        {
+            mask = 1;
+            while (mask)
+            {
+                if (word & mask)
+                {
+                    itemno = rrhs[ruleno];
+                    while (csp < csend && *csp < itemno)
+                        *itemsetend++ = *csp++;
+                    *itemsetend++ = itemno;
+                    while (csp < csend && *csp == itemno)
+                        ++csp;
+                }
+
+                    mask <<= 1;
+                    ++ruleno;
+            }
+        }
+    }
+
+    while (csp < csend)
+        *itemsetend++ = *csp++;
+
+#ifdef        DEBUG
+  print_closure(n);
+#endif
+}
+
+
+
+void finalize_closure(void)
+{
+  FREE(itemset);
+  FREE(ruleset);
+  FREE(first_derives + ntokens * WORDSIZE(nrules));
+}
+
+
+#ifdef        DEBUG
+
+void print_closure(int n)
+{
+  register short *isp;
+
+  printf("\n\nn = %d\n\n", n);
+  for (isp = itemset; isp < itemsetend; isp++)
+    printf("   %d\n", *isp);
+}
+
+
+void print_EFF(void)
+{
+    register int i, j;
+    register unsigned *rowp;
+    register unsigned word;
+    register unsigned mask;
+
+    printf("\n\nEpsilon Free Firsts\n");
+
+    for (i = start_symbol; i < nsyms; i++)
+    {
+        printf("\n%s", symbol_name[i]);
+        rowp = EFF + ((i - start_symbol) * WORDSIZE(nvars));
+        word = *rowp++;
+
+        mask = 1;
+        for (j = 0; j < nvars; j++)
+        {
+            if (word & mask)
+                printf("  %s", symbol_name[start_symbol + j]);
+
+            mask <<= 1;
+            if (mask == 0)
+            {
+                word = *rowp++;
+                mask = 1;
+            }
+        }
+    }
+}
+
+
+void print_first_derives(void)
+{
+  register int i;
+  register int j;
+  register unsigned *rp;
+  register unsigned cword;
+  register unsigned mask;
+
+  printf("\n\n\nFirst Derives\n");
+
+  for (i = start_symbol; i < nsyms; i++)
+    {
+      printf("\n%s derives\n", symbol_name[i]);
+      rp = first_derives + i * WORDSIZE(nrules);
+      cword = *rp++;
+      mask = 1;
+      for (j = 0; j <= nrules; j++)
+        {
+          if (cword & mask)
+            printf("   %d\n", j);
+
+          mask <<= 1;
+          if (mask == 0)
+            {
+              cword = *rp++;
+              mask = 1;
+            }
+        }
+    }
+
+  fflush(stdout);
+}
+
+#endif
diff --git a/yacc/defs.h b/yacc/defs.h
new file mode 100644
index 00000000..8377d05d
--- /dev/null
+++ b/yacc/defs.h
@@ -0,0 +1,361 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include "../config/s.h"
+
+/*  machine-dependent definitions                              */
+/*  the following definitions are for the Tahoe                */
+/*  they might have to be changed for other machines           */
+
+/*  MAXCHAR is the largest unsigned character value            */
+/*  MAXSHORT is the largest value of a C short                 */
+/*  MINSHORT is the most negative value of a C short           */
+/*  MAXTABLE is the maximum table size                         */
+/*  BITS_PER_WORD is the number of bits in a C unsigned        */
+/*  WORDSIZE computes the number of words needed to            */
+/*        store n bits                                         */
+/*  BIT returns the value of the n-th bit starting             */
+/*        from r (0-indexed)                                   */
+/*  SETBIT sets the n-th bit starting from r                   */
+
+#define        MAXCHAR                UCHAR_MAX
+#define        MAXSHORT        SHRT_MAX
+#define MINSHORT        SHRT_MIN
+#define MAXTABLE        32500
+
+#define BITS_PER_WORD        (8*sizeof(unsigned))
+#define        WORDSIZE(n)        (((n)+(BITS_PER_WORD-1))/BITS_PER_WORD)
+#define        BIT(r, n)        ((((r)[(n)/BITS_PER_WORD])>>((n)%BITS_PER_WORD))&1)
+#define        SETBIT(r, n)        ((r)[(n)/BITS_PER_WORD]|=(1<<((n)%BITS_PER_WORD)))
+
+/*  character names  */
+
+#define        NUL                '\0'    /*  the null character  */
+#define        NEWLINE                '\n'    /*  line feed  */
+#define        SP                ' '     /*  space  */
+#define        BS                '\b'    /*  backspace  */
+#define        HT                '\t'    /*  horizontal tab  */
+#define        VT                '\013'  /*  vertical tab  */
+#define        CR                '\r'    /*  carriage return  */
+#define        FF                '\f'    /*  form feed  */
+#define        QUOTE                '\''    /*  single quote  */
+#define        DOUBLE_QUOTE        '\"'    /*  double quote  */
+#define        BACKSLASH        '\\'    /*  backslash  */
+
+
+/* defines for constructing filenames */
+
+#define CODE_SUFFIX        ".code.c"
+#define        DEFINES_SUFFIX        ".tab.h"
+#define        OUTPUT_SUFFIX        ".ml"
+#define        VERBOSE_SUFFIX        ".output"
+#define INTERFACE_SUFFIX ".mli"
+
+/* keyword codes */
+
+#define TOKEN 0
+#define LEFT 1
+#define RIGHT 2
+#define NONASSOC 3
+#define MARK 4
+#define TEXT 5
+#define TYPE 6
+#define START 7
+#define UNION 8
+#define IDENT 9
+
+/*  symbol classes  */
+
+#define UNKNOWN 0
+#define TERM 1
+#define NONTERM 2
+
+
+/*  the undefined value  */
+
+#define UNDEFINED (-1)
+
+
+/*  action codes  */
+
+#define SHIFT 1
+#define REDUCE 2
+
+
+/*  character macros  */
+
+#define IS_IDENT(c)       (isalnum(c) || (c) == '_' || (c) == '.' || (c) == '$')
+#define IS_OCTAL(c)       ((c) >= '0' && (c) <= '7')
+#define NUMERIC_VALUE(c)  ((c) - '0')
+
+
+/*  symbol macros  */
+
+#define ISTOKEN(s)        ((s) < start_symbol)
+#define ISVAR(s)        ((s) >= start_symbol)
+
+
+/*  storage allocation macros  */
+
+#define CALLOC(k,n)      (calloc((unsigned)(k),(unsigned)(n)))
+#define FREE(x)          (free((char*)(x)))
+#define MALLOC(n)        (malloc((unsigned)(n)))
+#define NEW(t)           ((t*)allocate(sizeof(t)))
+#define NEW2(n,t)        ((t*)allocate((unsigned)((n)*sizeof(t))))
+#define REALLOC(p,n)     (realloc((char*)(p),(unsigned)(n)))
+
+
+/*  the structure of a symbol table entry  */
+
+typedef struct bucket bucket;
+struct bucket
+{
+    struct bucket *link;
+    struct bucket *next;
+    char *name;
+    char *tag;
+    short value;
+    short index;
+    short prec;
+    char class;
+    char assoc;
+    char entry;
+    char true_token;
+};
+
+/* TABLE_SIZE is the number of entries in the symbol table.      */
+/* TABLE_SIZE must be a power of two.                            */
+
+#define        TABLE_SIZE 4096
+
+/*  the structure of the LR(0) state machine  */
+
+typedef struct core core;
+struct core
+{
+    struct core *next;
+    struct core *link;
+    short number;
+    short accessing_symbol;
+    short nitems;
+    short items[1];
+};
+
+
+/*  the structure used to record shifts  */
+
+typedef struct shifts shifts;
+struct shifts
+{
+    struct shifts *next;
+    short number;
+    short nshifts;
+    short shift[1];
+};
+
+
+/*  the structure used to store reductions  */
+
+typedef struct reductions reductions;
+struct reductions
+{
+    struct reductions *next;
+    short number;
+    short nreds;
+    short rules[1];
+};
+
+
+/*  the structure used to represent parser actions  */
+
+typedef struct action action;
+struct action
+{
+    struct action *next;
+    short symbol;
+    short number;
+    short prec;
+    char action_code;
+    char assoc;
+    char suppressed;
+};
+
+
+/* global variables */
+
+extern char dflag;
+extern char lflag;
+extern char rflag;
+extern char tflag;
+extern char vflag;
+extern char qflag;
+extern char sflag;
+extern char eflag;
+extern char big_endian;
+
+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;
+extern char *entry_file_name;
+extern char *code_file_name;
+extern char *defines_file_name;
+extern char *input_file_name;
+extern char *output_file_name;
+extern char *text_file_name;
+extern char *union_file_name;
+extern char *verbose_file_name;
+extern char *interface_file_name;
+
+extern FILE *action_file;
+extern FILE *entry_file;
+extern FILE *code_file;
+extern FILE *defines_file;
+extern FILE *input_file;
+extern FILE *output_file;
+extern FILE *text_file;
+extern FILE *union_file;
+extern FILE *verbose_file;
+extern FILE *interface_file;
+
+extern int nitems;
+extern int nrules;
+extern int ntotalrules;
+extern int nsyms;
+extern int ntokens;
+extern int nvars;
+extern int ntags;
+
+extern char unionized;
+extern char line_format[];
+
+extern int   start_symbol;
+extern char  **symbol_name;
+extern short *symbol_value;
+extern short *symbol_prec;
+extern char  *symbol_assoc;
+extern char  **symbol_tag;
+extern char  *symbol_true_token;
+
+extern short *ritem;
+extern short *rlhs;
+extern short *rrhs;
+extern short *rprec;
+extern char  *rassoc;
+
+extern short **derives;
+extern char *nullable;
+
+extern bucket *first_symbol;
+extern bucket *last_symbol;
+
+extern int nstates;
+extern core *first_state;
+extern shifts *first_shift;
+extern reductions *first_reduction;
+extern short *accessing_symbol;
+extern core **state_table;
+extern shifts **shift_table;
+extern reductions **reduction_table;
+extern unsigned *LA;
+extern short *LAruleno;
+extern short *lookaheads;
+extern short *goto_map;
+extern short *from_state;
+extern short *to_state;
+
+extern action **parser;
+extern int SRtotal;
+extern int RRtotal;
+extern short *SRconflicts;
+extern short *RRconflicts;
+extern short *defred;
+extern short *rules_used;
+extern short nunused;
+extern short final_state;
+
+/* global functions */
+
+#ifdef __GNUC__
+/* Works only in GCC 2.5 and later */
+#define Noreturn __attribute ((noreturn))
+#else
+#define Noreturn
+#endif
+
+extern char *allocate(unsigned int n);
+extern bucket *lookup(char *name);
+extern bucket *make_bucket(char *name);
+extern action *parse_actions(register int stateno);
+extern action *get_shifts(int stateno);
+extern action *add_reductions(int stateno, register action *actions);
+extern action *add_reduce(register action *actions, register int ruleno, register int symbol);
+extern void closure (short int *nucleus, int n);
+extern void create_symbol_table (void);
+extern void default_action_error (void) Noreturn;
+extern void done (int k) Noreturn;
+extern void entry_without_type (char *s) Noreturn;
+extern void fatal (char *msg) Noreturn;
+extern void finalize_closure (void);
+extern void free_parser (void);
+extern void free_symbol_table (void);
+extern void free_symbols (void);
+extern void illegal_character (char *c_cptr) Noreturn;
+extern void illegal_token_ref (int i, char *name) Noreturn;
+extern void lalr (void);
+extern void lr0 (void);
+extern void make_parser (void);
+extern void no_grammar (void) Noreturn;
+extern void no_space (void) Noreturn;
+extern void open_error (char *filename) Noreturn;
+extern void output (void);
+extern void over_unionized (char *u_cptr) Noreturn;
+extern void prec_redeclared (void);
+extern void polymorphic_entry_point(char *s) Noreturn;
+extern void forbidden_conflicts (void);
+extern void reader (void);
+extern void reflexive_transitive_closure (unsigned int *R, int n);
+extern void reprec_warning (char *s);
+extern void retyped_warning (char *s);
+extern void revalued_warning (char *s);
+extern void set_first_derives (void);
+extern void syntax_error (int st_lineno, char *st_line, char *st_cptr) Noreturn, terminal_lhs (int s_lineno) Noreturn;
+extern void terminal_start (char *s) Noreturn;
+extern void tokenized_start (char *s) Noreturn;
+extern void too_many_entries (void) Noreturn;
+extern void undefined_goal (char *s);
+extern void undefined_symbol (char *s);
+extern void unexpected_EOF (void) Noreturn;
+extern void unknown_rhs (int i) Noreturn;
+extern void unterminated_action (int a_lineno, char *a_line, char *a_cptr) Noreturn;
+extern void unterminated_comment (int c_lineno, char *c_line, char *c_cptr) Noreturn;
+extern void unterminated_string (int s_lineno, char *s_line, char *s_cptr) Noreturn;
+extern void unterminated_text (int t_lineno, char *t_line, char *t_cptr) Noreturn;
+extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr) Noreturn;
+extern void used_reserved (char *s) Noreturn;
+extern void verbose (void);
+extern void write_section (char **section);
diff --git a/yacc/error.c b/yacc/error.c
new file mode 100644
index 00000000..236908c0
--- /dev/null
+++ b/yacc/error.c
@@ -0,0 +1,323 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+/* routines for printing error messages  */
+
+#include "defs.h"
+
+void fatal(char *msg)
+{
+    fprintf(stderr, "%s: f - %s\n", myname, msg);
+    done(2);
+}
+
+
+void no_space(void)
+{
+    fprintf(stderr, "%s: f - out of space\n", myname);
+    done(2);
+}
+
+
+void open_error(char *filename)
+{
+    fprintf(stderr, "%s: f - cannot open \"%s\"\n", myname, filename);
+    done(2);
+}
+
+
+void unexpected_EOF(void)
+{
+    fprintf(stderr, "File \"%s\", line %d: unexpected end-of-file\n",
+            virtual_input_file_name, lineno);
+    done(1);
+}
+
+
+void print_pos(char *st_line, char *st_cptr)
+{
+    register char *s;
+
+    if (st_line == 0) return;
+    for (s = st_line; *s != '\n'; ++s)
+    {
+        if (isprint((unsigned char) *s) || *s == '\t')
+            putc(*s, stderr);
+        else
+            putc('?', stderr);
+    }
+    putc('\n', stderr);
+    for (s = st_line; s < st_cptr; ++s)
+    {
+        if (*s == '\t')
+            putc('\t', stderr);
+        else
+            putc(' ', stderr);
+    }
+    putc('^', stderr);
+    putc('\n', stderr);
+}
+
+
+void syntax_error(int st_lineno, char *st_line, char *st_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: syntax error\n",
+            virtual_input_file_name, st_lineno);
+    print_pos(st_line, st_cptr);
+    done(1);
+}
+
+
+void unterminated_comment(int c_lineno, char *c_line, char *c_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: unmatched /*\n",
+            virtual_input_file_name, c_lineno);
+    print_pos(c_line, c_cptr);
+    done(1);
+}
+
+
+void unterminated_string(int s_lineno, char *s_line, char *s_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: unterminated string\n",
+            virtual_input_file_name, s_lineno);
+    print_pos(s_line, s_cptr);
+    done(1);
+}
+
+
+void unterminated_text(int t_lineno, char *t_line, char *t_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: unmatched %%{\n",
+            virtual_input_file_name, t_lineno);
+    print_pos(t_line, t_cptr);
+    done(1);
+}
+
+
+void unterminated_union(int u_lineno, char *u_line, char *u_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: unterminated %%union declaration\n",
+            virtual_input_file_name, u_lineno);
+    print_pos(u_line, u_cptr);
+    done(1);
+}
+
+
+void over_unionized(char *u_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: too many %%union declarations\n",
+            virtual_input_file_name, lineno);
+    print_pos(line, u_cptr);
+    done(1);
+}
+
+
+void illegal_tag(int t_lineno, char *t_line, char *t_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: illegal tag\n",
+            virtual_input_file_name, t_lineno);
+    print_pos(t_line, t_cptr);
+    done(1);
+}
+
+
+void illegal_character(char *c_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: illegal character\n",
+            virtual_input_file_name, lineno);
+    print_pos(line, c_cptr);
+    done(1);
+}
+
+
+void used_reserved(char *s)
+{
+    fprintf(stderr, "File \"%s\", line %d: illegal use of reserved symbol \
+`%s'\n", virtual_input_file_name, lineno, s);
+    done(1);
+}
+
+
+void tokenized_start(char *s)
+{
+     fprintf(stderr, "File \"%s\", line %d: the start symbol `%s' cannot \
+be declared to be a token\n", virtual_input_file_name, lineno, s);
+     done(1);
+}
+
+
+void retyped_warning(char *s)
+{
+    fprintf(stderr, "File \"%s\", line %d: warning: the type of `%s' has been \
+redeclared\n", virtual_input_file_name, lineno, s);
+}
+
+
+void reprec_warning(char *s)
+{
+    fprintf(stderr, "File \"%s\", line %d: warning: the precedence of `%s' has \
+been redeclared\n", virtual_input_file_name, lineno, s);
+}
+
+
+void revalued_warning(char *s)
+{
+    fprintf(stderr, "File \"%s\", line %d: warning: the value of `%s' has been \
+redeclared\n", virtual_input_file_name, lineno, s);
+}
+
+
+void terminal_start(char *s)
+{
+    fprintf(stderr, "File \"%s\", line %d: the entry point `%s' is a \
+token\n", virtual_input_file_name, lineno, s);
+    done(1);
+}
+
+void too_many_entries(void)
+{
+    fprintf(stderr, "File \"%s\", line %d: more than 256 entry points\n",
+            virtual_input_file_name, lineno);
+    done(1);
+}
+
+
+void no_grammar(void)
+{
+    fprintf(stderr, "File \"%s\", line %d: no grammar has been specified\n",
+            virtual_input_file_name, lineno);
+    done(1);
+}
+
+
+void terminal_lhs(int s_lineno)
+{
+    fprintf(stderr, "File \"%s\", line %d: a token appears on the lhs \
+of a production\n", virtual_input_file_name, s_lineno);
+    done(1);
+}
+
+
+void prec_redeclared(void)
+{
+    fprintf(stderr, "File \"%s\", line %d: warning: conflicting %%prec \
+specifiers\n", virtual_input_file_name, lineno);
+}
+
+
+void unterminated_action(int a_lineno, char *a_line, char *a_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: unterminated action\n",
+            virtual_input_file_name, a_lineno);
+    print_pos(a_line, a_cptr);
+    done(1);
+}
+
+
+void dollar_warning(int a_lineno, int i)
+{
+    fprintf(stderr, "File \"%s\", line %d: warning: $%d references beyond the \
+end of the current rule\n", virtual_input_file_name, a_lineno, i);
+}
+
+
+void dollar_error(int a_lineno, char *a_line, char *a_cptr)
+{
+    fprintf(stderr, "File \"%s\", line %d: illegal $-name\n",
+            virtual_input_file_name, a_lineno);
+    print_pos(a_line, a_cptr);
+    done(1);
+}
+
+
+void untyped_lhs(void)
+{
+    fprintf(stderr, "File \"%s\", line %d: $$ is untyped\n",
+            virtual_input_file_name, lineno);
+    done(1);
+}
+
+
+void untyped_rhs(int i, char *s)
+{
+    fprintf(stderr, "File \"%s\", line %d: $%d (%s) is untyped\n",
+            virtual_input_file_name, lineno, i, s);
+    done(1);
+}
+
+
+void unknown_rhs(int i)
+{
+    fprintf(stderr, "File \"%s\", line %d: $%d is unbound\n",
+            virtual_input_file_name, lineno, i);
+    done(1);
+}
+
+void illegal_token_ref(int i, char *name)
+{
+    fprintf(stderr, "File \"%s\", line %d: $%d refers to terminal `%s', \
+which has no argument\n",
+            virtual_input_file_name, lineno, i, name);
+    done(1);
+}
+
+void default_action_error(void)
+{
+    fprintf(stderr, "File \"%s\", line %d: no action specified for this \
+production\n",
+            virtual_input_file_name, lineno);
+    done(1);
+}
+
+
+void undefined_goal(char *s)
+{
+    fprintf(stderr, "%s: e - the start symbol `%s' is undefined\n", myname, s);
+    done(1);
+}
+
+void undefined_symbol(char *s)
+{
+    fprintf(stderr, "%s: e - the symbol `%s' is undefined\n", myname, s);
+    done(1);
+}
+
+
+void entry_without_type(char *s)
+{
+    fprintf(stderr,
+            "%s: e - no type has been declared for the start symbol `%s'\n",
+            myname, s);
+    done(1);
+}
+
+void polymorphic_entry_point(char *s)
+{
+    fprintf(stderr,
+            "%s: e - the start symbol `%s' has a polymorphic type\n",
+            myname, s);
+    done(1);
+}
+
+void forbidden_conflicts(void)
+{
+    fprintf(stderr,
+            "%s: the grammar has conflicts, but --strict was specified\n",
+            myname);
+    done(1);
+}
diff --git a/yacc/lalr.c b/yacc/lalr.c
new file mode 100644
index 00000000..5a3101ad
--- /dev/null
+++ b/yacc/lalr.c
@@ -0,0 +1,664 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+typedef
+  struct shorts
+    {
+      struct shorts *next;
+      short value;
+    }
+  shorts;
+
+int tokensetsize;
+short *lookaheads;
+short *LAruleno;
+unsigned *LA;
+short *accessing_symbol;
+core **state_table;
+shifts **shift_table;
+reductions **reduction_table;
+short *goto_map;
+short *from_state;
+short *to_state;
+
+short **transpose(short int **R, int n);
+
+static int infinity;
+static int maxrhs;
+static int ngotos;
+static unsigned *F;
+static short **includes;
+static shorts **lookback;
+static short **R;
+static short *INDEX;
+static short *VERTICES;
+static int top;
+
+
+
+void set_state_table (void);
+void set_accessing_symbol (void);
+void set_shift_table (void);
+void set_reduction_table (void);
+void set_maxrhs (void);
+void initialize_LA (void);
+void set_goto_map (void);
+void initialize_F (void);
+void build_relations (void);
+void compute_FOLLOWS (void);
+void compute_lookaheads (void);
+void digraph (short int **relation);
+void add_lookback_edge (int stateno, int ruleno, int gotono);
+void traverse (register int i);
+
+void lalr(void)
+{
+    tokensetsize = WORDSIZE(ntokens);
+
+    set_state_table();
+    set_accessing_symbol();
+    set_shift_table();
+    set_reduction_table();
+    set_maxrhs();
+    initialize_LA();
+    set_goto_map();
+    initialize_F();
+    build_relations();
+    compute_FOLLOWS();
+    compute_lookaheads();
+}
+
+
+
+void set_state_table(void)
+{
+    register core *sp;
+
+    state_table = NEW2(nstates, core *);
+    for (sp = first_state; sp; sp = sp->next)
+        state_table[sp->number] = sp;
+}
+
+
+
+void set_accessing_symbol(void)
+{
+    register core *sp;
+
+    accessing_symbol = NEW2(nstates, short);
+    for (sp = first_state; sp; sp = sp->next)
+        accessing_symbol[sp->number] = sp->accessing_symbol;
+}
+
+
+
+void set_shift_table(void)
+{
+    register shifts *sp;
+
+    shift_table = NEW2(nstates, shifts *);
+    for (sp = first_shift; sp; sp = sp->next)
+        shift_table[sp->number] = sp;
+}
+
+
+
+void set_reduction_table(void)
+{
+    register reductions *rp;
+
+    reduction_table = NEW2(nstates, reductions *);
+    for (rp = first_reduction; rp; rp = rp->next)
+        reduction_table[rp->number] = rp;
+}
+
+
+
+void set_maxrhs(void)
+{
+  register short *itemp;
+  register short *item_end;
+  register int length;
+  register int max;
+
+  length = 0;
+  max = 0;
+  item_end = ritem + nitems;
+  for (itemp = ritem; itemp < item_end; itemp++)
+    {
+      if (*itemp >= 0)
+        {
+          length++;
+        }
+      else
+        {
+          if (length > max) max = length;
+          length = 0;
+        }
+    }
+
+  maxrhs = max;
+}
+
+
+
+void initialize_LA(void)
+{
+  register int i, j, k;
+  register reductions *rp;
+
+  lookaheads = NEW2(nstates + 1, short);
+
+  k = 0;
+  for (i = 0; i < nstates; i++)
+    {
+      lookaheads[i] = k;
+      rp = reduction_table[i];
+      if (rp)
+        k += rp->nreds;
+    }
+  lookaheads[nstates] = k;
+
+  LA = NEW2(k * tokensetsize, unsigned);
+  LAruleno = NEW2(k, short);
+  lookback = NEW2(k, shorts *);
+
+  k = 0;
+  for (i = 0; i < nstates; i++)
+    {
+      rp = reduction_table[i];
+      if (rp)
+        {
+          for (j = 0; j < rp->nreds; j++)
+            {
+              LAruleno[k] = rp->rules[j];
+              k++;
+            }
+        }
+    }
+}
+
+
+void set_goto_map(void)
+{
+  register shifts *sp;
+  register int i;
+  register int symbol;
+  register int k;
+  register short *temp_map;
+  register int state2;
+  register int state1;
+
+  goto_map = NEW2(nvars + 1, short) - ntokens;
+  temp_map = NEW2(nvars + 1, short) - ntokens;
+
+  ngotos = 0;
+  for (sp = first_shift; sp; sp = sp->next)
+    {
+      for (i = sp->nshifts - 1; i >= 0; i--)
+        {
+          symbol = accessing_symbol[sp->shift[i]];
+
+          if (ISTOKEN(symbol)) break;
+
+          if (ngotos == MAXSHORT)
+            fatal("too many gotos");
+
+          ngotos++;
+          goto_map[symbol]++;
+        }
+    }
+
+  k = 0;
+  for (i = ntokens; i < nsyms; i++)
+    {
+      temp_map[i] = k;
+      k += goto_map[i];
+    }
+
+  for (i = ntokens; i < nsyms; i++)
+    goto_map[i] = temp_map[i];
+
+  goto_map[nsyms] = ngotos;
+  temp_map[nsyms] = ngotos;
+
+  from_state = NEW2(ngotos, short);
+  to_state = NEW2(ngotos, short);
+
+  for (sp = first_shift; sp; sp = sp->next)
+    {
+      state1 = sp->number;
+      for (i = sp->nshifts - 1; i >= 0; i--)
+        {
+          state2 = sp->shift[i];
+          symbol = accessing_symbol[state2];
+
+          if (ISTOKEN(symbol)) break;
+
+          k = temp_map[symbol]++;
+          from_state[k] = state1;
+          to_state[k] = state2;
+        }
+    }
+
+  FREE(temp_map + ntokens);
+}
+
+
+
+/*  Map_goto maps a state/symbol pair into its numeric representation.        */
+
+int
+map_goto(int state, int symbol)
+{
+    register int high;
+    register int low;
+    register int middle;
+    register int s;
+
+    low = goto_map[symbol];
+    high = goto_map[symbol + 1];
+
+    for (;;)
+    {
+        assert(low <= high);
+        middle = (low + high) >> 1;
+        s = from_state[middle];
+        if (s == state)
+            return (middle);
+        else if (s < state)
+            low = middle + 1;
+        else
+            high = middle - 1;
+    }
+}
+
+
+
+void initialize_F(void)
+{
+  register int i;
+  register int j;
+  register int k;
+  register shifts *sp;
+  register short *edge;
+  register unsigned *rowp;
+  register short *rp;
+  register short **reads;
+  register int nedges;
+  register int stateno;
+  register int symbol;
+  register int nwords;
+
+  nwords = ngotos * tokensetsize;
+  F = NEW2(nwords, unsigned);
+
+  reads = NEW2(ngotos, short *);
+  edge = NEW2(ngotos + 1, short);
+  nedges = 0;
+
+  rowp = F;
+  for (i = 0; i < ngotos; i++)
+    {
+      stateno = to_state[i];
+      sp = shift_table[stateno];
+
+      if (sp)
+        {
+          k = sp->nshifts;
+
+          for (j = 0; j < k; j++)
+            {
+              symbol = accessing_symbol[sp->shift[j]];
+              if (ISVAR(symbol))
+                break;
+              SETBIT(rowp, symbol);
+            }
+
+          for (; j < k; j++)
+            {
+              symbol = accessing_symbol[sp->shift[j]];
+              if (nullable[symbol])
+                edge[nedges++] = map_goto(stateno, symbol);
+            }
+
+          if (nedges)
+            {
+              reads[i] = rp = NEW2(nedges + 1, short);
+
+              for (j = 0; j < nedges; j++)
+                rp[j] = edge[j];
+
+              rp[nedges] = -1;
+              nedges = 0;
+            }
+        }
+
+      rowp += tokensetsize;
+    }
+
+  SETBIT(F, 0);
+  digraph(reads);
+
+  for (i = 0; i < ngotos; i++)
+    {
+      if (reads[i])
+        FREE(reads[i]);
+    }
+
+  FREE(reads);
+  FREE(edge);
+}
+
+
+
+void build_relations(void)
+{
+  register int i;
+  register int j;
+  register int k;
+  register short *rulep;
+  register short *rp;
+  register shifts *sp;
+  register int length;
+  register int nedges;
+  register int done;
+  register int state1;
+  register int stateno;
+  register int symbol1;
+  register int symbol2;
+  register short *shortp;
+  register short *edge;
+  register short *states;
+  register short **new_includes;
+
+  includes = NEW2(ngotos, short *);
+  edge = NEW2(ngotos + 1, short);
+  states = NEW2(maxrhs + 1, short);
+
+  for (i = 0; i < ngotos; i++)
+    {
+      nedges = 0;
+      state1 = from_state[i];
+      symbol1 = accessing_symbol[to_state[i]];
+
+      for (rulep = derives[symbol1]; *rulep >= 0; rulep++)
+        {
+          length = 1;
+          states[0] = state1;
+          stateno = state1;
+
+          for (rp = ritem + rrhs[*rulep]; *rp >= 0; rp++)
+            {
+              symbol2 = *rp;
+              sp = shift_table[stateno];
+              k = sp->nshifts;
+
+              for (j = 0; j < k; j++)
+                {
+                  stateno = sp->shift[j];
+                  if (accessing_symbol[stateno] == symbol2) break;
+                }
+
+              states[length++] = stateno;
+            }
+
+          add_lookback_edge(stateno, *rulep, i);
+
+          length--;
+          done = 0;
+          while (!done)
+            {
+              done = 1;
+              rp--;
+              if (ISVAR(*rp))
+                {
+                  stateno = states[--length];
+                  edge[nedges++] = map_goto(stateno, *rp);
+                  if (nullable[*rp] && length > 0) done = 0;
+                }
+            }
+        }
+
+      if (nedges)
+        {
+          includes[i] = shortp = NEW2(nedges + 1, short);
+          for (j = 0; j < nedges; j++)
+            shortp[j] = edge[j];
+          shortp[nedges] = -1;
+        }
+    }
+
+  new_includes = transpose(includes, ngotos);
+
+  for (i = 0; i < ngotos; i++)
+    if (includes[i])
+      FREE(includes[i]);
+
+  FREE(includes);
+
+  includes = new_includes;
+
+  FREE(edge);
+  FREE(states);
+}
+
+
+void add_lookback_edge(int stateno, int ruleno, int gotono)
+{
+    register int i, k;
+    register int found;
+    register shorts *sp;
+
+    i = lookaheads[stateno];
+    k = lookaheads[stateno + 1];
+    found = 0;
+    while (!found && i < k)
+    {
+        if (LAruleno[i] == ruleno)
+            found = 1;
+        else
+            ++i;
+    }
+    assert(found);
+
+    sp = NEW(shorts);
+    sp->next = lookback[i];
+    sp->value = gotono;
+    lookback[i] = sp;
+}
+
+
+
+short **
+transpose(short int **R, int n)
+{
+  register short **new_R;
+  register short **temp_R;
+  register short *nedges;
+  register short *sp;
+  register int i;
+  register int k;
+
+  nedges = NEW2(n, short);
+
+  for (i = 0; i < n; i++)
+    {
+      sp = R[i];
+      if (sp)
+        {
+          while (*sp >= 0)
+            nedges[*sp++]++;
+        }
+    }
+
+  new_R = NEW2(n, short *);
+  temp_R = NEW2(n, short *);
+
+  for (i = 0; i < n; i++)
+    {
+      k = nedges[i];
+      if (k > 0)
+        {
+          sp = NEW2(k + 1, short);
+          new_R[i] = sp;
+          temp_R[i] = sp;
+          sp[k] = -1;
+        }
+    }
+
+  FREE(nedges);
+
+  for (i = 0; i < n; i++)
+    {
+      sp = R[i];
+      if (sp)
+        {
+          while (*sp >= 0)
+            *temp_R[*sp++]++ = i;
+        }
+    }
+
+  FREE(temp_R);
+
+  return (new_R);
+}
+
+
+
+void compute_FOLLOWS(void)
+{
+  digraph(includes);
+}
+
+
+void compute_lookaheads(void)
+{
+  register int i, n;
+  register unsigned *fp1, *fp2, *fp3;
+  register shorts *sp, *next;
+  register unsigned *rowp;
+
+  rowp = LA;
+  n = lookaheads[nstates];
+  for (i = 0; i < n; i++)
+    {
+      fp3 = rowp + tokensetsize;
+      for (sp = lookback[i]; sp; sp = sp->next)
+        {
+          fp1 = rowp;
+          fp2 = F + tokensetsize * sp->value;
+          while (fp1 < fp3)
+            *fp1++ |= *fp2++;
+        }
+      rowp = fp3;
+    }
+
+  for (i = 0; i < n; i++)
+    for (sp = lookback[i]; sp; sp = next)
+      {
+        next = sp->next;
+        FREE(sp);
+      }
+
+  FREE(lookback);
+  FREE(F);
+}
+
+
+void digraph(short int **relation)
+{
+  register int i;
+
+  infinity = ngotos + 2;
+  INDEX = NEW2(ngotos + 1, short);
+  VERTICES = NEW2(ngotos + 1, short);
+  top = 0;
+
+  R = relation;
+
+  for (i = 0; i < ngotos; i++)
+    INDEX[i] = 0;
+
+  for (i = 0; i < ngotos; i++)
+    {
+      if (INDEX[i] == 0 && R[i])
+        traverse(i);
+    }
+
+  FREE(INDEX);
+  FREE(VERTICES);
+}
+
+
+
+void traverse(register int i)
+{
+  register unsigned *fp1;
+  register unsigned *fp2;
+  register unsigned *fp3;
+  register int j;
+  register short *rp;
+
+  int height;
+  unsigned *base;
+
+  VERTICES[++top] = i;
+  INDEX[i] = height = top;
+
+  base = F + i * tokensetsize;
+  fp3 = base + tokensetsize;
+
+  rp = R[i];
+  if (rp)
+    {
+      while ((j = *rp++) >= 0)
+        {
+          if (INDEX[j] == 0)
+            traverse(j);
+
+          if (INDEX[i] > INDEX[j])
+            INDEX[i] = INDEX[j];
+
+          fp1 = base;
+          fp2 = F + j * tokensetsize;
+
+          while (fp1 < fp3)
+            *fp1++ |= *fp2++;
+        }
+    }
+
+  if (INDEX[i] == height)
+    {
+      for (;;)
+        {
+          j = VERTICES[top--];
+          INDEX[j] = infinity;
+
+          if (i == j)
+            break;
+
+          fp1 = base;
+          fp2 = F + j * tokensetsize;
+
+          while (fp1 < fp3)
+            *fp2++ = *fp1++;
+        }
+    }
+}
diff --git a/yacc/lr0.c b/yacc/lr0.c
new file mode 100644
index 00000000..5cef9e5b
--- /dev/null
+++ b/yacc/lr0.c
@@ -0,0 +1,621 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+extern short *itemset;
+extern short *itemsetend;
+extern unsigned *ruleset;
+
+int nstates;
+core *first_state;
+shifts *first_shift;
+reductions *first_reduction;
+
+int get_state(int symbol);
+core *new_state(int symbol);
+
+static core **state_set;
+static core *this_state;
+static core *last_state;
+static shifts *last_shift;
+static reductions *last_reduction;
+
+static int nshifts;
+static short *shift_symbol;
+
+static short *redset;
+static short *shiftset;
+
+static short **kernel_base;
+static short **kernel_end;
+static short *kernel_items;
+
+
+
+void initialize_states (void);
+void save_reductions (void);
+void new_itemsets (void);
+void save_shifts (void);
+void print_derives (void);
+void show_cores (void), show_ritems (void), show_rrhs (void), show_shifts (void);
+
+void allocate_itemsets(void)
+{
+    register short *itemp;
+    register short *item_end;
+    register int symbol;
+    register int i;
+    register int count;
+    register int max;
+    register short *symbol_count;
+
+    count = 0;
+    symbol_count = NEW2(nsyms, short);
+
+    item_end = ritem + nitems;
+    for (itemp = ritem; itemp < item_end; itemp++)
+    {
+        symbol = *itemp;
+        if (symbol >= 0)
+        {
+            count++;
+            symbol_count[symbol]++;
+        }
+    }
+
+    kernel_base = NEW2(nsyms, short *);
+    kernel_items = NEW2(count, short);
+
+    count = 0;
+    max = 0;
+    for (i = 0; i < nsyms; i++)
+    {
+        kernel_base[i] = kernel_items + count;
+        count += symbol_count[i];
+        if (max < symbol_count[i])
+            max = symbol_count[i];
+    }
+
+    shift_symbol = symbol_count;
+    kernel_end = NEW2(nsyms, short *);
+}
+
+
+void allocate_storage(void)
+{
+    allocate_itemsets();
+    shiftset = NEW2(nsyms, short);
+    redset = NEW2(nrules + 1, short);
+    state_set = NEW2(nitems, core *);
+}
+
+
+void append_states(void)
+{
+    register int i;
+    register int j;
+    register int symbol;
+
+#ifdef        TRACE
+    fprintf(stderr, "Entering append_states()\n");
+#endif
+    for (i = 1; i < nshifts; i++)
+    {
+        symbol = shift_symbol[i];
+        j = i;
+        while (j > 0 && shift_symbol[j - 1] > symbol)
+        {
+            shift_symbol[j] = shift_symbol[j - 1];
+            j--;
+        }
+        shift_symbol[j] = symbol;
+    }
+
+    for (i = 0; i < nshifts; i++)
+    {
+        symbol = shift_symbol[i];
+        shiftset[i] = get_state(symbol);
+    }
+}
+
+
+void free_storage(void)
+{
+    FREE(shift_symbol);
+    FREE(redset);
+    FREE(shiftset);
+    FREE(kernel_base);
+    FREE(kernel_end);
+    FREE(kernel_items);
+    FREE(state_set);
+}
+
+
+
+void generate_states(void)
+{
+    allocate_storage();
+    itemset = NEW2(nitems, short);
+    ruleset = NEW2(WORDSIZE(nrules), unsigned);
+    set_first_derives();
+    initialize_states();
+
+    while (this_state)
+    {
+        closure(this_state->items, this_state->nitems);
+        save_reductions();
+        new_itemsets();
+        append_states();
+
+        if (nshifts > 0)
+            save_shifts();
+
+        this_state = this_state->next;
+    }
+
+    finalize_closure();
+    free_storage();
+}
+
+
+
+int
+get_state(int symbol)
+{
+    register int key;
+    register short *isp1;
+    register short *isp2;
+    register short *iend;
+    register core *sp;
+    register int found;
+    register int n;
+
+#ifdef        TRACE
+    fprintf(stderr, "Entering get_state(%d)\n", symbol);
+#endif
+
+    isp1 = kernel_base[symbol];
+    iend = kernel_end[symbol];
+    n = iend - isp1;
+
+    key = *isp1;
+    assert(0 <= key && key < nitems);
+    sp = state_set[key];
+    if (sp)
+    {
+        found = 0;
+        while (!found)
+        {
+            if (sp->nitems == n)
+            {
+                found = 1;
+                isp1 = kernel_base[symbol];
+                isp2 = sp->items;
+
+                while (found && isp1 < iend)
+                {
+                    if (*isp1++ != *isp2++)
+                        found = 0;
+                }
+            }
+
+            if (!found)
+            {
+                if (sp->link)
+                {
+                    sp = sp->link;
+                }
+                else
+                {
+                    sp = sp->link = new_state(symbol);
+                    found = 1;
+                }
+            }
+        }
+    }
+    else
+    {
+        state_set[key] = sp = new_state(symbol);
+    }
+
+    return (sp->number);
+}
+
+
+
+void initialize_states(void)
+{
+    register int i;
+    register short *start_derives;
+    register core *p;
+
+    start_derives = derives[start_symbol];
+    for (i = 0; start_derives[i] >= 0; ++i)
+        continue;
+
+    p = (core *) MALLOC(sizeof(core) + i*sizeof(short));
+    if (p == 0) no_space();
+
+    p->next = 0;
+    p->link = 0;
+    p->number = 0;
+    p->accessing_symbol = 0;
+    p->nitems = i;
+
+    for (i = 0;  start_derives[i] >= 0; ++i)
+        p->items[i] = rrhs[start_derives[i]];
+
+    first_state = last_state = this_state = p;
+    nstates = 1;
+}
+
+
+void new_itemsets(void)
+{
+    register int i;
+    register int shiftcount;
+    register short *isp;
+    register short *ksp;
+    register int symbol;
+
+    for (i = 0; i < nsyms; i++)
+        kernel_end[i] = 0;
+
+    shiftcount = 0;
+    isp = itemset;
+    while (isp < itemsetend)
+    {
+        i = *isp++;
+        symbol = ritem[i];
+        if (symbol > 0)
+        {
+            ksp = kernel_end[symbol];
+            if (!ksp)
+            {
+                shift_symbol[shiftcount++] = symbol;
+                ksp = kernel_base[symbol];
+            }
+
+            *ksp++ = i + 1;
+            kernel_end[symbol] = ksp;
+        }
+    }
+
+    nshifts = shiftcount;
+}
+
+
+
+core *
+new_state(int symbol)
+{
+    register int n;
+    register core *p;
+    register short *isp1;
+    register short *isp2;
+    register short *iend;
+
+#ifdef        TRACE
+    fprintf(stderr, "Entering new_state(%d)\n", symbol);
+#endif
+
+    if (nstates >= MAXSHORT)
+        fatal("too many states");
+
+    isp1 = kernel_base[symbol];
+    iend = kernel_end[symbol];
+    n = iend - isp1;
+
+    p = (core *) allocate((unsigned) (sizeof(core) + (n - 1) * sizeof(short)));
+    p->accessing_symbol = symbol;
+    p->number = nstates;
+    p->nitems = n;
+
+    isp2 = p->items;
+    while (isp1 < iend)
+        *isp2++ = *isp1++;
+
+    last_state->next = p;
+    last_state = p;
+
+    nstates++;
+
+    return (p);
+}
+
+
+/* show_cores is used for debugging */
+
+void show_cores(void)
+{
+    core *p;
+    int i, j, k, n;
+    int itemno;
+
+    k = 0;
+    for (p = first_state; p; ++k, p = p->next)
+    {
+        if (k) printf("\n");
+        printf("state %d, number = %d, accessing symbol = %s\n",
+                k, p->number, symbol_name[p->accessing_symbol]);
+        n = p->nitems;
+        for (i = 0; i < n; ++i)
+        {
+            itemno = p->items[i];
+            printf("%4d  ", itemno);
+            j = itemno;
+            while (ritem[j] >= 0) ++j;
+            printf("%s :", symbol_name[rlhs[-ritem[j]]]);
+            j = rrhs[-ritem[j]];
+            while (j < itemno)
+                printf(" %s", symbol_name[ritem[j++]]);
+            printf(" .");
+            while (ritem[j] >= 0)
+                printf(" %s", symbol_name[ritem[j++]]);
+            printf("\n");
+            fflush(stdout);
+        }
+    }
+}
+
+
+/* show_ritems is used for debugging */
+
+void show_ritems(void)
+{
+    int i;
+
+    for (i = 0; i < nitems; ++i)
+        printf("ritem[%d] = %d\n", i, ritem[i]);
+}
+
+
+/* show_rrhs is used for debugging */
+
+void show_rrhs(void)
+{
+    int i;
+
+    for (i = 0; i < nrules; ++i)
+        printf("rrhs[%d] = %d\n", i, rrhs[i]);
+}
+
+
+/* show_shifts is used for debugging */
+
+void show_shifts(void)
+{
+    shifts *p;
+    int i, j, k;
+
+    k = 0;
+    for (p = first_shift; p; ++k, p = p->next)
+    {
+        if (k) printf("\n");
+        printf("shift %d, number = %d, nshifts = %d\n", k, p->number,
+                p->nshifts);
+        j = p->nshifts;
+        for (i = 0; i < j; ++i)
+            printf("\t%d\n", p->shift[i]);
+    }
+}
+
+
+void save_shifts(void)
+{
+    register shifts *p;
+    register short *sp1;
+    register short *sp2;
+    register short *send;
+
+    p = (shifts *) allocate((unsigned) (sizeof(shifts) +
+                        (nshifts - 1) * sizeof(short)));
+
+    p->number = this_state->number;
+    p->nshifts = nshifts;
+
+    sp1 = shiftset;
+    sp2 = p->shift;
+    send = shiftset + nshifts;
+
+    while (sp1 < send)
+        *sp2++ = *sp1++;
+
+    if (last_shift)
+    {
+        last_shift->next = p;
+        last_shift = p;
+    }
+    else
+    {
+        first_shift = p;
+        last_shift = p;
+    }
+}
+
+
+
+void save_reductions(void)
+{
+    register short *isp;
+    register short *rp1;
+    register short *rp2;
+    register int item;
+    register int count;
+    register reductions *p;
+    register short *rend;
+
+    count = 0;
+    for (isp = itemset; isp < itemsetend; isp++)
+    {
+        item = ritem[*isp];
+        if (item < 0)
+        {
+            redset[count++] = -item;
+        }
+    }
+
+    if (count)
+    {
+        p = (reductions *) allocate((unsigned) (sizeof(reductions) +
+                                        (count - 1) * sizeof(short)));
+
+        p->number = this_state->number;
+        p->nreds = count;
+
+        rp1 = redset;
+        rp2 = p->rules;
+        rend = rp1 + count;
+
+        while (rp1 < rend)
+            *rp2++ = *rp1++;
+
+        if (last_reduction)
+        {
+            last_reduction->next = p;
+            last_reduction = p;
+        }
+        else
+        {
+            first_reduction = p;
+            last_reduction = p;
+        }
+    }
+}
+
+
+void set_derives(void)
+{
+    register int i, k;
+    register int lhs;
+    register short *rules;
+
+    derives = NEW2(nsyms, short *);
+    rules = NEW2(nvars + nrules, short);
+
+    k = 0;
+    for (lhs = start_symbol; lhs < nsyms; lhs++)
+    {
+        derives[lhs] = rules + k;
+        for (i = 0; i < nrules; i++)
+        {
+            if (rlhs[i] == lhs)
+            {
+                rules[k] = i;
+                k++;
+            }
+        }
+        rules[k] = -1;
+        k++;
+    }
+
+#ifdef        DEBUG
+    print_derives();
+#endif
+}
+
+void free_derives(void)
+{
+    FREE(derives[start_symbol]);
+    FREE(derives);
+}
+
+#ifdef        DEBUG
+void print_derives(void)
+{
+    register int i;
+    register short *sp;
+
+    printf("\nDERIVES\n\n");
+
+    for (i = start_symbol; i < nsyms; i++)
+    {
+        printf("%s derives ", symbol_name[i]);
+        for (sp = derives[i]; *sp >= 0; sp++)
+        {
+            printf("  %d", *sp);
+        }
+        putchar('\n');
+    }
+
+    putchar('\n');
+}
+#endif
+
+
+void set_nullable(void)
+{
+    register int i, j;
+    register int empty;
+    int done;
+
+    nullable = MALLOC(nsyms);
+    if (nullable == 0) no_space();
+
+    for (i = 0; i < nsyms; ++i)
+        nullable[i] = 0;
+
+    done = 0;
+    while (!done)
+    {
+        done = 1;
+        for (i = 1; i < nitems; i++)
+        {
+            empty = 1;
+            while ((j = ritem[i]) >= 0)
+            {
+                if (!nullable[j])
+                    empty = 0;
+                ++i;
+            }
+            if (empty)
+            {
+                j = rlhs[-j];
+                if (!nullable[j])
+                {
+                    nullable[j] = 1;
+                    done = 0;
+                }
+            }
+        }
+    }
+
+#ifdef DEBUG
+    for (i = 0; i < nsyms; i++)
+    {
+        if (nullable[i])
+            printf("%s is nullable\n", symbol_name[i]);
+        else
+            printf("%s is not nullable\n", symbol_name[i]);
+    }
+#endif
+}
+
+
+void free_nullable(void)
+{
+    FREE(nullable);
+}
+
+
+void lr0(void)
+{
+    set_derives();
+    set_nullable();
+    generate_states();
+}
diff --git a/yacc/main.c b/yacc/main.c
new file mode 100644
index 00000000..e7606dae
--- /dev/null
+++ b/yacc/main.c
@@ -0,0 +1,470 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include 
+#include 
+#include "defs.h"
+#ifdef HAS_UNISTD
+#include 
+#endif
+
+#include "version.h"
+
+char dflag;
+char lflag;
+char rflag;
+char tflag;
+char vflag;
+char qflag;
+char eflag;
+char sflag;
+char big_endian;
+
+char *file_prefix = 0;
+char *myname = "yacc";
+char temp_form[] = "yacc.XXXXXXX";
+
+#ifdef NO_UNIX
+char dirsep = '\\';
+#else
+char dirsep = '/';
+#endif
+
+int lineno;
+char *virtual_input_file_name = NULL;
+int outline;
+
+char *action_file_name;
+char *entry_file_name;
+char *code_file_name;
+char *interface_file_name;
+char *defines_file_name;
+char *input_file_name = "";
+char *output_file_name;
+char *text_file_name;
+char *union_file_name;
+char *verbose_file_name;
+
+#ifdef HAS_MKSTEMP
+int action_fd = -1, entry_fd = -1, text_fd = -1, union_fd = -1;
+#endif
+
+FILE *action_file;      /*  a temp file, used to save actions associated    */
+                        /*  with rules until the parser is written          */
+FILE *entry_file;
+FILE *code_file;        /*  y.code.c (used when the -r option is specified) */
+FILE *defines_file;     /*  y.tab.h                                         */
+FILE *input_file;       /*  the input file                                  */
+FILE *output_file;      /*  y.tab.c                                         */
+FILE *text_file;        /*  a temp file, used to save text until all        */
+                        /*  symbols have been defined                       */
+FILE *union_file;       /*  a temp file, used to save the union             */
+                        /*  definition until all symbol have been           */
+                        /*  defined                                         */
+FILE *verbose_file;     /*  y.output                                        */
+FILE *interface_file;
+
+int nitems;
+int nrules;
+int ntotalrules;
+int nsyms;
+int ntokens;
+int nvars;
+
+int   start_symbol;
+char  **symbol_name;
+short *symbol_value;
+short *symbol_prec;
+char  *symbol_assoc;
+char **symbol_tag;
+char *symbol_true_token;
+
+short *ritem;
+short *rlhs;
+short *rrhs;
+short *rprec;
+char  *rassoc;
+short **derives;
+char *nullable;
+
+#if !defined(HAS_MKSTEMP)
+extern char *mktemp(char *);
+#endif
+#ifndef NO_UNIX
+extern char *getenv(const char *);
+#endif
+
+
+void done(int k)
+{
+#ifdef HAS_MKSTEMP
+    if (action_fd != -1)
+       unlink(action_file_name);
+    if (entry_fd != -1)
+       unlink(entry_file_name);
+    if (text_fd != -1)
+       unlink(text_file_name);
+    if (union_fd != -1)
+       unlink(union_file_name);
+#else
+    if (action_file) { fclose(action_file); unlink(action_file_name); }
+    if (entry_file) { fclose(entry_file); unlink(entry_file_name); }
+    if (text_file) { fclose(text_file); unlink(text_file_name); }
+    if (union_file) { fclose(union_file); unlink(union_file_name); }
+#endif
+    if (output_file && k > 0) {
+      fclose(output_file); unlink(output_file_name);
+    }
+    if (interface_file && k > 0) {
+      fclose(interface_file); unlink(interface_file_name);
+    }
+    exit(k);
+}
+
+
+void onintr(int dummy)
+{
+    done(1);
+}
+
+
+void set_signals(void)
+{
+#ifdef SIGINT
+    if (signal(SIGINT, SIG_IGN) != SIG_IGN)
+        signal(SIGINT, onintr);
+#endif
+#ifdef SIGTERM
+    if (signal(SIGTERM, SIG_IGN) != SIG_IGN)
+        signal(SIGTERM, onintr);
+#endif
+#ifdef SIGHUP
+    if (signal(SIGHUP, SIG_IGN) != SIG_IGN)
+        signal(SIGHUP, onintr);
+#endif
+}
+
+
+void usage(void)
+{
+    fprintf(stderr, "usage: %s [-v] [--strict] [-q] [-b file_prefix] filename\n",
+            myname);
+    exit(1);
+}
+
+void getargs(int argc, char **argv)
+{
+    register int i;
+    register char *s;
+
+    if (argc > 0) myname = argv[0];
+    for (i = 1; i < argc; ++i)
+    {
+        s = argv[i];
+        if (*s != '-') break;
+        switch (*++s)
+        {
+        case '\0':
+            input_file = stdin;
+            file_prefix = "stdin";
+            if (i + 1 < argc) usage();
+            return;
+
+        case '-':
+            if (!strcmp (argv[i], "--strict")){
+              eflag = 1;
+              goto end_of_option;
+            }
+            ++i;
+            goto no_more_options;
+
+        case 'v':
+            if (!strcmp (argv[i], "-version")){
+              printf ("The OCaml parser generator, version "
+                      OCAML_VERSION "\n");
+              exit (0);
+            }else if (!strcmp (argv[i], "-vnum")){
+              printf (OCAML_VERSION "\n");
+              exit (0);
+            }else{
+              vflag = 1;
+            }
+            break;
+
+        case 'q':
+            qflag = 1;
+            break;
+
+        case 'b':
+            if (*++s)
+                 file_prefix = s;
+            else if (++i < argc)
+                file_prefix = argv[i];
+            else
+                usage();
+            continue;
+
+        default:
+            usage();
+        }
+
+        for (;;)
+        {
+            switch (*++s)
+            {
+            case '\0':
+                goto end_of_option;
+
+            case 'v':
+                vflag = 1;
+                break;
+
+            case 'q':
+                qflag = 1;
+                break;
+
+            default:
+                usage();
+            }
+        }
+end_of_option:;
+    }
+
+no_more_options:;
+    if (i + 1 != argc) usage();
+    input_file_name = argv[i];
+    if (file_prefix == 0) {
+      int len;
+      len = strlen(argv[i]);
+      file_prefix = malloc(len + 1);
+      if (file_prefix == 0) no_space();
+      strcpy(file_prefix, argv[i]);
+      while (len > 0) {
+        len--;
+        if (file_prefix[len] == '.') {
+          file_prefix[len] = 0;
+          break;
+        }
+      }
+    }
+}
+
+
+char *
+allocate(unsigned int n)
+{
+    register char *p;
+
+    p = NULL;
+    if (n)
+    {
+        p = CALLOC(1, n);
+        if (!p) no_space();
+    }
+    return (p);
+}
+
+
+void create_file_names(void)
+{
+    int i, len;
+    char *tmpdir;
+
+#ifdef NO_UNIX
+    tmpdir = getenv("TEMP");
+    if (tmpdir == 0) tmpdir = ".";
+#else
+    tmpdir = getenv("TMPDIR");
+    if (tmpdir == 0) tmpdir = "/tmp";
+#endif
+    len = strlen(tmpdir);
+    i = len + sizeof(temp_form);
+    if (len && tmpdir[len-1] != dirsep)
+        ++i;
+
+    action_file_name = MALLOC(i);
+    if (action_file_name == 0) no_space();
+    entry_file_name = MALLOC(i);
+    if (entry_file_name == 0) no_space();
+    text_file_name = MALLOC(i);
+    if (text_file_name == 0) no_space();
+    union_file_name = MALLOC(i);
+    if (union_file_name == 0) no_space();
+
+    strcpy(action_file_name, tmpdir);
+    strcpy(entry_file_name, tmpdir);
+    strcpy(text_file_name, tmpdir);
+    strcpy(union_file_name, tmpdir);
+
+    if (len && tmpdir[len - 1] != dirsep)
+    {
+        action_file_name[len] = dirsep;
+        entry_file_name[len] = dirsep;
+        text_file_name[len] = dirsep;
+        union_file_name[len] = dirsep;
+        ++len;
+    }
+
+    strcpy(action_file_name + len, temp_form);
+    strcpy(entry_file_name + len, temp_form);
+    strcpy(text_file_name + len, temp_form);
+    strcpy(union_file_name + len, temp_form);
+
+    action_file_name[len + 5] = 'a';
+    entry_file_name[len + 5] = 'e';
+    text_file_name[len + 5] = 't';
+    union_file_name[len + 5] = 'u';
+
+#ifdef HAS_MKSTEMP
+    action_fd = mkstemp(action_file_name);
+    if (action_fd == -1)
+        open_error(action_file_name);
+    entry_fd = mkstemp(entry_file_name);
+    if (entry_fd == -1)
+        open_error(entry_file_name);
+    text_fd = mkstemp(text_file_name);
+    if (text_fd == -1)
+        open_error(text_file_name);
+    union_fd = mkstemp(union_file_name);
+    if (union_fd == -1)
+        open_error(union_file_name);
+#else
+    mktemp(action_file_name);
+    mktemp(entry_file_name);
+    mktemp(text_file_name);
+    mktemp(union_file_name);
+#endif
+
+    len = strlen(file_prefix);
+
+    output_file_name = MALLOC(len + 7);
+    if (output_file_name == 0)
+        no_space();
+    strcpy(output_file_name, file_prefix);
+    strcpy(output_file_name + len, OUTPUT_SUFFIX);
+
+    code_file_name = output_file_name;
+
+    if (vflag)
+    {
+        verbose_file_name = MALLOC(len + 8);
+        if (verbose_file_name == 0)
+            no_space();
+        strcpy(verbose_file_name, file_prefix);
+        strcpy(verbose_file_name + len, VERBOSE_SUFFIX);
+    }
+
+    interface_file_name = MALLOC(len + 8);
+    if (interface_file_name == 0)
+        no_space();
+    strcpy(interface_file_name, file_prefix);
+    strcpy(interface_file_name + len, INTERFACE_SUFFIX);
+
+}
+
+
+void open_files(void)
+{
+    create_file_names();
+
+    if (input_file == 0)
+    {
+        input_file = fopen(input_file_name, "r");
+        if (input_file == 0)
+            open_error(input_file_name);
+    }
+
+#ifdef HAS_MKSTEMP
+    action_file = fdopen(action_fd, "w");
+#else
+    action_file = fopen(action_file_name, "w");
+#endif
+    if (action_file == 0)
+        open_error(action_file_name);
+
+#ifdef HAS_MKSTEMP
+    entry_file = fdopen(entry_fd, "w");
+#else
+    entry_file = fopen(entry_file_name, "w");
+#endif
+    if (entry_file == 0)
+        open_error(entry_file_name);
+
+#ifdef HAS_MKSTEMP
+    text_file = fdopen(text_fd, "w");
+#else
+    text_file = fopen(text_file_name, "w");
+#endif
+    if (text_file == 0)
+        open_error(text_file_name);
+
+    if (vflag)
+    {
+        verbose_file = fopen(verbose_file_name, "w");
+        if (verbose_file == 0)
+            open_error(verbose_file_name);
+    }
+
+    if (dflag)
+    {
+        defines_file = fopen(defines_file_name, "w");
+        if (defines_file == 0)
+            open_error(defines_file_name);
+#ifdef HAS_MKSTEMP
+        union_file = fdopen(union_fd, "w");
+#else
+        union_file = fopen(union_file_name, "w");
+#endif
+        if (union_file ==  0)
+            open_error(union_file_name);
+    }
+
+    output_file = fopen(output_file_name, "w");
+    if (output_file == 0)
+        open_error(output_file_name);
+
+    if (rflag)
+    {
+        code_file = fopen(code_file_name, "w");
+        if (code_file == 0)
+            open_error(code_file_name);
+    }
+    else
+        code_file = output_file;
+
+
+    interface_file = fopen(interface_file_name, "w");
+    if (interface_file == 0)
+      open_error(interface_file_name);
+}
+
+int main(int argc, char **argv)
+{
+    set_signals();
+    getargs(argc, argv);
+    open_files();
+    reader();
+    lr0();
+    lalr();
+    make_parser();
+    verbose();
+    if (eflag && SRtotal + RRtotal > 0) forbidden_conflicts();
+    output();
+    done(0);
+    /*NOTREACHED*/
+    return 0;
+}
diff --git a/yacc/mkpar.c b/yacc/mkpar.c
new file mode 100644
index 00000000..79b2f928
--- /dev/null
+++ b/yacc/mkpar.c
@@ -0,0 +1,365 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+action **parser;
+int SRtotal;
+int RRtotal;
+short *SRconflicts;
+short *RRconflicts;
+short *defred;
+short *rules_used;
+short nunused;
+short final_state;
+
+static int SRcount;
+static int RRcount;
+
+void find_final_state (void);
+void remove_conflicts (void);
+void unused_rules (void);
+void total_conflicts (void);
+void defreds (void);
+
+void make_parser(void)
+{
+    register int i;
+
+    parser = NEW2(nstates, action *);
+    for (i = 0; i < nstates; i++)
+        parser[i] = parse_actions(i);
+
+    find_final_state();
+    remove_conflicts();
+    unused_rules();
+    if (SRtotal + RRtotal > 0) total_conflicts();
+    defreds();
+}
+
+
+action *
+parse_actions(register int stateno)
+{
+    register action *actions;
+
+    actions = get_shifts(stateno);
+    actions = add_reductions(stateno, actions);
+    return (actions);
+}
+
+
+action *
+get_shifts(int stateno)
+{
+    register action *actions, *temp;
+    register shifts *sp;
+    register short *to_state;
+    register int i, k;
+    register int symbol;
+
+    actions = 0;
+    sp = shift_table[stateno];
+    if (sp)
+    {
+        to_state = sp->shift;
+        for (i = sp->nshifts - 1; i >= 0; i--)
+        {
+            k = to_state[i];
+            symbol = accessing_symbol[k];
+            if (ISTOKEN(symbol))
+            {
+                temp = NEW(action);
+                temp->next = actions;
+                temp->symbol = symbol;
+                temp->number = k;
+                temp->prec = symbol_prec[symbol];
+                temp->action_code = SHIFT;
+                temp->assoc = symbol_assoc[symbol];
+                actions = temp;
+            }
+        }
+    }
+    return (actions);
+}
+
+action *
+add_reductions(int stateno, register action *actions)
+{
+    register int i, j, m, n;
+    register int ruleno, tokensetsize;
+    register unsigned *rowp;
+
+    tokensetsize = WORDSIZE(ntokens);
+    m = lookaheads[stateno];
+    n = lookaheads[stateno + 1];
+    for (i = m; i < n; i++)
+    {
+        ruleno = LAruleno[i];
+        rowp = LA + i * tokensetsize;
+        for (j = ntokens - 1; j >= 0; j--)
+        {
+            if (BIT(rowp, j))
+                actions = add_reduce(actions, ruleno, j);
+        }
+    }
+    return (actions);
+}
+
+
+action *
+add_reduce(register action *actions, register int ruleno, register int symbol)
+{
+    register action *temp, *prev, *next;
+
+    prev = 0;
+    for (next = actions; next && next->symbol < symbol; next = next->next)
+        prev = next;
+
+    while (next && next->symbol == symbol && next->action_code == SHIFT)
+    {
+        prev = next;
+        next = next->next;
+    }
+
+    while (next && next->symbol == symbol &&
+            next->action_code == REDUCE && next->number < ruleno)
+    {
+        prev = next;
+        next = next->next;
+    }
+
+    temp = NEW(action);
+    temp->next = next;
+    temp->symbol = symbol;
+    temp->number = ruleno;
+    temp->prec = rprec[ruleno];
+    temp->action_code = REDUCE;
+    temp->assoc = rassoc[ruleno];
+
+    if (prev)
+        prev->next = temp;
+    else
+        actions = temp;
+
+    return (actions);
+}
+
+
+void find_final_state(void)
+{
+    register int goal, i;
+    register short *to_state;
+    register shifts *p;
+
+    p = shift_table[0];
+    to_state = p->shift;
+    goal = ritem[1];
+    for (i = p->nshifts - 1; i >= 0; --i)
+    {
+        final_state = to_state[i];
+        if (accessing_symbol[final_state] == goal) break;
+    }
+}
+
+
+void unused_rules(void)
+{
+    register int i;
+    register action *p;
+
+    rules_used = (short *) MALLOC(nrules*sizeof(short));
+    if (rules_used == 0) no_space();
+
+    for (i = 0; i < nrules; ++i)
+        rules_used[i] = 0;
+
+    for (i = 0; i < nstates; ++i)
+    {
+        for (p = parser[i]; p; p = p->next)
+        {
+            if (p->action_code == REDUCE && p->suppressed == 0)
+                rules_used[p->number] = 1;
+        }
+    }
+
+    nunused = 0;
+    for (i = 3; i < nrules; ++i)
+        if (!rules_used[i]) ++nunused;
+
+    if (nunused){
+        if (nunused == 1)
+            fprintf(stderr, "1 rule never reduced\n");
+        else
+            fprintf(stderr, "%d rules never reduced\n", nunused);
+    }
+}
+
+
+void remove_conflicts(void)
+{
+    register int i;
+    register int symbol;
+    register action *p, *pref;
+
+    SRtotal = 0;
+    RRtotal = 0;
+    SRconflicts = NEW2(nstates, short);
+    RRconflicts = NEW2(nstates, short);
+    pref = NULL;
+    for (i = 0; i < nstates; i++)
+    {
+        SRcount = 0;
+        RRcount = 0;
+        symbol = -1;
+        for (p = parser[i]; p; p = p->next)
+        {
+            if (p->symbol != symbol)
+            {
+                pref = p;
+                symbol = p->symbol;
+            }
+            else if (i == final_state && symbol == 0)
+            {
+                SRcount++;
+                p->suppressed = 1;
+            }
+            else if (pref->action_code == SHIFT)
+            {
+                if (pref->prec > 0 && p->prec > 0)
+                {
+                    if (pref->prec < p->prec)
+                    {
+                        pref->suppressed = 2;
+                        pref = p;
+                    }
+                    else if (pref->prec > p->prec)
+                    {
+                        p->suppressed = 2;
+                    }
+                    else if (pref->assoc == LEFT)
+                    {
+                        pref->suppressed = 2;
+                        pref = p;
+                    }
+                    else if (pref->assoc == RIGHT)
+                    {
+                        p->suppressed = 2;
+                    }
+                    else
+                    {
+                        pref->suppressed = 2;
+                        p->suppressed = 2;
+                    }
+                }
+                else
+                {
+                    SRcount++;
+                    p->suppressed = 1;
+                }
+            }
+            else
+            {
+                RRcount++;
+                p->suppressed = 1;
+            }
+        }
+        SRtotal += SRcount;
+        RRtotal += RRcount;
+        SRconflicts[i] = SRcount;
+        RRconflicts[i] = RRcount;
+    }
+}
+
+
+void total_conflicts(void)
+{
+    if (SRtotal == 1)
+        fprintf(stderr, "1 shift/reduce conflict");
+    else if (SRtotal > 1)
+        fprintf(stderr, "%d shift/reduce conflicts", SRtotal);
+
+    if (SRtotal && RRtotal)
+        fprintf(stderr, ", ");
+
+    if (RRtotal == 1)
+        fprintf(stderr, "1 reduce/reduce conflict");
+    else if (RRtotal > 1)
+        fprintf(stderr, "%d reduce/reduce conflicts", RRtotal);
+
+    fprintf(stderr, ".\n");
+}
+
+
+int
+sole_reduction(int stateno)
+{
+    register int count, ruleno;
+    register action *p;
+
+    count = 0;
+    ruleno = 0;
+    for (p = parser[stateno]; p; p = p->next)
+    {
+        if (p->action_code == SHIFT && p->suppressed == 0)
+            return (0);
+        else if (p->action_code == REDUCE && p->suppressed == 0)
+        {
+            if (ruleno > 0 && p->number != ruleno)
+                return (0);
+            if (p->symbol != 1)
+                ++count;
+            ruleno = p->number;
+        }
+    }
+
+    if (count == 0)
+        return (0);
+    return (ruleno);
+}
+
+
+void defreds(void)
+{
+    register int i;
+
+    defred = NEW2(nstates, short);
+    for (i = 0; i < nstates; i++)
+        defred[i] = sole_reduction(i);
+}
+
+void free_action_row(register action *p)
+{
+  register action *q;
+
+  while (p)
+    {
+      q = p->next;
+      FREE(p);
+      p = q;
+    }
+}
+
+void free_parser(void)
+{
+  register int i;
+
+  for (i = 0; i < nstates; i++)
+    free_action_row(parser[i]);
+
+  FREE(parser);
+}
diff --git a/yacc/output.c b/yacc/output.c
new file mode 100644
index 00000000..4e871dec
--- /dev/null
+++ b/yacc/output.c
@@ -0,0 +1,985 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+static int nvectors;
+static int nentries;
+static short **froms;
+static short **tos;
+static short *tally;
+static short *width;
+static short *state_count;
+static short *order;
+static short *base;
+static short *pos;
+static int maxtable;
+static short *table;
+static short *check;
+static int lowzero;
+static int high;
+
+
+void free_itemsets (void);
+void free_shifts (void);
+void free_reductions (void);
+void output_stored_text (void);
+void output_transl (void);
+void output_rule_data (void);
+void output_yydefred (void);
+void output_actions (void);
+void output_debug (void);
+void output_trailing_text (void);
+void output_semantic_actions (void);
+void output_entries (void);
+void token_actions (void);
+void goto_actions (void);
+void sort_actions (void);
+void pack_table (void);
+void output_base (void);
+void output_table (void);
+void output_check (void);
+int default_goto (int symbol);
+void save_column (int symbol, int default_state);
+int matching_vector (int vector);
+int pack_vector (int vector);
+
+
+void output(void)
+{
+  extern char *header[], *define_tables[];
+
+  free_itemsets();
+  free_shifts();
+  free_reductions();
+  write_section(header);
+  output_stored_text();
+  output_transl();
+  output_rule_data();
+  output_yydefred();
+  output_actions();
+  output_debug();
+  free_parser();
+  if (sflag){
+    if (!rflag) ++outline;
+    fprintf(output_file,
+      "let yyact = Array.new %d (fun _ -> (failwith \"parser\" : Obj.t))\n",
+      ntotalrules);
+  }else{
+    if (!rflag) outline += 2;
+    fprintf(output_file,
+      "let yyact = [|\n  (fun _ -> failwith \"parser\")\n");
+  }
+  output_semantic_actions();
+  if (!sflag){
+    if (!rflag) ++outline;
+    fprintf(output_file, "|]\n");
+  }
+  write_section(define_tables);
+  output_entries();
+  output_trailing_text();
+}
+
+
+static void output_char(unsigned int n)
+{
+  n = n & 0xFF;
+  putc('\\', output_file);
+  putc('0' + n / 100, output_file);
+  putc('0' + (n / 10) % 10, output_file);
+  putc('0' + n % 10, output_file);
+}
+
+static void output_short(int n)
+{
+  output_char(n);
+  output_char(n >> 8);
+}
+
+void output_rule_data(void)
+{
+    register int i;
+    register int j;
+
+
+    fprintf(output_file, "let yylhs = \"");
+    output_short(symbol_value[start_symbol]);
+
+    j = 8;
+    for (i = 3; i < nrules; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        output_short(symbol_value[rlhs[i]]);
+    }
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+
+    fprintf(output_file, "let yylen = \"");
+    output_short(2);
+
+    j = 8;
+    for (i = 3; i < nrules; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+          j++;
+
+        output_short(rrhs[i + 1] - rrhs[i] - 1);
+    }
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+}
+
+
+void output_yydefred(void)
+{
+    register int i, j;
+
+    fprintf(output_file, "let yydefred = \"");
+    output_short(defred[0] ? defred[0] - 2 : 0);
+
+    j = 8;
+    for (i = 1; i < nstates; i++)
+    {
+        if (j < 8)
+            ++j;
+        else
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+
+        output_short(defred[i] ? defred[i] - 2 : 0);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+}
+
+
+void output_actions(void)
+{
+    nvectors = 2*nstates + nvars;
+
+    froms = NEW2(nvectors, short *);
+    tos = NEW2(nvectors, short *);
+    tally = NEW2(nvectors, short);
+    width = NEW2(nvectors, short);
+
+    token_actions();
+    FREE(lookaheads);
+    FREE(LA);
+    FREE(LAruleno);
+    FREE(accessing_symbol);
+
+    goto_actions();
+    FREE(goto_map + ntokens);
+    FREE(from_state);
+    FREE(to_state);
+
+    sort_actions();
+    pack_table();
+    output_base();
+    output_table();
+    output_check();
+}
+
+
+void token_actions(void)
+{
+    register int i, j;
+    register int shiftcount, reducecount;
+    register int max, min;
+    register short *actionrow, *r, *s;
+    register action *p;
+
+    actionrow = NEW2(2*ntokens, short);
+    for (i = 0; i < nstates; ++i)
+    {
+        if (parser[i])
+        {
+            for (j = 0; j < 2*ntokens; ++j)
+            actionrow[j] = 0;
+
+            shiftcount = 0;
+            reducecount = 0;
+            for (p = parser[i]; p; p = p->next)
+            {
+                if (p->suppressed == 0)
+                {
+                    if (p->action_code == SHIFT)
+                    {
+                        ++shiftcount;
+                        actionrow[p->symbol] = p->number;
+                    }
+                    else if (p->action_code == REDUCE && p->number != defred[i])
+                    {
+                        ++reducecount;
+                        actionrow[p->symbol + ntokens] = p->number;
+                    }
+                }
+            }
+
+            tally[i] = shiftcount;
+            tally[nstates+i] = reducecount;
+            width[i] = 0;
+            width[nstates+i] = 0;
+            if (shiftcount > 0)
+            {
+                froms[i] = r = NEW2(shiftcount, short);
+                tos[i] = s = NEW2(shiftcount, short);
+                min = MAXSHORT;
+                max = 0;
+                for (j = 0; j < ntokens; ++j)
+                {
+                    if (actionrow[j])
+                    {
+                        if (min > symbol_value[j])
+                            min = symbol_value[j];
+                        if (max < symbol_value[j])
+                            max = symbol_value[j];
+                        *r++ = symbol_value[j];
+                        *s++ = actionrow[j];
+                    }
+                }
+                width[i] = max - min + 1;
+            }
+            if (reducecount > 0)
+            {
+                froms[nstates+i] = r = NEW2(reducecount, short);
+                tos[nstates+i] = s = NEW2(reducecount, short);
+                min = MAXSHORT;
+                max = 0;
+                for (j = 0; j < ntokens; ++j)
+                {
+                    if (actionrow[ntokens+j])
+                    {
+                        if (min > symbol_value[j])
+                            min = symbol_value[j];
+                        if (max < symbol_value[j])
+                            max = symbol_value[j];
+                        *r++ = symbol_value[j];
+                        *s++ = actionrow[ntokens+j] - 2;
+                    }
+                }
+                width[nstates+i] = max - min + 1;
+            }
+        }
+    }
+    FREE(actionrow);
+}
+
+void goto_actions(void)
+{
+    register int i, j, k;
+
+    state_count = NEW2(nstates, short);
+
+    k = default_goto(start_symbol + 1);
+    fprintf(output_file, "let yydgoto = \"");
+    output_short(k);
+
+    save_column(start_symbol + 1, k);
+
+    j = 8;
+    for (i = start_symbol + 2; i < nsyms; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        k = default_goto(i);
+        output_short(k);
+        save_column(i, k);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+    FREE(state_count);
+}
+
+int
+default_goto(int symbol)
+{
+    register int i;
+    register int m;
+    register int n;
+    register int default_state;
+    register int max;
+
+    m = goto_map[symbol];
+    n = goto_map[symbol + 1];
+
+    if (m == n) return (0);
+
+    for (i = 0; i < nstates; i++)
+        state_count[i] = 0;
+
+    for (i = m; i < n; i++)
+        state_count[to_state[i]]++;
+
+    max = 0;
+    default_state = 0;
+    for (i = 0; i < nstates; i++)
+    {
+        if (state_count[i] > max)
+        {
+            max = state_count[i];
+            default_state = i;
+        }
+    }
+
+    return (default_state);
+}
+
+
+
+void save_column(int symbol, int default_state)
+{
+    register int i;
+    register int m;
+    register int n;
+    register short *sp;
+    register short *sp1;
+    register short *sp2;
+    register int count;
+    register int symno;
+
+    m = goto_map[symbol];
+    n = goto_map[symbol + 1];
+
+    count = 0;
+    for (i = m; i < n; i++)
+    {
+        if (to_state[i] != default_state)
+            ++count;
+    }
+    if (count == 0) return;
+
+    symno = symbol_value[symbol] + 2*nstates;
+
+    froms[symno] = sp1 = sp = NEW2(count, short);
+    tos[symno] = sp2 = NEW2(count, short);
+
+    for (i = m; i < n; i++)
+    {
+        if (to_state[i] != default_state)
+        {
+            *sp1++ = from_state[i];
+            *sp2++ = to_state[i];
+        }
+    }
+
+    tally[symno] = count;
+    width[symno] = sp1[-1] - sp[0] + 1;
+}
+
+void sort_actions(void)
+{
+  register int i;
+  register int j;
+  register int k;
+  register int t;
+  register int w;
+
+  order = NEW2(nvectors, short);
+  nentries = 0;
+
+  for (i = 0; i < nvectors; i++)
+    {
+      if (tally[i] > 0)
+        {
+          t = tally[i];
+          w = width[i];
+          j = nentries - 1;
+
+          while (j >= 0 && (width[order[j]] < w))
+            j--;
+
+          while (j >= 0 && (width[order[j]] == w) && (tally[order[j]] < t))
+            j--;
+
+          for (k = nentries - 1; k > j; k--)
+            order[k + 1] = order[k];
+
+          order[j + 1] = i;
+          nentries++;
+        }
+    }
+}
+
+
+void pack_table(void)
+{
+    register int i;
+    register int place;
+    register int state;
+
+    base = NEW2(nvectors, short);
+    pos = NEW2(nentries, short);
+
+    maxtable = 1000;
+    table = NEW2(maxtable, short);
+    check = NEW2(maxtable, short);
+
+    lowzero = 0;
+    high = 0;
+
+    for (i = 0; i < maxtable; i++)
+        check[i] = -1;
+
+    for (i = 0; i < nentries; i++)
+    {
+        state = matching_vector(i);
+
+        if (state < 0)
+            place = pack_vector(i);
+        else
+            place = base[state];
+
+        pos[i] = place;
+        base[order[i]] = place;
+    }
+
+    for (i = 0; i < nvectors; i++)
+    {
+        if (froms[i])
+            FREE(froms[i]);
+        if (tos[i])
+            FREE(tos[i]);
+    }
+
+    FREE(froms);
+    FREE(tos);
+    FREE(pos);
+}
+
+
+/*  The function matching_vector determines if the vector specified by    */
+/*  the input parameter matches a previously considered vector.  The      */
+/*  test at the start of the function checks if the vector represents     */
+/*  a row of shifts over terminal symbols or a row of reductions, or a    */
+/*  column of shifts over a nonterminal symbol.  Berkeley Yacc does not   */
+/*  check if a column of shifts over a nonterminal symbols matches a      */
+/*  previously considered vector.  Because of the nature of LR parsing    */
+/*  tables, no two columns can match.  Therefore, the only possible       */
+/*  match would be between a row and a column.  Such matches are          */
+/*  unlikely.  Therefore, to save time, no attempt is made to see if a    */
+/*  column matches a previously considered vector.                        */
+/*                                                                        */
+/*  Matching_vector is poorly designed.  The test could easily be made    */
+/*  faster.  Also, it depends on the vectors being in a specific          */
+/*  order.                                                                */
+
+int
+matching_vector(int vector)
+{
+    register int i;
+    register int j;
+    register int k;
+    register int t;
+    register int w;
+    register int match;
+    register int prev;
+
+    i = order[vector];
+    if (i >= 2*nstates)
+        return (-1);
+
+    t = tally[i];
+    w = width[i];
+
+    for (prev = vector - 1; prev >= 0; prev--)
+    {
+        j = order[prev];
+        if (width[j] != w || tally[j] != t)
+            return (-1);
+
+        match = 1;
+        for (k = 0; match && k < t; k++)
+        {
+            if (tos[j][k] != tos[i][k] || froms[j][k] != froms[i][k])
+                match = 0;
+        }
+
+        if (match)
+            return (j);
+    }
+
+    return (-1);
+}
+
+
+
+int
+pack_vector(int vector)
+{
+    register int i, j, k, l;
+    register int t;
+    register int loc;
+    register int ok;
+    register short *from;
+    register short *to;
+    int newmax;
+
+    i = order[vector];
+    t = tally[i];
+    assert(t);
+
+    from = froms[i];
+    to = tos[i];
+
+    j = lowzero - from[0];
+    for (k = 1; k < t; ++k)
+        if (lowzero - from[k] > j)
+            j = lowzero - from[k];
+    for (;; ++j)
+    {
+        if (j == 0)
+            continue;
+        ok = 1;
+        for (k = 0; ok && k < t; k++)
+        {
+            loc = j + from[k];
+            if (loc >= maxtable)
+            {
+                if (loc >= MAXTABLE)
+                    fatal("maximum table size exceeded");
+
+                newmax = maxtable;
+                do { newmax += 200; } while (newmax <= loc);
+                table = (short *) REALLOC(table, newmax*sizeof(short));
+                if (table == 0) no_space();
+                check = (short *) REALLOC(check, newmax*sizeof(short));
+                if (check == 0) no_space();
+                for (l  = maxtable; l < newmax; ++l)
+                {
+                    table[l] = 0;
+                    check[l] = -1;
+                }
+                maxtable = newmax;
+            }
+
+            if (check[loc] != -1)
+                ok = 0;
+        }
+        for (k = 0; ok && k < vector; k++)
+        {
+            if (pos[k] == j)
+                ok = 0;
+        }
+        if (ok)
+        {
+            for (k = 0; k < t; k++)
+            {
+                loc = j + from[k];
+                table[loc] = to[k];
+                check[loc] = from[k];
+                if (loc > high) high = loc;
+            }
+
+            while (lowzero < maxtable && check[lowzero] != -1)
+                ++lowzero;
+
+            return (j);
+        }
+    }
+}
+
+
+
+void output_base(void)
+{
+    register int i, j;
+
+    fprintf(output_file, "let yysindex = \"");
+    output_short(base[0]);
+
+    j = 8;
+    for (i = 1; i < nstates; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        output_short(base[i]);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+
+    fprintf(output_file, "let yyrindex = \"");
+    output_short(base[nstates]);
+
+    j = 8;
+    for (i = nstates + 1; i < 2*nstates; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        output_short(base[i]);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+
+    fprintf(output_file, "let yygindex = \"");
+    output_short(base[2*nstates]);
+
+    j = 8;
+    for (i = 2*nstates + 1; i < nvectors - 1; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        output_short(base[i]);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+    FREE(base);
+}
+
+
+
+void output_table(void)
+{
+    register int i;
+    register int j;
+
+    ++outline;
+    fprintf(code_file, "let yytablesize = %d\n", high);
+    fprintf(output_file, "let yytable = \"");
+    output_short(table[0]);
+
+    j = 8;
+    for (i = 1; i <= high; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        output_short(table[i]);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+    FREE(table);
+}
+
+
+
+void output_check(void)
+{
+    register int i;
+    register int j;
+
+    fprintf(output_file, "let yycheck = \"");
+    output_short(check[0]);
+
+    j = 8;
+    for (i = 1; i <= high; i++)
+    {
+        if (j >= 8)
+        {
+            if (!rflag) ++outline;
+            fprintf(output_file, "\\\n");
+            j = 1;
+        }
+        else
+            ++j;
+
+        output_short(check[i]);
+    }
+
+    if (!rflag) outline += 2;
+    fprintf(output_file, "\"\n\n");
+    FREE(check);
+}
+
+
+void output_transl(void)
+{
+  int i;
+
+  ++outline;
+  fprintf(code_file, "let yytransl_const = [|\n");
+  for (i = 0; i < ntokens; i++) {
+    if (symbol_true_token[i] && symbol_tag[i] == NULL) {
+      ++outline;
+      fprintf(code_file, "  %3d (* %s *);\n", symbol_value[i], symbol_name[i]);
+    }
+  }
+  outline += 2;
+  fprintf(code_file, "    0|]\n\n");
+  ++outline;
+  fprintf(code_file, "let yytransl_block = [|\n");
+  for (i = 0; i < ntokens; i++) {
+    if (symbol_true_token[i] && symbol_tag[i] != NULL) {
+      ++outline;
+      fprintf(code_file, "  %3d (* %s *);\n", symbol_value[i], symbol_name[i]);
+    }
+  }
+  outline += 2;
+  fprintf(code_file, "    0|]\n\n");
+}
+
+void output_stored_text(void)
+{
+    register int c;
+    register FILE *in, *out;
+
+    fclose(text_file);
+    text_file = fopen(text_file_name, "r");
+    if (text_file == NULL)
+        open_error(text_file_name);
+    in = text_file;
+    if ((c = getc(in)) == EOF)
+        return;
+    out = code_file;
+    if (c ==  '\n')
+        ++outline;
+    putc(c, out);
+    while ((c = getc(in)) != EOF)
+    {
+        if (c == '\n')
+            ++outline;
+        putc(c, out);
+    }
+    if (!lflag)
+        fprintf(out, line_format, ++outline + 1, code_file_name);
+}
+
+
+void output_debug(void)
+{
+  int i;
+
+  ++outline;
+  fprintf(code_file, "let yynames_const = \"\\\n");
+  for (i = 0; i < ntokens; i++) {
+    if (symbol_true_token[i] && symbol_tag[i] == NULL) {
+      ++outline;
+      fprintf(code_file, "  %s\\000\\\n", symbol_name[i]);
+    }
+  }
+  outline += 2;
+  fprintf(code_file, "  \"\n\n");
+  ++outline;
+  fprintf(code_file, "let yynames_block = \"\\\n");
+  for (i = 0; i < ntokens; i++) {
+    if (symbol_true_token[i] && symbol_tag[i] != NULL) {
+      ++outline;
+      fprintf(code_file, "  %s\\000\\\n", symbol_name[i]);
+    }
+  }
+  outline += 2;
+  fprintf(code_file, "  \"\n\n");
+}
+
+void output_trailing_text(void)
+{
+    register int c, last;
+    register FILE *in, *out;
+
+    if (line == 0)
+        return;
+
+    in = input_file;
+    out = code_file;
+
+    ++outline;
+    fprintf (out, ";;\n");
+
+    c = *cptr;
+    if (c == '\n')
+    {
+        ++lineno;
+        if ((c = getc(in)) == EOF)
+            return;
+        if (!lflag)
+        {
+            ++outline;
+            fprintf(out, line_format, lineno, input_file_name);
+        }
+        if (c == '\n')
+            ++outline;
+        putc(c, out);
+        last = c;
+    }
+    else
+    {
+        if (!lflag)
+        {
+            ++outline;
+            fprintf(out, line_format, lineno, input_file_name);
+        }
+        do { putc(c, out); } while ((c = *++cptr) != '\n');
+        ++outline;
+        putc('\n', out);
+        last = '\n';
+    }
+
+
+    while ((c = getc(in)) != EOF)
+    {
+        if (c == '\n')
+            ++outline;
+        putc(c, out);
+        last = c;
+    }
+
+    if (last != '\n')
+    {
+        ++outline;
+        putc('\n', out);
+    }
+    if (!lflag)
+        fprintf(out, line_format, ++outline + 1, code_file_name);
+}
+
+
+void copy_file(FILE **file, char *file_name)
+{
+  register int c, last;
+  register FILE *out = code_file;
+  int state = 0;
+
+  fclose(*file);
+    *file = fopen(file_name, "r");
+    if (*file == NULL)
+        open_error(file_name);
+
+    last = '\n';
+
+    while ((c = getc(*file)) != EOF)
+    {
+      switch (c){
+      case '\n': state = 1; break;
+      case '#': state = (state == 1) ? 2 : 0; break;
+      case ' ': state = (state == 2) ? 3 : 0; break;
+      case '0':
+        if (state == 3){
+          fprintf (out, "%d \"%s", outline+2, code_file_name);
+          c = '"';
+        }
+        state = 0;
+        break;
+      default: state = 0; break;
+      }
+      if (c == '\n') ++outline;
+      putc(c, out);
+      last = c;
+    }
+
+    if (last != '\n')
+    {
+        ++outline;
+        putc('\n', out);
+    }
+
+}
+
+void output_semantic_actions(void)
+{
+  copy_file (&action_file, action_file_name);
+}
+
+void output_entries(void)
+{
+  copy_file (&entry_file, entry_file_name);
+}
+
+void free_itemsets(void)
+{
+    register core *cp, *next;
+
+    FREE(state_table);
+    for (cp = first_state; cp; cp = next)
+    {
+        next = cp->next;
+        FREE(cp);
+    }
+}
+
+
+void free_shifts(void)
+{
+    register shifts *sp, *next;
+
+    FREE(shift_table);
+    for (sp = first_shift; sp; sp = next)
+    {
+        next = sp->next;
+        FREE(sp);
+    }
+}
+
+
+
+void free_reductions(void)
+{
+    register reductions *rp, *next;
+
+    FREE(reduction_table);
+    for (rp = first_reduction; rp; rp = next)
+    {
+        next = rp->next;
+        FREE(rp);
+    }
+}
diff --git a/yacc/reader.c b/yacc/reader.c
new file mode 100644
index 00000000..3e99e8c8
--- /dev/null
+++ b/yacc/reader.c
@@ -0,0 +1,1914 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include 
+#include "defs.h"
+
+/*  The line size must be a positive integer.  One hundred was chosen      */
+/*  because few lines in Yacc input grammars exceed 100 characters.        */
+/*  Note that if a line exceeds LINESIZE characters, the line buffer       */
+/*  will be expanded to accomodate it.                                     */
+
+#define LINESIZE 100
+
+char *cache;
+int cinc, cache_size;
+
+int ntags, tagmax;
+char **tag_table;
+
+char saw_eof, unionized;
+char *cptr, *line;
+int linesize;
+
+bucket *goal;
+int prec;
+int gensym;
+char last_was_action;
+
+int maxitems;
+bucket **pitem;
+
+int maxrules;
+bucket **plhs;
+
+int name_pool_size;
+char *name_pool;
+
+char line_format[] = "# %d \"%s\"\n";
+
+
+
+void start_rule (register bucket *bp, int s_lineno);
+
+void cachec(int c)
+{
+    assert(cinc >= 0);
+    if (cinc >= cache_size)
+    {
+        cache_size += 256;
+        cache = REALLOC(cache, cache_size);
+        if (cache == 0) no_space();
+    }
+    cache[cinc] = c;
+    ++cinc;
+}
+
+
+void get_line(void)
+{
+    register FILE *f = input_file;
+    register int c;
+    register int i;
+
+    if (saw_eof || (c = getc(f)) == EOF)
+    {
+        if (line) { FREE(line); line = 0; }
+        cptr = 0;
+        saw_eof = 1;
+        return;
+    }
+
+    if (line == 0 || linesize != (LINESIZE + 1))
+    {
+        if (line) FREE(line);
+        linesize = LINESIZE + 1;
+        line = MALLOC(linesize);
+        if (line == 0) no_space();
+    }
+
+    i = 0;
+    ++lineno;
+    for (;;)
+    {
+        line[i]  =  c;
+        if (++i >= linesize)
+        {
+            linesize += LINESIZE;
+            line = REALLOC(line, linesize);
+            if (line ==  0) no_space();
+        }
+        if (c == '\n') {
+          if (i >= 2 && line[i-2] == '\r') {
+            line[i-2] = '\n'; i--;
+          }
+          line[i] = '\0'; cptr = line; return;
+        }
+        c = getc(f);
+        if (c ==  EOF) { saw_eof = 1; c = '\n'; }
+    }
+}
+
+
+char *
+dup_line(void)
+{
+    register char *p, *s, *t;
+
+    if (line == 0) return (0);
+    s = line;
+    while (*s != '\n') ++s;
+    p = MALLOC(s - line + 1);
+    if (p == 0) no_space();
+
+    s = line;
+    t = p;
+    while ((*t++ = *s++) != '\n') continue;
+    return (p);
+}
+
+
+void skip_comment(void)
+{
+    register char *s;
+
+    int st_lineno = lineno;
+    char *st_line = dup_line();
+    char *st_cptr = st_line + (cptr - line);
+
+    s = cptr + 2;
+    for (;;)
+    {
+        if (*s == '*' && s[1] == '/')
+        {
+            cptr = s + 2;
+            FREE(st_line);
+            return;
+        }
+        if (*s == '\n')
+        {
+            get_line();
+            if (line == 0)
+                unterminated_comment(st_lineno, st_line, st_cptr);
+            s = cptr;
+        }
+        else
+            ++s;
+    }
+}
+
+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];
+  }
+  buf[i] = '\0';      /* PR#4796 */
+  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)
+{
+    register char *s;
+
+    if (line == 0)
+    {
+        get_line();
+        parse_line_directive ();
+        if (line == 0)
+            return (EOF);
+    }
+
+    s = cptr;
+    for (;;)
+    {
+        switch (*s)
+        {
+        case '\n':
+            get_line();
+            parse_line_directive ();
+            if (line == 0) return (EOF);
+            s = cptr;
+            break;
+
+        case ' ':
+        case '\t':
+        case '\f':
+        case '\r':
+        case '\v':
+        case ',':
+        case ';':
+            ++s;
+            break;
+
+        case '\\':
+            cptr = s;
+            return ('%');
+
+        case '/':
+            if (s[1] == '*')
+            {
+                cptr = s;
+                skip_comment();
+                s = cptr;
+                break;
+            }
+            else if (s[1] == '/')
+            {
+                get_line();
+                parse_line_directive ();
+                if (line == 0) return (EOF);
+                s = cptr;
+                break;
+            }
+            /* fall through */
+
+        default:
+            cptr = s;
+            return (*s);
+        }
+    }
+}
+
+
+int
+keyword(void)
+{
+    register int c;
+    char *t_cptr = cptr;
+
+    c = *++cptr;
+    if (isalpha(c))
+    {
+        cinc = 0;
+        for (;;)
+        {
+            if (isalpha(c))
+            {
+                if (isupper(c)) c = tolower(c);
+                cachec(c);
+            }
+            else if (isdigit(c) || c == '_' || c == '.' || c == '$')
+                cachec(c);
+            else
+                break;
+            c = *++cptr;
+        }
+        cachec(NUL);
+
+        if (strcmp(cache, "token") == 0 || strcmp(cache, "term") == 0)
+            return (TOKEN);
+        if (strcmp(cache, "type") == 0)
+            return (TYPE);
+        if (strcmp(cache, "left") == 0)
+            return (LEFT);
+        if (strcmp(cache, "right") == 0)
+            return (RIGHT);
+        if (strcmp(cache, "nonassoc") == 0 || strcmp(cache, "binary") == 0)
+            return (NONASSOC);
+        if (strcmp(cache, "start") == 0)
+            return (START);
+        if (strcmp(cache, "union") == 0)
+            return (UNION);
+        if (strcmp(cache, "ident") == 0)
+            return (IDENT);
+    }
+    else
+    {
+        ++cptr;
+        if (c == '{')
+            return (TEXT);
+        if (c == '%' || c == '\\')
+            return (MARK);
+        if (c == '<')
+            return (LEFT);
+        if (c == '>')
+            return (RIGHT);
+        if (c == '0')
+            return (TOKEN);
+        if (c == '2')
+            return (NONASSOC);
+    }
+    syntax_error(lineno, line, t_cptr);
+    /*NOTREACHED*/
+    return 0;
+}
+
+
+void copy_ident(void)
+{
+    register int c;
+    register FILE *f = output_file;
+
+    c = nextc();
+    if (c == EOF) unexpected_EOF();
+    if (c != '"') syntax_error(lineno, line, cptr);
+    ++outline;
+    fprintf(f, "#ident \"");
+    for (;;)
+    {
+        c = *++cptr;
+        if (c == '\n')
+        {
+            fprintf(f, "\"\n");
+            return;
+        }
+        putc(c, f);
+        if (c == '"')
+        {
+            putc('\n', f);
+            ++cptr;
+            return;
+        }
+    }
+}
+
+
+void copy_text(void)
+{
+    register int c;
+    int quote;
+    register FILE *f = text_file;
+    int need_newline = 0;
+    int t_lineno = lineno;
+    char *t_line = dup_line();
+    char *t_cptr = t_line + (cptr - line - 2);
+
+    if (*cptr == '\n')
+    {
+        get_line();
+        if (line == 0)
+            unterminated_text(t_lineno, t_line, t_cptr);
+    }
+    fprintf(f, line_format, lineno, input_file_name);
+
+loop:
+    c = *cptr++;
+    switch (c)
+    {
+    case '\n':
+        putc('\n', f);
+        need_newline = 0;
+        get_line();
+        if (line) goto loop;
+        unterminated_text(t_lineno, t_line, t_cptr);
+
+    case '"':
+        {
+            int s_lineno = lineno;
+            char *s_line = dup_line();
+            char *s_cptr = s_line + (cptr - line - 1);
+
+            quote = c;
+            putc(c, f);
+            for (;;)
+            {
+                c = *cptr++;
+                putc(c, f);
+                if (c == quote)
+                {
+                    need_newline = 1;
+                    FREE(s_line);
+                    goto loop;
+                }
+                if (c == '\n')
+                    unterminated_string(s_lineno, s_line, s_cptr);
+                if (c == '\\')
+                {
+                    c = *cptr++;
+                    putc(c, f);
+                    if (c == '\n')
+                    {
+                        get_line();
+                        if (line == 0)
+                            unterminated_string(s_lineno, s_line, s_cptr);
+                    }
+                }
+            }
+        }
+
+    case '\'':
+        putc(c, f);
+        if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') {
+          fwrite(cptr, 1, 2, f);
+          cptr += 2;
+        } else
+        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
+        if (cptr[0] == '\\' && cptr[2] == '\'') {
+          fwrite(cptr, 1, 3, f);
+          cptr += 3;
+        }
+        goto loop;
+
+    case '(':
+        putc(c, f);
+        need_newline = 1;
+        c = *cptr;
+        if (c == '*')
+        {
+            int c_lineno = lineno;
+            char *c_line = dup_line();
+            char *c_cptr = c_line + (cptr - line - 1);
+
+            putc('*', f);
+            ++cptr;
+            for (;;)
+            {
+                c = *cptr++;
+                putc(c, f);
+                if (c == '*' && *cptr == ')')
+                {
+                    putc(')', f);
+                    ++cptr;
+                    FREE(c_line);
+                    goto loop;
+                }
+                if (c == '\n')
+                {
+                    get_line();
+                    if (line == 0)
+                        unterminated_comment(c_lineno, c_line, c_cptr);
+                }
+            }
+        }
+        need_newline = 1;
+        goto loop;
+
+    case '%':
+    case '\\':
+        if (*cptr == '}')
+        {
+            if (need_newline) putc('\n', f);
+            ++cptr;
+            FREE(t_line);
+            return;
+        }
+        /* fall through */
+
+    default:
+        putc(c, f);
+        need_newline = 1;
+        goto loop;
+    }
+}
+
+
+void copy_union(void)
+{
+    register int c;
+    int quote;
+    int depth;
+    int u_lineno = lineno;
+    char *u_line = dup_line();
+    char *u_cptr = u_line + (cptr - line - 6);
+
+    if (unionized) over_unionized(cptr - 6);
+    unionized = 1;
+
+    if (!lflag)
+        fprintf(text_file, line_format, lineno, input_file_name);
+
+    fprintf(text_file, "typedef union");
+    if (dflag) fprintf(union_file, "typedef union");
+
+    depth = 1;
+    cptr++;
+
+loop:
+    c = *cptr++;
+    putc(c, text_file);
+    if (dflag) putc(c, union_file);
+    switch (c)
+    {
+    case '\n':
+        get_line();
+        if (line == 0) unterminated_union(u_lineno, u_line, u_cptr);
+        goto loop;
+
+    case '{':
+        ++depth;
+        goto loop;
+
+    case '}':
+        --depth;
+        if (c == '}' && depth == 0) {
+          fprintf(text_file, " YYSTYPE;\n");
+          FREE(u_line);
+          return;
+        }
+        goto loop;
+
+    case '\'':
+    case '"':
+        {
+            int s_lineno = lineno;
+            char *s_line = dup_line();
+            char *s_cptr = s_line + (cptr - line - 1);
+
+            quote = c;
+            for (;;)
+            {
+                c = *cptr++;
+                putc(c, text_file);
+                if (dflag) putc(c, union_file);
+                if (c == quote)
+                {
+                    FREE(s_line);
+                    goto loop;
+                }
+                if (c == '\n')
+                    unterminated_string(s_lineno, s_line, s_cptr);
+                if (c == '\\')
+                {
+                    c = *cptr++;
+                    putc(c, text_file);
+                    if (dflag) putc(c, union_file);
+                    if (c == '\n')
+                    {
+                        get_line();
+                        if (line == 0)
+                            unterminated_string(s_lineno, s_line, s_cptr);
+                    }
+                }
+            }
+        }
+
+    case '(':
+        c = *cptr;
+        if (c == '*')
+        {
+            int c_lineno = lineno;
+            char *c_line = dup_line();
+            char *c_cptr = c_line + (cptr - line - 1);
+
+            putc('*', text_file);
+            if (dflag) putc('*', union_file);
+            ++cptr;
+            for (;;)
+            {
+                c = *cptr++;
+                putc(c, text_file);
+                if (dflag) putc(c, union_file);
+                if (c == '*' && *cptr == ')')
+                {
+                    putc(')', text_file);
+                    if (dflag) putc(')', union_file);
+                    ++cptr;
+                    FREE(c_line);
+                    goto loop;
+                }
+                if (c == '\n')
+                {
+                    get_line();
+                    if (line == 0)
+                        unterminated_comment(c_lineno, c_line, c_cptr);
+                }
+            }
+        }
+        goto loop;
+
+    default:
+        goto loop;
+    }
+}
+
+
+int
+hexval(int c)
+{
+    if (c >= '0' && c <= '9')
+        return (c - '0');
+    if (c >= 'A' && c <= 'F')
+        return (c - 'A' + 10);
+    if (c >= 'a' && c <= 'f')
+        return (c - 'a' + 10);
+    return (-1);
+}
+
+
+bucket *
+get_literal(void)
+{
+    register int c, quote;
+    register int i;
+    register int n;
+    register char *s;
+    register bucket *bp;
+    int s_lineno = lineno;
+    char *s_line = dup_line();
+    char *s_cptr = s_line + (cptr - line);
+
+    quote = *cptr++;
+    cinc = 0;
+    for (;;)
+    {
+        c = *cptr++;
+        if (c == quote) break;
+        if (c == '\n') unterminated_string(s_lineno, s_line, s_cptr);
+        if (c == '\\')
+        {
+            char *c_cptr = cptr - 1;
+
+            c = *cptr++;
+            switch (c)
+            {
+            case '\n':
+                get_line();
+                if (line == 0) unterminated_string(s_lineno, s_line, s_cptr);
+                continue;
+
+            case '0': case '1': case '2': case '3':
+            case '4': case '5': case '6': case '7':
+                n = c - '0';
+                c = *cptr;
+                if (IS_OCTAL(c))
+                {
+                    n = (n << 3) + (c - '0');
+                    c = *++cptr;
+                    if (IS_OCTAL(c))
+                    {
+                        n = (n << 3) + (c - '0');
+                        ++cptr;
+                    }
+                }
+                if (n > MAXCHAR) illegal_character(c_cptr);
+                c = n;
+                    break;
+
+            case 'x':
+                c = *cptr++;
+                n = hexval(c);
+                if (n < 0 || n >= 16)
+                    illegal_character(c_cptr);
+                for (;;)
+                {
+                    c = *cptr;
+                    i = hexval(c);
+                    if (i < 0 || i >= 16) break;
+                    ++cptr;
+                    n = (n << 4) + i;
+                    if (n > MAXCHAR) illegal_character(c_cptr);
+                }
+                c = n;
+                break;
+
+            case 'a': c = 7; break;
+            case 'b': c = '\b'; break;
+            case 'f': c = '\f'; break;
+            case 'n': c = '\n'; break;
+            case 'r': c = '\r'; break;
+            case 't': c = '\t'; break;
+            case 'v': c = '\v'; break;
+            }
+        }
+        cachec(c);
+    }
+    FREE(s_line);
+
+    n = cinc;
+    s = MALLOC(n);
+    if (s == 0) no_space();
+
+    for (i = 0; i < n; ++i)
+        s[i] = cache[i];
+
+    cinc = 0;
+    if (n == 1)
+        cachec('\'');
+    else
+        cachec('"');
+
+    for (i = 0; i < n; ++i)
+    {
+        c = ((unsigned char *)s)[i];
+        if (c == '\\' || c == cache[0])
+        {
+            cachec('\\');
+            cachec(c);
+        }
+        else if (isprint(c))
+            cachec(c);
+        else
+        {
+            cachec('\\');
+            switch (c)
+            {
+            case 7: cachec('a'); break;
+            case '\b': cachec('b'); break;
+            case '\f': cachec('f'); break;
+            case '\n': cachec('n'); break;
+            case '\r': cachec('r'); break;
+            case '\t': cachec('t'); break;
+            case '\v': cachec('v'); break;
+            default:
+                cachec(((c >> 6) & 7) + '0');
+                cachec(((c >> 3) & 7) + '0');
+                cachec((c & 7) + '0');
+                break;
+            }
+        }
+    }
+
+    if (n == 1)
+        cachec('\'');
+    else
+        cachec('"');
+
+    cachec(NUL);
+    bp = lookup(cache);
+    bp->class = TERM;
+    if (n == 1 && bp->value == UNDEFINED)
+        bp->value = *(unsigned char *)s;
+    FREE(s);
+
+    return (bp);
+}
+
+
+int
+is_reserved(char *name)
+{
+    char *s;
+
+    if (strcmp(name, ".") == 0 ||
+            strcmp(name, "$accept") == 0 ||
+            strcmp(name, "$end") == 0)
+        return (1);
+
+    if (name[0] == '$' && name[1] == '$' && isdigit((unsigned char) name[2]))
+    {
+        s = name + 3;
+        while (isdigit((unsigned char) *s)) ++s;
+        if (*s == NUL) return (1);
+    }
+
+    return (0);
+}
+
+
+bucket *
+get_name(void)
+{
+    register int c;
+
+    cinc = 0;
+    for (c = *cptr; IS_IDENT(c); c = *++cptr)
+        cachec(c);
+    cachec(NUL);
+
+    if (is_reserved(cache)) used_reserved(cache);
+
+    return (lookup(cache));
+}
+
+
+int
+get_number(void)
+{
+    register int c;
+    register int n;
+
+    n = 0;
+    for (c = *cptr; isdigit(c); c = *++cptr)
+        n = 10*n + (c - '0');
+
+    return (n);
+}
+
+
+char *
+get_tag(void)
+{
+    register int c;
+    register int i;
+    register char *s;
+    char *t_line = dup_line();
+    long bracket_depth;
+
+    cinc = 0;
+    bracket_depth = 0;
+    while (1) {
+      c = *++cptr;
+      if (c == EOF) unexpected_EOF();
+      if (c == '\n') syntax_error(lineno, line, cptr);
+      if (c == '>' && 0 == bracket_depth && cptr[-1] != '-') break;
+      if (c == '[') ++ bracket_depth;
+      if (c == ']') -- bracket_depth;
+      cachec(c);
+    }
+    ++cptr;
+    cachec(NUL);
+
+    for (i = 0; i < ntags; ++i)
+    {
+        if (strcmp(cache, tag_table[i]) == 0)
+            return (tag_table[i]);
+    }
+
+    if (ntags >= tagmax)
+    {
+        tagmax += 16;
+        tag_table = (char **)
+                        (tag_table ? REALLOC(tag_table, tagmax*sizeof(char *))
+                                   : MALLOC(tagmax*sizeof(char *)));
+        if (tag_table == 0) no_space();
+    }
+
+    s = MALLOC(cinc);
+    if  (s == 0) no_space();
+    strcpy(s, cache);
+    tag_table[ntags] = s;
+    ++ntags;
+    FREE(t_line);
+    return (s);
+}
+
+
+void declare_tokens(int assoc)
+{
+    register int c;
+    register bucket *bp;
+    char *tag = 0;
+
+    if (assoc != TOKEN) ++prec;
+
+    c = nextc();
+    if (c == EOF) unexpected_EOF();
+    if (c == '<')
+    {
+        tag = get_tag();
+        c = nextc();
+        if (c == EOF) unexpected_EOF();
+    }
+
+    for (;;)
+    {
+        if (isalpha(c) || c == '_' || c == '.' || c == '$')
+            bp = get_name();
+        else if (c == '\'' || c == '"')
+            bp = get_literal();
+        else
+            return;
+
+        if (bp == goal) tokenized_start(bp->name);
+        bp->class = TERM;
+
+        if (tag)
+        {
+            if (bp->tag && tag != bp->tag)
+                retyped_warning(bp->name);
+            bp->tag = tag;
+        }
+
+        if (assoc == TOKEN)
+        {
+            bp->true_token = 1;
+        }
+        else
+        {
+            if (bp->prec && prec != bp->prec)
+                reprec_warning(bp->name);
+            bp->assoc = assoc;
+            bp->prec = prec;
+        }
+
+        if (strcmp(bp->name, "EOF") == 0)
+            bp->value = 0;
+
+        c = nextc();
+        if (c == EOF) unexpected_EOF();
+        if (isdigit(c))
+        {
+            int value = get_number();
+            if (bp->value != UNDEFINED && value != bp->value)
+                revalued_warning(bp->name);
+            bp->value = value;
+            c = nextc();
+            if (c == EOF) unexpected_EOF();
+        }
+    }
+}
+
+
+void declare_types(void)
+{
+    register int c;
+    register bucket *bp;
+    char *tag;
+
+    c = nextc();
+    if (c == EOF) unexpected_EOF();
+    if (c != '<') syntax_error(lineno, line, cptr);
+    tag = get_tag();
+
+    for (;;)
+    {
+        c = nextc();
+        if (isalpha(c) || c == '_' || c == '.' || c == '$')
+            bp = get_name();
+        else if (c == '\'' || c == '"')
+            bp = get_literal();
+        else
+            return;
+
+        if (bp->tag && tag != bp->tag)
+            retyped_warning(bp->name);
+        bp->tag = tag;
+    }
+}
+
+
+void declare_start(void)
+{
+    register int c;
+    register bucket *bp;
+    static int entry_counter = 0;
+
+    for (;;) {
+      c = nextc();
+      if (!isalpha(c) && c != '_' && c != '.' && c != '$') return;
+      bp = get_name();
+
+      if (bp->class == TERM)
+        terminal_start(bp->name);
+      bp->entry = ++entry_counter;
+      if (entry_counter == 256)
+        too_many_entries();
+    }
+}
+
+
+void read_declarations(void)
+{
+    register int c, k;
+
+    cache_size = 256;
+    cache = MALLOC(cache_size);
+    if (cache == 0) no_space();
+
+    for (;;)
+    {
+        c = nextc();
+        if (c == EOF) unexpected_EOF();
+        if (c != '%') syntax_error(lineno, line, cptr);
+        switch (k = keyword())
+        {
+        case MARK:
+            return;
+
+        case IDENT:
+            copy_ident();
+            break;
+
+        case TEXT:
+            copy_text();
+            break;
+
+        case UNION:
+            copy_union();
+            break;
+
+        case TOKEN:
+        case LEFT:
+        case RIGHT:
+        case NONASSOC:
+            declare_tokens(k);
+            break;
+
+        case TYPE:
+            declare_types();
+            break;
+
+        case START:
+            declare_start();
+            break;
+        }
+    }
+}
+
+void output_token_type(void)
+{
+  bucket * bp;
+  int n;
+
+  fprintf(interface_file, "type token =\n");
+  if (!rflag) ++outline;
+  fprintf(output_file, "type token =\n");
+  n = 0;
+  for (bp = first_symbol; bp; bp = bp->next) {
+    if (bp->class == TERM && bp->true_token) {
+      fprintf(interface_file, "  | %s", bp->name);
+      fprintf(output_file, "  | %s", bp->name);
+      if (bp->tag) {
+        /* Print the type expression in parentheses to make sure
+           that the constructor is unary */
+        fprintf(interface_file, " of (%s)", bp->tag);
+        fprintf(output_file, " of (%s)", bp->tag);
+      }
+      fprintf(interface_file, "\n");
+      if (!rflag) ++outline;
+      fprintf(output_file, "\n");
+      n++;
+    }
+  }
+  fprintf(interface_file, "\n");
+  if (!rflag) ++outline;
+  fprintf(output_file, "\n");
+}
+
+void initialize_grammar(void)
+{
+    nitems = 4;
+    maxitems = 300;
+    pitem = (bucket **) MALLOC(maxitems*sizeof(bucket *));
+    if (pitem == 0) no_space();
+    pitem[0] = 0;
+    pitem[1] = 0;
+    pitem[2] = 0;
+    pitem[3] = 0;
+
+    nrules = 3;
+    maxrules = 100;
+    plhs = (bucket **) MALLOC(maxrules*sizeof(bucket *));
+    if (plhs == 0) no_space();
+    plhs[0] = 0;
+    plhs[1] = 0;
+    plhs[2] = 0;
+    rprec = (short *) MALLOC(maxrules*sizeof(short));
+    if (rprec == 0) no_space();
+    rprec[0] = 0;
+    rprec[1] = 0;
+    rprec[2] = 0;
+    rassoc = (char *) MALLOC(maxrules*sizeof(char));
+    if (rassoc == 0) no_space();
+    rassoc[0] = TOKEN;
+    rassoc[1] = TOKEN;
+    rassoc[2] = TOKEN;
+}
+
+
+void expand_items(void)
+{
+    maxitems += 300;
+    pitem = (bucket **) REALLOC(pitem, maxitems*sizeof(bucket *));
+    if (pitem == 0) no_space();
+}
+
+
+void expand_rules(void)
+{
+    maxrules += 100;
+    plhs = (bucket **) REALLOC(plhs, maxrules*sizeof(bucket *));
+    if (plhs == 0) no_space();
+    rprec = (short *) REALLOC(rprec, maxrules*sizeof(short));
+    if (rprec == 0) no_space();
+    rassoc = (char *) REALLOC(rassoc, maxrules*sizeof(char));
+    if (rassoc == 0) no_space();
+}
+
+
+void advance_to_start(void)
+{
+    register int c;
+    register bucket *bp;
+    char *s_cptr;
+    int s_lineno;
+
+    for (;;)
+    {
+        c = nextc();
+        if (c != '%') break;
+        s_cptr = cptr;
+        switch (keyword())
+        {
+        case MARK:
+            no_grammar();
+
+        case TEXT:
+            copy_text();
+            break;
+
+        case START:
+            declare_start();
+            break;
+
+        default:
+            syntax_error(lineno, line, s_cptr);
+        }
+    }
+
+    c = nextc();
+    if (!isalpha(c) && c != '_' && c != '.' && c != '_')
+        syntax_error(lineno, line, cptr);
+    bp = get_name();
+    if (goal == 0)
+    {
+        if (bp->class == TERM)
+            terminal_start(bp->name);
+        goal = bp;
+    }
+
+    s_lineno = lineno;
+    c = nextc();
+    if (c == EOF) unexpected_EOF();
+    if (c != ':') syntax_error(lineno, line, cptr);
+    start_rule(bp, s_lineno);
+    ++cptr;
+}
+
+
+int at_first;
+
+void start_rule(register bucket *bp, int s_lineno)
+{
+    if (bp->class == TERM)
+        terminal_lhs(s_lineno);
+    bp->class = NONTERM;
+    if (nrules >= maxrules)
+        expand_rules();
+    plhs[nrules] = bp;
+    rprec[nrules] = UNDEFINED;
+    rassoc[nrules] = TOKEN;
+    at_first = 1;
+}
+
+
+void end_rule(void)
+{
+    if (!last_was_action) default_action_error();
+
+    last_was_action = 0;
+    if (nitems >= maxitems) expand_items();
+    pitem[nitems] = 0;
+    ++nitems;
+    ++nrules;
+}
+
+
+void insert_empty_rule(void)
+{
+    register bucket *bp, **bpp;
+
+    assert(cache);
+    sprintf(cache, "$$%d", ++gensym);
+    bp = make_bucket(cache);
+    last_symbol->next = bp;
+    last_symbol = bp;
+    bp->tag = plhs[nrules]->tag;
+    bp->class = NONTERM;
+
+    if ((nitems += 2) > maxitems)
+        expand_items();
+    bpp = pitem + nitems - 1;
+    *bpp-- = bp;
+    while ((bpp[0] = bpp[-1])) --bpp;
+
+    if (++nrules >= maxrules)
+        expand_rules();
+    plhs[nrules] = plhs[nrules-1];
+    plhs[nrules-1] = bp;
+    rprec[nrules] = rprec[nrules-1];
+    rprec[nrules-1] = 0;
+    rassoc[nrules] = rassoc[nrules-1];
+    rassoc[nrules-1] = TOKEN;
+}
+
+
+void add_symbol(void)
+{
+    register int c;
+    register bucket *bp;
+    int s_lineno = lineno;
+    char *ecptr = cptr;
+
+    c = *cptr;
+    if (c == '\'' || c == '"')
+        bp = get_literal();
+    else
+        bp = get_name();
+
+    c = nextc();
+    if (c == ':')
+    {
+        end_rule();
+        start_rule(bp, s_lineno);
+        ++cptr;
+        return;
+    }
+
+    if (last_was_action) syntax_error (lineno, line, ecptr);
+    last_was_action = 0;
+
+    if (++nitems > maxitems)
+        expand_items();
+    pitem[nitems-1] = bp;
+}
+
+
+void copy_action(void)
+{
+    register int c;
+    register int i, n;
+    int depth;
+    int quote;
+    bucket *item;
+    char *tagres;
+    register FILE *f = action_file;
+    int a_lineno = lineno;
+    char *a_line = dup_line();
+    char *a_cptr = a_line + (cptr - line);
+
+    if (last_was_action) syntax_error (lineno, line, cptr);
+    last_was_action = 1;
+
+    /*
+      fprintf(f, "(* Rule %d, file %s, line %d *)\n",
+            nrules-2, input_file_name, lineno);
+            */
+    if (sflag)
+      fprintf(f, "yyact.(%d) <- (fun __caml_parser_env ->\n", nrules-2);
+    else
+      fprintf(f, "; (fun __caml_parser_env ->\n");
+
+    n = 0;
+    for (i = nitems - 1; pitem[i]; --i) ++n;
+
+    for (i = 1; i <= n; i++) {
+      item = pitem[nitems + i - n - 1];
+      if (item->class == TERM && !item->tag) continue;
+      fprintf(f, "    let _%d = ", i);
+      if (item->tag)
+        fprintf(f, "(Parsing.peek_val __caml_parser_env %d : %s) in\n", n - i,
+                item->tag);
+      else if (sflag)
+        fprintf(f, "Parsing.peek_val __caml_parser_env %d in\n", n - i);
+      else
+        fprintf(f, "(Parsing.peek_val __caml_parser_env %d : '%s) in\n", n - i,
+                item->name);
+    }
+    fprintf(f, "    Obj.repr(\n");
+    fprintf(f, line_format, lineno, input_file_name);
+    for (i = 0; i < cptr - line; i++) fputc(' ', f);
+    fputc ('(', f);
+
+    depth = 1;
+    cptr++;
+
+loop:
+    c = *cptr;
+    if (c == '$')
+    {
+        if (isdigit((unsigned char) cptr[1]))
+        {
+            ++cptr;
+            i = get_number();
+
+            if (i <= 0 || i > n)
+              unknown_rhs(i);
+            item = pitem[nitems + i - n - 1];
+            if (item->class == TERM && !item->tag)
+              illegal_token_ref(i, item->name);
+            fprintf(f, "_%d", i);
+            goto loop;
+        }
+    }
+    if (isalpha(c) || c == '_' || c == '$')
+    {
+        do
+        {
+            putc(c, f);
+            c = *++cptr;
+        } while (isalnum(c) || c == '_' || c == '$');
+        goto loop;
+    }
+    if (c == '}' && depth == 1) {
+      fprintf(f, ")\n# 0\n              ");
+      cptr++;
+      tagres = plhs[nrules]->tag;
+      if (tagres)
+        fprintf(f, " : %s))\n", tagres);
+      else if (sflag)
+        fprintf(f, "))\n");
+      else
+        fprintf(f, " : '%s))\n", plhs[nrules]->name);
+      if (sflag)
+        fprintf(f, "\n");
+      FREE(a_line);
+      return;
+    }
+    putc(c, f);
+    ++cptr;
+    switch (c)
+    {
+    case '\n':
+        get_line();
+        if (line) goto loop;
+        unterminated_action(a_lineno, a_line, a_cptr);
+
+    case '{':
+        ++depth;
+        goto loop;
+
+    case '}':
+        --depth;
+        goto loop;
+
+    case '"':
+        {
+            int s_lineno = lineno;
+            char *s_line = dup_line();
+            char *s_cptr = s_line + (cptr - line - 1);
+
+            quote = c;
+            for (;;)
+            {
+                c = *cptr++;
+                putc(c, f);
+                if (c == quote)
+                {
+                    FREE(s_line);
+                    goto loop;
+                }
+                if (c == '\n')
+                    unterminated_string(s_lineno, s_line, s_cptr);
+                if (c == '\\')
+                {
+                    c = *cptr++;
+                    putc(c, f);
+                    if (c == '\n')
+                    {
+                        get_line();
+                        if (line == 0)
+                            unterminated_string(s_lineno, s_line, s_cptr);
+                    }
+                }
+            }
+        }
+
+    case '\'':
+        if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') {
+          fwrite(cptr, 1, 2, f);
+          cptr += 2;
+        } else
+        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
+        if (cptr[0] == '\\' && cptr[2] == '\'') {
+          fwrite(cptr, 1, 3, f);
+          cptr += 3;
+        }
+        goto loop;
+
+    case '(':
+        c = *cptr;
+        if (c == '*')
+        {
+            int c_lineno = lineno;
+            char *c_line = dup_line();
+            char *c_cptr = c_line + (cptr - line - 1);
+
+            putc('*', f);
+            ++cptr;
+            for (;;)
+            {
+                c = *cptr++;
+                putc(c, f);
+                if (c == '*' && *cptr == ')')
+                {
+                    putc(')', f);
+                    ++cptr;
+                    FREE(c_line);
+                    goto loop;
+                }
+                if (c == '\n')
+                {
+                    get_line();
+                    if (line == 0)
+                        unterminated_comment(c_lineno, c_line, c_cptr);
+                }
+            }
+        }
+        goto loop;
+
+    default:
+        goto loop;
+    }
+}
+
+
+int
+mark_symbol(void)
+{
+    register int c;
+    register bucket *bp;
+
+    c = cptr[1];
+    if (c == '%' || c == '\\')
+    {
+        cptr += 2;
+        return (1);
+    }
+
+    if (c == '=')
+        cptr += 2;
+    else if ((c == 'p' || c == 'P') &&
+             ((c = cptr[2]) == 'r' || c == 'R') &&
+             ((c = cptr[3]) == 'e' || c == 'E') &&
+             ((c = cptr[4]) == 'c' || c == 'C') &&
+             ((c = cptr[5], !IS_IDENT(c))))
+        cptr += 5;
+    else
+        syntax_error(lineno, line, cptr);
+
+    c = nextc();
+    if (isalpha(c) || c == '_' || c == '.' || c == '$')
+        bp = get_name();
+    else if (c == '\'' || c == '"')
+        bp = get_literal();
+    else
+    {
+        syntax_error(lineno, line, cptr);
+        /*NOTREACHED*/
+    }
+
+    if (rprec[nrules] != UNDEFINED && bp->prec != rprec[nrules])
+        prec_redeclared();
+
+    rprec[nrules] = bp->prec;
+    rassoc[nrules] = bp->assoc;
+    return (0);
+}
+
+
+void read_grammar(void)
+{
+    register int c;
+
+    initialize_grammar();
+    advance_to_start();
+
+    for (;;)
+    {
+        c = nextc();
+        if (c == '|' && at_first){
+          ++cptr;
+          c = nextc();
+        }
+        at_first = 0;
+        if (c == EOF) break;
+        if (isalpha(c) || c == '_' || c == '.' || c == '$' || c == '\'' ||
+                c == '"')
+            add_symbol();
+        else if (c == '{' || c == '=')
+            copy_action();
+        else if (c == '|')
+        {
+            end_rule();
+            start_rule(plhs[nrules-1], 0);
+            ++cptr;
+        }
+        else if (c == '%')
+        {
+            if (mark_symbol()) break;
+        }
+        else
+            syntax_error(lineno, line, cptr);
+    }
+    end_rule();
+}
+
+
+void free_tags(void)
+{
+    register int i;
+
+    if (tag_table == 0) return;
+
+    for (i = 0; i < ntags; ++i)
+    {
+        assert(tag_table[i]);
+        FREE(tag_table[i]);
+    }
+    FREE(tag_table);
+}
+
+
+void pack_names(void)
+{
+    register bucket *bp;
+    register char *p, *s, *t;
+
+    name_pool_size = 13;  /* 13 == sizeof("$end") + sizeof("$accept") */
+    for (bp = first_symbol; bp; bp = bp->next)
+        name_pool_size += strlen(bp->name) + 1;
+    name_pool = MALLOC(name_pool_size);
+    if (name_pool == 0) no_space();
+
+    strcpy(name_pool, "$accept");
+    strcpy(name_pool+8, "$end");
+    t = name_pool + 13;
+    for (bp = first_symbol; bp; bp = bp->next)
+    {
+        p = t;
+        s = bp->name;
+        while ((*t++ = *s++)) continue;
+        FREE(bp->name);
+        bp->name = p;
+    }
+}
+
+
+void check_symbols(void)
+{
+    register bucket *bp;
+
+    if (goal->class == UNKNOWN)
+        undefined_goal(goal->name);
+
+    for (bp = first_symbol; bp; bp = bp->next)
+    {
+        if (bp->class == UNKNOWN)
+        {
+            undefined_symbol(bp->name);
+            bp->class = TERM;
+        }
+    }
+}
+
+
+void pack_symbols(void)
+{
+    register bucket *bp;
+    register bucket **v;
+    register int i, j, k, n;
+
+    nsyms = 2;
+    ntokens = 1;
+    for (bp = first_symbol; bp; bp = bp->next)
+    {
+        ++nsyms;
+        if (bp->class == TERM) ++ntokens;
+    }
+    start_symbol = ntokens;
+    nvars = nsyms - ntokens;
+
+    symbol_name = (char **) MALLOC(nsyms*sizeof(char *));
+    if (symbol_name == 0) no_space();
+    symbol_value = (short *) MALLOC(nsyms*sizeof(short));
+    if (symbol_value == 0) no_space();
+    symbol_prec = (short *) MALLOC(nsyms*sizeof(short));
+    if (symbol_prec == 0) no_space();
+    symbol_assoc = MALLOC(nsyms);
+    if (symbol_assoc == 0) no_space();
+    symbol_tag = (char **) MALLOC(nsyms*sizeof(char *));
+    if (symbol_tag == 0) no_space();
+    symbol_true_token = (char *) MALLOC(nsyms*sizeof(char));
+    if (symbol_true_token == 0) no_space();
+
+    v = (bucket **) MALLOC(nsyms*sizeof(bucket *));
+    if (v == 0) no_space();
+
+    v[0] = 0;
+    v[start_symbol] = 0;
+
+    i = 1;
+    j = start_symbol + 1;
+    for (bp = first_symbol; bp; bp = bp->next)
+    {
+        if (bp->class == TERM)
+            v[i++] = bp;
+        else
+            v[j++] = bp;
+    }
+    assert(i == ntokens && j == nsyms);
+
+    for (i = 1; i < ntokens; ++i)
+        v[i]->index = i;
+
+    goal->index = start_symbol + 1;
+    k = start_symbol + 2;
+    while (++i < nsyms)
+        if (v[i] != goal)
+        {
+            v[i]->index = k;
+            ++k;
+        }
+
+    goal->value = 0;
+    k = 1;
+    for (i = start_symbol + 1; i < nsyms; ++i)
+    {
+        if (v[i] != goal)
+        {
+            v[i]->value = k;
+            ++k;
+        }
+    }
+
+    k = 0;
+    for (i = 1; i < ntokens; ++i)
+    {
+        n = v[i]->value;
+        if (n > 256)
+        {
+            for (j = k++; j > 0 && symbol_value[j-1] > n; --j)
+                symbol_value[j] = symbol_value[j-1];
+            symbol_value[j] = n;
+        }
+    }
+
+    if (v[1]->value == UNDEFINED)
+        v[1]->value = 256;
+
+    j = 0;
+    n = 257;
+    for (i = 2; i < ntokens; ++i)
+    {
+        if (v[i]->value == UNDEFINED)
+        {
+            while (j < k && n == symbol_value[j])
+            {
+                while (++j < k && n == symbol_value[j]) continue;
+                ++n;
+            }
+            v[i]->value = n;
+            ++n;
+        }
+    }
+
+    symbol_name[0] = name_pool + 8;
+    symbol_value[0] = 0;
+    symbol_prec[0] = 0;
+    symbol_assoc[0] = TOKEN;
+    symbol_tag[0] = "";
+    symbol_true_token[0] = 0;
+    for (i = 1; i < ntokens; ++i)
+    {
+        symbol_name[i] = v[i]->name;
+        symbol_value[i] = v[i]->value;
+        symbol_prec[i] = v[i]->prec;
+        symbol_assoc[i] = v[i]->assoc;
+        symbol_tag[i] = v[i]->tag;
+        symbol_true_token[i] = v[i]->true_token;
+    }
+    symbol_name[start_symbol] = name_pool;
+    symbol_value[start_symbol] = -1;
+    symbol_prec[start_symbol] = 0;
+    symbol_assoc[start_symbol] = TOKEN;
+    symbol_tag[start_symbol] = "";
+    symbol_true_token[start_symbol] = 0;
+    for (++i; i < nsyms; ++i)
+    {
+        k = v[i]->index;
+        symbol_name[k] = v[i]->name;
+        symbol_value[k] = v[i]->value;
+        symbol_prec[k] = v[i]->prec;
+        symbol_assoc[k] = v[i]->assoc;
+        symbol_tag[i] = v[i]->tag;
+        symbol_true_token[i] = v[i]->true_token;
+    }
+
+    FREE(v);
+}
+
+static unsigned char caml_ident_start[32] =
+"\000\000\000\000\000\000\000\000\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377";
+static unsigned char caml_ident_body[32] =
+"\000\000\000\000\200\000\377\003\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377";
+
+#define In_bitmap(bm,c) (bm[(unsigned char)(c) >> 3] & (1 << ((c) & 7)))
+
+static int is_polymorphic(char * s)
+{
+  while (*s != 0) {
+    char c = *s++;
+    if (c == '\'' || c == '#') return 1;
+    if (c == '[') {
+      c = *s;
+      while (c == ' ' || c == '\t' || c == '\r' || c == '\n') c = *++s;
+      if (c == '<' || c == '>') return 1;
+    }
+    if (In_bitmap(caml_ident_start, c)) {
+      while (In_bitmap(caml_ident_body, *s)) s++;
+    }
+  }
+  return 0;
+}
+
+void make_goal(void)
+{
+  static char name[7] = "'\\xxx'";
+  bucket * bp;
+  bucket * bc;
+
+  goal = lookup("%entry%");
+  ntotalrules = nrules - 2;
+  for(bp = first_symbol; bp != 0; bp = bp->next) {
+    if (bp->entry) {
+      start_rule(goal, 0);
+      if (nitems + 2> maxitems)
+        expand_items();
+      name[2] = '0' + ((bp->entry >> 6) & 7);
+      name[3] = '0' + ((bp->entry >> 3) & 7);
+      name[4] = '0' + (bp->entry & 7);
+      bc = lookup(name);
+      bc->class = TERM;
+      bc->value = (unsigned char) bp->entry;
+      pitem[nitems++] = bc;
+      pitem[nitems++] = bp;
+      if (bp->tag == NULL)
+        entry_without_type(bp->name);
+      if (is_polymorphic(bp->tag))
+        polymorphic_entry_point(bp->name);
+      fprintf(entry_file,
+              "let %s (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =\n   (Parsing.yyparse yytables %d lexfun lexbuf : %s)\n",
+              bp->name, bp->entry, bp->tag);
+      fprintf(interface_file,
+              "val %s :\n  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> %s\n",
+              bp->name,
+              bp->tag);
+      fprintf(action_file,
+              "(* Entry %s *)\n", bp->name);
+      if (sflag)
+        fprintf(action_file,
+                "yyact.(%d) <- (fun __caml_parser_env -> raise "
+                "(Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))\n",
+                ntotalrules);
+      else
+        fprintf(action_file,
+                "; (fun __caml_parser_env -> raise "
+                "(Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))\n");
+      ntotalrules++;
+      last_was_action = 1;
+      end_rule();
+    }
+  }
+}
+
+void pack_grammar(void)
+{
+    register int i, j;
+    int assoc, prec;
+
+    ritem = (short *) MALLOC(nitems*sizeof(short));
+    if (ritem == 0) no_space();
+    rlhs = (short *) MALLOC(nrules*sizeof(short));
+    if (rlhs == 0) no_space();
+    rrhs = (short *) MALLOC((nrules+1)*sizeof(short));
+    if (rrhs == 0) no_space();
+    rprec = (short *) REALLOC(rprec, nrules*sizeof(short));
+    if (rprec == 0) no_space();
+    rassoc = REALLOC(rassoc, nrules);
+    if (rassoc == 0) no_space();
+
+    ritem[0] = -1;
+    ritem[1] = goal->index;
+    ritem[2] = 0;
+    ritem[3] = -2;
+    rlhs[0] = 0;
+    rlhs[1] = 0;
+    rlhs[2] = start_symbol;
+    rrhs[0] = 0;
+    rrhs[1] = 0;
+    rrhs[2] = 1;
+
+    j = 4;
+    for (i = 3; i < nrules; ++i)
+    {
+        rlhs[i] = plhs[i]->index;
+        rrhs[i] = j;
+        assoc = TOKEN;
+        prec = 0;
+        while (pitem[j])
+        {
+            ritem[j] = pitem[j]->index;
+            if (pitem[j]->class == TERM)
+            {
+                prec = pitem[j]->prec;
+                assoc = pitem[j]->assoc;
+            }
+            ++j;
+        }
+        ritem[j] = -i;
+        ++j;
+        if (rprec[i] == UNDEFINED)
+        {
+            rprec[i] = prec;
+            rassoc[i] = assoc;
+        }
+    }
+    rrhs[i] = j;
+
+    FREE(plhs);
+    FREE(pitem);
+}
+
+
+void print_grammar(void)
+{
+    register int i, j, k;
+    int spacing = 0;
+    register FILE *f = verbose_file;
+
+    if (!vflag) return;
+
+    k = 1;
+    for (i = 2; i < nrules; ++i)
+    {
+        if (rlhs[i] != rlhs[i-1])
+        {
+            if (i != 2) fprintf(f, "\n");
+            fprintf(f, "%4d  %s :", i - 2, symbol_name[rlhs[i]]);
+            spacing = strlen(symbol_name[rlhs[i]]) + 1;
+        }
+        else
+        {
+            fprintf(f, "%4d  ", i - 2);
+            j = spacing;
+            while (--j >= 0) putc(' ', f);
+            putc('|', f);
+        }
+
+        while (ritem[k] >= 0)
+        {
+            fprintf(f, " %s", symbol_name[ritem[k]]);
+            ++k;
+        }
+        ++k;
+        putc('\n', f);
+    }
+}
+
+
+void reader(void)
+{
+    virtual_input_file_name = substring (input_file_name, 0,
+                                         strlen (input_file_name));
+    create_symbol_table();
+    read_declarations();
+    output_token_type();
+    read_grammar();
+    make_goal();
+    free_symbol_table();
+    free_tags();
+    pack_names();
+    check_symbols();
+    pack_symbols();
+    pack_grammar();
+    free_symbols();
+    print_grammar();
+}
diff --git a/yacc/skeleton.c b/yacc/skeleton.c
new file mode 100644
index 00000000..7cc8126e
--- /dev/null
+++ b/yacc/skeleton.c
@@ -0,0 +1,60 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+char *header[] =
+{
+  "open Parsing;;",
+  "let _ = parse_error;;", /* avoid warning 33 (PR#5719) */
+  0
+};
+
+char *define_tables[] =
+{
+  "let yytables =",
+  "  { Parsing.actions=yyact;",
+  "    Parsing.transl_const=yytransl_const;",
+  "    Parsing.transl_block=yytransl_block;",
+  "    Parsing.lhs=yylhs;",
+  "    Parsing.len=yylen;",
+  "    Parsing.defred=yydefred;",
+  "    Parsing.dgoto=yydgoto;",
+  "    Parsing.sindex=yysindex;",
+  "    Parsing.rindex=yyrindex;",
+  "    Parsing.gindex=yygindex;",
+  "    Parsing.tablesize=yytablesize;",
+  "    Parsing.table=yytable;",
+  "    Parsing.check=yycheck;",
+  "    Parsing.error_function=parse_error;",
+  "    Parsing.names_const=yynames_const;",
+  "    Parsing.names_block=yynames_block }",
+  0
+};
+
+void write_section(char **section)
+{
+    register int i;
+    register FILE *fp;
+
+    fp = code_file;
+    for (i = 0; section[i]; ++i)
+    {
+        ++outline;
+        fprintf(fp, "%s\n", section[i]);
+    }
+}
diff --git a/yacc/symtab.c b/yacc/symtab.c
new file mode 100644
index 00000000..5cd69b82
--- /dev/null
+++ b/yacc/symtab.c
@@ -0,0 +1,130 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include 
+#include "defs.h"
+
+
+bucket **symbol_table;
+bucket *first_symbol;
+bucket *last_symbol;
+
+
+int
+hash(char *name)
+{
+    register char *s;
+    register int c, k;
+
+    assert(name && *name);
+    s = name;
+    k = *s;
+    while ((c = *++s))
+        k = (31*k + c) & (TABLE_SIZE - 1);
+
+    return (k);
+}
+
+
+bucket *
+make_bucket(char *name)
+{
+    register bucket *bp;
+
+    assert(name);
+    bp = (bucket *) MALLOC(sizeof(bucket));
+    if (bp == 0) no_space();
+    bp->link = 0;
+    bp->next = 0;
+    bp->name = MALLOC(strlen(name) + 1);
+    if (bp->name == 0) no_space();
+    bp->tag = 0;
+    bp->value = UNDEFINED;
+    bp->index = 0;
+    bp->prec = 0;
+    bp-> class = UNKNOWN;
+    bp->assoc = TOKEN;
+    bp->entry = 0;
+    bp->true_token = 0;
+
+    if (bp->name == 0) no_space();
+    strcpy(bp->name, name);
+
+    return (bp);
+}
+
+
+bucket *
+lookup(char *name)
+{
+    register bucket *bp, **bpp;
+
+    bpp = symbol_table + hash(name);
+    bp = *bpp;
+
+    while (bp)
+    {
+        if (strcmp(name, bp->name) == 0) return (bp);
+        bpp = &bp->link;
+        bp = *bpp;
+    }
+
+    *bpp = bp = make_bucket(name);
+    last_symbol->next = bp;
+    last_symbol = bp;
+
+    return (bp);
+}
+
+
+void create_symbol_table(void)
+{
+    register int i;
+    register bucket *bp;
+
+    symbol_table = (bucket **) MALLOC(TABLE_SIZE*sizeof(bucket *));
+    if (symbol_table == 0) no_space();
+    for (i = 0; i < TABLE_SIZE; i++)
+        symbol_table[i] = 0;
+
+    bp = make_bucket("error");
+    bp->index = 1;
+    bp->class = TERM;
+
+    first_symbol = bp;
+    last_symbol = bp;
+    symbol_table[hash("error")] = bp;
+}
+
+
+void free_symbol_table(void)
+{
+    FREE(symbol_table);
+    symbol_table = 0;
+}
+
+
+void free_symbols(void)
+{
+    register bucket *p, *q;
+
+    for (p = first_symbol; p; p = q)
+    {
+        q = p->next;
+        FREE(p);
+    }
+}
diff --git a/yacc/verbose.c b/yacc/verbose.c
new file mode 100644
index 00000000..5f1b0b9d
--- /dev/null
+++ b/yacc/verbose.c
@@ -0,0 +1,349 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+
+static short *null_rules;
+
+
+void print_state (int state);
+void log_unused (void);
+void log_conflicts (void);
+void print_conflicts (int state);
+void print_core (int state);
+void print_nulls (int state);
+void print_actions (int stateno);
+void print_shifts (register action *p);
+void print_reductions (register action *p, register int defred);
+void print_gotos (int stateno);
+
+void verbose(void)
+{
+    register int i;
+
+    if (!vflag) return;
+
+    null_rules = (short *) MALLOC(nrules*sizeof(short));
+    if (null_rules == 0) no_space();
+    fprintf(verbose_file, "\f\n");
+    for (i = 0; i < nstates; i++)
+        print_state(i);
+    FREE(null_rules);
+
+    if (nunused)
+        log_unused();
+    if (SRtotal || RRtotal)
+        log_conflicts();
+
+    fprintf(verbose_file, "\n\n%d terminals, %d nonterminals\n", ntokens,
+            nvars);
+    fprintf(verbose_file, "%d grammar rules, %d states\n", nrules - 2, nstates);
+}
+
+
+void log_unused(void)
+{
+    register int i;
+    register short *p;
+
+    fprintf(verbose_file, "\n\nRules never reduced:\n");
+    for (i = 3; i < nrules; ++i)
+    {
+        if (!rules_used[i])
+        {
+            fprintf(verbose_file, "\t%s :", symbol_name[rlhs[i]]);
+            for (p = ritem + rrhs[i]; *p >= 0; ++p)
+                fprintf(verbose_file, " %s", symbol_name[*p]);
+            fprintf(verbose_file, "  (%d)\n", i - 2);
+        }
+    }
+}
+
+
+void log_conflicts(void)
+{
+    register int i;
+
+    fprintf(verbose_file, "\n\n");
+    for (i = 0; i < nstates; i++)
+    {
+        if (SRconflicts[i] || RRconflicts[i])
+        {
+            fprintf(verbose_file, "State %d contains ", i);
+            if (SRconflicts[i] == 1)
+                fprintf(verbose_file, "1 shift/reduce conflict");
+            else if (SRconflicts[i] > 1)
+                fprintf(verbose_file, "%d shift/reduce conflicts",
+                        SRconflicts[i]);
+            if (SRconflicts[i] && RRconflicts[i])
+                fprintf(verbose_file, ", ");
+            if (RRconflicts[i] == 1)
+                fprintf(verbose_file, "1 reduce/reduce conflict");
+            else if (RRconflicts[i] > 1)
+                fprintf(verbose_file, "%d reduce/reduce conflicts",
+                        RRconflicts[i]);
+            fprintf(verbose_file, ".\n");
+        }
+    }
+}
+
+
+void print_state(int state)
+{
+    if (state)
+        fprintf(verbose_file, "\n\n");
+    if (SRconflicts[state] || RRconflicts[state])
+        print_conflicts(state);
+    fprintf(verbose_file, "state %d\n", state);
+    print_core(state);
+    print_nulls(state);
+    print_actions(state);
+}
+
+
+void print_conflicts(int state)
+{
+    register int symbol, act, number;
+    register action *p;
+
+    symbol = -1;
+    act = 0;
+    number = 0;
+    for (p = parser[state]; p; p = p->next)
+    {
+        if (p->suppressed == 2)
+            continue;
+
+        if (p->symbol != symbol)
+        {
+            symbol = p->symbol;
+            number = p->number;
+            if (p->action_code == SHIFT)
+                act = SHIFT;
+            else
+                act = REDUCE;
+        }
+        else if (p->suppressed == 1)
+        {
+            if (state == final_state && symbol == 0)
+            {
+                fprintf(verbose_file, "%d: shift/reduce conflict \
+(accept, reduce %d) on $end\n", state, p->number - 2);
+            }
+            else
+            {
+                if (act == SHIFT)
+                {
+                    fprintf(verbose_file, "%d: shift/reduce conflict \
+(shift %d, reduce %d) on %s\n", state, number, p->number - 2,
+                            symbol_name[symbol]);
+                }
+                else
+                {
+                    fprintf(verbose_file, "%d: reduce/reduce conflict \
+(reduce %d, reduce %d) on %s\n", state, number - 2, p->number - 2,
+                            symbol_name[symbol]);
+                }
+            }
+        }
+    }
+}
+
+
+void print_core(int state)
+{
+    register int i;
+    register int k;
+    register int rule;
+    register core *statep;
+    register short *sp;
+    register short *sp1;
+
+    statep = state_table[state];
+    k = statep->nitems;
+
+    for (i = 0; i < k; i++)
+    {
+        sp1 = sp = ritem + statep->items[i];
+
+        while (*sp >= 0) ++sp;
+        rule = -(*sp);
+        fprintf(verbose_file, "\t%s : ", symbol_name[rlhs[rule]]);
+
+        for (sp = ritem + rrhs[rule]; sp < sp1; sp++)
+            fprintf(verbose_file, "%s ", symbol_name[*sp]);
+
+        putc('.', verbose_file);
+
+        while (*sp >= 0)
+        {
+            fprintf(verbose_file, " %s", symbol_name[*sp]);
+            sp++;
+        }
+        fprintf(verbose_file, "  (%d)\n", -2 - *sp);
+    }
+}
+
+
+void print_nulls(int state)
+{
+    register action *p;
+    register int i, j, k, nnulls;
+
+    nnulls = 0;
+    for (p = parser[state]; p; p = p->next)
+    {
+        if (p->action_code == REDUCE &&
+                (p->suppressed == 0 || p->suppressed == 1))
+        {
+            i = p->number;
+            if (rrhs[i] + 1 == rrhs[i+1])
+            {
+                for (j = 0; j < nnulls && i > null_rules[j]; ++j)
+                    continue;
+
+                if (j == nnulls)
+                {
+                    ++nnulls;
+                    null_rules[j] = i;
+                }
+                else if (i != null_rules[j])
+                {
+                    ++nnulls;
+                    for (k = nnulls - 1; k > j; --k)
+                        null_rules[k] = null_rules[k-1];
+                    null_rules[j] = i;
+                }
+            }
+        }
+    }
+
+    for (i = 0; i < nnulls; ++i)
+    {
+        j = null_rules[i];
+        fprintf(verbose_file, "\t%s : .  (%d)\n", symbol_name[rlhs[j]],
+                j - 2);
+    }
+    fprintf(verbose_file, "\n");
+}
+
+
+void print_actions(int stateno)
+{
+    register action *p;
+    register shifts *sp;
+    register int as;
+
+    if (stateno == final_state)
+        fprintf(verbose_file, "\t$end  accept\n");
+
+    p = parser[stateno];
+    if (p)
+    {
+        print_shifts(p);
+        print_reductions(p, defred[stateno]);
+    }
+
+    sp = shift_table[stateno];
+    if (sp && sp->nshifts > 0)
+    {
+        as = accessing_symbol[sp->shift[sp->nshifts - 1]];
+        if (ISVAR(as))
+            print_gotos(stateno);
+    }
+}
+
+
+void print_shifts(register action *p)
+{
+    register int count;
+    register action *q;
+
+    count = 0;
+    for (q = p; q; q = q->next)
+    {
+        if (q->suppressed < 2 && q->action_code == SHIFT)
+            ++count;
+    }
+
+    if (count > 0)
+    {
+        for (; p; p = p->next)
+        {
+            if (p->action_code == SHIFT && p->suppressed == 0)
+                fprintf(verbose_file, "\t%s  shift %d\n",
+                            symbol_name[p->symbol], p->number);
+        }
+    }
+}
+
+
+void print_reductions(register action *p, register int defred)
+{
+    register int k, anyreds;
+    register action *q;
+
+    anyreds = 0;
+    for (q = p; q ; q = q->next)
+    {
+        if (q->action_code == REDUCE && q->suppressed < 2)
+        {
+            anyreds = 1;
+            break;
+        }
+    }
+
+    if (anyreds == 0)
+        fprintf(verbose_file, "\t.  error\n");
+    else
+    {
+        for (; p; p = p->next)
+        {
+            if (p->action_code == REDUCE && p->number != defred)
+            {
+                k = p->number - 2;
+                if (p->suppressed == 0)
+                    fprintf(verbose_file, "\t%s  reduce %d\n",
+                            symbol_name[p->symbol], k);
+            }
+        }
+
+        if (defred > 0)
+            fprintf(verbose_file, "\t.  reduce %d\n", defred - 2);
+    }
+}
+
+
+void print_gotos(int stateno)
+{
+    register int i, k;
+    register int as;
+    register short *to_state;
+    register shifts *sp;
+
+    putc('\n', verbose_file);
+    sp = shift_table[stateno];
+    to_state = sp->shift;
+    for (i = 0; i < sp->nshifts; ++i)
+    {
+        k = to_state[i];
+        as = accessing_symbol[k];
+        if (ISVAR(as))
+            fprintf(verbose_file, "\t%s  goto %d\n", symbol_name[as], k);
+    }
+}
diff --git a/yacc/warshall.c b/yacc/warshall.c
new file mode 100644
index 00000000..72da2941
--- /dev/null
+++ b/yacc/warshall.c
@@ -0,0 +1,97 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA 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 Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Based on public-domain code from Berkeley Yacc */
+
+#include "defs.h"
+
+void transitive_closure(unsigned int *R, int n)
+{
+    register int rowsize;
+    register unsigned mask;
+    register unsigned *rowj;
+    register unsigned *rp;
+    register unsigned *rend;
+    register unsigned *ccol;
+    register unsigned *relend;
+    register unsigned *cword;
+    register unsigned *rowi;
+
+    rowsize = WORDSIZE(n);
+    relend = R + n*rowsize;
+
+    cword = R;
+    mask = 1;
+    rowi = R;
+    while (rowi < relend)
+    {
+        ccol = cword;
+        rowj = R;
+
+        while (rowj < relend)
+        {
+            if (*ccol & mask)
+            {
+                rp = rowi;
+                rend = rowj + rowsize;
+                while (rowj < rend)
+                    *rowj++ |= *rp++;
+            }
+            else
+            {
+                rowj += rowsize;
+            }
+
+            ccol += rowsize;
+        }
+
+        mask <<= 1;
+        if (mask == 0)
+        {
+            mask = 1;
+            cword++;
+        }
+
+        rowi += rowsize;
+    }
+}
+
+void reflexive_transitive_closure(unsigned int *R, int n)
+{
+    register int rowsize;
+    register unsigned mask;
+    register unsigned *rp;
+    register unsigned *relend;
+
+    transitive_closure(R, n);
+
+    rowsize = WORDSIZE(n);
+    relend = R + n*rowsize;
+
+    mask = 1;
+    rp = R;
+    while (rp < relend)
+    {
+        *rp |= mask;
+        mask <<= 1;
+        if (mask == 0)
+        {
+            mask = 1;
+            rp++;
+        }
+
+        rp += rowsize;
+    }
+}
-- 
2.30.2